{-# Language BlockArguments, TemplateHaskell, OverloadedStrings, BangPatterns #-}

{-|
Module      : Client.State.Network
Description : IRC network session state
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

This module is responsible for tracking the state of an individual IRC
connection while the client is connected to it. This state includes
user information, server settings, channel membership, and more.

This module is more complicated than many of the other modules in the
client because it is responsible for interpreting each IRC message from
the server and updating the connection state accordingly.
-}

module Client.State.Network
  (
  -- * Connection state
    NetworkState(..)
  , AuthenticateState(..)
  , ConnectRestriction(..)
  , newNetworkState

  -- * Lenses
  , csNick
  , csChannels
  , csChannelList
  , csWhoReply
  , csSocket
  , csModeTypes
  , csChannelTypes
  , csTransaction
  , csModes
  , csSnomask
  , csStatusMsg
  , csSettings
  , csUserInfo
  , csUsers
  , csUser
  , csModeCount
  , csNetwork
  , csNextPingTime
  , csPingStatus
  , csLatency
  , csLastReceived
  , csCertificate
  , csMessageHooks
  , csAuthenticationState
  , csSeed
  , csAway
  , clsElist
  , clsDone
  , clsItems

  -- * Cross-message state
  , Transaction(..)

  -- * Connection predicates
  , isChannelIdentifier
  , iHaveOp

  -- * Messages interactions
  , sendMsg
  , initialMessages
  , squelchIrcMsg

  -- * NetworkState update
  , Apply(..)
  , applyMessage
  , hideMessage

  -- * Timer information
  , PingStatus(..)
  , _PingConnecting
  , TimedAction(..)
  , nextTimedAction
  , applyTimedAction

  -- * Moderation
  , useChanServ
  , sendModeration
  , sendTopic
  ) where

import Client.Authentication.Ecdh qualified as Ecdh
import Client.Authentication.Ecdsa qualified as Ecdsa
import Client.Authentication.Scram qualified as Scram
import Client.Configuration.ServerSettings
import Client.Hook (MessageHook)
import Client.Hooks (messageHooks)
import Client.Network.Async (abortConnection, send, NetworkConnection, TerminationReason(PingTimeout))
import Client.State.Channel
import Client.UserHost (UserAndHost(UserAndHost, _uhAccount))
import Client.WhoReply
import Control.Lens
import Data.Bits (Bits((.&.)))
import Data.ByteString qualified as B
import Data.ByteString.Base64 qualified as B64
import Data.Either qualified as Either
import Data.Foldable (for_, traverse_ )
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.List (foldl', delete, intersect, sort, sortBy, union)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isJust, mapMaybe, listToMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Data.Text.Read qualified as Text
import Data.Time
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Irc.Codes
import Irc.Commands
import Irc.Identifier (Identifier, idText, mkId)
import Irc.Message
import Irc.Modes
import Irc.RawIrcMsg
import Irc.UserInfo
import LensUtils (overStrict, setStrict)
import System.Random qualified as Random

-- | State tracked for each IRC connection
data NetworkState = NetworkState
  { NetworkState -> HashMap Identifier ChannelState
_csChannels     :: !(HashMap Identifier ChannelState) -- ^ joined channels
  , NetworkState -> ChannelList
_csChannelList  :: !ChannelList -- ^ cached ELIST parameter and /list output
  , NetworkState -> WhoReply
_csWhoReply     :: !WhoReply -- ^ cached reply from the last WHO query
  , NetworkState -> NetworkConnection
_csSocket       :: !NetworkConnection -- ^ network socket
  , NetworkState -> ModeTypes
_csModeTypes    :: !ModeTypes -- ^ channel mode meanings
  , NetworkState -> ModeTypes
_csUmodeTypes   :: !ModeTypes -- ^ user mode meanings
  , NetworkState -> [Char]
_csChannelTypes :: ![Char] -- ^ channel identifier prefixes
  , NetworkState -> Transaction
_csTransaction  :: !Transaction -- ^ state for multi-message sequences
  , NetworkState -> [Char]
_csModes        :: ![Char] -- ^ modes for the connected user
  , NetworkState -> [Char]
_csSnomask      :: ![Char] -- ^ server notice modes for the connected user
  , NetworkState -> [Char]
_csStatusMsg    :: ![Char] -- ^ modes that prefix statusmsg channel names
  , NetworkState -> ServerSettings
_csSettings     :: !ServerSettings -- ^ settings used for this connection
  , NetworkState -> UserInfo
_csUserInfo     :: !UserInfo -- ^ usermask used by the server for this connection
  , NetworkState -> HashMap Identifier UserAndHost
_csUsers        :: !(HashMap Identifier UserAndHost) -- ^ user and hostname for other nicks
  , NetworkState -> Int
_csModeCount    :: !Int -- ^ maximum mode changes per MODE command
  , NetworkState -> Text
_csNetwork      :: !Text -- ^ name of network connection
  , NetworkState -> [MessageHook]
_csMessageHooks :: ![MessageHook] -- ^ names of message hooks to apply to this connection
  , NetworkState -> AuthenticateState
_csAuthenticationState :: !AuthenticateState
  , NetworkState -> Bool
_csAway         :: !Bool -- ^ Tracks when you are marked away

  -- Timing information
  , NetworkState -> Maybe UTCTime
_csNextPingTime :: !(Maybe UTCTime) -- ^ time for next ping event
  , NetworkState -> Maybe NominalDiffTime
_csLatency      :: !(Maybe NominalDiffTime) -- ^ latency calculated from previous pong
  , NetworkState -> PingStatus
_csPingStatus   :: !PingStatus      -- ^ state of ping timer
  , NetworkState -> Maybe UTCTime
_csLastReceived :: !(Maybe UTCTime) -- ^ time of last message received
  , NetworkState -> [Text]
_csCertificate  :: ![Text]

  -- Randomization
  , NetworkState -> StdGen
_csSeed         :: Random.StdGen
  }

-- | State of the authentication transaction
data AuthenticateState
  = AS_None               -- ^ no active transaction
  | AS_PlainStarted       -- ^ PLAIN mode initiated
  | AS_EcdsaStarted       -- ^ ECDSA-NIST mode initiated
  | AS_EcdsaWaitChallenge -- ^ ECDSA-NIST user sent waiting for challenge
  | AS_ExternalStarted    -- ^ EXTERNAL mode initiated
  | AS_ScramStarted
  | AS_Scram1 Scram.Phase1
  | AS_Scram2 Scram.Phase2
  | AS_EcdhStarted
  | AS_EcdhWaitChallenge Ecdh.Phase1

-- | Status of the ping timer
data PingStatus
  = PingSent !UTCTime -- ^ ping sent at given time, waiting for pong
  | PingNone          -- ^ not waiting for a pong
  | PingConnecting !Int !(Maybe UTCTime) !ConnectRestriction -- ^ number of attempts, last known connection time
  deriving Int -> PingStatus -> ShowS
[PingStatus] -> ShowS
PingStatus -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PingStatus] -> ShowS
$cshowList :: [PingStatus] -> ShowS
show :: PingStatus -> [Char]
$cshow :: PingStatus -> [Char]
showsPrec :: Int -> PingStatus -> ShowS
$cshowsPrec :: Int -> PingStatus -> ShowS
Show

-- | Cached channel information from /list and elsewhere.
data ChannelList = ChannelList
  { ChannelList -> Maybe Text
_clsElist :: !(Maybe Text) -- ^ The last ELIST parameter used. Nothing is also used to trigger cache purges
  , ChannelList -> Bool
_clsDone  :: !Bool -- ^ Whether to purge the hash map on receiving a new RPL_LIST
  , ChannelList -> [(Identifier, Int, Text)]
_clsItems :: ![(Identifier, Int, Text)] -- ^ The list of channel infos.
  }

data ConnectRestriction
  = NoRestriction       -- ^ no message restriction
  | StartTLSRestriction -- ^ STARTTLS hasn't finished
  | WaitTLSRestriction  -- ^ No messages allowed until TLS starts
  deriving Int -> ConnectRestriction -> ShowS
[ConnectRestriction] -> ShowS
ConnectRestriction -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ConnectRestriction] -> ShowS
$cshowList :: [ConnectRestriction] -> ShowS
show :: ConnectRestriction -> [Char]
$cshow :: ConnectRestriction -> [Char]
showsPrec :: Int -> ConnectRestriction -> ShowS
$cshowsPrec :: Int -> ConnectRestriction -> ShowS
Show

-- | Timer-based events
data TimedAction
  = TimedDisconnect    -- ^ terminate the connection due to timeout
  | TimedSendPing      -- ^ transmit a ping to the server
  | TimedForgetLatency -- ^ erase latency (when it is outdated)
  deriving (TimedAction -> TimedAction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimedAction -> TimedAction -> Bool
$c/= :: TimedAction -> TimedAction -> Bool
== :: TimedAction -> TimedAction -> Bool
$c== :: TimedAction -> TimedAction -> Bool
Eq, Eq TimedAction
TimedAction -> TimedAction -> Bool
TimedAction -> TimedAction -> Ordering
TimedAction -> TimedAction -> TimedAction
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TimedAction -> TimedAction -> TimedAction
$cmin :: TimedAction -> TimedAction -> TimedAction
max :: TimedAction -> TimedAction -> TimedAction
$cmax :: TimedAction -> TimedAction -> TimedAction
>= :: TimedAction -> TimedAction -> Bool
$c>= :: TimedAction -> TimedAction -> Bool
> :: TimedAction -> TimedAction -> Bool
$c> :: TimedAction -> TimedAction -> Bool
<= :: TimedAction -> TimedAction -> Bool
$c<= :: TimedAction -> TimedAction -> Bool
< :: TimedAction -> TimedAction -> Bool
$c< :: TimedAction -> TimedAction -> Bool
compare :: TimedAction -> TimedAction -> Ordering
$ccompare :: TimedAction -> TimedAction -> Ordering
Ord, Int -> TimedAction -> ShowS
[TimedAction] -> ShowS
TimedAction -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TimedAction] -> ShowS
$cshowList :: [TimedAction] -> ShowS
show :: TimedAction -> [Char]
$cshow :: TimedAction -> [Char]
showsPrec :: Int -> TimedAction -> ShowS
$cshowsPrec :: Int -> TimedAction -> ShowS
Show)

data Transaction
  = NoTransaction
  | NamesTransaction [Text]
  | BanTransaction [(Text,MaskListEntry)]
  | WhoTransaction [UserInfo]
  | CapLsTransaction [(Text, Maybe Text)]
  deriving Int -> Transaction -> ShowS
[Transaction] -> ShowS
Transaction -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Transaction] -> ShowS
$cshowList :: [Transaction] -> ShowS
show :: Transaction -> [Char]
$cshow :: Transaction -> [Char]
showsPrec :: Int -> Transaction -> ShowS
$cshowsPrec :: Int -> Transaction -> ShowS
Show


makeLenses ''NetworkState
makeLenses ''ChannelList
makePrisms ''Transaction
makePrisms ''PingStatus
makePrisms ''TimedAction

newChannelList :: Maybe Text -> Maybe (Identifier, Int, Text) -> ChannelList
newChannelList :: Maybe Text -> Maybe (Identifier, Int, Text) -> ChannelList
newChannelList Maybe Text
elist Maybe (Identifier, Int, Text)
Nothing = ChannelList
  { _clsElist :: Maybe Text
_clsElist = Maybe Text
elist
  , _clsDone :: Bool
_clsDone = Bool
False
  , _clsItems :: [(Identifier, Int, Text)]
_clsItems = []
  }
newChannelList Maybe Text
elist (Just (Identifier, Int, Text)
v) = ChannelList
  { _clsElist :: Maybe Text
_clsElist = Maybe Text
elist
  , _clsDone :: Bool
_clsDone = Bool
False
  , _clsItems :: [(Identifier, Int, Text)]
_clsItems = [(Identifier, Int, Text)
v]
  }

defaultChannelTypes :: String
defaultChannelTypes :: [Char]
defaultChannelTypes = [Char]
"#&"

csNick :: Lens' NetworkState Identifier
csNick :: Lens' NetworkState Identifier
csNick = Lens' NetworkState UserInfo
csUserInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Identifier -> f Identifier) -> UserInfo -> f UserInfo
uiNick

