{-# Language OverloadedStrings #-}
module Client.State.Extensions
( clientChatExtension
, clientCommandExtension
, clientStartExtensions
, clientNotifyExtensions
, clientStopExtensions
, clientExtTimer
) 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
clientStartExtensions ::
ClientState ->
IO ClientState
clientStartExtensions st =
do let cfg = view clientConfig st
st1 <- clientStopExtensions st
foldM start1 st1 (view configExtensions cfg)
start1 :: ClientState -> ExtensionConfiguration -> IO ClientState
start1 st config =
do res <- try (openExtension config) :: IO (Either IOError ActiveExtension)
case res of
Left err ->
do now <- getZonedTime
return $! recordNetworkMessage ClientMessage
{ _msgTime = now
, _msgBody = ErrorBody (Text.pack (displayException err))
, _msgNetwork = ""
} st
Right ae ->
do let i = case IntMap.maxViewWithKey (view (clientExtensions . esActive) st) of
Just ((k,_),_) -> k+1
Nothing -> 0
let st1 = st & clientExtensions . esActive . at i ?~ ae
(st2, h) <- clientPark i st1 $ \ptr -> startExtension ptr config ae
return $! st2 & clientExtensions . esActive . ix i %~ \ae' ->
ae' { aeSession = h }
clientStopExtensions ::
ClientState ->
IO ClientState
clientStopExtensions st =
do let (aes,st1) = st & clientExtensions . esActive <<.~ IntMap.empty
ifoldlM step st1 aes
where
step i st2 ae =
do (st3,_) <- clientPark i st2 $ \ptr -> deactivateExtension ptr ae
return st3
clientChatExtension ::
Text ->
Text ->
Text ->
ClientState ->
IO (ClientState, Bool)
clientChatExtension net tgt msg st
| noCallback = return (st, True)
| otherwise = evalNestedIO $
do chat <- withChat net tgt msg
liftIO (chat1 chat st (IntMap.toList aes))
where
aes = view (clientExtensions . esActive) st
noCallback = all (\ae -> fgnChat (aeFgn ae) == nullFunPtr) aes
chat1 ::
Ptr FgnChat ->
ClientState ->
[(Int,ActiveExtension)] ->
IO (ClientState, Bool)
chat1 _ st [] = return (st, True)
chat1 chat st ((i,ae):aes) =
do (st1, allow) <- clientPark i st $ \ptr -> chatExtension ptr ae chat
if allow then chat1 chat st1 aes
else return (st1, False)
clientNotifyExtensions ::
Text ->
RawIrcMsg ->
ClientState ->
IO (ClientState, Bool)
clientNotifyExtensions network raw st
| noCallback = return (st, True)
| otherwise = evalNestedIO $
do fgn <- withRawIrcMsg network raw
liftIO (message1 fgn st (IntMap.toList aes))
where
aes = view (clientExtensions . esActive) st
noCallback = all (\ae -> fgnMessage (aeFgn ae) == nullFunPtr) aes
message1 ::
Ptr FgnMsg ->
ClientState ->
[(Int,ActiveExtension)] ->
IO (ClientState, Bool)
message1 _ st [] = return (st, True)
message1 chat st ((i,ae):aes) =
do (st1, allow) <- clientPark i st $ \ptr -> notifyExtension ptr ae chat
if allow then message1 chat st1 aes
else return (st1, False)
clientCommandExtension ::
Text ->
Text ->
ClientState ->
IO (Maybe ClientState)
clientCommandExtension name command st =
case find (\(_,ae) -> aeName ae == name)
(IntMap.toList (view (clientExtensions . esActive) st)) of
Nothing -> return Nothing
Just (i,ae) ->
do (st', _) <- clientPark i st $ \ptr ->
commandExtension ptr command ae
return (Just st')
clientPark ::
Int ->
ClientState ->
(Ptr () -> IO a) ->
IO (ClientState, a)
clientPark i st k =
do let mvar = view (clientExtensions . esMVar) st
putMVar mvar (i,st)
let token = views (clientExtensions . esStablePtr) castStablePtrToPtr st
res <- k token
(_,st') <- takeMVar mvar
return (st', res)
clientExtTimer ::
Int ->
ClientState ->
IO ClientState
clientExtTimer i st =
do let ae = st ^?! clientExtensions . esActive . ix i
case popTimer ae of
Nothing -> return st
Just (_, timerId, fun, dat, ae') ->
do let st1 = set (clientExtensions . esActive . ix i) ae' st
(st2,_) <- clientPark i st1 $ \ptr ->
runTimerCallback fun ptr (aeSession ae) dat timerId
return st2