{-# Language OverloadedStrings #-}
{-|
Module      : Client.State.Extensions
Description : Integration between the client and external extensions
Copyright   : (c) Eric Mertens, 2018
License     : ISC
Maintainer  : emertens@gmail.com

This module implements the interaction between the client and its extensions.
This includes aspects of the extension system that depend on the current client
state.
-}
module Client.State.Extensions
  ( clientChatExtension
  , clientCommandExtension
  , clientStartExtensions
  , clientNotifyExtensions
  , clientStopExtensions
  , clientExtTimer
  , clientThreadJoin
  ) where

import Control.Concurrent.MVar
import Control.Monad.IO.Class
import Control.Exception
import Control.Lens
import Control.Monad
import Data.Foldable
import Data.Text (Text)
import Data.Time
import Foreign.Ptr
import Foreign.StablePtr
import qualified Data.Text as Text
import qualified Data.IntMap as IntMap

import Irc.RawIrcMsg

import Client.State
import Client.Message
import Client.CApi
import Client.CApi.Types
import Client.Configuration

-- | Start extensions after ensuring existing ones are stopped
clientStartExtensions ::
  ClientState    {- ^ client state                     -} ->
  IO ClientState {- ^ client state with new extensions -}
clientStartExtensions :: ClientState -> IO ClientState
clientStartExtensions ClientState
st =
  do let cfg :: Configuration
cfg = Getting Configuration ClientState Configuration
-> ClientState -> Configuration
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Configuration ClientState Configuration
Lens' ClientState Configuration
clientConfig ClientState
st
     ClientState
st1 <- ClientState -> IO ClientState
clientStopExtensions ClientState
st
     (ClientState -> ExtensionConfiguration -> IO ClientState)
-> ClientState -> [ExtensionConfiguration] -> IO ClientState
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ClientState -> ExtensionConfiguration -> IO ClientState
start1 ClientState
st1 (Getting
  [ExtensionConfiguration] Configuration [ExtensionConfiguration]
-> Configuration -> [ExtensionConfiguration]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  [ExtensionConfiguration] Configuration [ExtensionConfiguration]
Lens' Configuration [ExtensionConfiguration]
configExtensions Configuration
cfg)

-- | Start a single extension and register it with the client or
-- record the error message.
start1 :: ClientState -> ExtensionConfiguration -> IO ClientState
start1 :: ClientState -> ExtensionConfiguration -> IO ClientState
start1 ClientState
st ExtensionConfiguration
config =
  do Either IOError ActiveExtension
res <- IO ActiveExtension -> IO (Either IOError ActiveExtension)
forall e a. Exception e => IO a -> IO (Either e a)
try (ExtensionConfiguration -> IO ActiveExtension
openExtension ExtensionConfiguration
config) :: IO (Either IOError ActiveExtension)

     case Either IOError ActiveExtension
res of
       Left IOError
err ->
         do ZonedTime
now <- IO ZonedTime
getZonedTime
            ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ClientMessage -> ClientState -> ClientState
recordNetworkMessage ClientMessage :: Text -> MessageBody -> ZonedTime -> ClientMessage
ClientMessage
              { _msgTime :: ZonedTime
_msgTime    = ZonedTime
now
              , _msgBody :: MessageBody
_msgBody    = Text -> MessageBody
ErrorBody (String -> Text
Text.pack (IOError -> String
forall e. Exception e => e -> String
displayException IOError
err))
              , _msgNetwork :: Text
_msgNetwork = Text
""
              } ClientState
st

       Right ActiveExtension
ae ->
            -- allocate a new identity for this extension
         do let i :: Key
i = case IntMap ActiveExtension
-> Maybe ((Key, ActiveExtension), IntMap ActiveExtension)
forall a. IntMap a -> Maybe ((Key, a), IntMap a)
IntMap.maxViewWithKey (Getting
  (IntMap ActiveExtension) ClientState (IntMap ActiveExtension)
-> ClientState -> IntMap ActiveExtension
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
-> ClientState -> Const (IntMap ActiveExtension) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
 -> ClientState -> Const (IntMap ActiveExtension) ClientState)
-> ((IntMap ActiveExtension
     -> Const (IntMap ActiveExtension) (IntMap ActiveExtension))
    -> ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
-> Getting
     (IntMap ActiveExtension) ClientState (IntMap ActiveExtension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension
 -> Const (IntMap ActiveExtension) (IntMap ActiveExtension))
-> ExtensionState -> Const (IntMap ActiveExtension) ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive) ClientState
st) of
                      Just ((Key
k,ActiveExtension
_),IntMap ActiveExtension
_) -> Key
kKey -> Key -> Key
forall a. Num a => a -> a -> a
+Key
1
                      Maybe ((Key, ActiveExtension), IntMap ActiveExtension)
