{-# Language GeneralizedNewtypeDeriving, RankNTypes, RecordWildCards #-}
{-|
Module      : Client.CApi
Description : Dynamically loaded extension API
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

Foreign interface to the IRC client via a simple C API
and dynamically loaded modules.

-}

module Client.CApi
  ( -- * Extension type
    ActiveExtension(..)

  -- * Extension callbacks
  , extensionSymbol
  , openExtension
  , startExtension
  , stopExtension
  , notifyExtension
  , commandExtension
  , chatExtension

  , ThreadEntry(..)
  , threadFinish

  , popTimer
  , pushTimer
  , cancelTimer

  , evalNestedIO
  , withChat
  , withRawIrcMsg
  ) where

import           Client.Configuration
                   (ExtensionConfiguration,
                    extensionPath, extensionRtldFlags, extensionArgs)
import           Client.CApi.Types
import           Control.Lens (view)
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Codensity
import           Data.IntPSQ (IntPSQ)
import qualified Data.IntPSQ as IntPSQ
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Time
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

------------------------------------------------------------------------

-- | The symbol that is loaded from an extension object.
--
-- Extensions are expected to export:
--
-- @
-- struct galua_extension extension;
-- @
extensionSymbol :: String
extensionSymbol :: String
extensionSymbol = String
"extension"

-- | Information about a loaded extension including the handle
-- to the loaded shared object, and state value returned by
-- the startup callback, and the loaded extension record.
data ActiveExtension = ActiveExtension
  { ActiveExtension -> FgnExtension
aeFgn     :: !FgnExtension -- ^ Struct of callback function pointers
  , ActiveExtension -> DL
aeDL      :: !DL           -- ^ Handle of dynamically linked extension
  , ActiveExtension -> Ptr ()
aeSession :: !(Ptr ())       -- ^ State value generated by start callback
  , ActiveExtension -> Text
aeName    :: !Text
  , ActiveExtension -> Int
aeMajorVersion, ActiveExtension -> Int
aeMinorVersion :: !Int
  , ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers  :: !(IntPSQ UTCTime TimerEntry)
  , ActiveExtension -> Int
aeNextTimer :: !Int
  , ActiveExtension -> Int
aeThreads :: !Int
  , ActiveExtension -> Bool
aeLive    :: !Bool
  }

data TimerEntry = TimerEntry !(FunPtr TimerCallback) !(Ptr ())

data ThreadEntry = ThreadEntry !(FunPtr ThreadFinish) !(Ptr ())

-- | Find the earliest timer ready to run if any are available.
popTimer ::
  ActiveExtension {- ^ extension -} ->
  Maybe (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
    {- ^ earlier time, callback, callback state, updated extension -}
popTimer :: ActiveExtension
-> Maybe
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
popTimer ActiveExtension
ae =
  do let timers :: IntPSQ UTCTime TimerEntry
timers = ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae
     Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ActiveExtension -> Bool
aeLive ActiveExtension
ae)
     (Int
timerId, UTCTime
time, TimerEntry FunPtr TimerCallback
fun Ptr ()
ptr, IntPSQ UTCTime TimerEntry
timers') <- IntPSQ UTCTime TimerEntry
-> Maybe (Int, UTCTime, TimerEntry, IntPSQ UTCTime TimerEntry)
forall p v. Ord p => IntPSQ p v -> Maybe (Int, p, v, IntPSQ p v)
IntPSQ.minView IntPSQ UTCTime TimerEntry
timers
     let ae' :: ActiveExtension
ae' = ActiveExtension
ae { aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers = IntPSQ UTCTime TimerEntry
timers' }
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
-> Maybe
     (UTCTime, TimerId, FunPtr TimerCallback, Ptr (), ActiveExtension)
forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
time, Int -> TimerId
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
timerId, FunPtr TimerCallback
fun, Ptr ()
ptr, ActiveExtension
ae')

-- | Schedue a new timer event for the given extension.
pushTimer ::
  UTCTime              {- ^ activation time   -} ->
  FunPtr TimerCallback {- ^ callback function -} ->
  Ptr ()               {- ^ callback state    -} ->
  ActiveExtension      {- ^ extension         -} ->
  (Int,ActiveExtension)
pushTimer :: UTCTime
-> FunPtr TimerCallback
-> Ptr ()
-> ActiveExtension
-> (Int, ActiveExtension)
pushTimer UTCTime
time FunPtr TimerCallback
fun Ptr ()
ptr ActiveExtension
ae = TimerEntry
entry TimerEntry -> (Int, ActiveExtension) -> (Int, ActiveExtension)
`seq` ActiveExtension
ae' ActiveExtension -> (Int, ActiveExtension) -> (Int, ActiveExtension)
`seq` (Int
i, ActiveExtension
ae')
  where
    entry :: TimerEntry
entry = FunPtr TimerCallback -> Ptr () -> TimerEntry
TimerEntry FunPtr TimerCallback
fun Ptr ()
ptr
    i :: Int
i     = ActiveExtension -> Int
aeNextTimer ActiveExtension
ae
    ae' :: ActiveExtension
ae'   = ActiveExtension
ae { aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers = Int
-> UTCTime
-> TimerEntry
-> IntPSQ UTCTime TimerEntry
-> IntPSQ UTCTime TimerEntry
forall p v. Ord p => Int -> p -> v -> IntPSQ p v -> IntPSQ p v
IntPSQ.insert Int
i UTCTime
time TimerEntry
entry (ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae)
               , aeNextTimer :: Int
aeNextTimer = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }

-- | Remove a timer from the schedule by ID
cancelTimer ::
  Int             {- ^ timer ID  -}  ->
  ActiveExtension {- ^ extension -}  ->
  Maybe (Ptr (), ActiveExtension)
cancelTimer :: Int -> ActiveExtension -> Maybe (Ptr (), ActiveExtension)
cancelTimer Int
timerId ActiveExtension
ae =
  do (UTCTime
_, TimerEntry FunPtr TimerCallback
_ Ptr ()
ptr) <- Int -> IntPSQ UTCTime TimerEntry -> Maybe (UTCTime, TimerEntry)
forall p v. Int -> IntPSQ p v -> Maybe (p, v)
IntPSQ.lookup Int
timerId (ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae)
     (Ptr (), ActiveExtension) -> Maybe (Ptr (), ActiveExtension)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr ()
ptr, ActiveExtension
ae { aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers = Int -> IntPSQ UTCTime TimerEntry -> IntPSQ UTCTime TimerEntry
forall p v. Ord p => Int -> IntPSQ p v -> IntPSQ p v
IntPSQ.delete Int
timerId (ActiveExtension -> IntPSQ UTCTime TimerEntry
aeTimers ActiveExtension
ae)})

-- | Load the extension from the given path and call the start
-- callback. The result of the start callback is saved to be
-- passed to any subsequent calls into the extension.
openExtension ::
  ExtensionConfiguration {- ^ extension configuration -} ->
  IO ActiveExtension
openExtension :: ExtensionConfiguration -> IO ActiveExtension
openExtension ExtensionConfiguration
config =
  do DL
dl   <- String -> [RTLDFlags] -> IO DL
dlopen (Getting String ExtensionConfiguration String
-> ExtensionConfiguration -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String ExtensionConfiguration String
Lens' ExtensionConfiguration String
extensionPath ExtensionConfiguration
config)
                    (Getting [RTLDFlags] ExtensionConfiguration [RTLDFlags]
-> ExtensionConfiguration -> [RTLDFlags]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [RTLDFlags] ExtensionConfiguration [RTLDFlags]
Lens' ExtensionConfiguration [RTLDFlags]
extensionRtldFlags ExtensionConfiguration
config)
     FunPtr Any
p    <- DL -> String -> IO (FunPtr Any)
forall a. DL -> String -> IO (FunPtr a)
dlsym DL
dl String
extensionSymbol
     FgnExtension
fgn  <- Ptr FgnExtension -> IO FgnExtension
forall a. Storable a => Ptr a -> IO a
peek (FunPtr Any -> Ptr FgnExtension
forall a b. FunPtr a -> Ptr b
castFunPtrToPtr FunPtr Any
p)
     String
name <- CString -> IO String
peekCString (FgnExtension -> CString
fgnName FgnExtension
fgn)
     ActiveExtension -> IO ActiveExtension
forall (m :: * -> *) a. Monad m => a -> m a
return (ActiveExtension -> IO ActiveExtension)
-> ActiveExtension -> IO ActiveExtension
forall a b. (a -> b) -> a -> b
$! ActiveExtension :: FgnExtension
-> DL
-> Ptr ()
-> Text
-> Int
-> Int
-> IntPSQ UTCTime TimerEntry
-> Int
-> Int
-> Bool
-> ActiveExtension
ActiveExtension
       { aeFgn :: FgnExtension
aeFgn          = FgnExtension
fgn
       , aeDL :: DL
aeDL           = DL
dl
       , aeSession :: Ptr ()
aeSession      = Ptr ()
forall a. Ptr a
nullPtr
       , aeName :: Text
aeName         = String -> Text
Text.pack String
name
       , aeTimers :: IntPSQ UTCTime TimerEntry
aeTimers       = IntPSQ UTCTime TimerEntry
forall p v. IntPSQ p v
IntPSQ.empty
       , aeMajorVersion :: Int
aeMajorVersion = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FgnExtension -> CInt
fgnMajorVersion FgnExtension
fgn)
       , aeMinorVersion :: Int
aeMinorVersion = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FgnExtension -> CInt
fgnMinorVersion FgnExtension
fgn)
       , aeNextTimer :: Int
aeNextTimer    = Int
1
       , aeThreads :: Int
aeThreads      = Int
0
       , aeLive :: Bool
aeLive         = Bool
True
       }

startExtension ::
  Ptr ()                 {- ^ client stable pointer   -} ->
  ExtensionConfiguration {- ^ extension configuration -} ->
  ActiveExtension        {- ^ active extension        -} ->
  IO (Ptr ())            {- ^ extension state         -}
startExtension :: Ptr () -> ExtensionConfiguration -> ActiveExtension -> IO (Ptr ())
startExtension Ptr ()
stab ExtensionConfiguration
config ActiveExtension
ae =
  do let f :: FunPtr StartExtension
f = FgnExtension -> FunPtr StartExtension
fgnStart (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     if FunPtr StartExtension
forall a. FunPtr a
nullFunPtr FunPtr StartExtension -> FunPtr StartExtension -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr StartExtension
f
       then Ptr () -> IO (Ptr ())
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr ()
forall a. Ptr a
nullPtr
       else NestedIO (Ptr ()) -> IO (Ptr ())
forall a. NestedIO a -> IO a
evalNestedIO (NestedIO (Ptr ()) -> IO (Ptr ()))
-> NestedIO (Ptr ()) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$
                  do CString
extPath <- (forall r. (CString -> IO r) -> IO r) -> NestedIO CString
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 (String -> (CString -> IO r) -> IO r
forall a. String -> (CString -> IO a) -> IO a
withCString (Getting String ExtensionConfiguration String
-> ExtensionConfiguration -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String ExtensionConfiguration String
Lens' ExtensionConfiguration String
extensionPath ExtensionConfiguration
config))
                     [FgnStringLen]
args <- (Text -> NestedIO FgnStringLen)
-> [Text] -> NestedIO [FgnStringLen]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> NestedIO FgnStringLen
withText
                           ([Text] -> NestedIO [FgnStringLen])
-> [Text] -> NestedIO [FgnStringLen]
forall a b. (a -> b) -> a -> b
$ Getting [Text] ExtensionConfiguration [Text]
-> ExtensionConfiguration -> [Text]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Text] ExtensionConfiguration [Text]
Lens' ExtensionConfiguration [Text]
extensionArgs ExtensionConfiguration
config
                     Ptr FgnStringLen
argsArray <- (forall r. (Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Ptr FgnStringLen)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ([FgnStringLen] -> (Ptr FgnStringLen -> IO r) -> IO r
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [FgnStringLen]
args)
                     let len :: CSize
len = Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([FgnStringLen] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FgnStringLen]
args)
                     IO (Ptr ()) -> NestedIO (Ptr ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Dynamic StartExtension
runStartExtension FunPtr StartExtension
f Ptr ()
stab CString
extPath Ptr FgnStringLen
argsArray CSize
len)

stopExtension :: ActiveExtension -> IO ()
stopExtension :: ActiveExtension -> IO ()
stopExtension ActiveExtension
ae =
  do let f :: FunPtr StopExtension
f = FgnExtension -> FunPtr StopExtension
fgnStop (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FunPtr StopExtension
forall a. FunPtr a
nullFunPtr FunPtr StopExtension -> FunPtr StopExtension -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr StopExtension
f) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       Dynamic StopExtension
runStopExtension FunPtr StopExtension
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae)
     DL -> IO ()
