{-# Language OverloadedStrings #-}
{-|
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.Commands
import           Client.Commands.Interpolation
import           Client.Configuration.ServerSettings
import           Client.Configuration.Sts
import           Client.Network.Async
import           Client.Network.Connect
import           Client.State
import           Client.State.Focus
import           Client.State.Network
import           Control.Lens
import           Control.Monad
import           Data.Text (Text)
import           Data.Time
import           Irc.Codes
import           Irc.Commands
import           Irc.Identifier
import           Irc.Message
import qualified Client.Authentication.Ecdsa as Ecdsa
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import           Text.Regex.TDFA.Text 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 (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs)
         ClientState
st' <- (ClientState -> [ExpansionChunk] -> IO ClientState)
-> ClientState -> [[ExpansionChunk]] -> IO ClientState
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)
                      (ASetter ClientState ClientState Focus Focus
-> Focus -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ClientState ClientState Focus Focus
Lens' ClientState Focus
clientFocus Focus
focus ClientState
st)
                      (Getting [[ExpansionChunk]] NetworkState [[ExpansionChunk]]
-> NetworkState -> [[ExpansionChunk]]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ServerSettings -> Const [[ExpansionChunk]] ServerSettings)
-> NetworkState -> Const [[ExpansionChunk]] NetworkState
Lens' NetworkState ServerSettings
csSettings ((ServerSettings -> Const [[ExpansionChunk]] ServerSettings)
 -> NetworkState -> Const [[ExpansionChunk]] NetworkState)
-> (([[ExpansionChunk]]
     -> Const [[ExpansionChunk]] [[ExpansionChunk]])
    -> ServerSettings -> Const [[ExpansionChunk]] ServerSettings)
-> Getting [[ExpansionChunk]] NetworkState [[ExpansionChunk]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([[ExpansionChunk]] -> Const [[ExpansionChunk]] [[ExpansionChunk]])
-> ServerSettings -> Const [[ExpansionChunk]] ServerSettings
Lens' ServerSettings [[ExpansionChunk]]
ssConnectCmds) NetworkState
cs)
         ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ASetter ClientState ClientState Focus Focus
-> Focus -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ClientState ClientState Focus Focus
Lens' ClientState Focus
clientFocus (Getting Focus ClientState Focus -> ClientState -> Focus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Focus ClientState Focus
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 = Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs
      , Getting Focus ClientState Focus -> ClientState -> Focus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Focus ClientState Focus
Lens' ClientState Focus
clientFocus ClientState
st Focus -> Focus -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Identifier -> Focus
ChannelFocus Text
network (Text -> Identifier
mkId Text
src) ->
         ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ASetter ClientState ClientState Focus Focus
-> Focus -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ClientState ClientState Focus Focus
Lens' ClientState Focus
clientFocus (Text -> Identifier -> Focus
ChannelFocus Text
network (Text -> Identifier
mkId Text
dst)) ClientState
st

    Authenticate Text
challenge
      | AuthenticateState
AS_EcdsaWaitChallenge <- Getting AuthenticateState NetworkState AuthenticateState
-> NetworkState -> AuthenticateState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting AuthenticateState NetworkState AuthenticateState
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 <- Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> [(Text, Maybe Text)] -> Maybe (Maybe Text)
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 <- Maybe (Maybe Text) -> Maybe Text
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Text -> [(Text, Maybe Text)] -> Maybe (Maybe Text)
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 <- Getting (First Regex) NetworkState KnownRegex
-> (KnownRegex -> Regex) -> NetworkState -> Maybe Regex
forall s (m :: * -> *) r a.
MonadReader s m =>
Getting (First r) s a -> (a -> r) -> m (Maybe r)
previews ((ServerSettings -> Const (First Regex) ServerSettings)
-> NetworkState -> Const (First Regex) NetworkState
Lens' NetworkState ServerSettings
csSettings ((ServerSettings -> Const (First Regex) ServerSettings)
 -> NetworkState -> Const (First Regex) NetworkState)
-> ((KnownRegex -> Const (First Regex) KnownRegex)
    -> ServerSettings -> Const (First Regex) ServerSettings)
-> Getting (First Regex) NetworkState KnownRegex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe KnownRegex -> Const (First Regex) (Maybe KnownRegex))
-> ServerSettings -> Const (First Regex) ServerSettings
Lens' ServerSettings (Maybe KnownRegex)
ssReconnectError ((Maybe KnownRegex -> Const (First Regex) (Maybe KnownRegex))
 -> ServerSettings -> Const (First Regex) ServerSettings)
-> ((KnownRegex -> Const (First Regex) KnownRegex)
    -> Maybe KnownRegex -> Const (First Regex) (Maybe KnownRegex))
-> (KnownRegex -> Const (First Regex) KnownRegex)
-> ServerSettings
-> Const (First Regex) ServerSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KnownRegex -> Const (First Regex) KnownRegex)
-> Maybe KnownRegex -> Const (First Regex) (Maybe KnownRegex)
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 = Getting (Maybe UTCTime) NetworkState (Maybe UTCTime)
-> NetworkState -> Maybe UTCTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe UTCTime) NetworkState (Maybe UTCTime)
Lens' NetworkState (Maybe UTCTime)
csLastReceived NetworkState
cs ->
         Int
