{-# Language RecordWildCards #-}
module Client.CApi
(
ActiveExtension(..)
, extensionSymbol
, activateExtension
, deactivateExtension
, notifyExtensions
, commandExtension
) where
import Client.CApi.Types
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Cont
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Foreign as Text
import Foreign.C
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Irc.Identifier
import Irc.RawIrcMsg
import Irc.UserInfo
import System.Posix.DynamicLinker
extensionSymbol :: String
extensionSymbol = "extension"
data ActiveExtension = ActiveExtension
{ aeFgn :: !FgnExtension
, aeDL :: !DL
, aeSession :: !(Ptr ())
, aeName :: !Text
, aeMajorVersion, aeMinorVersion :: !Int
}
activateExtension ::
Ptr () ->
FilePath ->
IO ActiveExtension
activateExtension stab path =
do dl <- dlopen path [RTLD_NOW, RTLD_LOCAL]
p <- dlsym dl extensionSymbol
fgn <- peek (castFunPtrToPtr p)
name <- peekCString (fgnName fgn)
let f = fgnStart fgn
s <- if nullFunPtr == f
then return nullPtr
else withCString path (runStartExtension f stab)
return $! ActiveExtension
{ aeFgn = fgn
, aeDL = dl
, aeSession = s
, aeName = Text.pack name
, aeMajorVersion = fromIntegral (fgnMajorVersion fgn)
, aeMinorVersion = fromIntegral (fgnMinorVersion fgn)
}
deactivateExtension :: Ptr () -> ActiveExtension -> IO ()
deactivateExtension stab ae =
do let f = fgnStop (aeFgn ae)
unless (nullFunPtr == f) $
runStopExtension f stab (aeSession ae)
dlclose (aeDL ae)
notifyExtensions ::
Ptr () ->
Text ->
RawIrcMsg ->
[ActiveExtension] ->
IO Bool
notifyExtensions stab network msg aes
| null aes' = return True
| otherwise = doNotifications
where
aes' = [ (f,s) | ae <- aes
, let f = fgnMessage (aeFgn ae)
s = aeSession ae
, f /= nullFunPtr ]
doNotifications =
runContT (withRawIrcMsg network msg) (go aes')
go [] _ = return True
go ((f,s):rest) msgPtr =
do res <- runProcessMessage f stab s msgPtr
if res == passMessage
then go rest msgPtr
else return False
commandExtension ::
Ptr () ->
[Text] ->
ActiveExtension ->
IO ()
commandExtension stab params ae = evalContT $
do cmd <- withCommand params
let f = fgnCommand (aeFgn ae)
lift $ unless (f == nullFunPtr)
$ runProcessCommand f stab (aeSession ae) cmd
withRawIrcMsg ::
Text ->
RawIrcMsg ->
ContT a IO (Ptr FgnMsg)
withRawIrcMsg network RawIrcMsg{..} =
do net <- withText network
pfxN <- withText $ maybe Text.empty (idText.userNick) _msgPrefix
pfxU <- withText $ maybe Text.empty userName _msgPrefix
pfxH <- withText $ maybe Text.empty userHost _msgPrefix
cmd <- withText _msgCommand
prms <- traverse withText _msgParams
tags <- traverse withTag _msgTags
let (keys,vals) = unzip tags
(tagN,keysPtr) <- contT2 $ withArrayLen keys
valsPtr <- ContT $ withArray vals
(prmN,prmPtr) <- contT2 $ withArrayLen prms
ContT $ with $ FgnMsg net pfxN pfxU pfxH cmd prmPtr (fromIntegral prmN)
keysPtr valsPtr (fromIntegral tagN)
withCommand ::
[Text] ->
ContT a IO (Ptr FgnCmd)
withCommand params =
do prms <- traverse withText params
(prmN,prmPtr) <- contT2 $ withArrayLen prms
ContT $ with $ FgnCmd prmPtr (fromIntegral prmN)
withTag :: TagEntry -> ContT a IO (FgnStringLen, FgnStringLen)
withTag (TagEntry k v) =
do pk <- withText k
pv <- withText v
return (pk,pv)
withText :: Text -> ContT a IO FgnStringLen
withText txt =
do (ptr,len) <- ContT $ Text.withCStringLen txt
return $ FgnStringLen ptr $ fromIntegral len
contT2 :: ((a -> b -> m c) -> m c) -> ContT c m (a,b)
contT2 f = ContT $ \g -> f $ curry g