Nothing -> Key
0

            let st1 :: ClientState
st1 = ClientState
st ClientState -> (ClientState -> ClientState) -> ClientState
forall a b. a -> (a -> b) -> b
& (ExtensionState -> Identity ExtensionState)
-> ClientState -> Identity ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Identity ExtensionState)
 -> ClientState -> Identity ClientState)
-> ((Maybe ActiveExtension -> Identity (Maybe ActiveExtension))
    -> ExtensionState -> Identity ExtensionState)
-> (Maybe ActiveExtension -> Identity (Maybe ActiveExtension))
-> ClientState
-> Identity ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> ExtensionState -> Identity ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
 -> ExtensionState -> Identity ExtensionState)
-> ((Maybe ActiveExtension -> Identity (Maybe ActiveExtension))
    -> IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> (Maybe ActiveExtension -> Identity (Maybe ActiveExtension))
-> ExtensionState
-> Identity ExtensionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap ActiveExtension)
-> Lens'
     (IntMap ActiveExtension) (Maybe (IxValue (IntMap ActiveExtension)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Key
Index (IntMap ActiveExtension)
i ((Maybe ActiveExtension -> Identity (Maybe ActiveExtension))
 -> ClientState -> Identity ClientState)
-> ActiveExtension -> ClientState -> ClientState
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ActiveExtension
ae
            (ClientState
st2, Ptr ()
h) <- Key -> ClientState -> IO (Ptr ()) -> IO (ClientState, Ptr ())
forall a. Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st1 (Ptr () -> ExtensionConfiguration -> ActiveExtension -> IO (Ptr ())
startExtension (ClientState -> Ptr ()
clientToken ClientState
st1) ExtensionConfiguration
config ActiveExtension
ae)

            -- save handle back into active extension
            ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> IO ClientState) -> ClientState -> IO ClientState
forall a b. (a -> b) -> a -> b
$! ClientState
st2 ClientState -> (ClientState -> ClientState) -> ClientState
forall a b. a -> (a -> b) -> b
& (ExtensionState -> Identity ExtensionState)
-> ClientState -> Identity ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Identity ExtensionState)
 -> ClientState -> Identity ClientState)
-> ((ActiveExtension -> Identity ActiveExtension)
    -> ExtensionState -> Identity ExtensionState)
-> (ActiveExtension -> Identity ActiveExtension)
-> ClientState
-> Identity ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> ExtensionState -> Identity ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
 -> ExtensionState -> Identity ExtensionState)
-> ((ActiveExtension -> Identity ActiveExtension)
    -> IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> (ActiveExtension -> Identity ActiveExtension)
-> ExtensionState
-> Identity ExtensionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap ActiveExtension)
-> Traversal'
     (IntMap ActiveExtension) (IxValue (IntMap ActiveExtension))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Key
Index (IntMap ActiveExtension)
i ((ActiveExtension -> Identity ActiveExtension)
 -> ClientState -> Identity ClientState)
-> (ActiveExtension -> ActiveExtension)
-> ClientState
-> ClientState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \ActiveExtension
ae' ->
                        ActiveExtension
ae' { aeSession :: Ptr ()
aeSession = Ptr ()
h }



-- | Unload all active extensions.
clientStopExtensions ::
  ClientState    {- ^ client state                          -} ->
  IO ClientState {- ^ client state with extensions unloaded -}
clientStopExtensions :: ClientState -> IO ClientState
clientStopExtensions ClientState
st =
  do let (IntMap ActiveExtension
aes,ClientState
st1) = ClientState
st ClientState
-> (ClientState -> (IntMap ActiveExtension, ClientState))
-> (IntMap ActiveExtension, ClientState)
forall a b. a -> (a -> b) -> b
& (ExtensionState -> (IntMap ActiveExtension, ExtensionState))
-> ClientState -> (IntMap ActiveExtension, ClientState)
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> (IntMap ActiveExtension, ExtensionState))
 -> ClientState -> (IntMap ActiveExtension, ClientState))
-> ((IntMap ActiveExtension
     -> (IntMap ActiveExtension, IntMap ActiveExtension))
    -> ExtensionState -> (IntMap ActiveExtension, ExtensionState))
