{-# 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 Client.CApi
import Client.CApi.Types
import Client.Configuration (configExtensions, ExtensionConfiguration)
import Client.Message
import Client.State
import Control.Concurrent.MVar (putMVar, takeMVar)
import Control.Exception (displayException, try)
import Control.Lens
import Control.Monad (foldM)
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (find)
import Data.IntMap qualified as IntMap
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (getZonedTime)
import Foreign.Ptr (Ptr, nullFunPtr)
import Foreign.StablePtr (castStablePtrToPtr)
import Irc.RawIrcMsg (RawIrcMsg)

-- | 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 = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' ClientState Configuration
clientConfig ClientState
st
     ClientState
st1 <- ClientState -> IO ClientState
clientStopExtensions ClientState
st
     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 (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view 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 <- 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
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ClientMessage -> ClientState -> ClientState
recordNetworkMessage ClientMessage
              { _msgTime :: ZonedTime
_msgTime    = ZonedTime
now
              , _msgBody :: MessageBody
_msgBody    = Text -> MessageBody
ErrorBody (String -> Text
Text.pack (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 :: Int
i = case forall a. IntMap a -> Maybe ((Int, a), IntMap a)
IntMap.maxViewWithKey (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive) ClientState
st) of
                      Just ((Int
k,ActiveExtension
_),IntMap ActiveExtension
_) -> Int
kforall a. Num a => a -> a -> a
+Int
1
                      Maybe ((Int, ActiveExtension), IntMap ActiveExtension)
Nothing -> Int
0

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

            -- save handle back into active extension
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ClientState
st2 forall a b. a -> (a -> b) -> b
& Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
i 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 forall a b. a -> (a -> b) -> b
& Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive 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
     forall i (f :: * -> *) (m :: * -> *) b a.
(FoldableWithIndex i f, Monad m) =>
(i -> b -> a -> m b) -> b -> f a -> m b
ifoldlM Int -> ClientState -> ActiveExtension -> IO ClientState
step ClientState
st1 IntMap ActiveExtension
aes
  where
    upd :: IntMap ActiveExtension
-> (IntMap ActiveExtension, IntMap ActiveExtension)
upd = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ActiveExtension -> ActiveExtension
disable) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> Int
aeThreads ActiveExtension
ae forall a. Eq a => a -> a -> Bool
== Int
0
    step :: Int -> ClientState -> ActiveExtension -> IO ClientState
step Int
i ClientState
st2 ActiveExtension
ae =
      do (ClientState
st3,()
_) <- forall a. Int -> ClientState -> IO a -> IO (ClientState, a)
clientPark Int
i ClientState
st2 (ActiveExtension -> IO ()
stopExtension ActiveExtension
ae)
         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 = forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st, Bool
True)
  | Bool
otherwise  = forall a. NestedIO a -> IO a
evalNestedIO forall a b. (a -> b) -> a -> b
$
                 do Ptr FgnChat
chat <- Text -> Text -> Text -> NestedIO (Ptr FgnChat)
withChat Text
net Text
tgt Text
msg
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr FgnChat
-> ClientState
-> [(Int, ActiveExtension)]
-> IO (ClientState, Bool)
chat1 Ptr FgnChat
chat ClientState
st (forall a. IntMap a -> [(Int, a)]
IntMap.toList (forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter ActiveExtension -> Bool
aeLive IntMap ActiveExtension
aes)))
  where
    aes :: IntMap ActiveExtension
aes = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive) ClientState
st
    noCallback :: Bool
noCallback = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ActiveExtension
ae -> FgnExtension -> FunPtr ProcessChat
fgnChat (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae) forall a. Eq a => a -> a -> Bool
== 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
-> [(Int, ActiveExtension)]
-> IO (ClientState, Bool)
chat1 Ptr FgnChat
_    ClientState
st [] = forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st, Bool
True)
chat1 Ptr FgnChat
chat ClientState
st ((Int
i,ActiveExtension
ae):[(Int, ActiveExtension)]
aes) =
  do (ClientState
st1, Bool
allow) <- forall a. Int -> ClientState -> IO a -> IO (ClientState, a)
clientPark Int
i ClientState
st (ActiveExtension -> Ptr FgnChat -> IO Bool
chatExtension ActiveExtension
ae Ptr FgnChat
chat)
     if Bool
allow then Ptr FgnChat
-> ClientState
-> [(Int, ActiveExtension)]
-> IO (ClientState, Bool)
chat1 Ptr FgnChat
chat ClientState
st1 [(Int, ActiveExtension)]
aes
              else 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st, Bool
True)
  | Bool
otherwise  = forall a. NestedIO a -> IO a
evalNestedIO forall a b. (a -> b) -> a -> b
$
                 do Ptr FgnMsg
fgn <- Text -> RawIrcMsg -> NestedIO (Ptr FgnMsg)
withRawIrcMsg Text
network RawIrcMsg
raw
                    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr FgnMsg
-> ClientState
-> [(Int, ActiveExtension)]
-> IO (ClientState, Bool)
message1 Ptr FgnMsg
fgn ClientState
st (forall a. IntMap a -> [(Int, a)]
IntMap.toList (forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter ActiveExtension -> Bool
aeLive IntMap ActiveExtension
aes)))
  where
    aes :: IntMap ActiveExtension