-- | Transmit a 'RawIrcMsg' on the connection associated
-- with the given network. For @PRIVMSG@ and @NOTICE@ overlong
-- commands are detected and transmitted as multiple messages.
sendMsg :: NetworkState -> RawIrcMsg -> IO ()
sendMsg :: NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs RawIrcMsg
msg =
  case (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand RawIrcMsg
msg, forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams RawIrcMsg
msg) of
    (Text
"PRIVMSG", [Text
tgt,Text
txt]) -> Text -> Text -> Text -> IO ()
multiline Text
"PRIVMSG" Text
tgt Text
txt
    (Text
"NOTICE",  [Text
tgt,Text
txt]) -> Text -> Text -> Text -> IO ()
multiline Text
"NOTICE"  Text
tgt Text
txt
    (Text, [Text])
_ -> RawIrcMsg -> IO ()
transmit RawIrcMsg
msg
  where
    transmit :: RawIrcMsg -> IO ()
transmit = NetworkConnection -> ByteString -> IO ()
send (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState NetworkConnection
csSocket NetworkState
cs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawIrcMsg -> ByteString
renderRawIrcMsg

    actionPrefix :: Text
actionPrefix = Text
"\^AACTION "
    actionSuffix :: Text
actionSuffix = Text
"\^A"

    -- Special case for splitting a single CTCP ACTION into
    -- multiple actions
    multiline :: Text -> Text -> Text -> IO ()
multiline Text
cmd Text
tgt Text
txt
      | Just Text
txt1 <- Text -> Text -> Maybe Text
Text.stripPrefix Text
actionPrefix Text
txt
      , Just Text
txt2 <- Text -> Text -> Maybe Text
Text.stripSuffix Text
actionSuffix Text
txt1 =
      let txtChunks :: [Text]
txtChunks     = Int -> Text -> [Text]
utf8ChunksOf Int
maxContentLen Text
txt2
          maxContentLen :: Int
maxContentLen = UserInfo -> Text -> Int
computeMaxMessageLength (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState UserInfo
csUserInfo NetworkState
cs) Text
tgt
                        forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
actionPrefix forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
actionSuffix
      in forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Text]
txtChunks forall a b. (a -> b) -> a -> b
$ \Text
txtChunk ->
           RawIrcMsg -> IO ()
transmit forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> RawIrcMsg
rawIrcMsg Text
cmd [Text
tgt, Text
actionPrefix forall a. Semigroup a => a -> a -> a
<> Text
txtChunk forall a. Semigroup a => a -> a -> a
<> Text
actionSuffix]

    -- Normal case
    multiline Text
cmd Text
tgt Text
txt =
      let txtChunks :: [Text]
txtChunks     = Int -> Text -> [Text]
utf8ChunksOf Int
maxContentLen Text
txt
          maxContentLen :: Int
maxContentLen = UserInfo -> Text -> Int
computeMaxMessageLength (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState UserInfo
csUserInfo NetworkState
cs) Text
tgt
      in forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Text]
txtChunks forall a b. (a -> b) -> a -> b
$ \Text
txtChunk ->
           RawIrcMsg -> IO ()
transmit forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> RawIrcMsg
rawIrcMsg Text
cmd [Text
tgt, Text
txtChunk]

-- This is an approximation for splitting the text. It doesn't
-- understand combining characters. A correct implementation
-- probably needs to use icu, but its going to take some work
-- to use that library to do this.
utf8ChunksOf :: Int -> Text -> [Text]
utf8ChunksOf :: Int -> Text -> [Text]
utf8ChunksOf Int
n Text
txt
  | ByteString -> Int
B.length ByteString
enc forall a. Ord a => a -> a -> Bool
<= Int
n = [Text
txt] -- fast/common case
  | Bool
otherwise         = Int -> Int -> Text -> [(Int, Int, Int)] -> [Text]
search Int
0 Int
0 Text
txt [(Int, Int, Int)]
info
  where
    isBeginning :: a -> Bool
isBeginning a
b = a
b forall a. Bits a => a -> a -> a
.&. a
0xc0 forall a. Eq a => a -> a -> Bool
/= a
0x80

    enc :: ByteString
enc = Text -> ByteString
Text.encodeUtf8 Text
txt

    beginnings :: [Int]
beginnings = (Word8 -> Bool) -> ByteString -> [Int]
B.findIndices forall {a}. (Bits a, Num a) => a -> Bool
isBeginning ByteString
enc

    info :: [(Int, Int, Int)]
info = forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0..] -- charIndex
                [Int]
beginnings
                (forall a. Int -> [a] -> [a]
drop Int
1 [Int]
beginnings forall a. [a] -> [a] -> [a]
++ [ByteString -> Int
B.length ByteString
enc])

    search :: Int -> Int -> Text -> [(Int, Int, Int)] -> [Text]
search Int
startByte Int
startChar Text
currentTxt [(Int, Int, Int)]
xs =
      case forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(Int
_,Int
_,Int
byteLen) -> Int
byteLenforall a. Num a => a -> a -> a
-Int
startByte forall a. Ord a => a -> a -> Bool
<= Int
n) [(Int, Int, Int)]
xs of
        [] -> [Text
currentTxt]
        (Int
charIx,Int
byteIx,Int
_):[(Int, Int, Int)]
xs' ->
          case Int -> Text -> (Text, Text)
Text.splitAt (Int
charIx forall a. Num a => a -> a -> a
- Int
startChar) Text
currentTxt of
            (Text
a,Text
b) -> Text
a forall a. a -> [a] -> [a]
: Int -> Int -> Text -> [(Int, Int, Int)] -> [Text]
search Int
byteIx Int
charIx Text
b [(Int, Int, Int)]
xs'

-- | Construct a new network state using the given settings and
-- default values as specified by the IRC specification.
newNetworkState ::
  Text              {- ^ network name              -} ->
  ServerSettings    {- ^ server settings           -} ->
  NetworkConnection {- ^ active network connection -} ->
  PingStatus        {- ^ initial ping status       -} ->
  Random.StdGen     {- ^ initial random seed       -} ->
  NetworkState      {- ^ new network state         -}
newNetworkState :: Text
-> ServerSettings
-> NetworkConnection
-> PingStatus
-> StdGen
-> NetworkState
newNetworkState Text
network ServerSettings
settings NetworkConnection
sock PingStatus
ping StdGen
seed = NetworkState
  { _csUserInfo :: UserInfo
_csUserInfo     = Identifier -> Text -> Text -> UserInfo
UserInfo Identifier
"*" Text
"" Text
""
  , _csChannels :: HashMap Identifier ChannelState
_csChannels     = forall k v. HashMap k v
HashMap.empty
  , _csChannelList :: ChannelList
_csChannelList  = Maybe Text -> Maybe (Identifier, Int, Text) -> ChannelList
newChannelList forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  , _csWhoReply :: WhoReply
_csWhoReply     = WhoReply -> WhoReply
finishWhoReply forall a b. (a -> b) -> a -> b
$ Text -> [Char] -> WhoReply
newWhoReply Text
"" [Char]
""
  , _csSocket :: NetworkConnection
_csSocket       = NetworkConnection
sock
  , _csChannelTypes :: [Char]
_csChannelTypes = [Char]
defaultChannelTypes
  , _csModeTypes :: ModeTypes
_csModeTypes    = ModeTypes
defaultModeTypes
  , _csUmodeTypes :: ModeTypes
_csUmodeTypes   = ModeTypes
defaultUmodeTypes
  , _csTransaction :: Transaction
_csTransaction  = Transaction
NoTransaction
  , _csModes :: [Char]
_csModes        = [Char]
""
  , _csSnomask :: [Char]
_csSnomask      = [Char]
""
  , _csStatusMsg :: [Char]
_csStatusMsg    = [Char]
""
  , _csSettings :: ServerSettings
_csSettings     = ServerSettings
settings
  , _csModeCount :: Int
_csModeCount    = Int
3
  , _csUsers :: HashMap Identifier UserAndHost
_csUsers        = forall k v. HashMap k v
HashMap.empty
  , _csNetwork :: Text
_csNetwork      = Text
network
  , _csMessageHooks :: [MessageHook]
_csMessageHooks = [HookConfig] -> [MessageHook]
buildMessageHooks (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings [HookConfig]
ssMessageHooks ServerSettings
settings)
  , _csAuthenticationState :: AuthenticateState
_csAuthenticationState = AuthenticateState
AS_None
  , _csAway :: Bool
_csAway         = Bool
False
  , _csPingStatus :: PingStatus
_csPingStatus   = PingStatus
ping
  , _csLatency :: Maybe NominalDiffTime
_csLatency      = forall a. Maybe a
Nothing
  , _csNextPingTime :: Maybe UTCTime
_csNextPingTime = forall a. Maybe a
Nothing
  , _csLastReceived :: Maybe UTCTime
_csLastReceived = forall a. Maybe a
Nothing
  , _csCertificate :: [Text]
_csCertificate  = []
  , _csSeed :: StdGen
_csSeed         = StdGen
seed
  }

buildMessageHooks :: [HookConfig] -> [MessageHook]
buildMessageHooks :: [HookConfig] -> [MessageHook]
buildMessageHooks = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe \(HookConfig Text
name [Text]
args) ->
  do [Text] -> Maybe MessageHook
hookFun <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
name HashMap Text ([Text] -> Maybe MessageHook)
messageHooks
     [Text] -> Maybe MessageHook
hookFun [Text]
args

data Apply = Apply [RawIrcMsg] NetworkState

hideMessage :: IrcMsg -> Bool
hideMessage :: IrcMsg -> Bool
hideMessage IrcMsg
m =
  case IrcMsg
m of
    Authenticate{} -> Bool
True
    BatchStart{} -> Bool
True
    BatchEnd{} -> Bool
True
    Ping{} -> Bool
True
    Pong{} -> Bool
True
    Reply Text
_ ReplyCode
RPL_WHOSPCRPL [Text
_,Text
"616",Text
_,Text
_,Text
_,Text
_] -> Bool
True
    IrcMsg
_ -> Bool
False

-- | Used for updates to a 'NetworkState' that require no reply.
noReply :: NetworkState -> Apply
noReply :: NetworkState -> Apply
noReply = [RawIrcMsg] -> NetworkState -> Apply
reply []

reply :: [RawIrcMsg] -> NetworkState -> Apply
reply :: [RawIrcMsg] -> NetworkState -> Apply
reply = [RawIrcMsg] -> NetworkState -> Apply
Apply

overChannel :: Identifier -> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel :: Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel Identifier
chan = forall s t a b.
LensLike ((,) StrictUnit) s t a b -> (a -> b) -> s -> t
overStrict (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Identifier
chan)

overChannels :: (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannels :: (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannels = forall s t a b.
LensLike ((,) StrictUnit) s t a b -> (a -> b) -> s -> t
overStrict (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)

applyMessage :: ZonedTime -> IrcMsg -> NetworkState -> Apply
applyMessage :: ZonedTime -> IrcMsg -> NetworkState -> Apply
applyMessage ZonedTime
msgWhen IrcMsg
msg NetworkState
cs
  = ZonedTime -> IrcMsg -> NetworkState -> Apply
applyMessage' ZonedTime
msgWhen IrcMsg
msg
  forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState (Maybe UTCTime)
csLastReceived (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
msgWhen) NetworkState
cs

applyMessage' :: ZonedTime -> IrcMsg -> NetworkState -> Apply
applyMessage' :: ZonedTime -> IrcMsg -> NetworkState -> Apply
applyMessage' ZonedTime
msgWhen IrcMsg
msg NetworkState
cs =
  case IrcMsg
msg of
    Ping [Text]
args -> [RawIrcMsg] -> NetworkState -> Apply
reply [[Text] -> RawIrcMsg
ircPong [Text]
args] NetworkState
cs
    Pong [Text]
_    -> NetworkState -> Apply
noReply (ZonedTime -> NetworkState -> NetworkState
doPong ZonedTime
msgWhen NetworkState
cs)
    Join Source
user Identifier
chan Text
acct Text
_ ->
         [RawIrcMsg] -> NetworkState -> Apply
reply [RawIrcMsg]
response
         forall a b. (a -> b) -> a -> b
$ UserInfo -> Text -> NetworkState -> NetworkState
recordUser (Source -> UserInfo
srcUser Source
user) Text
acct
         forall a b. (a -> b) -> a -> b
$ Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel Identifier
chan (Identifier -> ChannelState -> ChannelState
joinChannel (UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
user)))
         forall a b. (a -> b) -> a -> b
$ UserInfo -> Identifier -> NetworkState -> NetworkState
createOnJoin (Source -> UserInfo
srcUser Source
user) Identifier
chan NetworkState
cs
     where
       response :: [RawIrcMsg]
response =
         [Identifier -> [Text] -> RawIrcMsg
ircMode Identifier
chan [] | UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
user) forall a. Eq a => a -> a -> Bool
== forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Identifier
csNick NetworkState
cs]

    Account Source