dlclose (ActiveExtension -> DL
aeDL ActiveExtension
ae)

-- | Call all of the process chat callbacks in the list of extensions.
-- This operation marshals the IRC message once and shares that across
-- all of the callbacks.
--
-- Returns 'True' to pass message to client.  Returns 'False to drop message.
chatExtension ::
  ActiveExtension {- ^ extension               -} ->
  Ptr FgnChat     {- ^ serialized chat message -} ->
  IO Bool         {- ^ allow message           -}
chatExtension :: ActiveExtension -> Ptr FgnChat -> IO Bool
chatExtension ActiveExtension
ae Ptr FgnChat
chat =
  do let f :: FunPtr ProcessChat
f = FgnExtension -> FunPtr ProcessChat
fgnChat (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     if FunPtr ProcessChat
f FunPtr ProcessChat -> FunPtr ProcessChat -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ProcessChat
forall a. FunPtr a
nullFunPtr
       then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else (ProcessResult
passMessage ProcessResult -> ProcessResult -> Bool
forall a. Eq a => a -> a -> Bool
==) (ProcessResult -> Bool) -> IO ProcessResult -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic ProcessChat
runProcessChat FunPtr ProcessChat
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae) Ptr FgnChat
chat

-- | Call all of the process message callbacks in the list of extensions.
-- This operation marshals the IRC message once and shares that across
-- all of the callbacks.
--
-- Returns 'True' to pass message to client.  Returns 'False to drop message.
notifyExtension ::
  ActiveExtension {- ^ extension                  -} ->
  Ptr FgnMsg      {- ^ serialized IRC message     -} ->
  IO Bool         {- ^ allow message              -}