-> (IntMap ActiveExtension
    -> (IntMap ActiveExtension, IntMap ActiveExtension))
-> ClientState
-> (IntMap ActiveExtension, ClientState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension
 -> (IntMap ActiveExtension, IntMap ActiveExtension))
-> ExtensionState -> (IntMap ActiveExtension, ExtensionState)
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension
  -> (IntMap ActiveExtension, IntMap ActiveExtension))
 -> ClientState -> (IntMap ActiveExtension, ClientState))
-> (IntMap ActiveExtension
    -> (IntMap ActiveExtension, IntMap ActiveExtension))
-> ClientState
-> (IntMap ActiveExtension, ClientState)
forall k (f :: k -> *) s (t :: k) a (b :: k).
LensLike f s t a b -> LensLike f s t a b
%%~ IntMap ActiveExtension
-> (IntMap ActiveExtension, IntMap ActiveExtension)
upd
     (Key -> ClientState -> ActiveExtension -> IO ClientState)
-> ClientState -> IntMap ActiveExtension -> IO ClientState
forall i (f :: * -> *) (m :: * -> *) b a.
(FoldableWithIndex i f, Monad m) =>
(i -> b -> a -> m b) -> b -> f a -> m b
ifoldlM Key -> ClientState -> ActiveExtension -> IO ClientState
step ClientState
st1 IntMap ActiveExtension
aes
  where
    upd :: IntMap ActiveExtension
-> (IntMap ActiveExtension, IntMap ActiveExtension)
upd = (IntMap ActiveExtension -> IntMap ActiveExtension)
-> (IntMap ActiveExtension, IntMap ActiveExtension)
-> (IntMap ActiveExtension, IntMap ActiveExtension)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ActiveExtension -> ActiveExtension)
-> IntMap ActiveExtension -> IntMap ActiveExtension
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActiveExtension -> ActiveExtension
disable) ((IntMap ActiveExtension, IntMap ActiveExtension)
 -> (IntMap ActiveExtension, IntMap ActiveExtension))
-> (IntMap ActiveExtension
    -> (IntMap ActiveExtension, IntMap ActiveExtension))
-> IntMap ActiveExtension
-> (IntMap ActiveExtension, IntMap ActiveExtension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ActiveExtension -> Bool)
-> IntMap ActiveExtension
-> (IntMap ActiveExtension, IntMap ActiveExtension)
forall a. (a -> Bool) -> IntMap a -> (IntMap a, IntMap a)
IntMap.partition ActiveExtension -> Bool
readyToClose
    disable :: ActiveExtension -> ActiveExtension
disable ActiveExtension
ae = ActiveExtension
ae { aeLive :: Bool
aeLive = Bool
False }
    readyToClose :: ActiveExtension -> Bool
readyToClose ActiveExtension
ae = ActiveExtension -> Key
aeThreads ActiveExtension
ae Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
0
    step :: Key -> ClientState -> ActiveExtension -> IO ClientState
step Key
i ClientState
st2 ActiveExtension
ae =
      do (ClientState
st3,()
_) <- Key -> ClientState -> IO () -> IO (ClientState, ())
forall a. Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st2 (ActiveExtension -> IO ()
stopExtension ActiveExtension
ae)
         ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st3


-- | Dispatch chat messages through extensions before sending to server.
clientChatExtension ::
  Text        {- ^ network                     -} ->
  Text        {- ^ target                      -} ->
  Text        {- ^ message                     -} ->
  ClientState {- ^ client state, allow message -} ->
  IO (ClientState, Bool)
clientChatExtension :: Text -> Text -> Text -> ClientState -> IO (ClientState, Bool)
clientChatExtension Text
net Text
tgt Text
msg ClientState
st
  | Bool
noCallback = (ClientState, Bool) -> IO (ClientState, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st, Bool
True)
  | Bool
otherwise  = NestedIO (ClientState, Bool) -> IO (ClientState, Bool)
forall a. NestedIO a -> IO a
evalNestedIO (NestedIO (ClientState, Bool) -> IO (ClientState, Bool))
-> NestedIO (ClientState, Bool) -> IO (ClientState, Bool)
forall a b. (a -> b) -> a -> b
$
                 do Ptr FgnChat