user Text
acct ->
           NetworkState -> Apply
noReply
         forall a b. (a -> b) -> a -> b
$ UserInfo -> Text -> NetworkState -> NetworkState
recordUser (Source -> UserInfo
srcUser Source
user) Text
acct NetworkState
cs

    Chghost Source
user Text
newUser Text
newHost ->
           NetworkState -> Apply
noReply
         forall a b. (a -> b) -> a -> b
$ Identifier -> Text -> Text -> NetworkState -> NetworkState
updateUserInfo (UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
user)) Text
newUser Text
newHost NetworkState
cs

    Quit Source
user Maybe Text
_reason ->
           NetworkState -> Apply
noReply
         forall a b. (a -> b) -> a -> b
$ Identifier -> NetworkState -> NetworkState
forgetUser (UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
user))
         forall a b. (a -> b) -> a -> b
$ (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannels (Identifier -> ChannelState -> ChannelState
partChannel (UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
user))) NetworkState
cs

    Part Source
user Identifier
chan Maybe Text
_mbreason -> Identifier -> Identifier -> Apply
exitChannel Identifier
chan (UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
user))

    Kick Source
_kicker Identifier
chan Identifier
nick Text
_reason -> Identifier -> Identifier -> Apply
exitChannel Identifier
chan Identifier
nick

    Nick Source
oldNick Identifier
newNick ->
         let nick :: Identifier
nick = UserInfo -> Identifier
userNick (Source -> UserInfo
srcUser Source
oldNick) in
           NetworkState -> Apply
noReply
         forall a b. (a -> b) -> a -> b
$ Identifier -> Identifier -> NetworkState -> NetworkState
renameUser Identifier
nick Identifier
newNick
         forall a b. (a -> b) -> a -> b
$ Identifier -> Identifier -> NetworkState -> NetworkState
updateMyNick Identifier
nick Identifier
newNick
         forall a b. (a -> b) -> a -> b
$ (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannels (Identifier -> Identifier -> ChannelState -> ChannelState
nickChange Identifier
nick Identifier
newNick) NetworkState
cs

    Reply Text
_ ReplyCode
RPL_WELCOME (Text
me:[Text]
_) -> ZonedTime -> Identifier -> NetworkState -> Apply
doWelcome ZonedTime
msgWhen (Text -> Identifier
mkId Text
me) NetworkState
cs
    Reply Text
_ ReplyCode
RPL_SASLSUCCESS [Text]
_ -> [RawIrcMsg] -> NetworkState -> Apply
reply [RawIrcMsg
ircCapEnd] NetworkState
cs
    Reply Text
_ ReplyCode
ERR_SASLFAIL [Text]
_ -> [RawIrcMsg] -> NetworkState -> Apply
reply [RawIrcMsg
ircCapEnd] NetworkState
cs
    Reply Text
_ ReplyCode
ERR_SASLABORTED [Text]
_ -> [RawIrcMsg] -> NetworkState -> Apply
reply [RawIrcMsg
ircCapEnd] NetworkState
cs
    Reply Text
_ ReplyCode
RPL_SASLMECHS [Text]
_ -> [RawIrcMsg] -> NetworkState -> Apply
reply [RawIrcMsg
ircCapEnd] NetworkState
cs

    Reply Text
_ ReplyCode
ERR_NICKNAMEINUSE (Text
_:Text
badnick:[Text]
_)
      | PingConnecting{} <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs -> Text -> NetworkState -> Apply
doBadNick Text
badnick NetworkState
cs
    Reply Text
_ ReplyCode
ERR_BANNEDNICK (Text
_:Text
badnick:[Text]
_)
      | PingConnecting{} <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs -> Text -> NetworkState -> Apply
doBadNick Text
badnick NetworkState
cs
    Reply Text
_ ReplyCode
ERR_ERRONEUSNICKNAME (Text
_:Text
badnick:[Text]
_)
      | PingConnecting{} <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs -> Text -> NetworkState -> Apply
doBadNick Text
badnick NetworkState
cs
    Reply Text
_ ReplyCode
ERR_UNAVAILRESOURCE (Text
_:Text
badnick:[Text]
_)
      | PingConnecting{} <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs -> Text -> NetworkState -> Apply
doBadNick Text
badnick NetworkState
cs

    Reply Text
_ ReplyCode
RPL_HOSTHIDDEN (Text
_:Text
host:[Text]
_) ->
        NetworkState -> Apply
noReply (forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState UserInfo
csUserInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> UserInfo -> f UserInfo
uiHost) Text
host NetworkState
cs)

    -- /who <#channel> %tuhna,616
    -- TODO: Use a different magic token here?
    Reply Text
_ ReplyCode
RPL_WHOSPCRPL [Text
_me,Text
"616",Text
user,Text
host,Text
nick,Text
acct] ->
       let acct' :: Text
acct' = if Text
acct forall a. Eq a => a -> a -> Bool
== Text
"0" then Text
"*" else Text
acct
       in NetworkState -> Apply
noReply (UserInfo -> Text -> NetworkState -> NetworkState
recordUser (Identifier -> Text -> Text -> UserInfo
UserInfo (Text -> Identifier
mkId Text
nick) Text
user Text
host) Text
acct' NetworkState
cs)

    Reply Text
_ ReplyCode
code [Text]
args      -> ReplyCode -> ZonedTime -> [Text] -> NetworkState -> Apply
doRpl ReplyCode
code ZonedTime
msgWhen [Text]
args NetworkState
cs
    Cap CapCmd
cmd                -> CapCmd -> NetworkState -> Apply
doCap CapCmd
cmd NetworkState
cs
    Authenticate Text
param     -> Text -> NetworkState -> Apply
doAuthenticate Text
param NetworkState
cs
    Mode Source
who Identifier
target (Text
modes:[Text]
params) -> ZonedTime
-> UserInfo
-> Identifier
-> Text
-> [Text]
-> NetworkState
-> Apply
doMode ZonedTime
msgWhen (Source -> UserInfo
srcUser Source
who) Identifier
target Text
modes [Text]
params NetworkState
cs
    Topic Source
user Identifier
chan Text
topic  -> NetworkState -> Apply
noReply (ZonedTime
-> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState
doTopic ZonedTime
msgWhen (Source -> UserInfo
srcUser Source
user) Identifier
chan Text
topic NetworkState
cs)
    IrcMsg
_                      -> NetworkState -> Apply
noReply NetworkState
cs
  where
    exitChannel :: Identifier -> Identifier -> Apply
exitChannel Identifier
chan Identifier
nick
      | Identifier
nick forall a. Eq a => a -> a -> Bool
== forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Identifier
csNick NetworkState
cs = NetworkState -> Apply
noReply forall a b. (a -> b) -> a -> b
$ NetworkState -> NetworkState
pruneUsers
                               forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState (HashMap Identifier ChannelState)
csChannels (forall m. At m => Index m -> m -> m
sans Identifier
chan) NetworkState
cs

      | Bool
otherwise              = NetworkState -> Apply
noReply forall a b. (a -> b) -> a -> b
$ Identifier -> NetworkState -> NetworkState
forgetUser' Identifier
nick
                               forall a b. (a -> b) -> a -> b
$ Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel Identifier
chan (Identifier -> ChannelState -> ChannelState
partChannel Identifier
nick) NetworkState
cs

-- | Restrict 'csUsers' to only users are in a channel that the client
-- is connected to.
pruneUsers :: NetworkState -> NetworkState
pruneUsers :: NetworkState -> NetworkState
pruneUsers NetworkState
cs = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState (HashMap Identifier UserAndHost)
csUsers (forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
`HashMap.intersection` HashMap Identifier [Char]
u) NetworkState
cs
  where
    u :: HashMap Identifier [Char]
u = forall a s. Getting a s a -> s -> a
foldOf (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState (HashMap Identifier [Char])
chanUsers) NetworkState
cs

-- | 001 'RPL_WELCOME' is the first message received when transitioning
-- from the initial handshake to a connected state. At this point we know
-- what nickname the server is using for our connection, and we can start
-- scheduling PINGs.
doWelcome ::
  ZonedTime  {- ^ message received -} ->
  Identifier {- ^ my nickname      -} ->
  NetworkState ->
  Apply
doWelcome :: ZonedTime -> Identifier -> NetworkState -> Apply
doWelcome ZonedTime
msgWhen Identifier
me
  = NetworkState -> Apply
noReply
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Identifier
csNick Identifier
me
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState (Maybe UTCTime)
csNextPingTime (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
30 (ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
msgWhen))
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState PingStatus
csPingStatus PingStatus
PingNone

-- | Handle 'ERR_NICKNAMEINUSE' errors when connecting.
doBadNick ::
  Text {- ^ bad nickname -} ->
  NetworkState ->
  Apply
doBadNick :: Text -> NetworkState -> Apply
doBadNick Text
badNick NetworkState
cs =
  case forall a. (a -> Bool) -> NonEmpty a -> [a]
NonEmpty.dropWhile (Text
badNickforall a. Eq a => a -> a -> Bool
/=) (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 (NonEmpty Text)
ssNicks) NetworkState
cs) of
    Text
_:Text
next:[Text]
_ -> [RawIrcMsg] -> NetworkState -> Apply
reply [Text -> RawIrcMsg
ircNick Text
next] NetworkState
cs
    [Text]
_        -> NetworkState -> Apply
doRandomNick NetworkState
cs

-- | Pick a random nickname now that we've run out of choices
doRandomNick :: NetworkState -> Apply
doRandomNick :: NetworkState -> Apply
doRandomNick NetworkState
cs = [RawIrcMsg] -> NetworkState -> Apply
reply [Text -> RawIrcMsg
ircNick Text
candidate] NetworkState
cs'
  where
    limit :: Int
limit       = Int
9 -- RFC 2812 puts the maximum nickname length as low as 9!
    range :: (Int, Int)
range       = (Int
0, Int
99999::Int) -- up to 5 random digits
    suffix :: [Char]
suffix      = forall a. Show a => a -> [Char]
show Int
n
    primaryNick :: Text
primaryNick = forall a. NonEmpty a -> a
NonEmpty.head (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 (NonEmpty Text)
ssNicks) NetworkState
cs)
    candidate :: Text
candidate   = Int -> Text -> Text
Text.take (Int
limitforall a. Num a => a -> a -> a
-forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
suffix) Text
primaryNick forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
suffix

    (Int
n, NetworkState
cs')    = NetworkState
cs forall a b. a -> (a -> b) -> b
& Lens' NetworkState StdGen
csSeed forall {k} (f :: k -> *) s (t :: k) a (b :: k).
LensLike f s t a b -> LensLike f s t a b
%%~ forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (Int, Int)
range

doList :: [Text] -> NetworkState -> NetworkState
doList :: [Text] -> NetworkState -> NetworkState
doList (Text
_:Text
chan:Text
users:[Text]
topic) NetworkState
cs
  | Bool
purge = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState ChannelList
csChannelList (Maybe Text -> Maybe (Identifier, Int, Text) -> ChannelList
newChannelList Maybe Text
elist (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! (Identifier, Int, Text)
value)) NetworkState
cs
  | Bool
otherwise = forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState ChannelList
csChannelList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelList [(Identifier, Int, Text)]
clsItems) [(Identifier, Int, Text)]
items' NetworkState
cs
  where
    items' :: [(Identifier, Int, Text)]
items' = (Identifier, Int, Text)
valueforall a. a -> [a] -> [a]
:(ChannelList -> [(Identifier, Int, Text)]
_clsItems forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkState -> ChannelList
_csChannelList forall a b. (a -> b) -> a -> b
$ NetworkState
cs)
    value :: (Identifier, Int, Text)
value = (Text -> Identifier
mkId Text
chan, Int
usercount, forall a. a -> Maybe a -> a
fromMaybe Text
"" (forall a. [a] -> Maybe a
listToMaybe [Text]
topic))
    usercount :: Int
