module Network.IRC.XChat.Plugin (
XchatVersion (..)
, currentVersion
, numericVersion
, PluginDescriptor (..)
, XchatPlugin
, XchatPluginHandle
, XChatPlugin (..)
, xChatGetChanList
, ChanFlgs (..)
, ChanType (..)
, Chan (..)
, xChatGetDccList
, DccStatus (..)
, DccType (..)
, Dcc (..)
, xChatGetIgnList
, IgnFlgs (..)
, Ign (..)
, xChatGetNotifyList
, Notify (..)
, xChatGetUserList
, User (..)
, XChatHook
, Eating (..)
, Hook
, PriorityC (..)
, PriorityA
, abstractPriority
, concretePriority
, Flags (..)
, xChatHookCommand
, xChatHookServer
, xChatHookPrint
, xChatHookTimer
, xChatHookFd
, xChatUnhook
, XChatContext
, xChatSetContext
, xChatFindContext
, xChatGetContext
, xChatPrint
, xChatCommand
, xChatNickcmp
, SettingResult (..)
, xChatGetPrefs
, xChatGetInfo
, xChatEmitPrint
, xChatSendModes
, StripRules (..)
, xChatStrip
, xChatPluginguiAdd
, xChatPluginguiRemove
, xChatGettext
) where
import Data.List (reverse)
import Foreign (peek, poke, shiftL, shiftR, (.|.), (.&.), testBit,
Int32, Int64, Ptr, FunPtr, Storable,
advancePtr, malloc, free, nullPtr, mallocArray)
import Foreign.C.Types (CInt (..), CChar (..), CTime (..))
import Foreign.C.String (CString (..), newCString, peekCString)
import System.Posix.Types (Fd (..))
import Control.Monad (unless)
import Data.Foldable (foldlM)
data XchatVersion = XchatVersion { major :: Int32
, minor :: Int32
, micro :: Int32
} deriving Show
currentVersion :: XchatVersion
currentVersion = XchatVersion { major = 1
, minor = 9
, micro = 11
}
numericVersion :: XchatVersion -> Int32
numericVersion v = major v * 10000 +
minor v * 100 +
micro v
cIntOfBools :: [a -> Bool] -> a -> CInt
cIntOfBools l a =
let step i f = (shiftL (i :: Int32) 1) .|. (if f a then 1 else 0)
in
fromIntegral $! foldl step 0 (reverse l)
data PluginDescriptor = PluginDescriptor { pluginName :: String
, pluginDescription :: String
, pluginVersion :: String
}
data SettingResult = SetFailure
| SetString String
| SetBool Bool
| SetInt Int32
data XchatList = XchatList
data XchatContext = XchatContext
type XchatListHandle = Ptr XchatList
type XchatContextHandle = Ptr XchatContext
newtype XChatContext = XCC XchatContextHandle
getArgs :: Ptr CString -> IO [String]
getArgs p =
let getAllArgs 0 acc _ = return $! reverse acc
getAllArgs n acc p = peek p >>= peekCString >>= \ s ->
if s == ""
then return $! reverse acc
else let m = n 1
q = advancePtr p 1
in
(seq m . seq q $
getAllArgs m (s : acc) q)
in
getAllArgs 31 [] (advancePtr p 1)
putArgs :: [String] -> IO (Ptr CString, IO ())
putArgs l =
let step (ptr, freer) str = newCString str >>= \ p ->
poke ptr p >>
return (advancePtr ptr 1, free p >> freer)
in
mallocArray (length l) >>= \ arr ->
foldlM step (arr, return ()) l >>= \ res ->
case res of
(_, freer) -> return (arr, freer >> free arr)
getOptString :: Maybe String -> IO CString
getOptString Nothing = return nullPtr
getOptString (Just s) = newCString s
freeOptString :: CString -> IO ()
freeOptString s = unless (s == nullPtr) $ free s
sideEffect :: Storable a => Ptr a -> (a -> IO (b, a)) -> IO b
sideEffect ptra trans = peek ptra >>= trans >>= \ p ->
poke ptra (snd p) >> return (fst p)
data XchatPlugin a = XchatPlugin
type XchatPluginHandle a = Ptr (XchatPlugin a)
newtype XChatPlugin a = XCP (Ptr a, XchatPluginHandle a)
data XchatHook a = XchatHook
type XchatHookHandle a = Ptr (XchatHook a)
newtype XChatHook a b c = XCH (XchatHookHandle a)
data Eating = Eating { eatXChat :: Bool
, eatPlugin :: Bool
}
retHook :: Storable a => Ptr a -> (a -> IO (Eating, a)) -> IO CInt
retHook pa cb = sideEffect pa cb >>= \ i ->
return (cIntOfBools [eatXChat, eatPlugin] i)
type Hook a b c d = XChatPlugin a -> (d -> a -> IO (Eating, a)) ->
(a -> IO (b, a)) -> IO (b, XChatHook a b c)
hook :: Storable a =>
(Ptr a -> IO (XchatHookHandle a)) -> Ptr a -> (a -> IO (b, a)) ->
IO (b, XChatHook a b c)
hook ioXCHH xCPHa init =
ioXCHH xCPHa >>= \ r -> sideEffect xCPHa init >>= \ b -> return (b, XCH r)
data PriorityC = Highest
| High
| Norm
| Low
| Lowest
| Custom Int32
newtype PriorityA = P Int32 deriving (Eq, Ord)
abstractPriority :: PriorityC -> PriorityA
abstractPriority Highest = P 127
abstractPriority High = P 64
abstractPriority Norm = P 0
abstractPriority Low = P (64)
abstractPriority Lowest = P (128)
abstractPriority (Custom i)
| i < 128 = P (128)
| i > 127 = P 127
| otherwise = P i
concretePriority :: PriorityA -> PriorityC
concretePriority (P i)
| i < 128 = Lowest
| i > 127 = Highest
| i == 64 = Low
| i == 0 = Norm
| i == 64 = High
| otherwise = Custom i
data Flags = Flags { fgRead :: Bool
, fgWrite :: Bool
, fgExn :: Bool
, fgNsock :: Bool
}
data StripRules = StripRules { noColor :: Bool
, noAttribute :: Bool
}
cIntOfFlag :: Flags -> CInt
cIntOfFlag = cIntOfBools [fgRead, fgWrite, fgExn, fgNsock]
flagOfCInt :: CInt -> Flags
flagOfCInt c =
Flags { fgRead = testBit c 0
, fgWrite = testBit c 1
, fgExn = testBit c 2
, fgNsock = testBit c 3
}
type Cb a = a -> IO (FunPtr a)
type Cb1 a = Ptr CString -> Ptr CString -> Ptr a -> IO CInt
foreign import ccall "wrapper" wrap1
:: Cb (Cb1 a)
type Cb2 a = Ptr CString -> Ptr a -> IO CInt
foreign import ccall "wrapper" wrap2
:: Cb (Cb2 a)
type Cb3 a = Ptr a -> IO CInt
foreign import ccall "wrapper" wrap3
:: Cb (Cb3 a)
type Cb4 a = CInt -> CInt -> Ptr a -> IO CInt
foreign import ccall "wrapper" wrap4
:: Cb (Cb4 a)
foreign import ccall "xchat-plugin-hack.h xchat_hook_command"
xChatHookCommandFFI
:: XchatPluginHandle a -> CString -> CInt -> FunPtr (Cb1 a) -> CString ->
Ptr a -> IO (XchatHookHandle a)
xChatHookCommand
:: Storable a => String -> PriorityA -> Maybe String -> Hook a b c String
xChatHookCommand com (P pri) help (XCP (pa, ph)) cb init =
let w _ s pa = peek (advancePtr s 1) >>= peekCString >>= retHook pa . cb
prio = fromIntegral pri
in
newCString com >>= \ com ->
getOptString help >>= \ help ->
wrap1 w >>= \ cb ->
hook (xChatHookCommandFFI ph com prio cb help) pa init >>= \ res ->
freeOptString help >>
free com >>
return res
foreign import ccall "xchat-plugin-hack.h xchat_hook_server"
xChatHookServerFFI
:: XchatPluginHandle a -> CString -> CInt -> FunPtr (Cb1 a) ->
Ptr a -> IO (XchatHookHandle a)
xChatHookServer :: Storable a => String -> PriorityA -> Hook a b c String
xChatHookServer ev (P pri) (XCP (pa, ph)) cb init =
let w _ s pa = peek (advancePtr s 1) >>= peekCString >>= retHook pa . cb
prio = fromIntegral pri
in
newCString ev >>= \ ev ->
wrap1 w >>= \ cb ->
hook (xChatHookServerFFI ph ev prio cb) pa init >>= \ res ->
free ev >>
return res
foreign import ccall "xchat-plugin-hack.h xchat_hook_print"
xChatHookPrintFFI
:: XchatPluginHandle a -> CString -> CInt -> FunPtr (Cb2 a) -> Ptr a ->
IO (XchatHookHandle a)
xChatHookPrint
:: Storable a => String -> PriorityA -> Hook a b c [String]
xChatHookPrint ev (P pri) (XCP (pa, ph)) cb init =
let prio = fromIntegral pri in
newCString ev >>= \ ev ->
wrap2 (\ s pa -> getArgs s >>= \ l -> retHook pa (cb l)) >>= \ cb ->
hook (xChatHookPrintFFI ph ev prio cb) pa init >>= \ res ->
free ev >>
return res
foreign import ccall "xchat-plugin-hack.h xchat_hook_timer"
xChatHookTimerFFI
:: XchatPluginHandle a -> CInt -> FunPtr (Cb3 a) -> Ptr a ->
IO (XchatHookHandle a)
xChatHookTimer
:: Storable a => Int32 -> Hook a b c ()
xChatHookTimer to (XCP (pa, ph)) cb init =
let tmo = fromIntegral to in
wrap3 (\ pa -> retHook pa (cb ())) >>= \ cb ->
hook (xChatHookTimerFFI ph tmo cb) pa init
foreign import ccall "xchat-plugin-hack.h xchat_hook_fd"
xChatHookFdFFI
:: XchatPluginHandle a -> CInt -> CInt -> FunPtr (Cb4 a) -> Ptr a ->
IO (XchatHookHandle a)
xChatHookFd :: Storable a => Fd -> Flags -> Hook a b c (Fd, Flags)
xChatHookFd (Fd fd) f (XCP (pa, ph)) cb init =
wrap4 (\ fd f pa -> retHook pa (cb (Fd fd, flagOfCInt f))) >>= \ cb ->
hook (xChatHookFdFFI ph fd (cIntOfFlag f) cb) pa init
foreign import ccall "xchat-plugin-hack.h xchat_unhook"
xChatUnhookFFI
:: XchatPluginHandle a -> XchatHookHandle a -> IO (Ptr a)
xChatUnhook
:: Storable a => XChatPlugin a -> XChatHook a b c -> (a -> IO (c, a)) -> IO c
xChatUnhook (XCP (pa, ph)) (XCH ha) deinit =
xChatUnhookFFI ph ha >> sideEffect pa deinit
foreign import ccall "xchat-plugin-hack.h xchat_print"
xChatPrintFFI :: XchatPluginHandle a -> CString -> IO ()
xChatPrint :: XChatPlugin a -> String -> IO ()
xChatPrint (XCP (_, ph)) s =
newCString s >>= \ p ->
xChatPrintFFI ph p >>
free p
foreign import ccall "xchat-plugin-hack.h xchat_command"
xChatCommandFFI :: XchatPluginHandle a -> CString -> IO ()
xChatCommand :: XChatPlugin a -> String -> IO ()
xChatCommand (XCP (_, ph)) s =
newCString s >>= \ s ->
xChatCommandFFI ph s >>
free s
foreign import ccall "xchat-plugin-hack.h xchat_set_context"
xChatSetContextFFI
:: XchatPluginHandle a -> XchatContextHandle -> IO CInt
xChatSetContext :: XChatPlugin a -> XChatContext -> IO Bool
xChatSetContext (XCP (_, ph)) (XCC ctx) =
xChatSetContextFFI ph ctx >>= \ i ->
return (i == 1)
foreign import ccall "xchat-plugin-hack.h xchat_find_context"
xChatFindContextFFI
:: XchatPluginHandle a -> CString -> CString -> IO XchatContextHandle
xChatFindContext :: XChatPlugin a -> Maybe String -> Maybe String ->
IO XChatContext
xChatFindContext (XCP (_, ph)) serv chan =
getOptString serv >>= \ t1 ->
getOptString chan >>= \ t2 ->
fmap XCC $ xChatFindContextFFI ph t1 t2 >>= \ res ->
freeOptString t1 >>
freeOptString t2 >>
return res
foreign import ccall "xchat-plugin-hack.h xchat_get_context"
xChatGetContextFFI
:: XchatPluginHandle a -> IO XchatContextHandle
xChatGetContext :: XChatPlugin a -> IO XChatContext
xChatGetContext (XCP (_, ph)) =
fmap XCC $ xChatGetContextFFI ph
foreign import ccall "xchat-plugin-hack.h xchat_nickcmp"
xChatNickcmpFFI :: XchatPluginHandle a -> CString -> CString -> IO CInt
xChatNickcmp :: XChatPlugin a -> String -> String -> IO Ordering
xChatNickcmp (XCP (_, ph)) s1 s2 =
newCString s1 >>= \ t1 ->
newCString s2 >>= \ t2 ->
xChatNickcmpFFI ph t1 t2 >>= \ i ->
free t1 >>
free t2 >>
return (if i < 0 then LT else if i > 0 then GT else EQ)
foreign import ccall "xchat-plugin-hack.h xchat_get_info"
xChatGetInfoFFI
:: XchatPluginHandle a -> CString -> IO CString
xChatGetInfo :: XChatPlugin a -> String -> IO (Maybe String)
xChatGetInfo (XCP (_, ph)) s =
newCString s >>= \ p ->
xChatGetInfoFFI ph p >>= \ c ->
free p >>
if c == nullPtr
then return Nothing
else fmap Just $ peekCString c
foreign import ccall "xchat-plugin-hack.h xchat_get_prefs"
xChatGetPrefsFFI
:: XchatPluginHandle a -> CString -> Ptr CString -> Ptr CInt -> IO CInt
xChatGetPrefs :: XChatPlugin a -> String -> IO SettingResult
xChatGetPrefs (XCP (_, ph)) s =
newCString s >>= \ c ->
malloc >>= \ sptr ->
malloc >>= \ iptr ->
xChatGetPrefsFFI ph c sptr iptr >>= \ i ->
(case i of 1 -> peek sptr >>= fmap SetString . peekCString
2 -> fmap (SetInt . fromIntegral) (peek iptr)
3 -> peek iptr >>= \ i -> return . SetBool $ (i /= 0)
otherwise -> return SetFailure) >>= \ res ->
free c >>
free sptr >>
free iptr >>
return res
foreign import ccall "xchat-plugin-hack.h xchat_emit_print0"
xChatEmitPrintFFI0
:: XchatPluginHandle a -> CString ->
IO CInt
foreign import ccall "xchat-plugin-hack.h xchat_emit_print1"
xChatEmitPrintFFI1
:: XchatPluginHandle a -> CString ->
CString -> IO CInt
foreign import ccall "xchat-plugin-hack.h xchat_emit_print2"
xChatEmitPrintFFI2
:: XchatPluginHandle a -> CString ->
CString -> CString -> IO CInt
foreign import ccall "xchat-plugin-hack.h xchat_emit_print3"
xChatEmitPrintFFI3
:: XchatPluginHandle a -> CString ->
CString -> CString -> CString -> IO CInt
foreign import ccall "xchat-plugin-hack.h xchat_emit_print4"
xChatEmitPrintFFI4
:: XchatPluginHandle a -> CString ->
CString -> CString -> CString -> CString -> IO CInt
xChatEmitPrint :: XChatPlugin a -> String -> [String] -> IO Bool
xChatEmitPrint (XCP (_, ph)) ev l =
newCString ev >>= \ s ->
mapM newCString l >>= \ l ->
fmap (== 1) (case l of
[] -> xChatEmitPrintFFI0 ph s
[a0] -> xChatEmitPrintFFI1 ph s a0
[a0, a1] -> xChatEmitPrintFFI2 ph s a0 a1
[a0, a1, a2] -> xChatEmitPrintFFI3 ph s a0 a1 a2
a0 : a1 : a2 : a3 : _ -> xChatEmitPrintFFI4 ph s a0 a1 a2 a3
) >>= \ res ->
free s >>
mapM free l >>
return res
foreign import ccall "xchat-plugin-hack.h xchat_send_modes"
xChatSendModesFFI
:: XchatPluginHandle a -> Ptr CString -> CInt -> CInt -> CChar -> CChar ->
IO ()
xChatSendModes :: XChatPlugin a -> [String] -> Maybe Int32 -> Bool -> Char -> IO ()
xChatSendModes (XCP (_, ph)) l n b c =
let mpp = case n of { Nothing -> 0 ; Just i -> fromIntegral i } in
putArgs l >>= \ (arr, freer) ->
let len = fromIntegral $ length l in
let sign = toEnum $ fromEnum (if b then '+' else '-') in
xChatSendModesFFI ph arr len mpp sign
(toEnum $ fromEnum c) >>
freer
foreign import ccall "xchat-plugin-hack.h xchat_free"
xChatFreeFFI
:: XchatPluginHandle a -> CString -> IO ()
foreign import ccall "xchat-plugin-hack.h xchat_strip"
xChatStripFFI
:: XchatPluginHandle a -> CString -> CInt -> CInt -> IO CString
xChatStrip :: String -> StripRules -> IO String
xChatStrip s r =
newCString s >>= \ ps ->
xChatStripFFI nullPtr ps (fromIntegral $ length s)
(cIntOfBools [noColor, noAttribute] r) >>= \ cs ->
peekCString cs >>= \ s ->
xChatFreeFFI nullPtr cs >>
free ps >>
return s
foreign import ccall "xchat-plugin-hack.h xchat_plugingui_add"
xChatPluginguiAddFFI
:: XchatPluginHandle a -> CString -> CString -> CString -> CString ->
Ptr () -> IO (XchatPluginHandle a)
xChatPluginguiAdd :: XChatPlugin a -> String -> PluginDescriptor -> IO (XChatPlugin a)
xChatPluginguiAdd (XCP (a, ph)) flnm d =
newCString flnm >>= \ fn ->
newCString (pluginName d) >>= \ n ->
newCString (pluginDescription d) >>= \ ds ->
newCString (pluginVersion d) >>= \ v ->
xChatPluginguiAddFFI ph fn n ds v nullPtr >>= \ pph ->
free fn >>
free n >>
free ds >>
free v >>
return (XCP (a, pph))
foreign import ccall "xchat-plugin-hack.h xchat_plugingui_remove"
xChatPluginguiRemoveFFI
:: XchatPluginHandle a -> XchatPluginHandle b -> IO ()
xChatPluginguiRemove :: XChatPlugin a -> IO ()
xChatPluginguiRemove (XCP (_, ph)) = xChatPluginguiRemoveFFI nullPtr ph
foreign import ccall "xchat-plugin-hack.h xchat_gettext"
xChatGettextFFI
:: XchatPluginHandle a -> CString -> IO CString
xChatGettext :: String -> IO String
xChatGettext s =
newCString s >>= \ cs ->
xChatGettextFFI nullPtr cs >>= \ ds ->
peekCString ds >>= \ t ->
free ds >>
free cs >>
return t
data ChanFlgs = ChanFlgs { connected :: Bool
, connecting :: Bool
, away :: Bool
, logged :: Bool
, whox :: Bool
, idmsg :: Bool
, jPmsg :: Bool
, beep :: Bool
, blinkTray :: Bool
, blinkTask :: Bool
}
chanFlgsOfInt :: Int32 -> ChanFlgs
chanFlgsOfInt i =
ChanFlgs { connected = testBit i 0
, connecting = testBit i 1
, away = testBit i 2
, logged = testBit i 3
, whox = testBit i 4
, idmsg = testBit i 6
, jPmsg = testBit i 6
, beep = testBit i 8
, blinkTray = testBit i 9
, blinkTask = testBit i 10
}
data ChanType = ChanServer
| ChanChannel
| ChanDialog
chanTypeOfInt :: Int32 -> ChanType
chanTypeOfInt c = case c of
0 -> ChanServer
1 -> ChanChannel
_ -> ChanDialog
data Chan = Chan { cChannel :: String
, cChantypes :: String
, cContext :: XChatContext
, cFlags :: ChanFlgs
, cId :: Int32
, cLag :: Int32
, cMaxmodes :: Int32
, cNetwork :: String
, cNickprefixes :: String
, cNickmodes :: String
, cQueue :: Int32
, cServer :: String
, cType :: ChanType
, cUsers :: Int32
}
data DccStatus = DccQueued
| DccActive
| DccFailed
| DccDone
| DccConnecting
| DccAborted
dccStatusOfInt :: Int32 -> DccStatus
dccStatusOfInt c = case c of
0 -> DccQueued
1 -> DccActive
2 -> DccFailed
3 -> DccDone
4 -> DccConnecting
_ -> DccAborted
data DccType = DccSend
| DccReceive
| DccChatRecv
| DccChatSend
dccTypeOfInt :: Int32 -> DccType
dccTypeOfInt c = case c of
0 -> DccSend
1 -> DccReceive
2 -> DccChatRecv
_ -> DccChatSend
data Dcc = Dcc { dAddress32 :: Int32
, dCps :: Int32
, dDestfile :: String
, dFile :: String
, dNick :: String
, dPort :: Int32
, dPos :: Int32
, dResume :: Int32
, dSize :: Int64
, dStatus :: DccStatus
, dType :: DccType
}
data IgnFlgs = IgnFlgs { private :: Bool
, notice :: Bool
, channel :: Bool
, ctcp :: Bool
, invite :: Bool
, unIgnore :: Bool
, noSave :: Bool
, dcc :: Bool
}
ignFlgsOfInt :: Int32 -> IgnFlgs
ignFlgsOfInt i =
IgnFlgs { private = testBit i 0
, notice = testBit i 1
, channel = testBit i 2
, ctcp = testBit i 3
, invite = testBit i 4
, unIgnore = testBit i 5
, noSave = testBit i 6
, dcc = testBit i 7
}
data Ign = Ign { iMask :: String
, iFlags :: IgnFlgs
}
data Notify = Notify { nNetworks :: [String]
, nNick :: String
, nOnline :: Bool
, nOn :: Int32
, nOff :: Int32
, nSeen :: Int32
}
data User = User { uAway :: Bool
, uLasttalk :: Int32
, uNick :: String
, uHost :: Maybe String
, uPrefix :: String
, uRealname :: Maybe String
, uSelected :: Bool
}
foreign import ccall "xchat-plugin-hack.h xchat_list_get"
xChatListGetFFI
:: XchatPluginHandle a -> CString -> IO XchatListHandle
foreign import ccall "xchat-plugin-hack.h xchat_list_free"
xChatListFreeFFI
:: XchatPluginHandle a -> XchatListHandle -> IO ()
foreign import ccall "xchat-plugin-hack.h xchat_list_next"
xChatListNextFFI
:: XchatPluginHandle a -> XchatListHandle -> IO CInt
foreign import ccall "xchat-plugin-hack.h xchat_list_str"
xChatListStrFFI
:: XchatPluginHandle a -> XchatListHandle -> CString -> IO CString
foreign import ccall "xchat-plugin-hack.h xchat_list_int"
xChatListIntFFI
:: XchatPluginHandle a -> XchatListHandle -> CString -> IO CInt
foreign import ccall "xchat-plugin-hack.h xchat_list_time"
xChatListTimeFFI
:: XchatPluginHandle a -> XchatListHandle -> CString -> IO CTime
foreign import ccall "xchat-plugin-hack.h xchat_list_context"
xChatListContextFFI
:: XchatPluginHandle a -> XchatListHandle -> CString -> IO XchatContextHandle
strListChan = newCString "channels"
strListDcc = newCString "dcc"
strListIgn = newCString "ignore"
strListNotify = newCString "notify"
strListUser = newCString "users"
strAddress = newCString "address32"
strCps = newCString "cps"
strDestfile = newCString "destfile"
strFile = newCString "file"
strNick = newCString "nick"
strPort = newCString "port"
strPos = newCString "pos"
strResume = newCString "iresume"
strSize = newCString "isize"
strSizehigh = newCString "isizehigh"
strStatus = newCString "istatus"
strChannel = newCString "channel"
strChantypes = newCString "chantypes"
strContext = newCString "context"
strFlags = newCString "flags"
strId = newCString "id"
strLag = newCString "lag"
strMaxmodes = newCString "maxmodes"
strNetwork = newCString "network"
strNickprefixes = newCString "nickprefixes"
strNickmodes = newCString "nickmodes"
strQueue = newCString "queue"
strServer = newCString "server"
strType = newCString "type"
strUsers = newCString "users"
strMask = newCString "mask"
strAway = newCString "away"
strLasttalk = newCString "lasttalk"
strHost = newCString "host"
strPrefix = newCString "prefix"
strRealname = newCString "realname"
strSelected = newCString "seleceted"
strNetworks = newCString "networks"
strOn = newCString "on"
strOff = newCString "off"
strSeen = newCString "seen"
getString :: XchatPluginHandle a -> XchatListHandle -> IO CString -> IO String
getString h l i = i >>= \ s ->
xChatListStrFFI h l s >>= peekCString >>= \ t ->
free s >>
return t
getMString :: XchatPluginHandle a -> XchatListHandle -> IO CString -> IO (Maybe String)
getMString h l i = i >>= \ s ->
xChatListStrFFI h l s >>= \ ms ->
free s >>
if ms == nullPtr
then return Nothing
else fmap return $ peekCString ms
getInt :: XchatPluginHandle a -> XchatListHandle -> IO CString -> IO Int32
getInt h l i = i >>= xChatListIntFFI h l >>= \ k -> return $ fromIntegral k
getTime :: XchatPluginHandle a -> XchatListHandle -> IO CString -> IO Int32
getTime h l i = i >>= xChatListTimeFFI h l >>= \ (CTime k) -> return k
xChatGetNotifyList :: XChatPlugin a -> IO [Notify]
xChatGetNotifyList (XCP (_, ph)) =
strListNotify >>= xChatListGetFFI ph >>= \ l ->
let getNotify = let gStr = getString ph l
gInt = getInt ph l
gMSt = getMString ph l
gTim = getTime ph l
splitOn a1 a2 [] = (reverse a1) : a2
splitOn a1 a2 (',' : l) = splitOn [] ((reverse a1) : a2) l
splitOn a1 a2 (a : l) = splitOn (a : a1) a2 l
net ns = case ns of
Nothing -> []
Just n -> splitOn [] [] n
in
gMSt strNetworks >>= \ networks ->
gStr strNick >>= \ nick ->
gInt strFlags >>= \ online ->
gTim strOn >>= \ on ->
gTim strOff >>= \ off ->
gTim strSeen >>= \ seen ->
return $ Notify { nNetworks = net networks
, nNick = nick
, nOnline = online /= 0
, nOn = on
, nOff = off
, nSeen = seen
}
getNotifies acc = xChatListNextFFI ph l >>= \ c ->
case fromIntegral c of
0 -> return acc
_ -> getNotify >>= \ not -> getNotifies (not : acc)
in
getNotifies [] >>= \ list ->
xChatListFreeFFI ph l >>
return list
xChatGetUserList :: XChatPlugin a -> IO [User]
xChatGetUserList (XCP (_, ph)) =
strListUser >>= xChatListGetFFI ph >>= \ l ->
let getUser = let gStr = getString ph l
gInt = getInt ph l
gTim = getTime ph l
gMSt = getMString ph l
in
gInt strAway >>= \ away ->
gTim strLasttalk >>= \ last ->
gStr strNick >>= \ nick ->
gMSt strHost >>= \ host ->
gStr strPrefix >>= \ prefix ->
gMSt strRealname >>= \ realname ->
gInt strSelected >>= \ selected ->
return $ User { uAway = away /= 0
, uLasttalk = last
, uNick = nick
, uHost = host
, uPrefix = prefix
, uRealname = realname
, uSelected = selected /= 0
}
getUsers acc = xChatListNextFFI ph l >>= \ c ->
case fromIntegral c of
0 -> return acc
_ -> getUser >>= \ usr -> getUsers (usr : acc)
in
getUsers [] >>= \ list ->
xChatListFreeFFI ph l >>
return list
xChatGetIgnList :: XChatPlugin a -> IO [Ign]
xChatGetIgnList (XCP (_, ph)) =
strListIgn >>= xChatListGetFFI ph >>= \ l ->
let getIgn = let gStr = getString ph l
gInt = getInt ph l
in
gStr strMask >>= \ mask ->
gInt strFlags >>= \ flags ->
return $ Ign { iMask = mask
, iFlags = ignFlgsOfInt flags
}
getIgns acc = xChatListNextFFI ph l >>= \ c ->
case fromIntegral c of
0 -> return acc
_ -> getIgn >>= \ ign -> getIgns (ign : acc)
in
getIgns [] >>= \ list ->
xChatListFreeFFI ph l >>
return list
xChatGetDccList :: XChatPlugin a -> IO [Dcc]
xChatGetDccList (XCP (_, ph)) =
strListDcc >>= xChatListGetFFI ph >>= \ l ->
let getDcc = let gStr = getString ph l
gInt = getInt ph l
in
gInt strAddress >>= \ address ->
gInt strCps >>= \ cps ->
gStr strDestfile >>= \ destfile ->
gStr strFile >>= \ file ->
gStr strNick >>= \ nick ->
gInt strPort >>= \ port ->
gInt strPos >>= \ pos ->
gInt strResume >>= \ resume ->
gInt strSize >>= \ sizeL ->
gInt strSizehigh >>= \ sizeH ->
gInt strStatus >>= \ status ->
gInt strType >>= \ typ ->
let bsizeH :: Int64
bsizeH = shiftL (fromIntegral sizeH) 32
bsizeL :: Int64
bsizeL = (fromIntegral sizeL) .&. (shiftR 1 32 1)
bsize = bsizeH .|. bsizeL
in
return $ Dcc { dAddress32 = address
, dCps = cps
, dDestfile = destfile
, dFile = file
, dNick = nick
, dPort = port
, dPos = pos
, dResume = resume
, dSize = bsize
, dStatus = dccStatusOfInt status
, dType = dccTypeOfInt typ
}
getDccs acc = xChatListNextFFI ph l >>= \ c ->
case fromIntegral c of
0 -> return acc
_ -> getDcc >>= \ dcc -> getDccs (dcc : acc)
in
getDccs [] >>= \ list ->
xChatListFreeFFI ph l >>
return list
xChatGetChanList :: XChatPlugin a -> IO [Chan]
xChatGetChanList (XCP (_, ph)) =
strListChan >>= xChatListGetFFI ph >>= \ l ->
let getChan = let gStr = getString ph l
gInt = getInt ph l
in
gStr strChannel >>= \ channel ->
gStr strChantypes >>= \ chantypes ->
(strContext >>= xChatListContextFFI ph l)
>>= \ ctx ->
gInt strFlags >>= \ flags ->
gInt strId >>= \ id ->
gInt strLag >>= \ lag ->
gInt strMaxmodes >>= \ maxmodes ->
gStr strNetwork >>= \ network ->
gStr strNickprefixes >>= \ nickprefixes ->
gStr strNickmodes >>= \ nickmodes ->
gInt strQueue >>= \ queue ->
gStr strServer >>= \ server ->
gInt strType >>= \ typ ->
gInt strUsers >>= \ users ->
return $ Chan { cChannel = channel
, cChantypes = chantypes
, cContext = XCC ctx
, cFlags = chanFlgsOfInt flags
, cId = id
, cLag = lag
, cMaxmodes = maxmodes
, cNetwork = network
, cNickprefixes = nickprefixes
, cNickmodes = nickmodes
, cQueue = queue
, cServer = server
, cType = chanTypeOfInt typ
, cUsers = users
}
getChans acc = xChatListNextFFI ph l >>= \ c ->
case fromIntegral c of
0 -> return acc
_ -> getChan >>= \ chan -> getChans (chan : acc)
in
getChans [] >>= \ list ->
xChatListFreeFFI ph l >>
return list