diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for glirc2 +## 2.29 +* Add support for timers to the extension API +* Add `glirc_set_focus` API call + ## 2.28 * Add formatting reference to `/palette` * Make RTLD flags configurable when loading an extension diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,3 @@ -{-# Language CPP #-} {-| Module : Main Description : Custom setup script @@ -25,19 +24,13 @@ import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, installedPkgs, withLibLBI) import Distribution.Simple.PackageIndex (allPackages) import Distribution.Simple.Setup (configVerbosity, fromFlag) -import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFile) +import Distribution.Simple.Utils (createDirectoryIfMissingVerbose, rewriteFileEx) import Distribution.Verbosity (Verbosity) import System.FilePath ((), (<.>)) -#if MIN_VERSION_Cabal(2,0,0) import Distribution.Simple.BuildPaths (autogenComponentModulesDir) -#else -import Distribution.Simple.BuildPaths (autogenModulesDir) -#endif -#if MIN_VERSION_Cabal(2,2,0) import qualified Distribution.SPDX as SPDX -#endif -- | Default Setup main extended to generate a Build module and to validate @@ -109,16 +102,12 @@ [InstalledPackageInfo] {- ^ transitive package dependencies -} -> IO () generateBuildModule verbosity pkg lbi pkgs = -#if MIN_VERSION_Cabal(2,0,0) withLibLBI pkg lbi $ \_lib clbi -> do let dir = autogenComponentModulesDir lbi clbi -#else - do let dir = autogenModulesDir lbi -#endif modname = buildModuleName pkg file = dir modname <.> "hs" createDirectoryIfMissingVerbose verbosity True dir - rewriteFile file + rewriteFileEx verbosity file $ unlines [ "{-|" , "Module : " ++ modname @@ -137,39 +126,23 @@ [InstalledPackageInfo] {- ^ transitive package dependencies -} -> String {- ^ haskell syntax -} renderDeps pkgs = - show [ (unPackageName (pkgName p), versionBranch (pkgVersion p)) + show [ (unPackageName (pkgName p), versionNumbers (pkgVersion p)) | p <- sourcePackageId <$> pkgs ] -#if MIN_VERSION_Cabal(2,0,0) -versionBranch :: Version -> [Int] -versionBranch = versionNumbers -#endif - -- | Check that all transitive dependencies are available under an acceptable -- license. Raises a user-error on failure. validateLicenses :: [InstalledPackageInfo] {- ^ transitive package dependencies -} -> IO () validateLicenses pkgs = - do let p pkg = toLicense (license pkg) `notElem` freeLicenses + do let toLicense = either licenseFromSPDX id + p pkg = toLicense (license pkg) `notElem` freeLicenses badPkgs = filter p pkgs unless (null badPkgs) $ do mapM_ print [ toLicense (license p) | p <- badPkgs ] fail "BAD LICENSE" - -class ToLicense a where toLicense :: a -> License -instance ToLicense License where toLicense = id - -#if MIN_VERSION_Cabal(2,2,0) -instance (ToLicense a, ToLicense b) => ToLicense (Either a b) where - toLicense (Right x) = toLicense x - toLicense (Left x) = toLicense x -instance ToLicense SPDX.License where - toLicense = licenseFromSPDX -#endif - -- | The set of permissive licenses that are acceptable for transitive dependencies diff --git a/exec/Exports.hs b/exec/Exports.hs --- a/exec/Exports.hs +++ b/exec/Exports.hs @@ -26,9 +26,14 @@ foreign export ccall glirc_my_nick :: Glirc_my_nick foreign export ccall glirc_user_account :: Glirc_user_account foreign export ccall glirc_user_channel_modes :: Glirc_user_channel_modes +foreign export ccall glirc_channel_modes :: Glirc_channel_modes +foreign export ccall glirc_channel_masks :: Glirc_channel_masks foreign export ccall glirc_mark_seen :: Glirc_mark_seen foreign export ccall glirc_clear_window :: Glirc_clear_window foreign export ccall glirc_free_string :: Glirc_free_string foreign export ccall glirc_free_strings :: Glirc_free_strings foreign export ccall glirc_current_focus :: Glirc_current_focus +foreign export ccall glirc_set_focus :: Glirc_set_focus foreign export ccall glirc_resolve_path :: Glirc_resolve_path +foreign export ccall glirc_set_timer :: Glirc_set_timer +foreign export ccall glirc_cancel_timer :: Glirc_cancel_timer diff --git a/exec/Main.hs b/exec/Main.hs --- a/exec/Main.hs +++ b/exec/Main.hs @@ -1,4 +1,5 @@ {-| + - Description : Entry-point of executable Copyright : (c) Eric Mertens, 2016 License : ISC @@ -21,6 +22,7 @@ import Client.EventLoop import Client.Options import Client.State +import Client.State.Extensions import Client.State.Focus import Exports () diff --git a/exec/linux_exported_symbols.txt b/exec/linux_exported_symbols.txt --- a/exec/linux_exported_symbols.txt +++ b/exec/linux_exported_symbols.txt @@ -9,12 +9,17 @@ glirc_my_nick; glirc_user_account; glirc_user_channel_modes; +glirc_channel_modes; +glirc_channel_masks; glirc_mark_seen; glirc_is_channel; glirc_is_logged_on; glirc_clear_window; glirc_current_focus; +glirc_set_focus; glirc_resolve_path; glirc_free_string; glirc_free_strings; +glirc_set_timer; +glirc_cancel_timer; }; diff --git a/exec/macos_exported_symbols.txt b/exec/macos_exported_symbols.txt --- a/exec/macos_exported_symbols.txt +++ b/exec/macos_exported_symbols.txt @@ -8,11 +8,16 @@ _glirc_my_nick _glirc_user_account _glirc_user_channel_modes +_glirc_channel_modes +_glirc_channel_masks _glirc_mark_seen _glirc_is_channel _glirc_is_logged_on _glirc_clear_window _glirc_current_focus +_glirc_set_focus _glirc_resolve_path _glirc_free_string _glirc_free_strings +_glirc_set_timer +_glirc_cancel_timer diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: glirc -version: 2.28 +version: 2.29 synopsis: Console IRC client description: Console IRC client . @@ -22,9 +22,9 @@ tested-with: GHC==8.4.3 custom-setup - setup-depends: base >=4.11 && <4.12, + setup-depends: base >=4.11 && <4.13, filepath >=1.4 && <1.5, - Cabal >=2.2 && <2.3, + Cabal >=2.2 && <2.5, source-repository head type: git @@ -97,6 +97,7 @@ Client.State.Channel Client.State.EditBox Client.State.EditBox.Content + Client.State.Extensions Client.State.Focus Client.State.Network Client.State.Window @@ -126,7 +127,7 @@ autogen-modules: Paths_glirc Build_glirc - build-depends: base >=4.11 && <4.12, + build-depends: base >=4.11 && <4.13, HsOpenSSL >=0.11 && <0.12, async >=2.1 && <2.3, attoparsec >=0.13 && <0.14, @@ -144,20 +145,21 @@ irc-core >=2.5 && <2.6, kan-extensions >=5.0 && <5.3, lens >=4.14 && <4.18, - network >=2.6.2 && <2.8, + network >=2.6.2 && <2.9, process >=1.4.2 && <1.7, + psqueues >=0.2.7 && <0.3, regex-tdfa >=1.2 && <1.3, semigroupoids >=5.1 && <5.4, split >=0.2 && <0.3, - stm >=2.4 && <2.5, - template-haskell >=2.11 && <2.14, + stm >=2.4 && <2.6, + template-haskell >=2.11 && <2.15, text >=1.2.2 && <1.3, time >=1.6 && <1.10, transformers >=0.5.2 && <0.6, unix >=2.7 && <2.8, unordered-containers >=0.2.7 && <0.3, vector >=0.11 && <0.13, - vty >=5.23.1 && <5.24, + vty >=5.23.1 && <5.25, test-suite test type: exitcode-stdio-1.0 diff --git a/include/glirc-api.h b/include/glirc-api.h --- a/include/glirc-api.h +++ b/include/glirc-api.h @@ -49,6 +49,9 @@ typedef enum process_result process_chat_type(struct glirc *G, void *S, const struct glirc_chat *); typedef void process_command_type(struct glirc *G, void *S, const struct glirc_command *); +typedef long timer_id; +typedef void timer_callback(struct glirc *G, void *S, void *dat, timer_id); + struct glirc_extension { const char *name; int major_version, minor_version; @@ -70,9 +73,12 @@ char ** glirc_list_channels(struct glirc *G, const char *net, size_t netlen); char ** glirc_list_channel_users(struct glirc *G, const char *net, size_t net_len, const char *chan, size_t chan_len); void glirc_current_focus(struct glirc *G, char **net, size_t *netlen, char **tgt , size_t *tgtlen); +void glirc_set_focus(struct glirc *G, const char *net, size_t netlen, const char *tgt , size_t tgtlen); char * glirc_my_nick(struct glirc *G, const char *net, size_t netlen); char * glirc_user_account(struct glirc *G, const char *net, size_t netlen, const char *nick, size_t nicklen); char * glirc_user_channel_modes(struct glirc *G, const char *net, size_t netlen, const char *chan, size_t chanlen, const char *nick, size_t nicklen); +char ** glirc_channel_modes(struct glirc *G, const char *net, size_t netlen, const char *chan, size_t chanlen); +char ** glirc_channel_masks(struct glirc *G, const char *net, size_t netlen, const char *chan, size_t chanlen, char mode); void glirc_mark_seen(struct glirc *G, const char *net, size_t net_len, const char *chan, size_t chan_len); void glirc_clear_window(struct glirc *G, const char *net, size_t net_len, const char *chan, size_t chan_len); int glirc_identifier_cmp(const char *s, size_t s_len, const char *t, size_t t_len); @@ -81,6 +87,8 @@ int glirc_is_logged_on(struct glirc *G, const char *net, size_t netlen, const char *tgt, size_t tgtlen); char * glirc_resolve_path(struct glirc *G, const char *path, size_t path_len); +timer_id glirc_set_timer(struct glirc *G, unsigned long millis, timer_callback *cb, void *dat); +void glirc_cancel_timer(struct glirc *G, timer_id tid); void glirc_free_string(char *); void glirc_free_strings(char **); diff --git a/src/Client/CApi.hs b/src/Client/CApi.hs --- a/src/Client/CApi.hs +++ b/src/Client/CApi.hs @@ -17,11 +17,20 @@ -- * Extension callbacks , extensionSymbol - , activateExtension + , openExtension + , startExtension , deactivateExtension - , notifyExtensions + , notifyExtension , commandExtension , chatExtension + + , popTimer + , pushTimer + , cancelTimer + + , evalNestedIO + , withChat + , withRawIrcMsg ) where import Client.Configuration @@ -32,8 +41,11 @@ 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 @@ -64,39 +76,85 @@ , aeSession :: !(Ptr ()) -- ^ State value generated by start callback , aeName :: !Text , aeMajorVersion, aeMinorVersion :: !Int + , aeTimers :: !(IntPSQ UTCTime TimerEntry) + , aeNextTimer :: !Int } +data TimerEntry = TimerEntry !(FunPtr TimerCallback) !(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 ae = + do let timers = aeTimers ae + (timerId, time, TimerEntry fun ptr, timers') <- IntPSQ.minView timers + let ae' = ae { aeTimers = timers' } + return (time, fromIntegral timerId, fun, ptr, 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 time fun ptr ae = entry `seq` ae' `seq` (i, ae') + where + entry = TimerEntry fun ptr + i = aeNextTimer ae + ae' = ae { aeTimers = IntPSQ.insert i time entry (aeTimers ae) + , aeNextTimer = i + 1 } + +-- | Remove a timer from the schedule by ID +cancelTimer :: + Int {- ^ timer ID -} -> + ActiveExtension {- ^ extension -} -> + ActiveExtension +cancelTimer timerId ae = ae + { aeTimers = IntPSQ.delete timerId (aeTimers 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. -activateExtension :: - Ptr () -> +openExtension :: ExtensionConfiguration {- ^ extension configuration -} -> IO ActiveExtension -activateExtension stab config = +openExtension config = do dl <- dlopen (view extensionPath config) (view extensionRtldFlags config) p <- dlsym dl extensionSymbol fgn <- peek (castFunPtrToPtr p) name <- peekCString (fgnName fgn) - let f = fgnStart fgn - s <- if nullFunPtr == f - then return nullPtr - else evalNestedIO $ + return $! ActiveExtension + { aeFgn = fgn + , aeDL = dl + , aeSession = nullPtr + , aeName = Text.pack name + , aeTimers = IntPSQ.empty + , aeMajorVersion = fromIntegral (fgnMajorVersion fgn) + , aeMinorVersion = fromIntegral (fgnMinorVersion fgn) + , aeNextTimer = 1 + } + +startExtension :: + Ptr () {- ^ client stable pointer -} -> + ExtensionConfiguration {- ^ extension configuration -} -> + ActiveExtension {- ^ active extension -} -> + IO (Ptr ()) {- ^ extension state -} +startExtension stab config ae = + do let f = fgnStart (aeFgn ae) + if nullFunPtr == f + then return nullPtr + else evalNestedIO $ do extPath <- nest1 (withCString (view extensionPath config)) args <- traverse withText $ view extensionArgs config argsArray <- nest1 (withArray args) let len = fromIntegral (length args) liftIO (runStartExtension f stab extPath argsArray len) - return $! ActiveExtension - { aeFgn = fgn - , aeDL = dl - , aeSession = s - , aeName = Text.pack name - , aeMajorVersion = fromIntegral (fgnMajorVersion fgn) - , aeMinorVersion = fromIntegral (fgnMinorVersion fgn) - } -- | Call the stop callback of the extension if it is defined -- and unload the shared object. @@ -108,72 +166,38 @@ dlclose (aeDL ae) --- | Call all of the process message callbacks in the list of extensions. +-- | 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. -notifyExtensions :: - Ptr () {- ^ clientstate stable pointer -} -> - Text {- ^ network -} -> - RawIrcMsg {- ^ current message -} -> - [ActiveExtension] {- ^ all active extensions -} -> - IO Bool {- ^ should pass message -} -notifyExtensions stab network msg aes - | null aes' = return True - | otherwise = doNotifications - where - -- only the extensions that have a incoming message callback - 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) - - -- run handlers until one of them drops the message - 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 () {- ^ client callback handle -} -> + ActiveExtension {- ^ extension -} -> + Ptr FgnChat {- ^ serialized chat message -} -> + IO Bool {- ^ allow message -} +chatExtension stab ae chat = + do let f = fgnChat (aeFgn ae) + if f == nullFunPtr + then return True + else (passMessage ==) <$> runProcessChat f stab (aeSession ae) chat --- | Call all of the process chat callbacks in the list of extensions. +-- | 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. -chatExtension :: - Ptr () {- ^ clientstate stable pointer -} -> - Text {- ^ network -} -> - Text {- ^ target (channel or user) -} -> - Text {- ^ message body -} -> - [ActiveExtension] {- ^ all active extensions -} -> - IO Bool {- ^ should pass message -} -chatExtension stab net tgt msg aes - | null aes' = return True - | otherwise = doNotifications - where - -- only the extensions that have a chat callback - 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) +notifyExtension :: + Ptr () {- ^ clientstate stable pointer -} -> + ActiveExtension {- ^ extension -} -> + Ptr FgnMsg {- ^ serialized IRC message -} -> + IO Bool {- ^ allow message -} +notifyExtension stab ae msg = + do let f = fgnMessage (aeFgn ae) + if f == nullFunPtr + then return True + else (passMessage ==) <$> runProcessMessage f stab (aeSession ae) msg - -- run handlers until one of them drops the message - 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 -- | Notify an extension of a client command with the given parameters. commandExtension :: diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs --- a/src/Client/CApi/Exports.hs +++ b/src/Client/CApi/Exports.hs @@ -37,6 +37,12 @@ , Glirc_user_channel_modes , glirc_user_channel_modes + , Glirc_channel_modes + , glirc_channel_modes + + , Glirc_channel_masks + , glirc_channel_masks + , Glirc_identifier_cmp , glirc_identifier_cmp @@ -55,6 +61,9 @@ , Glirc_current_focus , glirc_current_focus + , Glirc_set_focus + , glirc_set_focus + , Glirc_free_string , glirc_free_string @@ -67,8 +76,15 @@ , Glirc_resolve_path , glirc_resolve_path + , Glirc_set_timer + , glirc_set_timer + + , Glirc_cancel_timer + , glirc_cancel_timer + ) where +import Client.CApi (cancelTimer, pushTimer) import Client.CApi.Types import Client.Configuration import Client.Message @@ -81,7 +97,9 @@ import Control.Exception import Control.Lens import Control.Monad (unless) +import Data.Char (chr) import Data.Foldable (traverse_) +import qualified Data.Map as Map import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Data.Text as Text @@ -101,7 +119,7 @@ ------------------------------------------------------------------------ -- | Dereference the stable pointer passed to extension callbacks -derefToken :: Ptr () -> IO (MVar ClientState) +derefToken :: Ptr () -> IO (MVar (Int, ClientState)) derefToken = deRefStablePtr . castPtrToStablePtr @@ -153,11 +171,10 @@ fgn <- peek msgPtr msg <- peekFgnMsg fgn network <- peekFgnStringLen (fmNetwork fgn) - withMVar mvar $ \st -> - case preview (clientConnection network) st of - Nothing -> return 1 - Just cs -> do sendMsg cs msg - return 0 + (_,st) <- readMVar mvar + case preview (clientConnection network) st of + Nothing -> return 1 + Just cs -> 0 <$ sendMsg cs msg `catch` \SomeException{} -> return 1 ------------------------------------------------------------------------ @@ -186,8 +203,8 @@ , _msgTime = now , _msgNetwork = Text.empty } - modifyMVar_ mvar $ \st -> - do return (recordNetworkMessage msg st) + modifyMVar_ mvar $ \(i,st) -> + do return (i, recordNetworkMessage msg st) return 0 `catch` \SomeException{} -> return 1 @@ -224,8 +241,8 @@ , _msgTime = now , _msgNetwork = net } - modifyMVar_ mvar $ \st -> - do return (recordChannelMessage net tgt msg st) + modifyMVar_ mvar $ \(i, st) -> + do return (i, recordChannelMessage net tgt msg st) return 0 `catch` \SomeException{} -> return 1 @@ -243,7 +260,7 @@ glirc_list_networks :: Glirc_list_networks glirc_list_networks stab = do mvar <- derefToken stab - st <- readMVar mvar + (_,st) <- readMVar mvar let networks = views clientNetworkMap HashMap.keys st strs <- traverse (newCString . Text.unpack) networks newArray0 nullPtr strs @@ -286,7 +303,7 @@ glirc_list_channels :: Glirc_list_channels glirc_list_channels stab networkPtr networkLen = do mvar <- derefToken stab - st <- readMVar mvar + (_,st) <- readMVar mvar network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) case preview (clientConnection network . csChannels) st of Nothing -> return nullPtr @@ -311,8 +328,8 @@ -- @glirc_free_strings@. glirc_list_channel_users :: Glirc_list_channel_users glirc_list_channel_users stab networkPtr networkLen channelPtr channelLen = - do mvar <- derefToken stab - st <- readMVar mvar + do mvar <- derefToken stab + (_, st) <- readMVar mvar network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) channel <- peekFgnStringLen (FgnStringLen channelPtr channelLen) let mb = preview ( clientConnection network @@ -340,8 +357,8 @@ -- @glirc_free_string@. glirc_my_nick :: Glirc_my_nick glirc_my_nick stab networkPtr networkLen = - do mvar <- derefToken stab - st <- readMVar mvar + do mvar <- derefToken stab + (_,st) <- readMVar mvar network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) let mb = preview (clientConnection network . csNick) st case mb of @@ -366,7 +383,7 @@ glirc_user_account :: Glirc_user_account glirc_user_account stab networkPtr networkLen nickPtr nickLen = do mvar <- derefToken stab - st <- readMVar mvar + (_,st) <- readMVar mvar network <- peekFgnStringLen (FgnStringLen networkPtr networkLen) nick <- peekFgnStringLen (FgnStringLen nickPtr nickLen ) let mb = preview ( clientConnection network @@ -396,7 +413,7 @@ glirc_user_channel_modes :: Glirc_user_channel_modes glirc_user_channel_modes stab netPtr netLen chanPtr chanLen nickPtr nickLen = do mvar <- derefToken stab - st <- readMVar mvar + (_,st) <- readMVar mvar network <- peekFgnStringLen (FgnStringLen netPtr netLen) chan <- peekFgnStringLen (FgnStringLen chanPtr chanLen ) nick <- peekFgnStringLen (FgnStringLen nickPtr nickLen ) @@ -409,6 +426,79 @@ ------------------------------------------------------------------------ +-- | Type of 'glirc_channel_modes' extension entry-point +type Glirc_channel_modes = + Ptr () {- ^ api token -} -> + CString {- ^ network name -} -> + CSize {- ^ network name length -} -> + CString {- ^ channel -} -> + CSize {- ^ channel length -} -> + IO (Ptr CString) + +-- | Return all of the modes of a given channel. The first +-- letter of each string returned is the mode. Any remaining +-- characters are the mode argument. +-- Caller is responsible for freeing successful result with +-- @glirc_free_strings@. If the user is not on a channel @NULL@ +-- is returned. The modes might not be known to the client for +-- a particular channel which can result in an empty list of +-- modes being returned. +glirc_channel_modes :: Glirc_channel_modes +glirc_channel_modes stab netPtr netLen chanPtr chanLen = + do mvar <- derefToken stab + (_,st) <- readMVar mvar + network <- peekFgnStringLen (FgnStringLen netPtr netLen) + chan <- peekFgnStringLen (FgnStringLen chanPtr chanLen ) + let mb = preview ( clientConnection network + . csChannels . ix (mkId chan) + . chanModes + ) st + case mb of + Nothing -> return nullPtr + Just modeMap -> + do let strings = [ mode : Text.unpack arg | (mode,arg) <- Map.toList modeMap ] + strs <- traverse newCString strings + newArray0 nullPtr strs + +------------------------------------------------------------------------ + +-- | Type of 'glirc_channel_masks' extension entry-point +type Glirc_channel_masks = + Ptr () {- ^ api token -} -> + CString {- ^ network name -} -> + CSize {- ^ network name length -} -> + CString {- ^ channel -} -> + CSize {- ^ channel length -} -> + CChar {- ^ mode -} -> + IO (Ptr CString) + +-- | Return all of the modes of a given channel. The first +-- letter of each string returned is the mode. Any remaining +-- characters are the mode argument. +-- Caller is responsible for freeing successful result with +-- @glirc_free_strings@. If the user is not on a channel @NULL@ +-- is returned. The modes might not be known to the client for +-- a particular channel which can result in an empty list of +-- modes being returned. +glirc_channel_masks :: Glirc_channel_masks +glirc_channel_masks stab netPtr netLen chanPtr chanLen cmode = + do let mode = chr (fromIntegral cmode) :: Char + mvar <- derefToken stab + (_,st) <- readMVar mvar + network <- peekFgnStringLen (FgnStringLen netPtr netLen) + chan <- peekFgnStringLen (FgnStringLen chanPtr chanLen ) + let mb = preview ( clientConnection network + . csChannels . ix (mkId chan) + . chanLists . ix mode + ) st + case mb of + Nothing -> return nullPtr + Just listMap -> + do strs <- traverse (newCString . Text.unpack) (HashMap.keys listMap) + newArray0 nullPtr strs + +------------------------------------------------------------------------ + -- | Type of 'glirc_mark_seen' extension entry-point type Glirc_mark_seen = Ptr () {- ^ api token -} -> @@ -432,8 +522,9 @@ | otherwise = ChannelFocus network (mkId channel) mvar <- derefToken stab - modifyMVar_ mvar $ \st -> - return $! overStrict (clientWindows . ix focus) windowSeen st + modifyMVar_ mvar $ \(i,st) -> + let st' = overStrict (clientWindows . ix focus) windowSeen st + in st' `seq` return (i,st') ------------------------------------------------------------------------ @@ -460,8 +551,9 @@ | otherwise = ChannelFocus network (mkId channel) mvar <- derefToken stab - modifyMVar_ mvar $ \st -> - return $! set (clientWindows . ix focus) emptyWindow st + modifyMVar_ mvar $ \(i,st) -> + let st' = set (clientWindows . ix focus) emptyWindow st + in st' `seq` return (i,st') ------------------------------------------------------------------------ @@ -494,11 +586,11 @@ -- | Type of 'glirc_current_focus' extension entry-point type Glirc_current_focus = - Ptr () {- ^ api token -} -> - Ptr CString {- ^ newly allocated network string -} -> - Ptr CSize {- ^ network length -} -> - Ptr CString {- ^ newly allocated target string -} -> - Ptr CSize {- ^ target length -} -> + Ptr () {- ^ api token -} -> + Ptr CString {- ^ OUT: newly allocated network string -} -> + Ptr CSize {- ^ OUT: network length -} -> + Ptr CString {- ^ OUT: newly allocated target string -} -> + Ptr CSize {- ^ OUT: target length -} -> IO () -- | Find the network and target identifier associated with the @@ -510,8 +602,8 @@ -- current target. glirc_current_focus :: Glirc_current_focus glirc_current_focus stab netP netL tgtP tgtL = - do mvar <- derefToken stab - st <- readMVar mvar + do mvar <- derefToken stab + (_,st) <- readMVar mvar let (net,tgt) = case view clientFocus st of Unfocused -> (Text.empty, Text.empty) NetworkFocus n -> (n , Text.empty) @@ -521,6 +613,39 @@ ------------------------------------------------------------------------ +-- | Type of 'glirc_set_focus' extension entry-point +type Glirc_set_focus = + Ptr () {- ^ api token -} -> + CString {- ^ network -} -> + CSize {- ^ network length -} -> + CString {- ^ target -} -> + CSize {- ^ target length -} -> + IO () + +-- | Assign window focus to a new value. +-- +-- Set to client window if network is empty. +-- +-- Set to network window if channel is empty. +-- +-- Set to chat window otherwise. +glirc_set_focus :: Glirc_set_focus +glirc_set_focus stab netP netL tgtP tgtL = + do mvar <- derefToken stab + net <- peekFgnStringLen (FgnStringLen netP netL) + tgt <- peekFgnStringLen (FgnStringLen tgtP tgtL) + + let focus + | Text.null net = Unfocused + | Text.null tgt = NetworkFocus net + | otherwise = ChannelFocus net (mkId tgt) + + modifyMVar_ mvar $ \(i,st) -> + let st' = changeFocus focus st + in st' `seq` return (i,st') + +------------------------------------------------------------------------ + -- | Type of 'glirc_is_channel' extension entry-point type Glirc_is_channel = Ptr () {- ^ api token -} -> @@ -537,7 +662,7 @@ glirc_is_channel :: Glirc_is_channel glirc_is_channel stab net netL tgt tgtL = do mvar <- derefToken stab - st <- readMVar mvar + (_,st) <- readMVar mvar network <- peekFgnStringLen (FgnStringLen net netL) target <- peekFgnStringLen (FgnStringLen tgt tgtL) @@ -563,7 +688,7 @@ glirc_is_logged_on :: Glirc_is_logged_on glirc_is_logged_on stab net netL tgt tgtL = do mvar <- derefToken stab - st <- readMVar mvar + (_,st) <- readMVar mvar network <- peekFgnStringLen (FgnStringLen net netL) target <- peekFgnStringLen (FgnStringLen tgt tgtL) @@ -587,9 +712,49 @@ glirc_resolve_path :: Glirc_resolve_path glirc_resolve_path stab pathP pathL = do mvar <- derefToken stab - st <- readMVar mvar + (_,st) <- readMVar mvar path <- peekFgnStringLen (FgnStringLen pathP pathL) let cfgPath = view clientConfigPath st cxt <- newFilePathContext cfgPath newCString (resolveFilePath cxt (Text.unpack path)) + +------------------------------------------------------------------------ + +-- | Type of 'glirc_set_timer' extension entry-point +type Glirc_set_timer = + Ptr () {- ^ api token -} -> + CULong {- ^ milliseconds delay -} -> + FunPtr TimerCallback {- ^ function -} -> + Ptr () {- ^ callback state -} -> + IO TimerId {- ^ timer ID -} + +-- | Register a function to be called after a given number of milliseconds +-- of delay. The returned timer ID can be used to cancel the timer. +glirc_set_timer :: Glirc_set_timer +glirc_set_timer stab millis fun ptr = + do mvar <- derefToken stab + time <- addUTCTime (fromIntegral millis / 1000) <$> getCurrentTime + modifyMVar mvar $ \(i,st) -> + let (timer,st') = st & clientExtensions . esActive . singular (ix i) + %%~ pushTimer time fun ptr + in st' `seq` return ((i,st'), fromIntegral timer) + +------------------------------------------------------------------------ + +-- | Type of 'glirc_cancel_timer' extension entry-point +type Glirc_cancel_timer = + Ptr () {- ^ api token -} -> + TimerId {- ^ timer ID -} -> + IO () + +-- | Register a function to be called after a given number of milliseconds +-- of delay. The returned timer ID can be used to cancel the timer. +glirc_cancel_timer :: Glirc_cancel_timer +glirc_cancel_timer stab timerId = + do mvar <- derefToken stab + modifyMVar_ mvar $ \(i,st) -> + let st' = overStrict (clientExtensions . esActive . singular (ix i)) + (cancelTimer (fromIntegral timerId)) + st + in st' `seq` return (i,st') diff --git a/src/Client/CApi/Types.hsc b/src/Client/CApi/Types.hsc --- a/src/Client/CApi/Types.hsc +++ b/src/Client/CApi/Types.hsc @@ -21,6 +21,8 @@ , ProcessMessage , ProcessCommand , ProcessChat + , TimerCallback + , TimerId -- * Strings , FgnStringLen(..) @@ -41,6 +43,7 @@ , runProcessMessage , runProcessCommand , runProcessChat + , runTimerCallback -- * report message codes , MessageCode(..), normalMessage, errorMessage @@ -58,6 +61,7 @@ import Data.Text (Text) import qualified Data.Text.Foreign as Text import Data.Word +import Data.Int import Foreign.C import Foreign.Marshal.Array import Foreign.Ptr @@ -128,6 +132,17 @@ Ptr FgnChat {- ^ chat info -} -> IO ProcessResult +-- | Integer type of timer IDs +type TimerId = #type timer_id + +-- | Callback function when timer triggers +type TimerCallback = + Ptr () {- ^ api token -} -> + Ptr () {- ^ extension state -} -> + Ptr () {- ^ timer state -} -> + TimerId {- ^ timer ID -} -> + IO () + -- | Type of dynamic function pointer wrappers. These convert C -- function-pointers into Haskell functions. type Dynamic a = FunPtr a -> a @@ -142,6 +157,8 @@ foreign import ccall "dynamic" runProcessCommand :: Dynamic ProcessCommand -- | Dynamic import for 'ProcessChat'. foreign import ccall "dynamic" runProcessChat :: Dynamic ProcessChat +-- | Dynamic import for timer callback +foreign import ccall "dynamic" runTimerCallback :: Dynamic TimerCallback ------------------------------------------------------------------------ diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -25,7 +25,6 @@ , commandsList ) where -import Client.CApi import Client.Commands.Arguments.Spec import Client.Commands.Arguments.Parser import Client.Commands.Exec @@ -38,6 +37,7 @@ import Client.State import Client.State.Channel import qualified Client.State.EditBox as Edit +import Client.State.Extensions import Client.State.Focus import Client.State.Network import Client.State.Window @@ -231,9 +231,7 @@ let msgTxt = Text.pack $ takeWhile (/='\n') msg tgtTxt = idText channel - (st1,allow) <- clientPark st $ \ptr -> - do let aes = view (clientExtensions . esActive) st - chatExtension ptr network tgtTxt msgTxt aes + (st1,allow) <- clientChatExtension network tgtTxt msgTxt st when allow (sendMsg cs (ircPrivmsg tgtTxt msgTxt)) @@ -2178,13 +2176,10 @@ cmdExtension :: ClientCommand (String, String) cmdExtension st (name,command) = - case find (\ae -> aeName ae == Text.pack name) - (view (clientExtensions . esActive) st) of - Nothing -> commandFailureMsg "unknown extension" st - Just ae -> - do (st',_) <- clientPark st $ \ptr -> - commandExtension ptr (Text.pack command) ae - commandSuccess st' + do res <- clientCommandExtension (Text.pack name) (Text.pack command) st + case res of + Nothing -> commandFailureMsg "unknown extension" st + Just st' -> commandSuccess st' -- | Implementation of @/exec@ command. cmdExec :: ClientCommand String diff --git a/src/Client/Commands/Recognizer.hs b/src/Client/Commands/Recognizer.hs --- a/src/Client/Commands/Recognizer.hs +++ b/src/Client/Commands/Recognizer.hs @@ -39,7 +39,6 @@ instance Monoid (Recognizer a) where mempty = Branch "" Nothing empty - mappend = both instance Semigroup (Recognizer a) where (<>) = both diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -17,7 +17,7 @@ ) where import qualified Client.Authentication.Ecdsa as Ecdsa -import Client.CApi +import Client.CApi (popTimer) import Client.Commands import Client.Commands.Interpolation import Client.Configuration (configJumpModifier, configKeyMap, configWindowNames) @@ -33,6 +33,7 @@ import Client.Network.Async import Client.State import qualified Client.State.EditBox as Edit +import Client.State.Extensions import Client.State.Focus import Client.State.Network import Control.Concurrent.STM @@ -64,6 +65,7 @@ = VtyEvent Event -- ^ Key presses and resizing | NetworkEvent NetworkEvent -- ^ Incoming network events | TimerEvent NetworkId TimedAction -- ^ Timed action and the applicable network + | ExtTimerEvent Int -- ^ extension ID -- | Block waiting for the next 'ClientEvent'. This function will compute @@ -85,21 +87,37 @@ prepareTimer = case earliestEvent st of Nothing -> return retry - Just (networkId,(runAt,action)) -> + Just (runAt,event) -> do now <- getCurrentTime let microsecs = truncate (1000000 * diffUTCTime runAt now) var <- registerDelay (max 0 microsecs) return $ do ready <- readTVar var unless ready retry - return (TimerEvent networkId action) + return event -- | Compute the earliest scheduled timed action for the client -earliestEvent :: ClientState -> Maybe (NetworkId, (UTCTime, TimedAction)) -earliestEvent = - minimumByOf - (clientConnections . (ifolded <. folding nextTimedAction) . withIndex) - (comparing (fst . snd)) +earliestEvent :: ClientState -> Maybe (UTCTime, ClientEvent) +earliestEvent st = earliest2 networkEvent extensionEvent + where + earliest2 (Just (time1, action1)) (Just (time2, action2)) + | time1 < time2 = Just (time1, action1) + | otherwise = Just (time2, action2) + earliest2 x y = mplus x y + mkEventN (network, (time, action)) = (time, TimerEvent network action) + networkEvent = + minimumByOf + (clientConnections . (ifolded <. folding nextTimedAction) . withIndex . to mkEventN) + (comparing fst) + st + + mkEventE (i, (time,_,_,_,_)) = (time, ExtTimerEvent i) + extensionEvent = + minimumByOf + (clientExtensions . esActive . (ifolded <. folding popTimer) . withIndex . to mkEventE) + (comparing fst) + st + -- | Apply this function to an initial 'ClientState' to launch the client. eventLoop :: Vty -> ClientState -> IO () eventLoop vty st = @@ -111,6 +129,7 @@ event <- getEvent vty st' case event of + ExtTimerEvent i -> eventLoop vty =<< clientExtTimer i st' TimerEvent networkId action -> eventLoop vty =<< doTimerEvent networkId action st' VtyEvent vtyEvent -> traverse_ (eventLoop vty) =<< doVtyEvent vty vtyEvent st' NetworkEvent networkEvent -> @@ -232,10 +251,7 @@ return $! recordError time cs msg st Just raw -> - do (st1,passed) <- clientPark st $ \ptr -> - notifyExtensions ptr network raw - (view (clientExtensions . esActive) st) - + do (st1,passed) <- clientNotifyExtensions network raw st if not passed then return st1 else do @@ -504,6 +520,12 @@ CommandQuit st -> Nothing <$ clientShutdown st CommandSuccess st -> continue (if clearOnSuccess then consumeInput st else st) CommandFailure st -> continue (set clientBell True st) + + +-- | Actions to be run when exiting the client. +clientShutdown :: ClientState -> IO () +clientShutdown st = () <$ clientStopExtensions st + -- other shutdown stuff might be added here later -- | Execute the the command on the first line of the text box diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -48,9 +48,6 @@ -- * Client operations , withClientState - , clientStartExtensions - , clientShutdown - , clientPark , clientMatcher , clientMatcher' , clientActiveRegex @@ -99,6 +96,8 @@ -- * Extensions , ExtensionState , esActive + , esMVar + , esStablePtr -- * URL view , urlPattern @@ -128,7 +127,6 @@ import Control.Lens import Control.Monad import Data.Foldable -import Data.Either import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) @@ -143,7 +141,6 @@ import qualified Data.Text as Text import qualified Data.Text.Lazy as LText import Data.Time -import Foreign.Ptr import Foreign.StablePtr import Irc.Codes import Irc.Identifier @@ -197,29 +194,21 @@ -- | State of the extension API including loaded extensions and the mechanism used -- to support reentry into the Haskell runtime from the C API. +-- +-- When executing inside an extension the mvar will contain the client state +-- and the ID of the running extension. data ExtensionState = ExtensionState - { _esActive :: [ActiveExtension] -- ^ active extensions - , _esMVar :: MVar ClientState -- ^ 'MVar' used to with 'clientPark' - , _esStablePtr :: StablePtr (MVar ClientState) -- ^ 'StablePtr' used with 'clientPark' + { _esActive :: IntMap ActiveExtension -- ^ active extensions + , _esMVar :: MVar ParkState -- ^ 'MVar' used to with 'clientPark' + , _esStablePtr :: StablePtr (MVar ParkState) -- ^ 'StablePtr' used with 'clientPark' } +-- | ID of active extension and stored client state +type ParkState = (Int,ClientState) + makeLenses ''ClientState makeLenses ''ExtensionState - --- | Prepare the client to support reentry from the extension API. -clientPark :: - ClientState {- ^ client state -} -> - (Ptr () -> IO a) {- ^ continuation using the stable pointer to the client -} -> - IO (ClientState, a) -clientPark st k = - do let mvar = view (clientExtensions . esMVar) st - putMVar mvar st - let token = views (clientExtensions . esStablePtr) castStablePtrToPtr st - res <- k token - st' <- takeMVar mvar - return (st', res) - -- | 'Traversal' for finding the 'NetworkState' associated with a given network -- if that connection is currently active. clientConnection :: @@ -283,7 +272,7 @@ do mvar <- newEmptyMVar bracket (newStablePtr mvar) freeStablePtr $ \stab -> k ExtensionState - { _esActive = [] + { _esActive = IntMap.empty , _esMVar = mvar , _esStablePtr = stab } @@ -670,7 +659,8 @@ defaultCompOpt defaultExecOpt{captureGroups=False} "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:cntrl:][:space:]]*)|\ - \]*>" + \]*>|\ + \\\(https?://[^\\)]*\\)" -- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable @@ -686,6 +676,7 @@ removeBrackets t = case Text.uncons t of Just ('<',t') | not (Text.null t') -> Text.init t' + Just ('(',t') | not (Text.null t') -> Text.init t' _ -> t -- | Remove a network connection and unlink it from the network map. @@ -789,45 +780,6 @@ applyWindowRenames _ _ st = st - --- | Actions to be run when exiting the client. -clientShutdown :: ClientState -> IO () -clientShutdown st = () <$ clientStopExtensions st - -- other shutdown stuff might be added here later - - --- | Unload all active extensions. -clientStopExtensions :: ClientState -> IO ClientState -clientStopExtensions st = - do let (aes,st1) = (clientExtensions . esActive <<.~ []) st - (st2,_) <- clientPark st1 $ \ptr -> - traverse_ (deactivateExtension ptr) aes - return st2 - --- | Start extensions after ensuring existing ones are stopped -clientStartExtensions :: ClientState -> IO ClientState -clientStartExtensions st = - do let cfg = view clientConfig st - st1 <- clientStopExtensions st - (st2, res) <- clientPark st1 $ \ptr -> - traverse (try . activateExtension ptr) - (view configExtensions cfg) - - let (errors, exts) = partitionEithers res - st3 <- recordErrors errors st2 - return $! set (clientExtensions . esActive) exts st3 - where - recordErrors [] ste = return ste - recordErrors es ste = - do now <- getZonedTime - return $! foldl' (recordError now) ste es - - recordError now ste e = - recordNetworkMessage ClientMessage - { _msgTime = now - , _msgBody = ErrorBody (Text.pack (show (e :: IOError))) - , _msgNetwork = "" - } ste ------------------------------------------------------------------------ -- Scrolling diff --git a/src/Client/State/Extensions.hs b/src/Client/State/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Client/State/Extensions.hs @@ -0,0 +1,195 @@ +{-# Language OverloadedStrings #-} +{-| +Module : Client.State.Extensions +Description : Integration between the client and external extensions +Copyright : (c) Eric Mertens, 2018 +License : ISC +Maintainer : emertens@gmail.com + +This module implements the interaction between the client and its extensions. +This includes aspects of the extension system that depend on the current client +state. +-} +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 + +-- | Start extensions after ensuring existing ones are stopped +clientStartExtensions :: + ClientState {- ^ client state -} -> + IO ClientState {- ^ client state with new extensions -} +clientStartExtensions st = + do let cfg = view clientConfig st + st1 <- clientStopExtensions st + foldM start1 st1 (view configExtensions cfg) + +-- | Start a single extension and register it with the client or +-- record the error message. +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 -> + -- allocate a new identity for this extension + 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 + + -- save handle back into active extension + return $! st2 & clientExtensions . esActive . ix i %~ \ae' -> + ae' { aeSession = h } + + + +-- | Unload all active extensions. +clientStopExtensions :: + ClientState {- ^ client state -} -> + IO ClientState {- ^ client state with extensions unloaded -} +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 + + +-- | Dispatch chat messages through extensions before sending to server. +clientChatExtension :: + Text {- ^ network -} -> + Text {- ^ target -} -> + Text {- ^ message -} -> + ClientState {- ^ client state, allow message -} -> + 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 {- ^ serialized chat message -} -> + ClientState {- ^ client state -} -> + [(Int,ActiveExtension)] {- ^ extensions needing callback -} -> + IO (ClientState, Bool) {- ^ new state and allow -} +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) + + +-- | Dispatch incoming IRC message through extensions +clientNotifyExtensions :: + Text {- ^ network -} -> + RawIrcMsg {- ^ incoming message -} -> + ClientState {- ^ client state -} -> + IO (ClientState, Bool) {- ^ drop message when false -} +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 {- ^ serialized IRC message -} -> + ClientState {- ^ client state -} -> + [(Int,ActiveExtension)] {- ^ extensions needing callback -} -> + IO (ClientState, Bool) {- ^ new state and allow -} +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) + + +-- | Dispatch @/extension@ command to correct extension. Returns +-- 'Nothing' when no matching extension is available. +clientCommandExtension :: + Text {- ^ extension name -} -> + Text {- ^ command -} -> + ClientState {- ^ client state -} -> + IO (Maybe ClientState) {- ^ new client state on success -} +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') + + +-- | Prepare the client to support reentry from the extension API. +clientPark :: + Int {- ^ extension ID -} -> + ClientState {- ^ client state -} -> + (Ptr () -> IO a) {- ^ continuation using the stable pointer to the client -} -> + 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) + + +-- | Run the next available timer event on a particular extension. +clientExtTimer :: + Int {- ^ extension ID -} -> + ClientState {- ^ client state -} -> + 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