blob: e70a65d7c0ce26782431fb326100bbdd3db86398 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
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
|