notifyExtension :: ActiveExtension -> Ptr FgnMsg -> IO Bool
notifyExtension ActiveExtension
ae Ptr FgnMsg
msg =
  do let f :: FunPtr ProcessMessage
f = FgnExtension -> FunPtr ProcessMessage
fgnMessage (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     if FunPtr ProcessMessage
f FunPtr ProcessMessage -> FunPtr ProcessMessage -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ProcessMessage
forall a. FunPtr a
nullFunPtr
       then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       else (ProcessResult
passMessage ProcessResult -> ProcessResult -> Bool
forall a. Eq a => a -> a -> Bool
==) (ProcessResult -> Bool) -> IO ProcessResult -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic ProcessMessage
runProcessMessage FunPtr ProcessMessage
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae) Ptr FgnMsg
msg


-- | Notify an extension of a client command with the given parameters.
commandExtension ::
  Text            {- ^ command                -} ->
  ActiveExtension {- ^ extension to command   -} ->
  IO ()
commandExtension :: Text -> ActiveExtension -> IO ()
commandExtension Text
command ActiveExtension
ae = NestedIO () -> IO ()
forall a. NestedIO a -> IO a
evalNestedIO (NestedIO () -> IO ()) -> NestedIO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  do Ptr FgnCmd
cmd <- Text -> NestedIO (Ptr FgnCmd)
withCommand Text
command
     let f :: FunPtr ProcessCommand