chat <- Text -> Text -> Text -> NestedIO (Ptr FgnChat)
withChat Text
net Text
tgt Text
msg
                    IO (ClientState, Bool) -> NestedIO (ClientState, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr FgnChat
-> ClientState
-> [(Key, ActiveExtension)]
-> IO (ClientState, Bool)
chat1 Ptr FgnChat
chat ClientState
st (IntMap ActiveExtension -> [(Key, ActiveExtension)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList ((ActiveExtension -> Bool)
-> IntMap ActiveExtension -> IntMap ActiveExtension
forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter ActiveExtension -> Bool
aeLive IntMap ActiveExtension
aes)))
  where
    aes :: IntMap ActiveExtension
aes = Getting
  (IntMap ActiveExtension) ClientState (IntMap ActiveExtension)
-> ClientState -> IntMap ActiveExtension
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
-> ClientState -> Const (IntMap ActiveExtension) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
 -> ClientState -> Const (IntMap ActiveExtension) ClientState)
-> ((IntMap ActiveExtension
     -> Const (IntMap ActiveExtension) (IntMap ActiveExtension))
    -> ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
-> Getting
     (IntMap ActiveExtension) ClientState (IntMap ActiveExtension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension
 -> Const (IntMap ActiveExtension) (IntMap ActiveExtension))
-> ExtensionState -> Const (IntMap ActiveExtension) ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive) ClientState
st
    noCallback :: Bool
noCallback = (ActiveExtension -> Bool) -> IntMap ActiveExtension -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ActiveExtension
ae -> FgnExtension -> FunPtr ProcessChat
fgnChat (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae) FunPtr ProcessChat -> FunPtr ProcessChat -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ProcessChat
forall a. FunPtr a
nullFunPtr) IntMap ActiveExtension
aes

chat1 ::
  Ptr FgnChat             {- ^ serialized chat message     -} ->
  ClientState             {- ^ client state                -} ->
  [(Int,ActiveExtension)] {- ^ extensions needing callback -} ->
  IO (ClientState, Bool)  {- ^ new state and allow         -}
chat1 :: Ptr FgnChat
-> ClientState
-> [(Key, ActiveExtension)]
-> IO (ClientState, Bool)
chat1 Ptr FgnChat
_    ClientState
st [] = (ClientState, Bool) -> IO (ClientState, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st, Bool
True)
chat1 Ptr FgnChat
chat ClientState
st ((Key
i,ActiveExtension
ae):[(Key, ActiveExtension)]
aes) =
  do (ClientState
st1, Bool
allow) <- Key -> ClientState -> IO Bool -> IO (ClientState, Bool)
forall a. Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st (ActiveExtension -> Ptr FgnChat -> IO Bool
chatExtension ActiveExtension
ae Ptr FgnChat
chat)
     if Bool
allow then Ptr FgnChat
-> ClientState
-> [(Key, ActiveExtension)]
-> IO (ClientState, Bool)
chat1 Ptr FgnChat
chat ClientState
st1 [(Key, ActiveExtension)]
aes
              else (ClientState, Bool) -> IO (ClientState, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st1, Bool
False)


-- | Dispatch incoming IRC message through extensions
clientNotifyExtensions ::
  Text                   {- ^ network                 -} ->
  RawIrcMsg              {- ^ incoming message        -} ->
  ClientState            {- ^ client state            -} ->
  IO (ClientState, Bool) {- ^ drop message when false -}
clientNotifyExtensions :: Text -> RawIrcMsg -> ClientState -> IO (ClientState, Bool)
clientNotifyExtensions Text
network RawIrcMsg
raw ClientState
st
  | Bool
noCallback = (ClientState, Bool) -> IO (ClientState, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st, Bool
True)
  | Bool
otherwise  = NestedIO (ClientState, Bool) -> IO (ClientState, Bool)
forall a. NestedIO a -> IO a
evalNestedIO (NestedIO (ClientState, Bool) -> IO (ClientState, Bool))
-> NestedIO (ClientState, Bool) -> IO (ClientState, Bool)
forall a b. (a -> b) -> a -> b
$
                 do Ptr FgnMsg