usercount = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> Either a b -> b
Either.fromRight (Int
0, Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => Reader a
Text.decimal forall a b. (a -> b) -> a -> b
$ Text
users
    elist :: Maybe Text
elist = ChannelList -> Maybe Text
_clsElist forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkState -> ChannelList
_csChannelList forall a b. (a -> b) -> a -> b
$ NetworkState
cs
    purge :: Bool
purge = ChannelList -> Bool
_clsDone forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkState -> ChannelList
_csChannelList forall a b. (a -> b) -> a -> b
$ NetworkState
cs
doList [Text]
_ NetworkState
cs = NetworkState
cs

doListEnd :: NetworkState -> NetworkState
doListEnd :: NetworkState -> NetworkState
doListEnd NetworkState
cs = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState ChannelList
csChannelList ChannelList
ncl NetworkState
cs
  where
    ncl :: ChannelList
ncl = ChannelList { _clsElist :: Maybe Text
_clsElist = Maybe Text
elist, _clsDone :: Bool
_clsDone = Bool
True, _clsItems :: [(Identifier, Int, Text)]
_clsItems = [(Identifier, Int, Text)]
sorted }
    elist :: Maybe Text
elist = ChannelList -> Maybe Text
_clsElist forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkState -> ChannelList
_csChannelList forall a b. (a -> b) -> a -> b
$ NetworkState
cs
    sorted :: [(Identifier, Int, Text)]
sorted = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {a} {c} {a} {c}.
Ord a =>
(a, a, c) -> (a, a, c) -> Ordering
sorter forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChannelList -> [(Identifier, Int, Text)]
_clsItems forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetworkState -> ChannelList
_csChannelList forall a b. (a -> b) -> a -> b
$ NetworkState
cs
    sorter :: (a, a, c) -> (a, a, c) -> Ordering
sorter (a
_, a
aU, c
_) (a
_, a
bU, c
_) = forall a. Ord a => a -> a -> Ordering
compare a
bU a
aU

doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState
doTopic :: ZonedTime
-> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState
doTopic ZonedTime
when UserInfo
user Identifier
chan Text
topic =
  Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel Identifier
chan (Text -> ChannelState -> ChannelState
setTopic Text
topic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ChannelState (Maybe TopicProvenance)
chanTopicProvenance (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! TopicProvenance
prov))
  where
    prov :: TopicProvenance
prov = TopicProvenance
             { _topicAuthor :: UserInfo
_topicAuthor = UserInfo
user
             , _topicTime :: UTCTime
_topicTime   = ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
when
             }

parseTimeParam :: Text -> Maybe UTCTime
parseTimeParam :: Text -> Maybe UTCTime
parseTimeParam Text
txt =
  case forall a. Integral a => Reader a
Text.decimal Text
txt of
    Right (Integer
i, Text
rest) | Text -> Bool
Text.null Text
rest ->
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! NominalDiffTime -> UTCTime
posixSecondsToUTCTime (forall a. Num a => Integer -> a
fromInteger Integer
i)
    Either [Char] (Integer, Text)
_ -> forall a. Maybe a
Nothing

doRpl :: ReplyCode -> ZonedTime -> [Text] -> NetworkState -> Apply
doRpl :: ReplyCode -> ZonedTime -> [Text] -> NetworkState -> Apply
doRpl ReplyCode
cmd ZonedTime
msgWhen [Text]
args NetworkState
cs =
  case ReplyCode
cmd of
    ReplyCode
RPL_UMODEIS ->
      case [Text]
args of
        Text
_me:Text
modes:[Text]
params
          | Just [(Bool, Char, Text)]
xs <- ModeTypes -> Text -> [Text] -> Maybe [(Bool, Char, Text)]
splitModes (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ModeTypes
csUmodeTypes NetworkState
cs) Text
modes [Text]
params ->
                 NetworkState -> Apply
noReply
               forall a b. (a -> b) -> a -> b
$ [(Bool, Char, Text)] -> NetworkState -> NetworkState
doMyModes [(Bool, Char, Text)]
xs
               forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState [Char]
csModes [Char]
"" NetworkState
cs -- reset modes
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_SNOMASK ->
      case [Text]
args of
        Text
_me:Text
snomask0:[Text]
_
          | Just Text
snomask <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"+" Text
snomask0 ->
           NetworkState -> Apply
noReply (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState [Char]
csSnomask (Text -> [Char]
Text.unpack Text
snomask) NetworkState
cs)
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_NOTOPIC ->
      case [Text]
args of
        Text
_me:Text
chan:[Text]
_ -> NetworkState -> Apply
noReply
                    forall a b. (a -> b) -> a -> b
$ Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel
                        (Text -> Identifier
mkId Text
chan)
                        (Text -> ChannelState -> ChannelState
setTopic Text
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ChannelState (Maybe TopicProvenance)
chanTopicProvenance forall a. Maybe a
Nothing)
                        NetworkState
cs
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_TOPIC ->
      case [Text]
args of
        Text
_me:Text
chan:Text
topic:[Text]
_ -> NetworkState -> Apply
noReply (Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel (Text -> Identifier
mkId Text
chan) (Text -> ChannelState -> ChannelState
setTopic Text
topic) NetworkState
cs)
        [Text]
_                -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_TOPICWHOTIME ->
      case [Text]
args of
        Text
_me:Text
chan:Text
who:Text
whenTxt:[Text]
_ | Just UTCTime
when <- Text -> Maybe UTCTime
parseTimeParam Text
whenTxt ->
          let !prov :: TopicProvenance
prov = TopicProvenance
                       { _topicAuthor :: UserInfo
_topicAuthor = Text -> UserInfo
parseUserInfo Text
who
                       , _topicTime :: UTCTime
_topicTime   = UTCTime
when
                       }
          in NetworkState -> Apply
noReply (Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel (Text -> Identifier
mkId Text
chan) (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ChannelState (Maybe TopicProvenance)
chanTopicProvenance (forall a. a -> Maybe a
Just TopicProvenance
prov)) NetworkState
cs)
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_CREATIONTIME ->
      case [Text]
args of
        Text
_me:Text
chan:Text
whenTxt:[Text]
_ | Just UTCTime
when <- Text -> Maybe UTCTime
parseTimeParam Text
whenTxt ->
          NetworkState -> Apply
noReply (Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel (Text -> Identifier
mkId Text
chan) (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ChannelState (Maybe UTCTime)
chanCreation (forall a. a -> Maybe a
Just UTCTime
when)) NetworkState
cs)
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_CHANNEL_URL ->
      case [Text]
args of
        Text
_me:Text
chan:Text
urlTxt:[Text]
_ ->
          NetworkState -> Apply
noReply (Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel (Text -> Identifier
mkId Text
chan) (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' ChannelState (Maybe Text)
chanUrl (forall a. a -> Maybe a
Just Text
urlTxt)) NetworkState
cs)
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_MYINFO -> NetworkState -> Apply
noReply ([Text] -> NetworkState -> NetworkState
myinfo [Text]
args NetworkState
cs)

    ReplyCode
RPL_ISUPPORT -> NetworkState -> Apply
noReply ([Text] -> NetworkState -> NetworkState
isupport [Text]
args NetworkState
cs)

    ReplyCode
RPL_NAMREPLY ->
      case [Text]
args of
        Text
_me:Text
_sym:Text
_tgt:Text
x:[Text]
_ ->
           NetworkState -> Apply
noReply forall a b. (a -> b) -> a -> b
$
           forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState Transaction
csTransaction
                (\Transaction
t -> let xs :: [Text]
xs = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Prism' Transaction [Text]
_NamesTransaction Transaction
t
                       in [Text]
xs seq :: forall a b. a -> b -> b
`seq` [Text] -> Transaction
NamesTransaction (Text
xforall a. a -> [a] -> [a]
:[Text]
xs))
                NetworkState
cs
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_ENDOFNAMES ->
      case [Text]
args of
        Text
_me:Text
tgt:[Text]
_ -> NetworkState -> Apply
noReply (Identifier -> NetworkState -> NetworkState
loadNamesList (Text -> Identifier
mkId Text
tgt) NetworkState
cs)
        [Text]
_         -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_BANLIST ->
      case [Text]
args of
        Text
_me:Text
_tgt:Text
mask:Text
who:Text
whenTxt:[Text]
_ -> NetworkState -> Apply
noReply (Text -> Text -> Text -> NetworkState -> NetworkState
recordListEntry Text
mask Text
who Text
whenTxt NetworkState
cs)
        [Text]
_                           -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_ENDOFBANLIST ->
      case [Text]
args of
        Text
_me:Text
tgt:[Text]
_ -> NetworkState -> Apply
noReply (Char -> Text -> NetworkState -> NetworkState
saveList Char
'b' Text
tgt NetworkState
cs)
        [Text]
_         -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_QUIETLIST ->
      case [Text]
args of
        Text
_me:Text
_tgt:Text
_q:Text
mask:Text
who:Text
whenTxt:[Text]
_ -> NetworkState -> Apply
noReply (Text -> Text -> Text -> NetworkState -> NetworkState
recordListEntry Text
mask Text
who Text
whenTxt NetworkState
cs)
        [Text]
_                              -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_ENDOFQUIETLIST ->
      case [Text]
args of
        Text
_me:Text
tgt:[Text]
_ -> NetworkState -> Apply
noReply (Char -> Text -> NetworkState -> NetworkState
saveList Char
'q' Text
tgt NetworkState
cs)
        [Text]
_         -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_INVEXLIST ->
      case [Text]
args of
        Text
_me:Text
_tgt:Text
mask:Text
who:Text
whenTxt:[Text]
_ -> NetworkState -> Apply
noReply (Text -> Text -> Text -> NetworkState -> NetworkState
recordListEntry Text
mask Text
who Text
whenTxt NetworkState
cs)
        [Text]
_                           -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_ENDOFINVEXLIST ->
      case [Text]
args of
        Text
_me:Text
tgt:[Text]
_ -> NetworkState -> Apply
noReply (Char -> Text -> NetworkState -> NetworkState
saveList Char
'I' Text
tgt NetworkState
cs)
        [Text]
_         -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_EXCEPTLIST ->
      case [Text]
args of
        Text
_me:Text
_tgt:Text
mask:Text
who:Text
whenTxt:[Text]
_ -> NetworkState -> Apply
noReply (Text -> Text -> Text -> NetworkState -> NetworkState
recordListEntry Text
mask Text
who Text
whenTxt NetworkState
cs)
        [Text]
_                           -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_ENDOFEXCEPTLIST ->
      case [Text]
args of
        Text
_me:Text
tgt:[Text]
_ -> NetworkState -> Apply
noReply (Char -> Text -> NetworkState -> NetworkState
saveList Char
'e' Text
tgt NetworkState
cs)
        [Text]
_         -> NetworkState -> Apply
noReply NetworkState
cs

    ReplyCode
RPL_WHOREPLY ->
      case [Text]
args of
        Text
_me:Text
_tgt:Text
uname:Text
host:Text
_server:Text
nick:[Text]
_ ->
          NetworkState -> Apply
noReply forall a b. (a -> b) -> a -> b
$
          forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState WhoReply
csWhoReply ([Text] -> WhoReply -> WhoReply
recordWhoReply [Text]
args) forall a b. (a -> b) -> a -> b
$
          forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState Transaction
csTransaction (\Transaction
t ->
            let !x :: UserInfo
x  = Identifier -> Text -> Text -> UserInfo
UserInfo (Text -> Identifier
mkId Text
nick) Text
uname Text
host
                !xs :: [UserInfo]
xs = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Prism' Transaction [UserInfo]
_WhoTransaction Transaction
t
            in [UserInfo] -> Transaction
WhoTransaction (UserInfo
x forall a. a -> [a] -> [a]
: [UserInfo]
xs))
            NetworkState
cs
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs
    ReplyCode
RPL_WHOSPCRPL -> NetworkState -> Apply
noReply (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState WhoReply
csWhoReply ([Text] -> WhoReply -> WhoReply
recordWhoXReply [Text]
args) NetworkState
cs)
    ReplyCode
RPL_ENDOFWHO -> NetworkState -> Apply
noReply (forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState WhoReply
csWhoReply WhoReply -> WhoReply
finishWhoReply forall a b. (a -> b) -> a -> b
$ NetworkState -> NetworkState
massRegistration NetworkState
cs)

    ReplyCode
RPL_CHANNELMODEIS ->
      case [Text]
args of
        Text
_me:Text
chan:Text
modes:[Text]
params ->
              ZonedTime
-> UserInfo
-> Identifier
-> Text
-> [Text]
-> NetworkState
-> Apply
doMode ZonedTime
msgWhen UserInfo
who Identifier
chanId Text
modes [Text]
params
            forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Identifier
chanId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState (Map Char Text)
chanModes) forall k a. Map k a
Map.empty NetworkState
cs
            where chanId :: Identifier
chanId = Text -> Identifier
mkId Text
chan
                  !who :: UserInfo
