From e649d8e60030bbff80115720225ac089a8b7bfd2 Mon Sep 17 00:00:00 2001
From: tv <tv@krebsco.de>
Date: Sun, 11 Jan 2026 20:44:54 +0100
Subject: Reaktor.Plugins.SASL: init

---
 src/Reaktor/IRC.hs          |  22 +++++++++
 src/Reaktor/Plugins/SASL.hs | 107 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 129 insertions(+)
 create mode 100644 src/Reaktor/Plugins/SASL.hs

(limited to 'src/Reaktor')

diff --git a/src/Reaktor/IRC.hs b/src/Reaktor/IRC.hs
index 2000d08..3dbfedb 100644
--- a/src/Reaktor/IRC.hs
+++ b/src/Reaktor/IRC.hs
@@ -20,7 +20,9 @@ import Prelude.Extended
 data Command =
     UnknownCommand Text | UnknownReply Int
     | ADMIN
+    | AUTHENTICATE
     | AWAY
+    | CAP
     | CONNECT
     | DIE
     | ERROR
@@ -207,6 +209,15 @@ data Command =
     | ERR_NOOPERHOST
     | ERR_UMODEUNKNOWNFLAG
     | ERR_USERSDONTMATCH
+
+    | RPL_LOGGEDIN
+    | RPL_LOGGEDOUT
+    | ERR_NICKLOCKED
+    | RPL_SASLSUCCESS
+    | ERR_SASLFAIL
+    | ERR_SASLTOOLONG
+    | ERR_SASLABORTED
+    | ERR_SASLALREADY
   deriving (Eq,Generic,Hashable,Show)
 
 instance ConvertibleStrings Text Command where
@@ -239,7 +250,9 @@ instance FromJSONKey Command where
 commands :: [(Text, Command)]
 commands =
     [ ("ADMIN", ADMIN)
+    , ("AUTHENTICATE", AUTHENTICATE)
     , ("AWAY", AWAY)
+    , ("CAP", CAP)
     , ("CONNECT", CONNECT)
     , ("DIE", DIE)
     , ("ERROR", ERROR)
@@ -429,6 +442,15 @@ replies =
     , (491, ERR_NOOPERHOST)
     , (501, ERR_UMODEUNKNOWNFLAG)
     , (502, ERR_USERSDONTMATCH)
+
+    , (900, RPL_LOGGEDIN)
+    , (901, RPL_LOGGEDOUT)
+    , (902, ERR_NICKLOCKED)
+    , (903, RPL_SASLSUCCESS)
+    , (904, ERR_SASLFAIL)
+    , (905, ERR_SASLTOOLONG)
+    , (906, ERR_SASLABORTED)
+    , (907, ERR_SASLALREADY)
     ]
 
 mCommandText :: HashMap Command Text
diff --git a/src/Reaktor/Plugins/SASL.hs b/src/Reaktor/Plugins/SASL.hs
new file mode 100644
index 0000000..e70a65d
--- /dev/null
+++ b/src/Reaktor/Plugins/SASL.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Reaktor.Plugins.SASL where
+
+import Data.Aeson
+import Data.Aeson.Types (typeMismatch)
+import Data.Base64.Types (extractBase64)
+import Data.Text qualified as Text
+import Data.Text.Encoding.Base64 (encodeBase64)
+import Prelude.Extended
+import Reaktor
+import Text.Read (readMaybe)
+
+
+data Mechanism = PLAIN
+  deriving (Read, Show)
+
+instance ToJSON Mechanism where
+  toJSON = String . Text.show
+
+instance FromJSON Mechanism where
+  parseJSON = withText "Mechanism" $ \s ->
+    case readMaybe (Text.unpack s) of
+      Just x  -> pure x
+      Nothing -> fail "Invalid Mechanism value"
+
+
+data Config = Config
+    { cMechanism :: Mechanism
+    , cUserName :: Text
+    , cPassword :: Text
+    }
+
+instance Default Config where
+  def = Config
+          { cMechanism = PLAIN
+          , cUserName = ""
+          , cPassword = ""
+          }
+
+instance FromJSON Config where
+  parseJSON = \case
+    Object v ->
+      Config
+        <$> v .:? "mechanism" .!= PLAIN
+        <*> v .: "username"
+        <*> v .: "password"
+    invalid ->
+      typeMismatch "Config" invalid
+
+
+new :: Config -> Actions -> IO (Message -> IO ())
+new Config{..} Actions{..} =
+    return $ \case
+      Start | cUserName /= "" && cPassword /= "" -> do
+        aSend (Message Nothing CAP ["REQ", "sasl"])
+
+      Message _ CAP [_username, "ACK", "sasl"] -> do
+        aSend (Message Nothing AUTHENTICATE [Text.show cMechanism])
+
+      Message _ AUTHENTICATE ["+"] ->
+        case cMechanism of
+          PLAIN ->
+            mapM_ (\chunk -> aSend (Message Nothing AUTHENTICATE [chunk]))
+                  (toAuthChunks (toBase64 ("\0" <> cUserName <> "\0" <> cPassword)))
+
+      Message _ RPL_SASLSUCCESS _ ->
+        aSend (Message Nothing CAP ["END"])
+
+      Message _ ERR_SASLFAIL _ ->
+        aSend (Message Nothing CAP ["END"])
+
+      Message _ ERR_SASLTOOLONG _ ->
+        aSend (Message Nothing CAP ["END"])
+
+      Message _ ERR_SASLALREADY _ ->
+        aSend (Message Nothing CAP ["END"])
+
+      _ -> pure ()
+
+
+toBase64 :: Text -> Text
+toBase64 = extractBase64 . encodeBase64
+
+
+-- Split input Text into chunks compatibe with the AUTHENTICATE command.
+-- This function assumes that each character in the input Text is exactly one
+-- byte long, which is true for any Base64 encoded Text.
+--
+-- See also: https://ircv3.net/specs/extensions/sasl-3.1#the-authenticate-command
+toAuthChunks :: Text -> [Text]
+toAuthChunks s =
+    if not (null chunks) && Text.length (last chunks) == 400 then
+      chunks <> ["+"]
+    else
+      chunks
+  where
+    chunks = toChunksOf 400 s
+
+
+toChunksOf :: Int -> Text -> [Text]
+toChunksOf n s
+    | Text.null s = []
+    | otherwise = let (a,b) = Text.splitAt n s
+                  in a : toChunksOf n b
-- 
cgit v1.2.3