fgn <- Text -> RawIrcMsg -> NestedIO (Ptr FgnMsg)
withRawIrcMsg Text
network RawIrcMsg
raw
                    IO (ClientState, Bool) -> NestedIO (ClientState, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr FgnMsg
-> ClientState
-> [(Key, ActiveExtension)]
-> IO (ClientState, Bool)
message1 Ptr FgnMsg
fgn ClientState
st (IntMap ActiveExtension -> [(Key, ActiveExtension)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList ((ActiveExtension -> Bool)
-> IntMap ActiveExtension -> IntMap ActiveExtension
forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter ActiveExtension -> Bool
aeLive IntMap ActiveExtension
aes)))
  where
    aes :: IntMap ActiveExtension
aes = Getting
  (IntMap ActiveExtension) ClientState (IntMap ActiveExtension)
-> ClientState -> IntMap ActiveExtension
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
-> ClientState -> Const (IntMap ActiveExtension) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
 -> ClientState -> Const (IntMap ActiveExtension) ClientState)
-> ((IntMap ActiveExtension
     -> Const (IntMap ActiveExtension) (IntMap ActiveExtension))
    -> ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
-> Getting
     (IntMap ActiveExtension) ClientState (IntMap ActiveExtension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension
 -> Const (IntMap ActiveExtension) (IntMap ActiveExtension))
-> ExtensionState -> Const (IntMap ActiveExtension) ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive) ClientState
st
    noCallback :: Bool
noCallback = (ActiveExtension -> Bool) -> IntMap ActiveExtension -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ActiveExtension
ae -> FgnExtension -> FunPtr ProcessMessage
fgnMessage (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae) FunPtr ProcessMessage -> FunPtr ProcessMessage -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ProcessMessage
forall a. FunPtr a
nullFunPtr) IntMap ActiveExtension
aes

message1 ::
  Ptr FgnMsg              {- ^ serialized IRC message      -} ->
  ClientState             {- ^ client state                -} ->
  [(Int,ActiveExtension)] {- ^ extensions needing callback -} ->
  IO (ClientState, Bool)  {- ^ new state and allow         -}
message1 :: Ptr FgnMsg
-> ClientState
-> [(Key, ActiveExtension)]
-> IO (ClientState, Bool)
message1 Ptr FgnMsg
_    ClientState
st [] = (ClientState, Bool) -> IO (ClientState, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st, Bool
True)
message1 Ptr FgnMsg
chat ClientState
st ((Key
i,ActiveExtension
ae):[(Key, ActiveExtension)]
aes) =
  do (ClientState
st1, Bool
allow) <- Key -> ClientState -> IO Bool -> IO (ClientState, Bool)
forall a. Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st (ActiveExtension -> Ptr FgnMsg -> IO Bool
notifyExtension ActiveExtension
ae Ptr FgnMsg
chat)
     if Bool
allow then Ptr FgnMsg
-> ClientState
-> [(Key, ActiveExtension)]
-> IO (ClientState, Bool)
message1 Ptr FgnMsg
chat ClientState
st1 [(Key, ActiveExtension)]
aes
              else (ClientState, Bool) -> IO (ClientState, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st1, Bool
False)


-- | Dispatch @/extension@ command to correct extension. Returns
-- 'Nothing' when no matching extension is available.
clientCommandExtension ::
  Text                   {- ^ extension name              -} ->
  Text                   {- ^ command                     -} ->
  ClientState            {- ^ client state                -} ->
  IO (Maybe ClientState) {- ^ new client state on success -}
clientCommandExtension :: Text -> Text -> ClientState -> IO (Maybe ClientState)
clientCommandExtension Text
name Text
command ClientState
st =
  case ((Key, ActiveExtension) -> Bool)
-> [(Key, ActiveExtension)] -> Maybe (Key, ActiveExtension)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Key
_,ActiveExtension
ae) -> ActiveExtension -> Text
aeName ActiveExtension
ae Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name)
            (IntMap ActiveExtension -> [(Key, ActiveExtension)]
forall a. IntMap a -> [(Key, a)]
IntMap.toList ((ActiveExtension -> Bool)
-> IntMap ActiveExtension -> IntMap ActiveExtension
forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter ActiveExtension -> Bool
aeLive (Getting
  (IntMap ActiveExtension) ClientState (IntMap ActiveExtension)
-> ClientState -> IntMap ActiveExtension
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
-> ClientState -> Const (IntMap ActiveExtension) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
 -> ClientState -> Const (IntMap ActiveExtension) ClientState)
-> ((IntMap ActiveExtension
     -> Const (IntMap ActiveExtension) (IntMap ActiveExtension))
    -> ExtensionState -> Const (IntMap ActiveExtension) ExtensionState)
-> Getting
     (IntMap ActiveExtension) ClientState (IntMap ActiveExtension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension
 -> Const (IntMap ActiveExtension) (IntMap ActiveExtension))
-> ExtensionState -> Const (IntMap ActiveExtension) ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive) ClientState
st))) of
        Maybe (Key, ActiveExtension)