who = Identifier -> Text -> Text -> UserInfo
UserInfo Identifier
"*" Text
"" Text
""
        [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    -- Away flag tracking
    ReplyCode
RPL_NOWAWAY -> NetworkState -> Apply
noReply (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Bool
csAway Bool
True NetworkState
cs)
    ReplyCode
RPL_UNAWAY  -> NetworkState -> Apply
noReply (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Bool
csAway Bool
False NetworkState
cs)

    -- /list
    ReplyCode
RPL_LIST    -> NetworkState -> Apply
noReply ([Text] -> NetworkState -> NetworkState
doList [Text]
args NetworkState
cs)
    ReplyCode
RPL_LISTEND -> NetworkState -> Apply
noReply (NetworkState -> NetworkState
doListEnd NetworkState
cs)

    ReplyCode
_ -> NetworkState -> Apply
noReply NetworkState
cs


-- | Add an entry to a mode list transaction
recordListEntry ::
  Text {- ^ mask -} ->
  Text {- ^ set by -} ->
  Text {- ^ set time -} ->
  NetworkState -> NetworkState
recordListEntry :: Text -> Text -> Text -> NetworkState -> NetworkState
recordListEntry Text
mask Text
who Text
whenTxt =
  case Text -> Maybe UTCTime
parseTimeParam Text
whenTxt of
    Maybe UTCTime
Nothing   -> forall a. a -> a
id
    Just UTCTime
when ->
      forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState Transaction
csTransaction forall a b. (a -> b) -> a -> b
$ \Transaction
t ->
        let !x :: MaskListEntry
x = MaskListEntry
                    { _maskListSetter :: Text
_maskListSetter = Text
who
                    , _maskListTime :: UTCTime
_maskListTime   = UTCTime
when
                    }
            !xs :: [(Text, MaskListEntry)]
xs = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Prism' Transaction [(Text, MaskListEntry)]
_BanTransaction Transaction
t
        in [(Text, MaskListEntry)] -> Transaction
BanTransaction ((Text
mask,MaskListEntry
x)forall a. a -> [a] -> [a]
:[(Text, MaskListEntry)]
xs)


-- | Save a completed ban, quiet, invex, or exempt list into the channel
-- state.
saveList ::
  Char {- ^ mode -} ->
  Text {- ^ channel -} ->
  NetworkState -> NetworkState
saveList :: Char -> Text -> NetworkState -> NetworkState
saveList Char
mode Text
tgt NetworkState
cs
   = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Transaction
csTransaction Transaction
NoTransaction
   forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
setStrict
        (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Text -> Identifier
mkId Text
tgt) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState (Map Char (HashMap Text MaskListEntry))
chanLists forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Char
mode)
        (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! HashMap Text MaskListEntry
newList)
        NetworkState
cs
  where
    newList :: HashMap Text MaskListEntry
newList = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState Transaction
csTransaction forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Transaction [(Text, MaskListEntry)]
_BanTransaction) NetworkState
cs)


-- | These replies are interpreted by the client and should only be shown
-- in the detailed view.
squelchReply :: ReplyCode -> Bool
squelchReply :: ReplyCode -> Bool
squelchReply ReplyCode
rpl =
  case ReplyCode
rpl of
    ReplyCode
RPL_NAMREPLY        -> Bool
True
    ReplyCode
RPL_ENDOFNAMES      -> Bool
True
    ReplyCode
RPL_BANLIST         -> Bool
True
    ReplyCode
RPL_ENDOFBANLIST    -> Bool
True
    ReplyCode
RPL_INVEXLIST       -> Bool
True
    ReplyCode
RPL_ENDOFINVEXLIST  -> Bool
True
    ReplyCode
RPL_EXCEPTLIST      -> Bool
True
    ReplyCode
RPL_ENDOFEXCEPTLIST -> Bool
True
    ReplyCode
RPL_QUIETLIST       -> Bool
True
    ReplyCode
RPL_ENDOFQUIETLIST  -> Bool
True
    ReplyCode
RPL_CHANNELMODEIS   -> Bool
True
    ReplyCode
RPL_UMODEIS         -> Bool
True
    ReplyCode
RPL_SNOMASK         -> Bool
True
    ReplyCode
RPL_WHOREPLY        -> Bool
True
    ReplyCode
RPL_ENDOFWHO        -> Bool
True
    ReplyCode
RPL_WHOSPCRPL       -> Bool
True
    ReplyCode
RPL_TOPICWHOTIME    -> Bool
True
    ReplyCode
RPL_CREATIONTIME    -> Bool
True
    ReplyCode
RPL_CHANNEL_URL     -> Bool
True
    ReplyCode
RPL_NOTOPIC         -> Bool
True
    ReplyCode
RPL_LISTSTART       -> Bool
True
    ReplyCode
RPL_LIST            -> Bool
True
    ReplyCode
RPL_LISTEND         -> Bool
True
    ReplyCode
_                   -> Bool
False

-- | Return 'True' for messages that should be hidden outside of
-- full detail view. These messages are interpreted by the client
-- so the user shouldn't need to see them directly to get the
-- relevant information.
squelchIrcMsg :: IrcMsg -> Bool
squelchIrcMsg :: IrcMsg -> Bool
squelchIrcMsg (Reply Text
_ ReplyCode
rpl [Text]
_) = ReplyCode -> Bool
squelchReply ReplyCode
rpl
squelchIrcMsg IrcMsg
_               = Bool
False

doMode ::
  ZonedTime {- ^ time of message -} ->
  UserInfo  {- ^ sender          -} ->
  Identifier {- ^ channel        -} ->
  Text       {- ^ mode flags     -} ->
  [Text]     {- ^ mode parameters -} ->
  NetworkState ->
  Apply
doMode :: ZonedTime
-> UserInfo
-> Identifier
-> Text
-> [Text]
-> NetworkState
-> Apply
doMode ZonedTime
when UserInfo
who Identifier
target Text
modes [Text]
args NetworkState
cs
  | forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Identifier
csNick NetworkState
cs forall a. Eq a => a -> a -> Bool
== Identifier
target
  , Just [(Bool, Char, Text)]
xs <- ModeTypes -> Text -> [Text] -> Maybe [(Bool, Char, Text)]
splitModes (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ModeTypes
csUmodeTypes NetworkState
cs) Text
modes [Text]
args =
        NetworkState -> Apply
noReply ([(Bool, Char, Text)] -> NetworkState -> NetworkState
doMyModes [(Bool, Char, Text)]
xs NetworkState
cs)

  | NetworkState -> Identifier -> Bool
isChannelIdentifier NetworkState
cs Identifier
target
  , Just [(Bool, Char, Text)]
xs <- ModeTypes -> Text -> [Text] -> Maybe [(Bool, Char, Text)]
splitModes (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ModeTypes
csModeTypes NetworkState
cs) Text
modes [Text]
args
  , let cs' :: NetworkState
cs' = ZonedTime
-> UserInfo
-> Identifier
-> [(Bool, Char, Text)]
-> NetworkState
-> NetworkState
doChannelModes ZonedTime
when UserInfo
who Identifier
target [(Bool, Char, Text)]
xs NetworkState
cs =

    if Identifier -> NetworkState -> Bool
iHaveOp Identifier
target NetworkState
cs'
      then let ([RawIrcMsg]
response, NetworkState
cs_) = NetworkState
cs' forall a b. a -> (a -> b) -> b
& Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Identifier
target forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState [RawIrcMsg]
chanQueuedModeration forall a s t b. LensLike ((,) a) s t a b -> b -> s -> (a, t)
<<.~ []
           in [RawIrcMsg] -> NetworkState -> Apply
reply [RawIrcMsg]
response NetworkState
cs_
      else NetworkState -> Apply
noReply NetworkState
cs'

doMode ZonedTime
_ UserInfo
_ Identifier
_ Text
_ [Text]
_ NetworkState
cs = NetworkState -> Apply
noReply NetworkState
cs -- ignore bad mode command

-- | Predicate to test if the connection has op in a given channel.
iHaveOp :: Identifier -> NetworkState -> Bool
iHaveOp :: Identifier -> NetworkState -> Bool
iHaveOp Identifier
channel NetworkState
cs =
  forall a s. Eq a => Getting Any s a -> a -> s -> Bool
elemOf (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Identifier
channel forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState (HashMap Identifier [Char])
chanUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Identifier
me forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded) Char
'@' NetworkState
cs
  where
    me :: Identifier
me = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Identifier
csNick NetworkState
cs


doChannelModes :: ZonedTime -> UserInfo -> Identifier -> [(Bool, Char, Text)] -> NetworkState -> NetworkState
doChannelModes :: ZonedTime
-> UserInfo
-> Identifier
-> [(Bool, Char, Text)]
-> NetworkState
-> NetworkState
doChannelModes ZonedTime
when UserInfo
who Identifier
chan [(Bool, Char, Text)]
changes NetworkState
cs = Identifier
-> (ChannelState -> ChannelState) -> NetworkState -> NetworkState
overChannel Identifier
chan ChannelState -> ChannelState
applyChannelModes NetworkState
cs
  where
    modeTypes :: ModeTypes
modeTypes = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ModeTypes
csModeTypes NetworkState
cs
    sigilMap :: [(Char, Char)]
sigilMap  = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
([(Char, Char)] -> f [(Char, Char)]) -> ModeTypes -> f ModeTypes
modesPrefixModes ModeTypes
modeTypes
    listModes :: [Char]
listModes = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesLists ModeTypes
modeTypes

    applyChannelModes :: ChannelState -> ChannelState
applyChannelModes ChannelState
c = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ChannelState -> (Bool, Char, Text) -> ChannelState
applyChannelMode ChannelState
c [(Bool, Char, Text)]
changes

    applyChannelMode :: ChannelState -> (Bool, Char, Text) -> ChannelState
applyChannelMode ChannelState
c (Bool
polarity, Char
mode, Text
arg)

      | Just Char
sigil <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
mode [(Char, Char)]
sigilMap =
          forall s t a b.
LensLike ((,) StrictUnit) s t a b -> (a -> b) -> s -> t
overStrict (Lens' ChannelState (HashMap Identifier [Char])
chanUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Text -> Identifier
mkId Text
arg))
                     (Bool -> Char -> ShowS
setPrefixMode Bool
polarity Char
sigil)
                     ChannelState
c

      | Char
mode forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
listModes =
        let entry :: Maybe MaskListEntry
entry | Bool
polarity = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! MaskListEntry
                         { _maskListSetter :: Text
_maskListSetter = UserInfo -> Text
renderUserInfo UserInfo
who
                         , _maskListTime :: UTCTime
_maskListTime   = ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
when
                         }
                  | Bool
otherwise = forall a. Maybe a
Nothing
        in forall s t a b. ASetter s t a b -> b -> s -> t
setStrict (Lens' ChannelState (Map Char (HashMap Text MaskListEntry))
chanLists forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Char
mode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
arg) Maybe MaskListEntry
entry ChannelState
c

      | Bool
polarity  = forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' ChannelState (Map Char Text)
chanModes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Char
mode) (forall a. a -> Maybe a
Just Text
arg) ChannelState
c
      | Bool
otherwise = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' ChannelState (Map Char Text)
chanModes (forall m. At m => Index m -> m -> m
sans Char
mode) ChannelState
c

    setPrefixMode :: Bool -> Char -> ShowS
setPrefixMode Bool
polarity Char
sigil [Char]
sigils
      | Bool -> Bool
not Bool
polarity        = forall a. Eq a => a -> [a] -> [a]
delete Char
sigil [Char]
sigils
      | Char
sigil forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
sigils = [Char]
sigils
      | Bool
otherwise           = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
sigils') (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Char, Char)]
sigilMap)
      where
        sigils' :: [Char]
sigils' = Char
sigil forall a. a -> [a] -> [a]
: [Char]
sigils


doMyModes :: [(Bool, Char, Text)] -> NetworkState -> NetworkState
doMyModes :: [(Bool, Char, Text)] -> NetworkState -> NetworkState
doMyModes [(Bool, Char, Text)]
changes = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState [Char]
csModes forall a b. (a -> b) -> a -> b
$ \[Char]
modes -> forall a. Ord a => [a] -> [a]
sort (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a} {c}. Eq a => [a] -> (Bool, a, c) -> [a]
applyOne [Char]
modes [(Bool, Char, Text)]
changes)
  where
    applyOne :: [a] -> (Bool, a, c) -> [a]
applyOne [a]
modes (Bool
True, a
mode, c
_)
      | a
mode forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
modes = [a]
modes
      | Bool
otherwise         = a
modeforall a. a -> [a] -> [a]
:[a]
modes
    applyOne [a]
modes (Bool
False, a
mode, c
_) = forall a. Eq a => a -> [a] -> [a]
delete a
mode [a]
modes