f = FgnExtension -> FunPtr ProcessCommand
fgnCommand (ActiveExtension -> FgnExtension
aeFgn ActiveExtension
ae)
     IO () -> NestedIO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> NestedIO ()) -> IO () -> NestedIO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FunPtr ProcessCommand
f FunPtr ProcessCommand -> FunPtr ProcessCommand -> Bool
forall a. Eq a => a -> a -> Bool
== FunPtr ProcessCommand
forall a. FunPtr a
nullFunPtr)
            (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Dynamic ProcessCommand
runProcessCommand FunPtr ProcessCommand
f (ActiveExtension -> Ptr ()
aeSession ActiveExtension
ae) Ptr FgnCmd
cmd

-- | Notify an extension that one of its threads has finished.
threadFinish :: ThreadEntry -> IO ()
threadFinish :: ThreadEntry -> IO ()
threadFinish (ThreadEntry FunPtr StopExtension
f Ptr ()
x) = Dynamic StopExtension
runThreadFinish FunPtr StopExtension
f Ptr ()
x

-- | Marshal a 'RawIrcMsg' into a 'FgnMsg' which will be valid for
-- the remainder of the computation.
withRawIrcMsg ::
  Text                 {- ^ network      -} ->
  RawIrcMsg            {- ^ message      -} ->
  NestedIO (Ptr FgnMsg)
withRawIrcMsg :: Text -> RawIrcMsg -> NestedIO (Ptr FgnMsg)
withRawIrcMsg Text
network RawIrcMsg{[Text]
[TagEntry]
Maybe UserInfo
Text
_msgTags :: RawIrcMsg -> [TagEntry]
_msgPrefix :: RawIrcMsg -> Maybe UserInfo
_msgCommand :: RawIrcMsg -> Text
_msgParams :: RawIrcMsg -> [Text]
_msgParams :: [Text]
_msgCommand :: Text
_msgPrefix :: Maybe UserInfo
_msgTags :: [TagEntry]
..} =
  do FgnStringLen
net     <- Text -> NestedIO FgnStringLen
withText Text
network
     FgnStringLen
pfxN    <- Text -> NestedIO FgnStringLen
withText (Text -> NestedIO FgnStringLen) -> Text -> NestedIO FgnStringLen
forall a b. (a -> b) -> a -> b
$ Text -> (UserInfo -> Text) -> Maybe UserInfo -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty (Identifier -> Text
idText(Identifier -> Text)
-> (UserInfo -> Identifier) -> UserInfo -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.UserInfo -> Identifier
userNick) Maybe UserInfo
_msgPrefix
     FgnStringLen
pfxU    <- Text -> NestedIO FgnStringLen
withText (Text -> NestedIO FgnStringLen) -> Text -> NestedIO FgnStringLen
forall a b. (a -> b) -> a -> b
$ Text -> (UserInfo -> Text) -> Maybe UserInfo -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty UserInfo -> Text
userName Maybe UserInfo
_msgPrefix
     FgnStringLen
pfxH    <- Text -> NestedIO FgnStringLen
withText (Text -> NestedIO FgnStringLen) -> Text -> NestedIO FgnStringLen
forall a b. (a -> b) -> a -> b
$ Text -> (UserInfo -> Text) -> Maybe UserInfo -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
Text.empty UserInfo -> Text
userHost Maybe UserInfo
_msgPrefix
     FgnStringLen
cmd     <- Text -> NestedIO FgnStringLen
withText Text
_msgCommand
     [FgnStringLen]
prms    <- (Text -> NestedIO FgnStringLen)
-> [Text] -> NestedIO [FgnStringLen]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> NestedIO FgnStringLen
withText [Text]
_msgParams
     [(FgnStringLen, FgnStringLen)]
tags    <- (TagEntry -> NestedIO (FgnStringLen, FgnStringLen))
-> [TagEntry] -> NestedIO [(FgnStringLen, FgnStringLen)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TagEntry -> NestedIO (FgnStringLen, FgnStringLen)
withTag  [TagEntry]
_msgTags
     let ([FgnStringLen]
keys,[FgnStringLen]
vals) = [(FgnStringLen, FgnStringLen)] -> ([FgnStringLen], [FgnStringLen])
forall a b. [(a, b)] -> ([a], [b])
unzip [(FgnStringLen, FgnStringLen)]
tags
     (Int
tagN,Ptr FgnStringLen
keysPtr) <- (forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen)
forall a b. (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 ((forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
 -> NestedIO (Int, Ptr FgnStringLen))
-> (forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen)
forall a b. (a -> b) -> a -> b
$ [FgnStringLen] -> (Int -> Ptr FgnStringLen -> IO r) -> IO r
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [FgnStringLen]
keys
     Ptr FgnStringLen
valsPtr        <- (forall r. (Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Ptr FgnStringLen)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. (Ptr FgnStringLen -> IO r) -> IO r)
 -> NestedIO (Ptr FgnStringLen))
-> (forall r. (Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Ptr FgnStringLen)
forall a b. (a -> b) -> a -> b
$ [FgnStringLen] -> (Ptr FgnStringLen -> IO r) -> IO r
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [FgnStringLen]
vals
     (Int
prmN,Ptr FgnStringLen
prmPtr)  <- (forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen)
forall a b. (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 ((forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
 -> NestedIO (Int, Ptr FgnStringLen))
-> (forall r. (Int -> Ptr FgnStringLen -> IO r) -> IO r)
-> NestedIO (Int, Ptr FgnStringLen)
forall a b. (a -> b) -> a -> b
$ [FgnStringLen] -> (Int -> Ptr FgnStringLen -> IO r) -> IO r
forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen [FgnStringLen]
prms
     (forall r. (Ptr FgnMsg -> IO r) -> IO r) -> NestedIO (Ptr FgnMsg)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. (Ptr FgnMsg -> IO r) -> IO r) -> NestedIO (Ptr FgnMsg))
-> (forall r. (Ptr FgnMsg -> IO r) -> IO r)
-> NestedIO (Ptr FgnMsg)
forall a b. (a -> b) -> a -> b
$ FgnMsg -> (Ptr FgnMsg -> IO r) -> IO r
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (FgnMsg -> (Ptr FgnMsg -> IO r) -> IO r)
-> FgnMsg -> (Ptr FgnMsg -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ FgnStringLen
-> FgnStringLen
-> FgnStringLen
-> FgnStringLen
-> FgnStringLen
-> Ptr FgnStringLen
-> CSize
-> Ptr FgnStringLen
-> Ptr FgnStringLen
-> CSize
-> FgnMsg
FgnMsg FgnStringLen
net FgnStringLen
pfxN FgnStringLen
pfxU FgnStringLen
pfxH FgnStringLen
cmd Ptr FgnStringLen
prmPtr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
prmN)
                                       Ptr FgnStringLen
keysPtr Ptr FgnStringLen
valsPtr (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tagN)

withChat ::
  Text {- ^ network -} ->
  Text {- ^ target  -} ->
  Text {- ^ message -} ->
  NestedIO (Ptr FgnChat)
withChat :: Text -> Text -> Text -> NestedIO (Ptr FgnChat)
withChat Text
net Text
tgt Text
msg =
  do FgnStringLen
net' <- Text -> NestedIO FgnStringLen
withText Text
net
     FgnStringLen
tgt' <- Text -> NestedIO FgnStringLen
withText Text
tgt
     FgnStringLen
msg' <- Text -> NestedIO FgnStringLen
withText Text
msg
     (forall r. (Ptr FgnChat -> IO r) -> IO r) -> NestedIO (Ptr FgnChat)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. (Ptr FgnChat -> IO r) -> IO r)
 -> NestedIO (Ptr FgnChat))
-> (forall r. (Ptr FgnChat -> IO r) -> IO r)
-> NestedIO (Ptr FgnChat)
forall a b. (a -> b) -> a -> b
$ FgnChat -> (Ptr FgnChat -> IO r) -> IO r
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (FgnChat -> (Ptr FgnChat -> IO r) -> IO r)
-> FgnChat -> (Ptr FgnChat -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ FgnStringLen -> FgnStringLen -> FgnStringLen -> FgnChat
FgnChat FgnStringLen
net' FgnStringLen
tgt' FgnStringLen
msg'

withCommand ::
  Text {- ^ command -} ->
  NestedIO (Ptr FgnCmd)
withCommand :: Text -> NestedIO (Ptr FgnCmd)
withCommand Text
command =
  do FgnStringLen
cmd <- Text -> NestedIO FgnStringLen
withText Text
command
     (forall r. (Ptr FgnCmd -> IO r) -> IO r) -> NestedIO (Ptr FgnCmd)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. (Ptr FgnCmd -> IO r) -> IO r) -> NestedIO (Ptr FgnCmd))
-> (forall r. (Ptr FgnCmd -> IO r) -> IO r)
-> NestedIO (Ptr FgnCmd)
forall a b. (a -> b) -> a -> b
$ FgnCmd -> (Ptr FgnCmd -> IO r) -> IO r
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (FgnCmd -> (Ptr FgnCmd -> IO r) -> IO r)
-> FgnCmd -> (Ptr FgnCmd -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ FgnStringLen -> FgnCmd
FgnCmd FgnStringLen
cmd

withTag :: TagEntry -> NestedIO (FgnStringLen, FgnStringLen)
withTag :: TagEntry -> NestedIO (FgnStringLen, FgnStringLen)
withTag (TagEntry Text
k Text
v) =
  do FgnStringLen
pk <- Text -> NestedIO FgnStringLen
withText Text
k
     FgnStringLen
pv <- Text -> NestedIO FgnStringLen
withText Text
v
     (FgnStringLen, FgnStringLen)
-> NestedIO (FgnStringLen, FgnStringLen)
forall (m :: * -> *) a. Monad m => a -> m a
return (FgnStringLen
pk,FgnStringLen
pv)

withText :: Text -> NestedIO FgnStringLen
withText :: Text -> NestedIO FgnStringLen
withText Text
txt =
  do (CString
ptr,Int
len) <- (forall r. ((CString, Int) -> IO r) -> IO r)
-> NestedIO (CString, Int)
forall a. (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 ((forall r. ((CString, Int) -> IO r) -> IO r)
 -> NestedIO (CString, Int))
-> (forall r. ((CString, Int) -> IO r) -> IO r)
-> NestedIO (CString, Int)
forall a b. (a -> b) -> a -> b
$ Text -> ((CString, Int) -> IO r) -> IO r
forall a. Text -> ((CString, Int) -> IO a) -> IO a
withText0 Text
txt
     FgnStringLen -> NestedIO FgnStringLen
forall (m :: * -> *) a. Monad m => a -> m a
return (FgnStringLen -> NestedIO FgnStringLen)
-> FgnStringLen -> NestedIO FgnStringLen
forall a b. (a -> b) -> a -> b
$ CString -> CSize -> FgnStringLen
FgnStringLen CString
ptr (CSize -> FgnStringLen) -> CSize -> FgnStringLen
forall a b. (a -> b) -> a -> b
$ Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len

------------------------------------------------------------------------

-- | Continuation-passing style bracked IO actions.
newtype NestedIO a = NestedIO (Codensity IO a)
  deriving (a -> NestedIO b -> NestedIO a
(a -> b) -> NestedIO a -> NestedIO b
(forall a b. (a -> b) -> NestedIO a -> NestedIO b)
-> (forall a b. a -> NestedIO b -> NestedIO a) -> Functor NestedIO
forall a b. a -> NestedIO b -> NestedIO a
forall a b. (a -> b) -> NestedIO a -> NestedIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> NestedIO b -> NestedIO a
$c<$ :: forall a b. a -> NestedIO b -> NestedIO a
fmap :: (a -> b) -> NestedIO a -> NestedIO b
$cfmap :: forall a b. (a -> b) -> NestedIO a -> NestedIO b
Functor, Functor NestedIO
a -> NestedIO a
Functor NestedIO
-> (forall a. a -> NestedIO a)
-> (forall a b. NestedIO (a -> b) -> NestedIO a -> NestedIO b)
-> (forall a b c.
    (a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c)
-> (forall a b. NestedIO a -> NestedIO b -> NestedIO b)
-> (forall a b. NestedIO a -> NestedIO b -> NestedIO a)
-> Applicative NestedIO
NestedIO a -> NestedIO b -> NestedIO b
NestedIO a -> NestedIO b -> NestedIO a
NestedIO (a -> b) -> NestedIO a -> NestedIO b
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
forall a. a -> NestedIO a
forall a b. NestedIO a -> NestedIO b -> NestedIO a
forall a b. NestedIO a -> NestedIO b -> NestedIO b
forall a b. NestedIO (a -> b) -> NestedIO a -> NestedIO b
forall a b c.
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: NestedIO a -> NestedIO b -> NestedIO a
$c<* :: forall a b. NestedIO a -> NestedIO b -> NestedIO a
*> :: NestedIO a -> NestedIO b -> NestedIO b
$c*> :: forall a b. NestedIO a -> NestedIO b -> NestedIO b
liftA2 :: (a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
$cliftA2 :: forall a b c.
(a -> b -> c) -> NestedIO a -> NestedIO b -> NestedIO c
<*> :: NestedIO (a -> b) -> NestedIO a -> NestedIO b
$c<*> :: forall a b. NestedIO (a -> b) -> NestedIO a -> NestedIO b
pure :: a -> NestedIO a
$cpure :: forall a. a -> NestedIO a
$cp1Applicative :: Functor NestedIO
Applicative, Applicative NestedIO
a -> NestedIO a
Applicative NestedIO
-> (forall a b. NestedIO a -> (a -> NestedIO b) -> NestedIO b)
-> (forall a b. NestedIO a -> NestedIO b -> NestedIO b)
-> (forall a. a -> NestedIO a)
-> Monad NestedIO
NestedIO a -> (a -> NestedIO b) -> NestedIO b
NestedIO a -> NestedIO b -> NestedIO b
forall a. a -> NestedIO a
forall a b. NestedIO a -> NestedIO b -> NestedIO b
forall a b. NestedIO a -> (a -> NestedIO b) -> NestedIO b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> NestedIO a
$creturn :: forall a. a -> NestedIO a
>> :: NestedIO a -> NestedIO b -> NestedIO b
$c>> :: forall a b. NestedIO a -> NestedIO b -> NestedIO b
>>= :: NestedIO a -> (a -> NestedIO b) -> NestedIO b
$c>>= :: forall a b. NestedIO a -> (a -> NestedIO b) -> NestedIO b
$cp1Monad :: Applicative NestedIO
Monad, Monad NestedIO
Monad NestedIO
-> (forall a. IO a -> NestedIO a) -> MonadIO NestedIO
IO a -> NestedIO a
forall a. IO a -> NestedIO a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> NestedIO a
$cliftIO :: forall a. IO a -> NestedIO a
$cp1MonadIO :: Monad NestedIO
MonadIO)

-- | Return the bracket IO action.
evalNestedIO :: NestedIO a -> IO a
evalNestedIO :: NestedIO a -> IO a
evalNestedIO (NestedIO Codensity IO a
m) = Codensity IO a -> IO a
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity Codensity IO a
m

-- | Wrap up a bracketing IO operation where the continuation takes 1 argument
nest1 :: (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 :: (forall r. (a -> IO r) -> IO r) -> NestedIO a
nest1 forall r. (a -> IO r) -> IO r
f = Codensity IO a -> NestedIO a
forall a. Codensity IO a -> NestedIO a
NestedIO ((forall r. (a -> IO r) -> IO r) -> Codensity IO a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity forall r. (a -> IO r) -> IO r
f)

-- | Wrap up a bracketing IO operation where the continuation takes 2 argument
nest2 :: (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a,b)
nest2 :: (forall r. (a -> b -> IO r) -> IO r) -> NestedIO (a, b)
nest2 forall r. (a -> b -> IO r) -> IO r
f = Codensity IO (a, b) -> NestedIO (a, b)
forall a. Codensity IO a -> NestedIO a
NestedIO ((forall b. ((a, b) -> IO b) -> IO b) -> Codensity IO (a, b)
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((a -> b -> IO b) -> IO b
forall r. (a -> b -> IO r) -> IO r
f ((a -> b -> IO b) -> IO b)
-> (((a, b) -> IO b) -> a -> b -> IO b) -> ((a, b) -> IO b) -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> IO b) -> a -> b -> IO b
forall a b c. ((a, b) -> c) -> a -> b -> c
curry))