{-# Language OverloadedStrings, PatternSynonyms #-}
{-|
Module      : Client.EventLoop.Network
Description : Event handlers for network messages affecting the client state
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

While most network messages only affect the model of that network connection,
some messages will affect the mutable state of the client itself.
-}
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

-- | Client-level responses to specific IRC messages.
-- This is in contrast to the connection state tracking logic in
-- "Client.NetworkState"
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]
_ ->
      -- run connection commands with the network focused and restore it afterward
      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'

    -- Change focus when we get a message that we're being forwarded to another channel
    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         {- ^ STS parameter string -} ->
  NetworkState {- ^ network state        -} ->
  ClientState  {- ^ client state         -} ->
  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 -- sts disabled
    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    {- ^ message time  -} ->
  Text         {- ^ challenge     -} ->
  NetworkState {- ^ network state -} ->
  ClientState  {- ^ client state  -} ->
  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       {- ^ now             -} ->
  NetworkState    {- ^ current network -} ->
  ClientState     {- ^ client state    -} ->
  [ExpansionChunk]{- ^ command         -} ->
  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 -- not supported
 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