selectCaps ::
  NetworkState         {- ^ network state  -} ->
  [(Text, Maybe Text)] {- ^ server caps    -} ->
  [Text]               {- ^ caps to enable -}
selectCaps :: NetworkState -> [(Text, Maybe Text)] -> [Text]
selectCaps NetworkState
cs [(Text, Maybe Text)]
offered = ([Text]
supported forall a. Eq a => [a] -> [a] -> [a]
`intersect` forall k a. Map k a -> [k]
Map.keys Map Text (Maybe Text)
capMap)
                        forall a. Eq a => [a] -> [a] -> [a]
`union`
                        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 [Text]
ssCapabilities) NetworkState
cs
  where
    capMap :: Map Text (Maybe Text)
capMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Maybe Text)]
offered

    supported :: [Text]
supported =
      [Text]
sasl forall a. [a] -> [a] -> [a]
++ [Text]
serverTime forall a. [a] -> [a] -> [a]
++
      [Text
"multi-prefix", Text
"batch", Text
"znc.in/playback", Text
"znc.in/self-message"
      , Text
"cap-notify", Text
"extended-join", Text
"account-notify", Text
"chghost"
      , Text
"userhost-in-names", Text
"account-tag", Text
"solanum.chat/identify-msg"
      , Text
"solanum.chat/realhost", Text
"away-notify"]

    -- logic for using IRCv3.2 server-time if available and falling back
    -- to ZNC's specific extension otherwise.
    serverTime :: [Text]
serverTime
      | Text
"server-time"            forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Text (Maybe Text)
capMap = [Text
"server-time"]
      | Text
"znc.in/server-time-iso" forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Text (Maybe Text)
capMap = [Text
"znc.in/server-time-iso"]
      | Bool
otherwise                                    = []

    ss :: ServerSettings
ss = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ServerSettings
csSettings NetworkState
cs
    sasl :: [Text]
sasl = [Text
"sasl" | forall a. Maybe a -> Bool
isJust (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ServerSettings
ss) ]

decodeAuthParam :: Text -> Maybe B.ByteString
decodeAuthParam :: Text -> Maybe ByteString
decodeAuthParam Text
"+" = forall a. a -> Maybe a
Just ByteString
""
decodeAuthParam Text
xs =
  case ByteString -> Either [Char] ByteString
B64.decode (Text -> ByteString
Text.encodeUtf8 Text
xs) of
    Right ByteString
bs -> forall a. a -> Maybe a
Just ByteString
bs
    Left [Char]
_ -> forall a. Maybe a
Nothing

abortAuth :: NetworkState -> Apply
abortAuth :: NetworkState -> Apply
abortAuth = [RawIrcMsg] -> NetworkState -> Apply
reply [Text -> RawIrcMsg
ircAuthenticate Text
"*"] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_None

doAuthenticate :: Text -> NetworkState -> Apply
doAuthenticate :: Text -> NetworkState -> Apply
doAuthenticate Text
paramTxt NetworkState
cs =
  case Text -> Maybe ByteString
decodeAuthParam Text
paramTxt of
    Maybe ByteString
Nothing -> NetworkState -> Apply
abortAuth NetworkState
cs
    Just ByteString
param -> ByteString -> NetworkState -> Apply
doAuthenticate' ByteString
param NetworkState
cs

doAuthenticate' :: B.ByteString -> NetworkState -> Apply
doAuthenticate' :: ByteString -> NetworkState -> Apply
doAuthenticate' ByteString
param NetworkState
cs =
  case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState AuthenticateState
csAuthenticationState NetworkState
cs of
    AuthenticateState
AS_PlainStarted
      | ByteString -> Bool
B.null ByteString
param
      , Just (SaslPlain Maybe Text
mbAuthz Text
authc (SecretText Text
pass)) <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ServerSettings
ss
      , let authz :: Text
authz = forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mbAuthz
      -> [RawIrcMsg] -> NetworkState -> Apply
reply
           (AuthenticatePayload -> [RawIrcMsg]
ircAuthenticates (Text -> Text -> Text -> AuthenticatePayload
encodePlainAuthentication Text
authz Text
authc Text
pass))
           (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_None NetworkState
cs)

    AuthenticateState
AS_ExternalStarted
      | ByteString -> Bool
B.null ByteString
param
      , Just (SaslExternal Maybe Text
mbAuthz) <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ServerSettings
ss
      , let authz :: Text
authz = forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mbAuthz
      -> [RawIrcMsg] -> NetworkState -> Apply
reply
           (AuthenticatePayload -> [RawIrcMsg]
ircAuthenticates (Text -> AuthenticatePayload
encodeExternalAuthentication Text
authz))
           (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_None NetworkState
cs)

    AuthenticateState
AS_EcdsaStarted
      | ByteString -> Bool
B.null ByteString
param
      , Just (SaslEcdsa Maybe Text
mbAuthz Text
authc [Char]
_) <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ServerSettings
ss
      -> [RawIrcMsg] -> NetworkState -> Apply
reply
           (AuthenticatePayload -> [RawIrcMsg]
ircAuthenticates (Maybe Text -> Text -> AuthenticatePayload
Ecdsa.encodeAuthentication Maybe Text
mbAuthz Text
authc))
           (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_EcdsaWaitChallenge NetworkState
cs)

    AuthenticateState
AS_EcdsaWaitChallenge -> NetworkState -> Apply
noReply NetworkState
cs -- handled in Client.EventLoop!

    AuthenticateState
AS_ScramStarted
      | ByteString -> Bool
B.null ByteString
param
      , Just (SaslScram ScramDigest
digest Maybe Text
mbAuthz Text
user (SecretText Text
pass))
          <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ServerSettings
ss
      , let authz :: Text
authz = forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
mbAuthz
      , (ByteString
nonce, NetworkState
cs') <- NetworkState
cs forall a b. a -> (a -> b) -> b
& Lens' NetworkState StdGen
csSeed forall {k} (f :: k -> *) s (t :: k) a (b :: k).
LensLike f s t a b -> LensLike f s t a b
%%~ StdGen -> (ByteString, StdGen)
scramNonce
      , (AuthenticatePayload
msg, Phase1
scram1) <-
          ScramDigest
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> (AuthenticatePayload, Phase1)
Scram.initiateScram ScramDigest
digest
            (Text -> ByteString
Text.encodeUtf8 Text
user)
            (Text -> ByteString
Text.encodeUtf8 Text
authz)
            (Text -> ByteString
Text.encodeUtf8 Text
pass)
            ByteString
nonce
      -> [RawIrcMsg] -> NetworkState -> Apply
reply
           (AuthenticatePayload -> [RawIrcMsg]
ircAuthenticates AuthenticatePayload
msg)
           (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState (Phase1 -> AuthenticateState
AS_Scram1 Phase1
scram1) NetworkState
cs')

    AS_Scram1 Phase1
scram1
      | Just (AuthenticatePayload
rsp, Phase2
scram2) <- Phase1 -> ByteString -> Maybe (AuthenticatePayload, Phase2)
Scram.addServerFirst Phase1
scram1 ByteString
param
      -> [RawIrcMsg] -> NetworkState -> Apply
reply
           (AuthenticatePayload -> [RawIrcMsg]
ircAuthenticates AuthenticatePayload
rsp)
           (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState (Phase2 -> AuthenticateState
AS_Scram2 Phase2
scram2) NetworkState
cs)

    AS_Scram2 Phase2
scram2
      | Phase2 -> ByteString -> Bool
Scram.addServerFinal Phase2
scram2 ByteString
param
      -> [RawIrcMsg] -> NetworkState -> Apply
reply
           [Text -> RawIrcMsg
ircAuthenticate Text
"+"]
           (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_None NetworkState
cs)

    AuthenticateState
AS_EcdhStarted
      | ByteString -> Bool
B.null ByteString
param
      , Just (SaslEcdh Maybe Text
mbAuthz Text
authc (SecretText Text
key)) <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ServerSettings
ss
      , Just (AuthenticatePayload
rsp, Phase1
ecdh1) <- Maybe Text -> Text -> Text -> Maybe (AuthenticatePayload, Phase1)
Ecdh.clientFirst Maybe Text
mbAuthz Text
authc Text
key
      -> [RawIrcMsg] -> NetworkState -> Apply
reply
           (AuthenticatePayload -> [RawIrcMsg]
ircAuthenticates AuthenticatePayload
rsp)
           (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState (Phase1 -> AuthenticateState
AS_EcdhWaitChallenge Phase1
ecdh1) NetworkState
cs)
    
    AS_EcdhWaitChallenge Phase1
ecdh1
      | Just AuthenticatePayload
rsp <- Phase1 -> ByteString -> Maybe AuthenticatePayload
Ecdh.clientResponse Phase1
ecdh1 ByteString
param
      -> [RawIrcMsg] -> NetworkState -> Apply
reply (AuthenticatePayload -> [RawIrcMsg]
ircAuthenticates AuthenticatePayload
rsp) (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_None NetworkState
cs)

    AuthenticateState
_ -> NetworkState -> Apply
abortAuth NetworkState
cs

  where
    ss :: ServerSettings
ss = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ServerSettings
csSettings NetworkState
cs

scramNonce :: Random.StdGen -> (B.ByteString, Random.StdGen)
scramNonce :: StdGen -> (ByteString, StdGen)
scramNonce = forall {t} {t}.
(Eq t, Num t, RandomGen t) =>
[Word8] -> t -> t -> (ByteString, t)
go [] Int
nonceSize
  where
    alphabet :: ByteString
alphabet = ByteString
"!\"#$%&'()*+-./0123456789:;<=>?@\
               \ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`\
               \abcdefghijklmnopqrstuvwxyz{|}~"

    nonceSize :: Int
nonceSize = Int
20 :: Int -- ceiling (128 / logBase 9 (length alphabet))

    go :: [Word8] -> t -> t -> (ByteString, t)
go [Word8]
acc t
0 t
g = ([Word8] -> ByteString
B.pack [Word8]
acc, t
g)
    go [Word8]
acc t
i t
g =
      case forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (Int
0, ByteString -> Int
B.length ByteString
alphabetforall a. Num a => a -> a -> a
-Int
1) t
g of
        (Int
x,t
g') -> [Word8] -> t -> t -> (ByteString, t)
go (HasCallStack => ByteString -> Int -> Word8
B.index ByteString
alphabet Int
xforall a. a -> [a] -> [a]
:[Word8]
acc) (t
iforall a. Num a => a -> a -> a
-t
1) t
g'

doCap :: CapCmd -> NetworkState -> Apply
doCap :: CapCmd -> NetworkState -> Apply
doCap CapCmd
cmd NetworkState
cs =
  case CapCmd
cmd of
    (CapLs CapMore
CapMore [(Text, Maybe Text)]
caps) ->
      NetworkState -> Apply
noReply (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Transaction
csTransaction ([(Text, Maybe Text)] -> Transaction
CapLsTransaction ([(Text, Maybe Text)]
caps forall a. [a] -> [a] -> [a]
++ [(Text, Maybe Text)]
prevCaps)) NetworkState
cs)
      where
        prevCaps :: [(Text, Maybe Text)]
prevCaps = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState Transaction
csTransaction forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Transaction [(Text, Maybe Text)]
_CapLsTransaction) NetworkState
cs

    CapLs CapMore
CapDone [(Text, Maybe Text)]
caps
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
reqCaps -> [RawIrcMsg] -> NetworkState -> Apply
reply [RawIrcMsg
ircCapEnd] NetworkState
cs'
      | Bool
otherwise    -> [RawIrcMsg] -> NetworkState -> Apply
reply [[Text] -> RawIrcMsg
ircCapReq [Text]
reqCaps] NetworkState
cs'
      where
        reqCaps :: [Text]
reqCaps = NetworkState -> [(Text, Maybe Text)] -> [Text]
selectCaps NetworkState
cs ([(Text, Maybe Text)]
caps forall a. [a] -> [a] -> [a]
++ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState Transaction
csTransaction forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Transaction [(Text, Maybe Text)]
_CapLsTransaction) NetworkState
cs)
        cs' :: NetworkState
cs' = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Transaction
csTransaction Transaction
NoTransaction NetworkState
cs

    CapNew [(Text, Maybe Text)]
caps
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
reqCaps -> NetworkState -> Apply
noReply NetworkState
cs
      | Bool
otherwise    -> [RawIrcMsg] -> NetworkState -> Apply
reply [[Text] -> RawIrcMsg
ircCapReq [Text]
reqCaps] NetworkState
cs
      where
        reqCaps :: [Text]
reqCaps = NetworkState -> [(Text, Maybe Text)] -> [Text]
selectCaps NetworkState
cs [(Text, Maybe Text)]
caps

    CapDel [Text]
_ -> NetworkState -> Apply
noReply NetworkState
cs

    CapAck [Text]
caps
      | let ss :: ServerSettings
ss = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ServerSettings
csSettings NetworkState
cs
      , Text
"sasl" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
caps
      , Just SaslMechanism
mech <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe SaslMechanism)
ssSaslMechanism ServerSettings
ss ->
        case SaslMechanism