Nothing -> Maybe ClientState -> IO (Maybe ClientState)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ClientState
forall a. Maybe a
Nothing
        Just (Key
i,ActiveExtension
ae) ->
          do (ClientState
st', ()
_) <- Key -> ClientState -> IO () -> IO (ClientState, ())
forall a. Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st (Text -> ActiveExtension -> IO ()
commandExtension Text
command ActiveExtension
ae)
             Maybe ClientState -> IO (Maybe ClientState)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState -> Maybe ClientState
forall a. a -> Maybe a
Just ClientState
st')


-- | Prepare the client to support reentry from the extension API.
clientPark ::
  Int              {- ^ extension ID                                        -} ->
  ClientState      {- ^ client state                                        -} ->
  IO a             {- ^ continuation using the stable pointer to the client -} ->
  IO (ClientState, a)
clientPark :: Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st IO a
k =
  do let mvar :: MVar ParkState
mvar = Getting (MVar ParkState) ClientState (MVar ParkState)
-> ClientState -> MVar ParkState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ExtensionState -> Const (MVar ParkState) ExtensionState)
-> ClientState -> Const (MVar ParkState) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Const (MVar ParkState) ExtensionState)
 -> ClientState -> Const (MVar ParkState) ClientState)
-> ((MVar ParkState -> Const (MVar ParkState) (MVar ParkState))
    -> ExtensionState -> Const (MVar ParkState) ExtensionState)
-> Getting (MVar ParkState) ClientState (MVar ParkState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MVar ParkState -> Const (MVar ParkState) (MVar ParkState))
-> ExtensionState -> Const (MVar ParkState) ExtensionState
Lens' ExtensionState (MVar ParkState)
esMVar) ClientState
st
     MVar ParkState -> ParkState -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ParkState
mvar (Key
i,ClientState
st)
     a
res     <- IO a
k
     (Key
_,ClientState
st') <- MVar ParkState -> IO ParkState
forall a. MVar a -> IO a
takeMVar MVar ParkState
mvar
     (ClientState, a) -> IO (ClientState, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st', a
res)

-- | Get the pointer used by C extensions to reenter the client.
clientToken :: ClientState -> Ptr ()
clientToken :: ClientState -> Ptr ()
clientToken = LensLike' (Const (Ptr ())) ClientState (StablePtr (MVar ParkState))
-> (StablePtr (MVar ParkState) -> Ptr ()) -> ClientState -> Ptr ()
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views ((ExtensionState -> Const (Ptr ()) ExtensionState)
-> ClientState -> Const (Ptr ()) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Const (Ptr ()) ExtensionState)
 -> ClientState -> Const (Ptr ()) ClientState)
-> ((StablePtr (MVar ParkState)
     -> Const (Ptr ()) (StablePtr (MVar ParkState)))
    -> ExtensionState -> Const (Ptr ()) ExtensionState)
-> LensLike'
     (Const (Ptr ())) ClientState (StablePtr (MVar ParkState))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StablePtr (MVar ParkState)
 -> Const (Ptr ()) (StablePtr (MVar ParkState)))
-> ExtensionState -> Const (Ptr ()) ExtensionState
Lens' ExtensionState (StablePtr (MVar ParkState))
esStablePtr) StablePtr (MVar ParkState) -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr

-- | Run the next available timer event on a particular extension.
clientExtTimer ::
  Int         {- ^ extension ID -} ->
  ClientState {- ^ client state -} ->
  IO ClientState
clientExtTimer :: Key -> ClientState -> IO ClientState
clientExtTimer Key
i ClientState
st =
  do let ae :: ActiveExtension
ae = ClientState
st ClientState
-> Getting (Endo ActiveExtension) ClientState ActiveExtension
-> ActiveExtension
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (ExtensionState -> Const (Endo ActiveExtension) ExtensionState)
-> ClientState -> Const (Endo ActiveExtension) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Const (Endo ActiveExtension) ExtensionState)
 -> ClientState -> Const (Endo ActiveExtension) ClientState)
-> ((ActiveExtension
     -> Const (Endo ActiveExtension) ActiveExtension)
    -> ExtensionState -> Const (Endo ActiveExtension) ExtensionState)
-> Getting (Endo ActiveExtension) ClientState ActiveExtension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension
 -> Const (Endo ActiveExtension) (IntMap ActiveExtension))
