{-# Language GeneralizedNewtypeDeriving, RankNTypes, RecordWildCards #-}
module Client.CApi
(
ActiveExtension(..)
, extensionSymbol
, activateExtension
, deactivateExtension
, notifyExtensions
, commandExtension
, chatExtension
) where
import Client.CApi.Types
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Codensity
import Data.Text (Text)
import qualified Data.Text 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 = evalNestedIO $
do raw <- withRawIrcMsg network msg
liftIO (go aes' raw)
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
chatExtension ::
Ptr () ->
Text ->
Text ->
Text ->
[ActiveExtension] ->
IO Bool
chatExtension stab net tgt msg aes
| null aes' = return True
| otherwise = doNotifications
where
aes' = [ (f, aeSession ae)
| ae <- aes
, let f = fgnChat (aeFgn ae)
, f /= nullFunPtr ]
doNotifications = evalNestedIO $
do chat <- withChat net tgt msg
liftIO (go aes' chat)
go [] _ = return True
go ((f,s):rest) ptr =
do res <- runProcessChat f stab s ptr
if res == passMessage
then go rest ptr
else return False
commandExtension ::
Ptr () ->
Text ->
ActiveExtension ->
IO ()
commandExtension stab command ae = evalNestedIO $
do cmd <- withCommand command
let f = fgnCommand (aeFgn ae)
liftIO $ unless (f == nullFunPtr)
$ runProcessCommand f stab (aeSession ae) cmd
withRawIrcMsg ::
Text ->
RawIrcMsg ->
NestedIO (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) <- nest2 $ withArrayLen keys
valsPtr <- nest1 $ withArray vals
(prmN,prmPtr) <- nest2 $ withArrayLen prms
nest1 $ with $ FgnMsg net pfxN pfxU pfxH cmd prmPtr (fromIntegral prmN)
keysPtr valsPtr (fromIntegral tagN)
withChat ::
Text ->
Text ->
Text ->
NestedIO (Ptr FgnChat)
withChat net tgt msg =
do net' <- withText net
tgt' <- withText tgt
msg' <- withText msg
nest1 $ with $ FgnChat net' tgt' msg'
withCommand ::
Text ->
NestedIO (Ptr FgnCmd)
withCommand command =
do cmd <- withText command
nest1 $ with $ FgnCmd cmd
withTag :: TagEntry -> NestedIO (FgnStringLen, FgnStringLen)
withTag (TagEntry k v) =
do pk <- withText k
pv <- withText v
return (pk,pv)
withText :: Text -> NestedIO FgnStringLen
withText txt =
do (ptr,len) <- nest1 $ withText0 txt
return $ FgnStringLen ptr $ fromIntegral len
newtype NestedIO a = NestedIO (Codensity IO a)
deriving (Functor, Applicative, Monad, MonadIO)
evalNestedIO :: NestedIO a -> IO a
evalNestedIO (NestedIO m) = lowerCodensity m
nest1 :: (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 f = NestedIO (Codensity f)
nest2 :: (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a,b)
nest2 f = NestedIO (Codensity (f . curry))