mech of
          SaslEcdsa{} ->
            [RawIrcMsg] -> NetworkState -> Apply
reply [Text -> RawIrcMsg
ircAuthenticate Text
Ecdsa.authenticationMode]
                  (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_EcdsaStarted NetworkState
cs)
          SaslPlain{} ->
            [RawIrcMsg] -> NetworkState -> Apply
reply [Text -> RawIrcMsg
ircAuthenticate Text
"PLAIN"]
                  (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_PlainStarted NetworkState
cs)
          SaslExternal{} ->
            [RawIrcMsg] -> NetworkState -> Apply
reply [Text -> RawIrcMsg
ircAuthenticate Text
"EXTERNAL"]
                  (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_ExternalStarted NetworkState
cs)
          SaslScram ScramDigest
digest Maybe Text
_ Text
_ Secret
_ ->
            [RawIrcMsg] -> NetworkState -> Apply
reply [Text -> RawIrcMsg
ircAuthenticate (ScramDigest -> Text
Scram.mechanismName ScramDigest
digest)]
                  (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_ScramStarted NetworkState
cs)
          SaslEcdh{} ->
            [RawIrcMsg] -> NetworkState -> Apply
reply [Text -> RawIrcMsg
ircAuthenticate Text
Ecdh.mechanismName]
                  (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState AuthenticateState
csAuthenticationState AuthenticateState
AS_EcdhStarted NetworkState
cs)

    CapCmd
_ -> [RawIrcMsg] -> NetworkState -> Apply
reply [RawIrcMsg
ircCapEnd] NetworkState
cs

initialMessages :: NetworkState -> [RawIrcMsg]
initialMessages :: NetworkState -> [RawIrcMsg]
initialMessages NetworkState
cs
   = [ RawIrcMsg
ircCapLs ]
  forall a. [a] -> [a] -> [a]
++ [ Text -> RawIrcMsg
ircPass Text
pass | Just (SecretText Text
pass) <- [forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings (Maybe Secret)
ssPassword ServerSettings
ss]]
  forall a. [a] -> [a] -> [a]
++ [ Text -> RawIrcMsg
ircNick (forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views Lens' ServerSettings (NonEmpty Text)
ssNicks forall a. NonEmpty a -> a
NonEmpty.head ServerSettings
ss)
     , Text -> Text -> RawIrcMsg
ircUser (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings Text
ssUser ServerSettings
ss) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ServerSettings Text
ssReal ServerSettings
ss)
     ]
  where
    ss :: ServerSettings
ss = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState ServerSettings
csSettings NetworkState
cs

loadNamesList :: Identifier -> NetworkState -> NetworkState
loadNamesList :: Identifier -> NetworkState -> NetworkState
loadNamesList Identifier
chan NetworkState
cs
  = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Transaction
csTransaction Transaction
NoTransaction
  forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip UserInfo -> NetworkState -> NetworkState
learnUserInfo)) (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(UserInfo, [Char])]
entries)
  forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
setStrict (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Identifier
chan forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState (HashMap Identifier [Char])
chanUsers) HashMap Identifier [Char]
newChanUsers
  forall a b. (a -> b) -> a -> b
$ NetworkState
cs
  where
    newChanUsers :: HashMap Identifier [Char]
newChanUsers = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [ (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (f :: * -> *).
Functor f =>
(Identifier -> f Identifier) -> UserInfo -> f UserInfo
uiNick UserInfo
ui, [Char]
modes) | (UserInfo
ui, [Char]
modes) <- [(UserInfo, [Char])]
entries ]

    -- userhost-in-names might or might not include the user and host
    -- if we find it we update the user information.
    learnUserInfo :: UserInfo -> NetworkState -> NetworkState
learnUserInfo (UserInfo Identifier
n Text
u Text
h)
      | Text -> Bool
Text.null Text
u Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
h = forall a. a -> a
id
      | Bool
otherwise = Identifier -> Text -> Text -> NetworkState -> NetworkState
updateUserInfo Identifier
n Text
u Text
h

    sigils :: [Char]
sigils = forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (Lens' NetworkState ModeTypes
csModeTypes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
([(Char, Char)] -> f [(Char, Char)]) -> ModeTypes -> f ModeTypes
modesPrefixModes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field2 s t a b => Lens s t a b
_2) NetworkState
cs

    splitEntry :: [Char] -> Text -> (UserInfo, [Char])
splitEntry [Char]
modes Text
str
      | Text -> Char
Text.head Text
str forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
sigils = [Char] -> Text -> (UserInfo, [Char])
splitEntry (Text -> Char
Text.head Text
str forall a. a -> [a] -> [a]
: [Char]
modes)
                                                 (Text -> Text
Text.tail Text
str)
      | Bool
otherwise = (Text -> UserInfo
parseUserInfo Text
str, forall a. [a] -> [a]
reverse [Char]
modes)

    entries :: [(UserInfo, [Char])]
    entries :: [(UserInfo, [Char])]
entries = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> Text -> (UserInfo, [Char])
splitEntry [Char]
"")
            forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Text -> [Text]
Text.words
            forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState Transaction
csTransaction forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Transaction [Text]
_NamesTransaction) NetworkState
cs


createOnJoin :: UserInfo -> Identifier -> NetworkState -> NetworkState
createOnJoin :: UserInfo -> Identifier -> NetworkState -> NetworkState
createOnJoin UserInfo
who Identifier
chan NetworkState
cs
  | UserInfo -> Identifier
userNick UserInfo
who forall a. Eq a => a -> a -> Bool
== forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Identifier
csNick NetworkState
cs =
        forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState UserInfo
csUserInfo UserInfo
who -- great time to learn our userinfo
      forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Identifier
chan) (forall a. a -> Maybe a
Just ChannelState
newChannel) NetworkState
cs
  | Bool
otherwise = NetworkState
cs

updateMyNick :: Identifier -> Identifier -> NetworkState -> NetworkState
updateMyNick :: Identifier -> Identifier -> NetworkState -> NetworkState
updateMyNick Identifier
oldNick Identifier
newNick NetworkState
cs
  | Identifier
oldNick forall a. Eq a => a -> a -> Bool
== forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState Identifier
csNick NetworkState
cs = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Identifier
csNick Identifier
newNick NetworkState
cs
  | Bool
otherwise = NetworkState
cs

myinfo ::
  [Text] ->
  NetworkState ->
  NetworkState
myinfo :: [Text] -> NetworkState -> NetworkState
myinfo (Text
_me : Text
_host : Text
_version : Text
umodes : [Text]
_) =
  -- special logic for s because I know it has arguments
  forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState ModeTypes
csUmodeTypes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesNeverArg) (forall a. Eq a => a -> [a] -> [a]
delete Char
's' (Text -> [Char]
Text.unpack Text
umodes))
myinfo [Text]
_ = forall a. a -> a
id

-- ISUPPORT is defined by
-- https://tools.ietf.org/html/draft-brocklesby-irc-isupport-03#section-3.14
isupport ::
  [Text] {- ^ ["key=value"] -} ->
  NetworkState ->
  NetworkState
isupport :: [Text] -> NetworkState -> NetworkState
isupport []     NetworkState
conn = NetworkState
conn
isupport [Text]
params NetworkState
conn = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {a}.
(Eq a, IsString a) =>
(a, Text) -> NetworkState -> NetworkState
isupport1) NetworkState
conn
                     forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> (Text, Text)
parseISupport
                     forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
init [Text]
params
  where
    isupport1 :: (a, Text) -> NetworkState -> NetworkState
isupport1 (a
"CHANTYPES",Text
types) = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState [Char]
csChannelTypes (Text -> [Char]
Text.unpack Text
types)
    isupport1 (a
"CHANMODES",Text
modes) = Text -> NetworkState -> NetworkState
updateChanModes Text
modes
    isupport1 (a
"PREFIX"   ,Text
modes) = Text -> NetworkState -> NetworkState
updateChanPrefix Text
modes
    isupport1 (a
"STATUSMSG",Text
prefix) = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState [Char]
csStatusMsg (Text -> [Char]
Text.unpack Text
prefix)
    isupport1 (a
"MODES",Text
nstr) | Right (Int
n,Text
"") <- forall a. Integral a => Reader a
Text.decimal Text
nstr =
                        forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Int
csModeCount Int
n
    isupport1 (a, Text)
_                   = forall a. a -> a
id

parseISupport :: Text -> (Text,Text)
parseISupport :: Text -> (Text, Text)
parseISupport Text
str =
  case (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
'=') Text
str of
    (Text
key,Text
val) -> (Text
key, Int -> Text -> Text
Text.drop Int
1 Text
val)

updateChanModes ::
  Text {- lists,always,set,never -} ->
  NetworkState ->
  NetworkState
updateChanModes :: Text -> NetworkState -> NetworkState
updateChanModes Text
modes
  = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState ModeTypes
csModeTypes
  forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesLists [Char]
listModes
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesAlwaysArg [Char]
alwaysModes
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesSetArg [Char]
setModes
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set forall (f :: * -> *).
Functor f =>
([Char] -> f [Char]) -> ModeTypes -> f ModeTypes
modesNeverArg [Char]
neverModes
  -- Note: doesn't set modesPrefixModes
  where
  next :: [Char] -> ([Char], [Char])
next = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t a b. Field2 s t a b => Lens s t a b
_2 (forall a. Int -> [a] -> [a]
drop Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
==Char
',')
  ([Char]
listModes  ,[Char]
modes1) = [Char] -> ([Char], [Char])
next (Text -> [Char]
Text.unpack Text
modes)
  ([Char]
alwaysModes,[Char]
modes2) = [Char] -> ([Char], [Char])
next [Char]
modes1
  ([Char]
setModes   ,[Char]
modes3) = [Char] -> ([Char], [Char])
next [Char]
modes2
  ([Char]
neverModes ,[Char]
_)      = [Char] -> ([Char], [Char])
next [Char]
modes3

updateChanPrefix ::
  Text {- e.g. "(ov)@+" -} ->
  NetworkState ->
  NetworkState
updateChanPrefix :: Text -> NetworkState -> NetworkState
updateChanPrefix Text
txt =
  case Text -> Maybe [(Char, Char)]
parsePrefixes Text
txt of
    Just [(Char, Char)]
prefixes -> forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState ModeTypes
csModeTypes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Functor f =>
([(Char, Char)] -> f [(Char, Char)]) -> ModeTypes -> f ModeTypes
modesPrefixModes) [(Char, Char)]
prefixes
    Maybe [(Char, Char)]
Nothing       -> forall a. a -> a
id

parsePrefixes :: Text -> Maybe [(Char,Char)]
parsePrefixes :: Text -> Maybe [(Char, Char)]
parsePrefixes Text
txt =
  case forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> [(Char, Char)]
Text.zip ((Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
')') Text
txt) of
    (Char
'(',Char
')'):[(Char, Char)]
rest -> forall a. a -> Maybe a
Just [(Char, Char)]
rest
    [(Char, Char)]
_              -> forall a. Maybe a
Nothing

isChannelIdentifier :: NetworkState -> Identifier -> Bool
isChannelIdentifier :: NetworkState -> Identifier -> Bool
isChannelIdentifier NetworkState
cs Identifier
ident =
  case Text -> Maybe (Char, Text)
Text.uncons (Identifier -> Text
idText Identifier
ident) of
    Just (Char
p, Text
_) -> Char
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState [Char]
csChannelTypes NetworkState
cs
    Maybe (Char, Text)
_           -> Bool
False

------------------------------------------------------------------------
-- Helpers for managing the user list
------------------------------------------------------------------------

csUser :: Functor f => Identifier -> LensLike' f NetworkState (Maybe UserAndHost)
csUser :: forall (f :: * -> *).
Functor f =>
Identifier -> LensLike' f NetworkState (Maybe UserAndHost)
csUser Identifier
i = Lens' NetworkState (HashMap Identifier UserAndHost)
csUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Identifier
i

recordUser :: UserInfo -> Text -> NetworkState -> NetworkState
recordUser :: UserInfo -> Text -> NetworkState -> NetworkState
recordUser (UserInfo Identifier
nick Text
user Text
host) Text
acct
  | Text -> Bool
