{-# Language OverloadedStrings, PatternSynonyms #-}
module Client.EventLoop.Network
( clientResponse
) where
import Client.Authentication.Ecdsa qualified as Ecdsa
import Client.Commands (CommandResult(CommandQuit, CommandFailure, CommandSuccess), commandExpansion, executeUserCommand)
import Client.Commands.Interpolation (resolveMacroExpansions, ExpansionChunk)
import Client.Configuration.ServerSettings
import Client.Configuration.Sts (savePolicyFile, StsPolicy(StsPolicy, _stsPort, _stsExpiration))
import Client.Network.Async (abortConnection, TerminationReason(StsUpgrade))
import Client.Network.Connect (ircPort)
import Client.State
import Client.State.Focus (Focus(ChannelFocus, NetworkFocus))
import Client.State.Network
import Control.Lens (view, (&), folded, previews, views, (?~), set, At(at))
import Control.Monad (join, foldM, forM)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Read qualified as Text
import Data.Time (ZonedTime, addUTCTime, getCurrentTime, formatTime, defaultTimeLocale, utcToLocalZonedTime)
import Irc.Codes (pattern ERR_LINKCHANNEL, pattern RPL_WELCOME)
import Irc.Commands (ircAuthenticate, ircCapEnd)
import Irc.Identifier (mkId)
import Irc.Message (IrcMsg(Error, Reply, Authenticate, Cap), CapCmd(CapNew, CapLs))
import Text.Regex.TDFA.Text qualified as Regex
clientResponse :: ZonedTime -> IrcMsg -> NetworkState -> ClientState -> IO ClientState
clientResponse :: ZonedTime
-> IrcMsg -> NetworkState -> ClientState -> IO ClientState
clientResponse ZonedTime
now IrcMsg
irc NetworkState
cs ClientState
st =
case IrcMsg
irc of
Reply Text
_ ReplyCode
RPL_WELCOME [Text]
_ ->
do let focus :: Focus
focus = Text -> Focus
NetworkFocus (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs)
ClientState
st' <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (ZonedTime
-> NetworkState
-> ClientState
-> [ExpansionChunk]
-> IO ClientState
processConnectCmd ZonedTime
now NetworkState
cs)
(forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Focus
clientFocus Focus
focus ClientState
st)
(forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState ServerSettings
csSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ServerSettings [[ExpansionChunk]]
ssConnectCmds) NetworkState
cs)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Focus
clientFocus (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Focus
clientFocus ClientState
st) ClientState
st'
Reply Text
_ ReplyCode
ERR_LINKCHANNEL (Text
_ : Text
src : Text
dst : [Text]
_)
| let network :: Text
network = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs
, forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Focus
clientFocus ClientState
st forall a. Eq a => a -> a -> Bool
== Text -> Identifier -> Focus
ChannelFocus Text
network (Text -> Identifier
mkId Text
src) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ClientState Focus
clientFocus (Text -> Identifier -> Focus
ChannelFocus Text
network (Text -> Identifier
mkId Text
dst)) ClientState
st
Authenticate Text
challenge
| AuthenticateState
AS_EcdsaWaitChallenge <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState AuthenticateState
csAuthenticationState NetworkState
cs ->
ZonedTime -> Text -> NetworkState -> ClientState -> IO ClientState
processSaslEcdsa ZonedTime
now Text
challenge NetworkState
cs ClientState
st
Cap (CapLs CapMore
_ [(Text, Maybe Text)]
caps)
| Just Text
stsVal <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"sts" [(Text, Maybe Text)]
caps) -> Text -> NetworkState -> ClientState -> IO ClientState
processSts Text
stsVal NetworkState
cs ClientState
st
Cap (CapNew [(Text, Maybe Text)]
caps)
| Just Text
stsVal <- forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"sts" [(Text, Maybe Text)]
caps) -> Text -> NetworkState -> ClientState -> IO ClientState
processSts Text
stsVal NetworkState
cs ClientState
st
Error Text
msg
| Just Regex
rx <- forall s (m :: * -> *) r a.
MonadReader s m =>
Getting (First r) s a -> (a -> r) -> m (Maybe r)
previews (Lens' NetworkState ServerSettings
csSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ServerSettings (Maybe KnownRegex)
ssReconnectError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded) KnownRegex -> Regex
getRegex NetworkState
cs
, Right{} <- Regex -> Text -> Either String (Maybe MatchArray)
Regex.execute Regex
rx Text
msg
, let discoTime :: Maybe UTCTime
discoTime = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState (Maybe UTCTime)
csLastReceived NetworkState
cs ->
Int
-> Maybe UTCTime
-> Maybe Int
-> Text
-> ClientState
-> IO ClientState
addConnection Int
1 Maybe UTCTime
discoTime forall a. Maybe a
Nothing (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs) ClientState
st
IrcMsg
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st
processSts ::
Text ->
NetworkState ->
ClientState ->
IO ClientState
processSts :: Text -> NetworkState -> ClientState -> IO ClientState
processSts Text
txt NetworkState
cs ClientState
st =
case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState ServerSettings
csSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ServerSettings TlsMode
ssTls) NetworkState
cs of
TlsMode
_ | forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views (Lens' NetworkState ServerSettings
csSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ServerSettings Bool
ssSts) Bool -> Bool
not NetworkState
cs -> forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st
TlsMode
TlsNo | Just Int
port <- Maybe Int
mbPort -> Int -> IO ClientState
upgradeConnection Int
port
TlsMode
TlsYes | Just Int
duration <- Maybe Int
mbDuration -> forall {p}. Integral p => p -> IO ClientState
setStsPolicy Int
duration
TlsMode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st
where
entries :: [(Text, Text)]
entries = Text -> (Text, Text)
splitEntry forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> [Text]
Text.splitOn Text
"," Text
txt
mbPort :: Maybe Int
mbPort = Text -> Maybe Int
readInt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"port" [(Text, Text)]
entries
mbDuration :: Maybe Int
mbDuration = Text -> Maybe Int
readInt forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"duration" [(Text, Text)]
entries
splitEntry :: Text -> (Text, Text)
splitEntry Text
e =
case (Char -> Bool) -> Text -> (Text, Text)
Text.break (Char
'=' forall a. Eq a => a -> a -> Bool
==) Text
e of
(Text
a, Text
b) -> (Text
a, Int -> Text -> Text
Text.drop Int
1 Text
b)
upgradeConnection :: Int -> IO ClientState
upgradeConnection Int
port =
do TerminationReason -> NetworkConnection -> IO ()
abortConnection TerminationReason
StsUpgrade (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState NetworkConnection
csSocket NetworkState
cs)
Int
-> Maybe UTCTime
-> Maybe Int
-> Text
-> ClientState
-> IO ClientState
addConnection Int
0 (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState (Maybe UTCTime)
csLastReceived NetworkState
cs) (forall a. a -> Maybe a
Just Int
port) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs) ClientState
st
setStsPolicy :: p -> IO ClientState
setStsPolicy p
duration =
do UTCTime
now <- IO UTCTime
getCurrentTime
let host :: Text
host = String -> Text
Text.pack (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState ServerSettings
csSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ServerSettings String
ssHostName) NetworkState
cs)
port :: Int
port = forall a b. (Integral a, Num b) => a -> b
fromIntegral (ServerSettings -> PortNumber
ircPort (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ServerSettings
csSettings NetworkState
cs))
policy :: StsPolicy
policy = StsPolicy
{ _stsExpiration :: UTCTime
_stsExpiration = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (forall a b. (Integral a, Num b) => a -> b
fromIntegral p
duration) UTCTime
now
, _stsPort :: Int
_stsPort = Int
port }
st' :: ClientState
st' = ClientState
st forall a b. a -> (a -> b) -> b
& Lens' ClientState (HashMap Text StsPolicy)
clientStsPolicy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
host forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ StsPolicy
policy
HashMap Text StsPolicy -> IO ()
savePolicyFile (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState (HashMap Text StsPolicy)
clientStsPolicy ClientState
st')
forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st'
readInt :: Text -> Maybe Int
readInt :: Text -> Maybe Int
readInt Text
x =
case forall a. Integral a => Reader a
Text.decimal Text
x of
Right (Int
n, Text
t) | Text -> Bool
Text.null Text
t -> forall a. a -> Maybe a
Just Int
n
Either String (Int, Text)
_ -> forall a. Maybe a
Nothing
processSaslEcdsa ::
ZonedTime ->
Text ->
NetworkState ->
ClientState ->
IO ClientState
processSaslEcdsa :: ZonedTime -> Text -> NetworkState -> ClientState -> IO ClientState
processSaslEcdsa ZonedTime
now Text
challenge NetworkState
cs ClientState
st =
case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ServerSettings
ss of
Just (SaslEcdsa Maybe Text
_ Text
_ String
path) ->
do Either String Text
res <- String -> Text -> IO (Either String Text)
Ecdsa.computeResponse String
path Text
challenge
case Either String Text
res of
Left String
e ->
do NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs RawIrcMsg
ircCapEnd
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
now (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs) (String -> Text
Text.pack String
e) ClientState
st
Right Text
resp ->
do NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs (Text -> RawIrcMsg
ircAuthenticate Text
resp)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall s t a b. ASetter s t a b -> b -> s -> t
set (AuthenticateState -> Identity AuthenticateState)
-> ClientState -> Identity ClientState
asLens AuthenticateState
AS_None ClientState
st
Maybe SaslMechanism
_ ->
do NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs RawIrcMsg
ircCapEnd
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
now (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs) Text
"panic: ecdsa mechanism not configured" ClientState
st
where
ss :: ServerSettings
ss = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ServerSettings
csSettings NetworkState
cs
asLens :: (AuthenticateState -> Identity AuthenticateState)
-> ClientState -> Identity ClientState
asLens = forall (f :: * -> *).
Applicative f =>
Text -> LensLike' f ClientState NetworkState
clientConnection (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' NetworkState AuthenticateState
csAuthenticationState
processConnectCmd ::
ZonedTime ->
NetworkState ->
ClientState ->
[ExpansionChunk] ->
IO ClientState
processConnectCmd :: ZonedTime
-> NetworkState
-> ClientState
-> [ExpansionChunk]
-> IO ClientState
processConnectCmd ZonedTime
now NetworkState
cs ClientState
st0 [ExpansionChunk]
cmdTxt =
do Maybe Text
dc <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe UTCTime
disco forall a b. (a -> b) -> a -> b
$ \UTCTime
t ->
String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%H:%M:%S"
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> IO ZonedTime
utcToLocalZonedTime UTCTime
t
let failureCase :: Text -> ClientState -> ClientState
failureCase Text
e = ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
now (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Text
csNetwork NetworkState
cs) (Text
"Bad connect-cmd: " forall a. Semigroup a => a -> a -> a
<> Text
e)
case forall (f :: * -> *).
Alternative f =>
(Text -> f Text)
-> (Integer -> f Text) -> [ExpansionChunk] -> f Text
resolveMacroExpansions (Maybe Text -> ClientState -> Text -> Maybe Text
commandExpansion Maybe Text
dc ClientState
st0) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) [ExpansionChunk]
cmdTxt of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Text -> ClientState -> ClientState
failureCase Text
"Unable to expand connect command" ClientState
st0
Just Text
cmdTxt' ->
do CommandResult
res <- Maybe Text -> String -> ClientState -> IO CommandResult
executeUserCommand Maybe Text
dc (Text -> String
Text.unpack Text
cmdTxt') ClientState
st0
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! case CommandResult
res of
CommandFailure ClientState
st -> Text -> ClientState -> ClientState
failureCase Text
cmdTxt' ClientState
st
CommandSuccess ClientState
st -> ClientState
st
CommandQuit ClientState
st -> ClientState
st
where
disco :: Maybe UTCTime
disco =
case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs of
PingConnecting Int
_ Maybe UTCTime
tm ConnectRestriction
_ -> Maybe UTCTime
tm
PingStatus
_ -> forall a. Maybe a
Nothing