glirc 2.28 → 2.29
raw patch · 16 files changed
+605/−232 lines, 16 filesdep +psqueuesdep ~basedep ~networkdep ~stmsetup-changed
Dependencies added: psqueues
Dependency ranges changed: base, network, stm, template-haskell, vty
Files
- ChangeLog.md +4/−0
- Setup.hs +5/−32
- exec/Exports.hs +5/−0
- exec/Main.hs +2/−0
- exec/linux_exported_symbols.txt +5/−0
- exec/macos_exported_symbols.txt +5/−0
- glirc.cabal +10/−8
- include/glirc-api.h +8/−0
- src/Client/CApi.hs +97/−73
- src/Client/CApi/Exports.hs +197/−32
- src/Client/CApi/Types.hsc +17/−0
- src/Client/Commands.hs +6/−11
- src/Client/Commands/Recognizer.hs +0/−1
- src/Client/EventLoop.hs +34/−12
- src/Client/State.hs +15/−63
- src/Client/State/Extensions.hs +195/−0
ChangeLog.md view
@@ -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
Setup.hs view
@@ -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
exec/Exports.hs view
@@ -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
exec/Main.hs view
@@ -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 ()
exec/linux_exported_symbols.txt view
@@ -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; };
exec/macos_exported_symbols.txt view
@@ -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
glirc.cabal view
@@ -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
include/glirc-api.h view
@@ -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 **);
src/Client/CApi.hs view
@@ -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 ::
src/Client/CApi/Exports.hs view
@@ -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')
src/Client/CApi/Types.hsc view
@@ -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 ------------------------------------------------------------------------
src/Client/Commands.hs view
@@ -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
src/Client/Commands/Recognizer.hs view
@@ -39,7 +39,6 @@ instance Monoid (Recognizer a) where mempty = Branch "" Nothing empty- mappend = both instance Semigroup (Recognizer a) where (<>) = both
src/Client/EventLoop.hs view
@@ -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
src/Client/State.hs view
@@ -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?://[^>]*>"+ \<https?://[^>]*>|\+ \\\(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
+ src/Client/State/Extensions.hs view
@@ -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