-> ExtensionState -> Const (Endo ActiveExtension) ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension
  -> Const (Endo ActiveExtension) (IntMap ActiveExtension))
 -> ExtensionState -> Const (Endo ActiveExtension) ExtensionState)
-> ((ActiveExtension
     -> Const (Endo ActiveExtension) ActiveExtension)
    -> IntMap ActiveExtension
    -> Const (Endo ActiveExtension) (IntMap ActiveExtension))
-> (ActiveExtension
    -> Const (Endo ActiveExtension) ActiveExtension)
-> ExtensionState
-> Const (Endo ActiveExtension) ExtensionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap ActiveExtension)
-> Traversal'
     (IntMap ActiveExtension) (IxValue (IntMap ActiveExtension))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Key
Index (IntMap ActiveExtension)
i
     case ActiveExtension
-> Maybe
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
popTimer ActiveExtension
ae of
       Maybe
  (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
Nothing -> ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st
       Just (UTCTime
_, TimerId
timerId, FunPtr TimerCallback
fun, Ptr ()
dat, ActiveExtension
ae') ->
         do let st1 :: ClientState
st1 = ((ActiveExtension -> Identity ActiveExtension)
 -> ClientState -> Identity ClientState)
-> ActiveExtension -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ((ExtensionState -> Identity ExtensionState)
-> ClientState -> Identity ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Identity ExtensionState)
 -> ClientState -> Identity ClientState)
-> ((ActiveExtension -> Identity ActiveExtension)
    -> ExtensionState -> Identity ExtensionState)
-> (ActiveExtension -> Identity ActiveExtension)
-> ClientState
-> Identity ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> ExtensionState -> Identity ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
 -> ExtensionState -> Identity ExtensionState)
-> ((ActiveExtension -> Identity ActiveExtension)
    -> IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> (ActiveExtension -> Identity ActiveExtension)
-> ExtensionState
-> Identity ExtensionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap ActiveExtension)
-> Traversal'
     (IntMap ActiveExtension) (IxValue (IntMap ActiveExtension))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Key
Index (IntMap ActiveExtension)
i) ActiveExtension
ae' ClientState
st
            (ClientState
st2,()
_) <- Key -> ClientState -> IO () -> IO (ClientState, ())
forall a. Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st1 (Dynamic TimerCallback
runTimerCallback FunPtr TimerCallback
fun Ptr ()
dat TimerId
timerId)
            ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st2

-- | Run the thread join action on a given extension.
clientThreadJoin ::
  Int         {- ^ extension ID  -} ->
  ThreadEntry {- ^ thread result -} ->
  ClientState {- ^ client state  -} ->
  IO ClientState
clientThreadJoin :: Key -> ThreadEntry -> ClientState -> IO ClientState
clientThreadJoin Key
i ThreadEntry
thread ClientState
st =
  let ae :: ActiveExtension
ae = ClientState
st ClientState
-> Getting (Endo ActiveExtension) ClientState ActiveExtension
-> ActiveExtension
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! (ExtensionState -> Const (Endo ActiveExtension) ExtensionState)
-> ClientState -> Const (Endo ActiveExtension) ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Const (Endo ActiveExtension) ExtensionState)
 -> ClientState -> Const (Endo ActiveExtension) ClientState)
-> ((ActiveExtension
     -> Const (Endo ActiveExtension) ActiveExtension)
    -> ExtensionState -> Const (Endo ActiveExtension) ExtensionState)
-> Getting (Endo ActiveExtension) ClientState ActiveExtension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension
 -> Const (Endo ActiveExtension) (IntMap ActiveExtension))
-> ExtensionState -> Const (Endo ActiveExtension) ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension
  -> Const (Endo ActiveExtension) (IntMap ActiveExtension))
 -> ExtensionState -> Const (Endo ActiveExtension) ExtensionState)
-> ((ActiveExtension
     -> Const (Endo ActiveExtension) ActiveExtension)
    -> IntMap ActiveExtension
    -> Const (Endo ActiveExtension) (IntMap ActiveExtension))
-> (ActiveExtension
    -> Const (Endo ActiveExtension) ActiveExtension)
-> ExtensionState
-> Const (Endo ActiveExtension) ExtensionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap ActiveExtension)
-> Traversal'
     (IntMap ActiveExtension) (IxValue (IntMap ActiveExtension))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Key
Index (IntMap ActiveExtension)
i
  in ActiveExtension -> IO ClientState