Text.null Text
user Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
host = forall a. a -> a
id
  | Bool
otherwise = forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState (HashMap Identifier UserAndHost)
csUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Identifier
nick)
                    (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Text -> Text -> Text -> UserAndHost
UserAndHost Text
user Text
host Text
acct)

-- | Process a CHGHOST command, updating a users information
updateUserInfo ::
  Identifier {- ^ nickname     -} ->
  Text       {- ^ new username -} ->
  Text       {- ^ new hostname -} ->
  NetworkState -> NetworkState
updateUserInfo :: Identifier -> Text -> Text -> NetworkState -> NetworkState
updateUserInfo Identifier
nick Text
user Text
host =
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' NetworkState (HashMap Identifier UserAndHost)
csUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Identifier
nick) forall a b. (a -> b) -> a -> b
$ \Maybe UserAndHost
old ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Text -> Text -> Text -> UserAndHost
UserAndHost Text
user Text
host (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" UserAndHost -> Text
_uhAccount Maybe UserAndHost
old)

forgetUser :: Identifier -> NetworkState -> NetworkState
forgetUser :: Identifier -> NetworkState -> NetworkState
forgetUser = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState (HashMap Identifier UserAndHost)
csUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> m -> m
sans

renameUser :: Identifier -> Identifier -> NetworkState -> NetworkState
renameUser :: Identifier -> Identifier -> NetworkState -> NetworkState
renameUser Identifier
old Identifier
new NetworkState
cs = forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' NetworkState (HashMap Identifier UserAndHost)
csUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Identifier
new) Maybe UserAndHost
entry NetworkState
cs'
  where
    (Maybe UserAndHost
entry,NetworkState
cs') = NetworkState
cs forall a b. a -> (a -> b) -> b
& Lens' NetworkState (HashMap Identifier UserAndHost)
csUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Identifier
old forall a s t b. LensLike ((,) a) s t a b -> b -> s -> (a, t)
<<.~ forall a. Maybe a
Nothing

forgetUser' :: Identifier -> NetworkState -> NetworkState
forgetUser' :: Identifier -> NetworkState -> NetworkState
forgetUser' Identifier
nick NetworkState
cs
  | Bool
keep      = NetworkState
cs
  | Bool
otherwise = Identifier -> NetworkState -> NetworkState
forgetUser Identifier
nick NetworkState
cs
  where
    keep :: Bool
keep = forall s a. Getting Any s a -> s -> Bool
has (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState (HashMap Identifier [Char])
chanUsers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Identifier
nick) NetworkState
cs

-- | Process a list of WHO replies
massRegistration :: NetworkState -> NetworkState
massRegistration :: NetworkState -> NetworkState
massRegistration NetworkState
cs
  = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState Transaction
csTransaction Transaction
NoTransaction
  forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' NetworkState (HashMap Identifier UserAndHost)
csUsers HashMap Identifier UserAndHost -> HashMap Identifier UserAndHost
updateUsers NetworkState
cs
  where
    infos :: [UserInfo]
infos = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' NetworkState Transaction
csTransaction forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Transaction [UserInfo]
_WhoTransaction) NetworkState
cs

    channelUsers :: HashSet Identifier
channelUsers =
      forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList (forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views (Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState (HashMap Identifier [Char])
chanUsers) forall k v. HashMap k v -> [k]
HashMap.keys NetworkState
cs)

    updateUsers :: HashMap Identifier UserAndHost -> HashMap Identifier UserAndHost
updateUsers HashMap Identifier UserAndHost
users = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HashMap Identifier UserAndHost
-> UserInfo -> HashMap Identifier UserAndHost
updateUser HashMap Identifier UserAndHost
users [UserInfo]
infos

    updateUser :: HashMap Identifier UserAndHost
-> UserInfo -> HashMap Identifier UserAndHost
updateUser HashMap Identifier UserAndHost
users (UserInfo Identifier
nick Text
user Text
host)
      | Bool -> Bool
not (Text -> Bool
Text.null Text
user)
      , Bool -> Bool
not (Text -> Bool
Text.null Text
host)
      , forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member Identifier
nick HashSet Identifier
channelUsers =
            forall k v.
(Eq k, Hashable k) =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HashMap.alter
                (\Maybe UserAndHost
mb -> case Maybe UserAndHost
mb of
                          Maybe UserAndHost
Nothing                     -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Text -> Text -> Text -> UserAndHost
UserAndHost Text
user Text
host Text
""
                          Just (UserAndHost Text
_ Text
_ Text
acct) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Text -> Text -> Text -> UserAndHost
UserAndHost Text
user Text
host Text
acct
                ) Identifier
nick HashMap Identifier UserAndHost
users
      | Bool
otherwise = HashMap Identifier UserAndHost
users

-- | Compute the earliest timed action for a connection, if any
nextTimedAction :: NetworkState -> Maybe (UTCTime, TimedAction)
nextTimedAction :: NetworkState -> Maybe (UTCTime, TimedAction)
nextTimedAction NetworkState
ns = forall a s.
Ord a =>
Getting (Endo (Endo (Maybe a))) s a -> s -> Maybe a
minimumOf (forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
foldedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded) [Maybe (UTCTime, TimedAction)]
actions
  where
    actions :: [Maybe (UTCTime, TimedAction)]
actions = [NetworkState -> Maybe (UTCTime, TimedAction)
nextPingAction NetworkState
ns, NetworkState -> Maybe (UTCTime, TimedAction)
nextForgetAction NetworkState
ns]

-- | Compute the timed action for forgetting the ping latency.
-- The client will wait for a multiple of the current latency
-- for the next pong response in order to reduce jitter in
-- the rendered latency when everything is fine.
nextForgetAction :: NetworkState -> Maybe (UTCTime, TimedAction)
nextForgetAction :: NetworkState -> Maybe (UTCTime, TimedAction)
nextForgetAction NetworkState
ns =
  do UTCTime
sentAt  <- forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Lens' NetworkState PingStatus
csPingStatus forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' PingStatus UTCTime
_PingSent) NetworkState
ns
     NominalDiffTime
latency <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState (Maybe NominalDiffTime)
csLatency NetworkState
ns
     let delay :: NominalDiffTime
delay = forall a. Ord a => a -> a -> a
max NominalDiffTime
0.1 (NominalDiffTime
3 forall a. Num a => a -> a -> a
* NominalDiffTime
latency) -- wait at least 0.1s (ensure positive waits)
         eventAt :: UTCTime
eventAt = NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
delay UTCTime
sentAt
     forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
eventAt, TimedAction
TimedForgetLatency)

-- | Compute the next action needed for the client ping logic.
nextPingAction :: NetworkState -> Maybe (UTCTime, TimedAction)
nextPingAction :: NetworkState -> Maybe (UTCTime, TimedAction)
nextPingAction NetworkState
cs =
  do UTCTime
runAt <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState (Maybe UTCTime)
csNextPingTime NetworkState
cs
     forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
runAt, TimedAction
action)
  where
    action :: TimedAction
action =
      case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs of
        PingSent UTCTime
sentAt
          | forall a. a -> Maybe a
Just UTCTime
sentAt forall a. Ord a => a -> a -> Bool
< forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState (Maybe UTCTime)
csLastReceived NetworkState
cs -> TimedAction
TimedSendPing
          | Bool
otherwise -> TimedAction
TimedDisconnect
        PingStatus
PingNone         -> TimedAction
TimedSendPing
        PingConnecting{} -> TimedAction
TimedSendPing

doPong :: ZonedTime -> NetworkState -> NetworkState
doPong :: ZonedTime -> NetworkState -> NetworkState
doPong ZonedTime
when NetworkState
cs = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState PingStatus
csPingStatus PingStatus
PingNone
               forall a b. (a -> b) -> a -> b
$ forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState (Maybe NominalDiffTime)
csLatency (forall a. a -> Maybe a
Just NominalDiffTime
delta) NetworkState
cs
  where
    delta :: NominalDiffTime
delta =
      case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState PingStatus
csPingStatus NetworkState
cs of
        PingSent UTCTime
sent -> UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (ZonedTime -> UTCTime
zonedTimeToUTC ZonedTime
when) UTCTime
sent
        PingStatus
_             -> NominalDiffTime
0

-- | Apply the given 'TimedAction' to a connection state.
applyTimedAction :: TimedAction -> NetworkState -> IO NetworkState
applyTimedAction :: TimedAction -> NetworkState -> IO NetworkState
applyTimedAction TimedAction
action NetworkState
cs =

  case TimedAction
action of
    TimedAction
TimedForgetLatency ->
      do 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' NetworkState (Maybe NominalDiffTime)
csLatency forall a. Maybe a
Nothing NetworkState
cs

    TimedAction
TimedDisconnect ->
      do TerminationReason -> NetworkConnection -> IO ()
abortConnection TerminationReason
PingTimeout (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' NetworkState NetworkConnection
csSocket 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' NetworkState (Maybe UTCTime)
csNextPingTime forall a. Maybe a
Nothing NetworkState
cs

    TimedAction
TimedSendPing ->
      do UTCTime
now <- IO UTCTime
getCurrentTime
         NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs ([Text] -> RawIrcMsg
ircPing [Text
"ping"])
         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' NetworkState (Maybe UTCTime)
csNextPingTime (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
60 UTCTime
now)
                forall a b. (a -> b) -> a -> b
$  forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' NetworkState PingStatus
csPingStatus   (UTCTime -> PingStatus
PingSent UTCTime
now) NetworkState
cs

------------------------------------------------------------------------
-- Moderation
------------------------------------------------------------------------

-- | Used to send commands that require ops to perform.
-- If this channel is one that the user has chanserv access and ops are needed
-- then ops are requested and the commands are queued, otherwise send them
-- directly.
sendModeration ::
  Identifier      {- ^ channel       -} ->
  [RawIrcMsg]     {- ^ commands      -} ->
  NetworkState    {- ^ network state -} ->
  IO NetworkState
sendModeration :: Identifier -> [RawIrcMsg] -> NetworkState -> IO NetworkState
sendModeration Identifier
channel [RawIrcMsg]
cmds NetworkState
cs
  | Identifier -> NetworkState -> Bool
useChanServ Identifier
channel NetworkState
cs =
      do let cmd :: RawIrcMsg
cmd = Text -> Text -> RawIrcMsg
ircPrivmsg Text
"ChanServ" ([Text] -> Text
Text.unwords [Text
"OP", Identifier -> Text
idText Identifier
channel])
         NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs RawIrcMsg
cmd
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Lens' NetworkState (HashMap Identifier ChannelState)
csChannels forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Identifier
channel forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ChannelState [RawIrcMsg]
chanQueuedModeration forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [RawIrcMsg]
cmds forall a b. (a -> b) -> a -> b
$ NetworkState
cs
  | Bool
otherwise = NetworkState
cs forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs) [RawIrcMsg]
cmds

useChanServ ::
  Identifier   {- ^ channel            -} ->
  NetworkState {- ^ network state      -} ->
  Bool         {- ^ chanserv available -}
useChanServ :: Identifier -> NetworkState -> Bool
useChanServ Identifier
channel NetworkState
cs =
  Identifier
channel forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` 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 [Identifier]
ssChanservChannels) NetworkState
cs Bool -> Bool -> Bool
&&
  Bool -> Bool
not (Identifier -> NetworkState -> Bool
iHaveOp Identifier
channel NetworkState
cs)

sendTopic ::
  Identifier   {- ^ channel       -} ->
  Text         {- ^ topic         -} ->
  NetworkState {- ^ network state -} ->
  IO ()
sendTopic :: Identifier -> Text -> NetworkState -> IO ()
sendTopic Identifier
channelId Text
topic NetworkState
cs = NetworkState -> RawIrcMsg -> IO ()
sendMsg NetworkState
cs RawIrcMsg
cmd
  where
    chanservTopicCmd :: RawIrcMsg
chanservTopicCmd =
      Text -> Text -> RawIrcMsg
ircPrivmsg
        Text
"ChanServ"
        ([Text] -> Text
Text.unwords [Text
"TOPIC", Identifier -> Text
idText Identifier
channelId, Text
topic])

    cmd :: RawIrcMsg
cmd
      | Text -> Bool
Text.null Text
topic          = Identifier -> Text -> RawIrcMsg
ircTopic Identifier
channelId Text
""
      | Identifier -> NetworkState -> Bool
useChanServ Identifier
channelId NetworkState
cs = RawIrcMsg
chanservTopicCmd
      | Bool
otherwise                = Identifier -> Text -> RawIrcMsg
ircTopic Identifier
channelId Text
topic