-> Maybe UTCTime
-> Maybe Int
-> Text
-> ClientState
-> IO ClientState
addConnection Int
1 Maybe UTCTime
discoTime Maybe Int
forall a. Maybe a
Nothing (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs) ClientState
st

    IrcMsg
_ -> ClientState -> IO ClientState
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 Getting TlsMode NetworkState TlsMode -> NetworkState -> TlsMode
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ServerSettings -> Const TlsMode ServerSettings)
-> NetworkState -> Const TlsMode NetworkState
Lens' NetworkState ServerSettings
csSettings ((ServerSettings -> Const TlsMode ServerSettings)
 -> NetworkState -> Const TlsMode NetworkState)
-> ((TlsMode -> Const TlsMode TlsMode)
    -> ServerSettings -> Const TlsMode ServerSettings)
-> Getting TlsMode NetworkState TlsMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TlsMode -> Const TlsMode TlsMode)
-> ServerSettings -> Const TlsMode ServerSettings
Lens' ServerSettings TlsMode
ssTls) NetworkState
cs of
    TlsMode
_      | LensLike' (Const Bool) NetworkState Bool
-> (Bool -> Bool) -> NetworkState -> Bool
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views ((ServerSettings -> Const Bool ServerSettings)
-> NetworkState -> Const Bool NetworkState
Lens' NetworkState ServerSettings
csSettings ((ServerSettings -> Const Bool ServerSettings)
 -> NetworkState -> Const Bool NetworkState)
-> ((Bool -> Const Bool Bool)
    -> ServerSettings -> Const Bool ServerSettings)
-> LensLike' (Const Bool) NetworkState Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool)
-> ServerSettings -> Const Bool ServerSettings
Lens' ServerSettings Bool
ssSts) Bool -> Bool
not NetworkState
cs -> ClientState -> IO ClientState
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       -> Int -> IO ClientState
forall a. Integral a => a -> IO ClientState
setStsPolicy Int
duration
    TlsMode
_                                          -> ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st

  where
    entries :: [(Text, Text)]
entries    = Text -> (Text, Text)
splitEntry (Text -> (Text, Text)) -> [Text] -> [(Text, Text)]
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 (Text -> Maybe Int) -> Maybe Text -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"port"     [(Text, Text)]
entries
    mbDuration :: Maybe Int
mbDuration = Text -> Maybe Int
readInt (Text -> Maybe Int) -> Maybe Text -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> [(Text, Text)] -> Maybe Text
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
'=' Char -> Char -> Bool
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 (Getting NetworkConnection NetworkState NetworkConnection
-> NetworkState -> NetworkConnection
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NetworkConnection NetworkState NetworkConnection
Lens' NetworkState NetworkConnection
csSocket NetworkState
cs)
         Int
-> Maybe UTCTime
-> Maybe Int
-> Text
-> ClientState
-> IO ClientState
addConnection Int
0 (Getting (Maybe UTCTime) NetworkState (Maybe UTCTime)
-> NetworkState -> Maybe UTCTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe UTCTime) NetworkState (Maybe UTCTime)
Lens' NetworkState (Maybe UTCTime)
csLastReceived NetworkState
cs) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
port) (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs) ClientState
st

    setStsPolicy :: a -> IO ClientState
setStsPolicy a
duration =
      do UTCTime
now <- IO UTCTime
getCurrentTime
         let host :: Text
host = String -> Text
Text.pack (Getting String NetworkState String -> NetworkState -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ServerSettings -> Const String ServerSettings)
-> NetworkState -> Const String NetworkState
Lens' NetworkState ServerSettings
csSettings ((ServerSettings -> Const String ServerSettings)
 -> NetworkState -> Const String NetworkState)
-> ((String -> Const String String)
    -> ServerSettings -> Const String ServerSettings)
-> Getting String NetworkState String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Const String String)
-> ServerSettings -> Const String ServerSettings
Lens' ServerSettings String
ssHostName) NetworkState
cs)
             port :: Int
port = PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ServerSettings -> PortNumber
ircPort (Getting ServerSettings NetworkState ServerSettings
-> NetworkState -> ServerSettings
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ServerSettings NetworkState ServerSettings
Lens' NetworkState ServerSettings
csSettings NetworkState
cs))
             policy :: StsPolicy
policy = StsPolicy :: UTCTime -> Int -> StsPolicy
StsPolicy
                        { _stsExpiration :: UTCTime
_stsExpiration = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (a -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
duration) UTCTime
now
                        , _stsPort :: Int
_stsPort       = Int
port }
             st' :: ClientState