aes = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive) ClientState
st
    noCallback :: Bool
noCallback = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ActiveExtension
ae -> FgnExtension -> FunPtr ProcessMessage
fgnMessage (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae) forall a. Eq a => a -> a -> Bool
== 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
-> [(Int, ActiveExtension)]
-> IO (ClientState, Bool)
message1 Ptr FgnMsg
_    ClientState
st [] = forall (m :: * -> *) a. Monad m => a -> m a
return (ClientState
st, Bool
True)
message1 Ptr FgnMsg
chat ClientState
st ((Int
i,ActiveExtension
ae):[(Int, ActiveExtension)]
aes) =
  do (ClientState
st1, Bool
allow) <- forall a. Int -> ClientState -> IO a -> IO (ClientState, a)
clientPark Int
i ClientState
st (ActiveExtension -> Ptr FgnMsg -> IO Bool
notifyExtension ActiveExtension
ae Ptr FgnMsg
chat)
     if Bool
allow then Ptr FgnMsg
-> ClientState
-> [(Int, ActiveExtension)]
-> IO (ClientState, Bool)
message1 Ptr FgnMsg
chat ClientState
st1 [(Int, ActiveExtension)]
aes
              else 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Int
_,ActiveExtension
ae) -> ActiveExtension -> Text
aeName ActiveExtension
ae forall a. Eq a => a -> a -> Bool
== Text
name)
            (forall a. IntMap a -> [(Int, a)]
IntMap.toList (forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter ActiveExtension -> Bool
aeLive (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive) ClientState
st))) of
        Maybe (Int, ActiveExtension)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just (Int
i,ActiveExtension
ae) ->
          do (ClientState
st', ()
_) <- forall a. Int -> ClientState -> IO a -> IO (ClientState, a)
clientPark Int
i ClientState
st (Text -> ActiveExtension -> IO ()
commandExtension Text
command ActiveExtension
ae)
             forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall a. Int -> ClientState -> IO a -> IO (ClientState, a)
clientPark Int
i ClientState
st IO a
k =
  do let mvar :: MVar ParkState
mvar = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (MVar ParkState)
esMVar) ClientState
st
     forall a. MVar a -> a -> IO ()
putMVar MVar ParkState
mvar (Int
i,ClientState
st)
     a
res     <- IO a
k
     (Int
_,ClientState
st') <- forall a. MVar a -> IO a
takeMVar MVar ParkState
mvar
     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 = forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (StablePtr (MVar ParkState))
esStablePtr) 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 :: Int -> ClientState -> IO ClientState
clientExtTimer Int
i ClientState
st =
  do let ae :: ActiveExtension
ae = ClientState
st forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
i
     case ActiveExtension
-> Maybe
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
popTimer ActiveExtension
ae of
       Maybe
  (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
Nothing -> 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 = forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
i) ActiveExtension
ae' ClientState
st
            (ClientState
st2,()
_) <- forall a. Int -> ClientState -> IO a -> IO (ClientState, a)
clientPark Int
i ClientState
st1 (Dynamic TimerCallback
runTimerCallback FunPtr TimerCallback
fun Ptr ()
dat TimerId
timerId)
            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 :: Int -> ThreadEntry -> ClientState -> IO ClientState
clientThreadJoin Int
i ThreadEntry
thread ClientState
st =
  let ae :: ActiveExtension
ae = ClientState
st forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
i
  in ActiveExtension -> IO ClientState
finish ActiveExtension
ae { aeThreads :: Int
aeThreads = ActiveExtension -> Int
aeThreads ActiveExtension
ae forall a. Num a => a -> a -> a
- Int
1}
  where
    finish :: ActiveExtension -> IO ClientState
finish ActiveExtension
ae
      | ActiveExtension -> Bool
aeLive ActiveExtension
ae = -- normal behavior, run finalizer
         do let st1 :: ClientState
st1 = forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
i) ActiveExtension
ae ClientState
st
            (ClientState
st2,()
_) <- forall a. Int -> ClientState -> IO a -> IO (ClientState, a)
clientPark Int
i ClientState
st1 (ThreadEntry -> IO ()
threadFinish ThreadEntry
thread)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientState
st2
      | ActiveExtension -> Int
aeThreads ActiveExtension
ae forall a. Eq a => a -> a -> Bool
== Int
0 = -- delayed stop, all threads done
         do let st1 :: ClientState
st1 = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive) (forall m. At m => Index m -> m -> m
sans Int
i) ClientState
st
            (ClientState
st2,()
_) <- forall a. Int -> ClientState -> IO a -> IO (ClientState, a)
clientPark Int
i ClientState
st1 (ActiveExtension -> IO ()
stopExtension ActiveExtension
ae)
            forall (m :: * -> *) a. Monad m => a -> m a
return ClientState
st2
      | Bool
otherwise = -- delayed stop, more threads remain
         do forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' ClientState ExtensionState
clientExtensions forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ExtensionState (IntMap ActiveExtension)
esActive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
i) ActiveExtension
ae ClientState
st)