finish ActiveExtension
ae { aeThreads :: Key
aeThreads = ActiveExtension -> Key
aeThreads ActiveExtension
ae Key -> Key -> Key
forall a. Num a => a -> a -> a
- Key
1}
  where
    finish :: ActiveExtension -> IO ClientState
finish ActiveExtension
ae
      | ActiveExtension -> Bool
aeLive ActiveExtension
ae = -- normal behavior, run finalizer
         do let st1 :: ClientState
st1 = ((ActiveExtension -> Identity ActiveExtension)
 -> ClientState -> Identity ClientState)
-> ActiveExtension -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ((ExtensionState -> Identity ExtensionState)
-> ClientState -> Identity ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Identity ExtensionState)
 -> ClientState -> Identity ClientState)
-> ((ActiveExtension -> Identity ActiveExtension)
    -> ExtensionState -> Identity ExtensionState)
-> (ActiveExtension -> Identity ActiveExtension)
-> ClientState
-> Identity ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> ExtensionState -> Identity ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
 -> ExtensionState -> Identity ExtensionState)
-> ((ActiveExtension -> Identity ActiveExtension)
    -> IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> (ActiveExtension -> Identity ActiveExtension)
-> ExtensionState
-> Identity ExtensionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap ActiveExtension)
-> Traversal'
     (IntMap ActiveExtension) (IxValue (IntMap ActiveExtension))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Key
Index (IntMap ActiveExtension)
i) ActiveExtension
ae ClientState
st
            (ClientState
st2,()
_) <- Key -> ClientState -> IO () -> IO (ClientState, ())
forall a. Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st1 (ThreadEntry -> IO ()
threadFinish ThreadEntry
thread)
            ClientState -> IO ClientState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientState
st2
      | ActiveExtension -> Key
aeThreads ActiveExtension
ae Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
0 = -- delayed stop, all threads done
         do let st1 :: ClientState
st1 = ASetter
  ClientState
  ClientState
  (IntMap ActiveExtension)
  (IntMap ActiveExtension)
-> (IntMap ActiveExtension -> IntMap ActiveExtension)
-> ClientState
-> ClientState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((ExtensionState -> Identity ExtensionState)
-> ClientState -> Identity ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Identity ExtensionState)
 -> ClientState -> Identity ClientState)
-> ((IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
    -> ExtensionState -> Identity ExtensionState)
-> ASetter
     ClientState
     ClientState
     (IntMap ActiveExtension)
     (IntMap ActiveExtension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> ExtensionState -> Identity ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive) (Index (IntMap ActiveExtension)
-> IntMap ActiveExtension -> IntMap ActiveExtension
forall m. At m => Index m -> m -> m
sans Key
Index (IntMap ActiveExtension)
i) ClientState
st
            (ClientState
st2,()
_) <- Key -> ClientState -> IO () -> IO (ClientState, ())
forall a. Key -> ClientState -> IO a -> IO (ClientState, a)
clientPark Key
i ClientState
st1 (ActiveExtension -> IO ()
stopExtension ActiveExtension
ae)
            ClientState -> IO ClientState
forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st2
      | Bool
otherwise = -- delayed stop, more threads remain
         do ClientState -> IO ClientState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((ActiveExtension -> Identity ActiveExtension)
 -> ClientState -> Identity ClientState)
-> ActiveExtension -> ClientState -> ClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ((ExtensionState -> Identity ExtensionState)
-> ClientState -> Identity ClientState
Lens' ClientState ExtensionState
clientExtensions ((ExtensionState -> Identity ExtensionState)
 -> ClientState -> Identity ClientState)
-> ((ActiveExtension -> Identity ActiveExtension)
    -> ExtensionState -> Identity ExtensionState)
-> (ActiveExtension -> Identity ActiveExtension)
-> ClientState
-> Identity ClientState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> ExtensionState -> Identity ExtensionState
Lens' ExtensionState (IntMap ActiveExtension)
esActive ((IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
 -> ExtensionState -> Identity ExtensionState)
-> ((ActiveExtension -> Identity ActiveExtension)
    -> IntMap ActiveExtension -> Identity (IntMap ActiveExtension))
-> (ActiveExtension -> Identity ActiveExtension)
-> ExtensionState
-> Identity ExtensionState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (IntMap ActiveExtension)
-> Traversal'
     (IntMap ActiveExtension) (IxValue (IntMap ActiveExtension))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Key
Index (IntMap ActiveExtension)
i) ActiveExtension
ae ClientState
st)