st' = ClientState
st ClientState -> (ClientState -> ClientState) -> ClientState
forall a b. a -> (a -> b) -> b
& (HashMap Text StsPolicy -> Identity (HashMap Text StsPolicy))
-> ClientState -> Identity ClientState
Lens' ClientState (HashMap Text StsPolicy)
clientStsPolicy ((HashMap Text StsPolicy -> Identity (HashMap Text StsPolicy))
 -> ClientState -> Identity ClientState)
-> ((Maybe StsPolicy -> Identity (Maybe StsPolicy))
    -> HashMap Text StsPolicy -> Identity (HashMap Text StsPolicy))
-> (Maybe StsPolicy -> Identity (Maybe StsPolicy))
-> ClientState
-> Identity ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text StsPolicy)
-> Lens'
     (HashMap Text StsPolicy) (Maybe (IxValue (HashMap Text StsPolicy)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (HashMap Text StsPolicy)
host ((Maybe StsPolicy -> Identity (Maybe StsPolicy))
 -> ClientState -> Identity ClientState)
-> StsPolicy -> ClientState -> ClientState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ StsPolicy
policy
         HashMap Text StsPolicy -> IO ()
savePolicyFile (Getting
  (HashMap Text StsPolicy) ClientState (HashMap Text StsPolicy)
-> ClientState -> HashMap Text StsPolicy
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (HashMap Text StsPolicy) ClientState (HashMap Text StsPolicy)
Lens' ClientState (HashMap Text StsPolicy)
clientStsPolicy ClientState
st')
         ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st'


readInt :: Text -> Maybe Int
readInt :: Text -> Maybe Int
readInt Text
x =
  case Reader Int
forall a. Integral a => Reader a
Text.decimal Text
x of
    Right (Int
n, Text
t) | Text -> Bool
Text.null Text
t -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
    Either String (Int, Text)
_                          -> Maybe Int
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 Getting (Maybe SaslMechanism) ServerSettings (Maybe SaslMechanism)
-> ServerSettings -> Maybe SaslMechanism
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe SaslMechanism) ServerSettings (Maybe SaslMechanism)
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
                ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
now (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
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)
                ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ASetter ClientState ClientState AuthenticateState AuthenticateState
-> AuthenticateState -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter ClientState ClientState AuthenticateState AuthenticateState
asLens AuthenticateState
AS_None ClientState
st

    Maybe SaslMechanism
_ ->
      do NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs RawIrcMsg
ircCapEnd
         ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ZonedTime -> Text -> Text -> ClientState -> ClientState
recordError ZonedTime
now (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs) Text
"panic: ecdsa mechanism not configured" ClientState
st
  where
    ss :: ServerSettings
ss = Getting ServerSettings NetworkState ServerSettings
-> NetworkState -> ServerSettings
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ServerSettings NetworkState ServerSettings
Lens' NetworkState ServerSettings
csSettings NetworkState
cs
    asLens :: ASetter ClientState ClientState AuthenticateState AuthenticateState
asLens = Text -> LensLike' Identity ClientState NetworkState
forall (f :: * -> *).
Applicative f =>
Text -> LensLike' f ClientState NetworkState
clientConnection (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs) LensLike' Identity ClientState NetworkState
-> ((AuthenticateState -> Identity AuthenticateState)
    -> NetworkState -> Identity NetworkState)
-> ASetter
     ClientState ClientState AuthenticateState AuthenticateState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AuthenticateState -> Identity AuthenticateState)
-> NetworkState -> Identity NetworkState
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 <- Maybe UTCTime -> (UTCTime -> IO Text) -> IO (Maybe Text)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe UTCTime
disco ((UTCTime -> IO Text) -> IO (Maybe Text))
-> (UTCTime -> IO Text) -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ \UTCTime
t ->
             String -> Text
Text.pack (String -> Text) -> (ZonedTime -> String) -> ZonedTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%H:%M:%S"
               (ZonedTime -> Text) -> IO ZonedTime -> IO Text
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 (Getting Text NetworkState Text -> NetworkState -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text NetworkState Text
Lens' NetworkState Text
csNetwork NetworkState
cs) (Text
"Bad connect-cmd: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e)
     case (Text -> Maybe Text)
-> (Integer -> Maybe Text) -> [ExpansionChunk] -> Maybe Text
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) (Maybe Text -> Integer -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) [ExpansionChunk]
cmdTxt of
       Maybe Text
Nothing -> ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
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
            ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
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 Getting PingStatus NetworkState PingStatus
-> NetworkState -> PingStatus
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PingStatus NetworkState PingStatus
Lens' NetworkState PingStatus
csPingStatus NetworkState
cs of
     PingConnecting Int
_ Maybe UTCTime
tm ConnectRestriction
_ -> Maybe UTCTime
tm
     PingStatus
_                     -> Maybe UTCTime
forall a. Maybe a
Nothing