diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for glirc2 +## 2.9 + +* Dynamically loadable extensions +* Implement Lua scripting extension +* Enable support for batch messages +* Grow metadata lines to the right + ## 2.8 * Support `vty-5.8` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -82,12 +82,13 @@ hostname: "example.com" port: 7000 connect-cmds: - * "JOIN #favoritechannel,#otherchannel" - * "PRIVMSG mybot :another command" + * "join #favoritechannel,#otherchannel" + * "msg mybot another command" -- Specify additional certificates beyond the system CAs + -- relative to home directory server-certificates: - * "/path/to/extra/certificate.pem" + * "extra/certificate.pem" macros: * name: "wipe" @@ -95,6 +96,11 @@ * "clear" * "znc *status clearbuffer $channel" + -- Example use of macro in combination with an extension + * name: "extra" + commands: + * "extension Lua some-parameter $network $channel" + palette: time: fg: [10,10,10] -- RGB values for color for timestamps @@ -119,6 +125,7 @@ * `palette` - Client color overrides * `window-names` - text - Names of windows (typically overridden on non QWERTY layouts) * `nick-padding` - nonnegative integer - Nicks are padded until they have the specified length +* `extensions` - list of text - Filenames of extension to load Settings -------- @@ -136,7 +143,7 @@ * `tls-insecure` - yes/no - disable certificate validation * `tls-client-cert` - text - path to TLS client certificate * `tls-client-key` - text - path to TLS client key -* `connect-cmds` - list of text - raw IRC commands to send upon connection +* `connect-cmds` - list of text - client commands to send upon connection * `socks-host` - text - hostname of SOCKS proxy to connect through * `socks-port` - number - port number of SOCKS proxy to connect through * `server-certificates` - list of text - list of CA certificates to use when validating certificates @@ -198,6 +205,7 @@ * `/reconnect` - Reconnect to the current server * `/reload` - Reload the previous configuration file (not retroactive!) * `/reload ` - Load a new configuration file +* `/extension ` - Send the given params to the named extension Connection commands @@ -309,8 +317,8 @@ * `name` - text - name of macro * `commands` - list of text - commands to send after expansion -Expansions ----------- +Macro Expansions +---------------- Variable names and integer indexes can be used when defining commands. Variables are specified with a leading `$`. For disambiguation a variable diff --git a/exported_symbols.txt b/exported_symbols.txt new file mode 100644 --- /dev/null +++ b/exported_symbols.txt @@ -0,0 +1,9 @@ +{ +glirc_send_message; +glirc_print; +glirc_identifier_cmp; +glirc_list_networks; +glirc_list_channels; +glirc_list_channel_users; +glirc_my_nick; +}; diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.8 +version: 2.9 synopsis: Console IRC client description: Console IRC client license: ISC @@ -9,7 +9,7 @@ copyright: 2016 Eric Mertens category: Network build-type: Custom -extra-source-files: ChangeLog.md README.md +extra-source-files: ChangeLog.md README.md exported_symbols.txt cabal-version: >=1.23 homepage: https://github.com/glguy/irc-core bug-reports: https://github.com/glguy/irc-core/issues @@ -30,12 +30,17 @@ Client.CommandArguments Client.Commands Client.Commands.Interpolation + Client.Commands.WordCompletion Client.Configuration Client.Configuration.Colors - Client.Connect + Client.Configuration.ServerSettings Client.ConnectionState Client.EditBox Client.EventLoop + Client.CApi.Exports + Client.CApi.Types + Client.CApi + Client.Focus Client.Hook Client.Hooks Client.Hook.Znc.Buffextras @@ -43,20 +48,21 @@ Client.Image.ChannelInfo Client.Image.MaskList Client.Image.Message + Client.Image.MircFormatting Client.Image.Palette Client.Image.UserList Client.Message - Client.MircFormatting - Client.NetworkConnection - Client.ServerSettings + Client.Network.Connect + Client.Network.Async Client.State Client.Window - Client.WordCompletion Config.FromConfig LensUtils StrictUnit Paths_glirc + build-tools: hsc2hs + build-depends: base >=4.9 && <4.10, async >=2.1 && < 2.2, attoparsec >=0.13 && <0.14, @@ -70,7 +76,7 @@ filepath >=1.4.1 && <1.5, gitrev >=1.2 && <1.3, hashable >=1.2.4 && <1.3, - irc-core >=2.0 && <2.1, + irc-core >=2.1 && <2.2, lens >=4.14 && <4.15, network >=2.6.2 && <2.7, split >=0.2 && <0.3, @@ -81,6 +87,7 @@ time >=1.6 && <1.7, tls >=1.3.8 && <1.4, transformers >=0.5.2 && <0.6, + unix >=2.7 && <2.8, unordered-containers >=0.2.7 && <0.3, vector >=0.11 && <0.12, vty >=5.8 && <5.9, @@ -90,4 +97,10 @@ ghc-options: -threaded -rtsopts hs-source-dirs: src + include-dirs: include + includes: include/glirc-api.h + install-includes: include/glirc-api.h default-language: Haskell2010 + + if os(Linux) + ld-options: -Wl,--dynamic-list=exported_symbols.txt diff --git a/src/Client/CApi.hs b/src/Client/CApi.hs new file mode 100644 --- /dev/null +++ b/src/Client/CApi.hs @@ -0,0 +1,186 @@ +{-# Language RecordWildCards #-} +{-| +Module : Client.CApi +Description : Dynamically loaded extension API +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +Foreign interface to the IRC client via a simple C API +and dynamically loaded modules. + +-} + +module Client.CApi + ( ActiveExtension(..) + , extensionSymbol + , activateExtension + , deactivateExtension + , notifyExtensions + , commandExtension + , withStableMVar + ) where + +import Client.CApi.Types +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont +import Data.Foldable +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Foreign as Text +import Foreign.C +import Foreign.Marshal +import Foreign.Ptr +import Foreign.StablePtr +import Foreign.Storable +import Irc.Identifier +import Irc.RawIrcMsg +import Irc.UserInfo +import System.Posix.DynamicLinker + +------------------------------------------------------------------------ + +-- | The symbol that is loaded from an extension object. +-- +-- Extensions are expected to export: +-- +-- @ +-- struct galua_extension extension; +-- @ +extensionSymbol :: String +extensionSymbol = "extension" + +-- | Information about a loaded extension including the handle +-- to the loaded shared object, and state value returned by +-- the startup callback, and the loaded extension record. +data ActiveExtension = ActiveExtension + { aeFgn :: !FgnExtension -- ^ Struct of callback function pointers + , aeDL :: !DL -- ^ Handle of dynamically linked extension + , aeSession :: !(Ptr ()) -- ^ State value generated by start callback + , aeName :: !Text + , aeMajorVersion, aeMinorVersion :: !Int + } + +-- | 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 () -> + FilePath {- ^ path to extension -} -> + IO ActiveExtension +activateExtension stab path = + do dl <- dlopen path [RTLD_NOW, RTLD_LOCAL] + p <- dlsym dl extensionSymbol + fgn <- peek (castFunPtrToPtr p) + name <- peekCString (fgnName fgn) + let f = fgnStart fgn + s <- if nullFunPtr == f + then return nullPtr + else withCString path (runStartExtension f stab) + return $! ActiveExtension + { aeFgn = fgn + , aeDL = dl + , aeSession = s + , aeName = Text.pack name + , aeMajorVersion = fromIntegral (fgnMajorVersion fgn) + , aeMinorVersion = fromIntegral (fgnMinorVersion fgn) + } + +-- | Call the stop callback of the extension if it is defined +-- and unload the shared object. +deactivateExtension :: Ptr () -> ActiveExtension -> IO () +deactivateExtension stab ae = + do let f = fgnStop (aeFgn ae) + unless (nullFunPtr == f) $ + (runStopExtension f stab (aeSession ae)) + dlclose (aeDL ae) + +-- | 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. +notifyExtensions :: + Ptr () {- ^ clientstate stable pointer -} -> + Text {- ^ network -} -> + RawIrcMsg {- ^ current message -} -> + [ActiveExtension] -> + IO () +notifyExtensions stab network msg aes + | null aes' = return () + | otherwise = evalContT doNotifications + where + aes' = [ (f,s) | ae <- aes + , let f = fgnMessage (aeFgn ae) + s = aeSession ae + , f /= nullFunPtr ] + + doNotifications :: ContT () IO () + doNotifications = + do msgPtr <- withRawIrcMsg network msg + (f,s) <- ContT $ for_ aes' + lift $ runProcessMessage f stab s msgPtr + +commandExtension :: + Ptr () {- ^ client state stableptr -} -> + [Text] {- ^ parameters -} -> + ActiveExtension {- ^ extension to command -} -> + IO () +commandExtension stab params ae = evalContT $ + do cmd <- withCommand params + let f = fgnCommand (aeFgn ae) + lift $ unless (f == nullFunPtr) + $ runProcessCommand f stab (aeSession ae) cmd + +-- | Create a 'StablePtr' around a 'MVar' which will be valid for the remainder +-- of the computation. +withStableMVar :: a -> (Ptr () -> IO b) -> IO (a,b) +withStableMVar x k = + do mvar <- newMVar x + res <- bracket (newStablePtr mvar) freeStablePtr (k . castStablePtrToPtr) + x' <- takeMVar mvar + return (x', res) + +-- | Marshal a 'RawIrcMsg' into a 'FgnMsg' which will be valid for +-- the remainder of the computation. +withRawIrcMsg :: + Text {- ^ network -} -> + RawIrcMsg {- ^ message -} -> + ContT a IO (Ptr FgnMsg) +withRawIrcMsg network RawIrcMsg{..} = + do net <- withText network + pfxN <- withText $ maybe Text.empty (idText.userNick) _msgPrefix + pfxU <- withText $ maybe Text.empty userName _msgPrefix + pfxH <- withText $ maybe Text.empty userHost _msgPrefix + cmd <- withText _msgCommand + prms <- traverse withText _msgParams + tags <- traverse withTag _msgTags + let (keys,vals) = unzip tags + (tagN,keysPtr) <- contT2 $ withArrayLen keys + valsPtr <- ContT $ withArray vals + (prmN,prmPtr) <- contT2 $ withArrayLen prms + ContT $ with $ FgnMsg net pfxN pfxU pfxH cmd prmPtr (fromIntegral prmN) + keysPtr valsPtr (fromIntegral tagN) + +withCommand :: + [Text] {- ^ parameters -} -> + ContT a IO (Ptr FgnCmd) +withCommand params = + do prms <- traverse withText params + (prmN,prmPtr) <- contT2 $ withArrayLen prms + ContT $ with $ FgnCmd prmPtr (fromIntegral prmN) + +withTag :: TagEntry -> ContT a IO (FgnStringLen, FgnStringLen) +withTag (TagEntry k v) = + do pk <- withText k + pv <- withText v + return (pk,pv) + +withText :: Text -> ContT a IO FgnStringLen +withText txt = + do (ptr,len) <- ContT $ Text.withCStringLen txt + return $ FgnStringLen ptr $ fromIntegral len + +contT2 :: ((a -> b -> m c) -> m c) -> ContT c m (a,b) +contT2 f = ContT $ \g -> f $ curry g diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs new file mode 100644 --- /dev/null +++ b/src/Client/CApi/Exports.hs @@ -0,0 +1,247 @@ +{-# Language RecordWildCards #-} +{-| +Module : Client.CApi.Exports +Description : Foreign exports which expose functionality for extensions +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module exports the C functions that extensions can used to query the state +of the client. +-} +module Client.CApi.Exports + ( -- * Extension API types + Glirc_send_message + , Glirc_print + , Glirc_list_networks + , Glirc_list_channels + , Glirc_list_channel_users + , Glirc_my_nick + , Glirc_identifier_cmp + ) where + +import Client.CApi.Types +import Client.State +import Client.ChannelState +import Client.ConnectionState +import Client.Message +import Control.Concurrent.MVar +import Control.Exception +import Control.Lens +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Foreign as Text +import Data.Time +import Foreign.C +import Foreign.Marshal +import Foreign.Ptr +import Foreign.StablePtr +import Foreign.Storable +import Irc.Identifier +import Irc.RawIrcMsg +import Irc.UserInfo + +------------------------------------------------------------------------ + +-- | Dereference the stable pointer passed to extension callbacks +derefToken :: Ptr () -> IO (MVar ClientState) +derefToken = deRefStablePtr . castPtrToStablePtr + + +------------------------------------------------------------------------ + +-- | Import a 'FgnMsg' into an 'RawIrcMsg' +peekFgnMsg :: FgnMsg -> IO RawIrcMsg +peekFgnMsg FgnMsg{..} = + do let strArray n p = traverse peekFgnStringLen =<< + peekArray (fromIntegral n) p + + tagKeys <- strArray fmTagN fmTagKeys + tagVals <- strArray fmTagN fmTagVals + prefixN <- peekFgnStringLen fmPrefixNick + prefixU <- peekFgnStringLen fmPrefixUser + prefixH <- peekFgnStringLen fmPrefixHost + command <- peekFgnStringLen fmCommand + params <- strArray fmParamN fmParams + + return RawIrcMsg + { _msgTags = zipWith TagEntry tagKeys tagVals + , _msgPrefix = if Text.null prefixN + then Nothing + else Just (UserInfo (mkId prefixN) prefixU prefixH) + , _msgCommand = command + , _msgParams = params + } + +------------------------------------------------------------------------ + +-- | Peek a 'FgnStringLen' as UTF-8 encoded bytes. +peekFgnStringLen :: FgnStringLen -> IO Text +peekFgnStringLen (FgnStringLen ptr len) = + Text.peekCStringLen (ptr, fromIntegral len) + +------------------------------------------------------------------------ + +-- | Network, command, and parameters are used when transmitting a message. +type Glirc_send_message = + Ptr () {- ^ api token -} -> + Ptr FgnMsg {- ^ pointer to message -} -> + IO CInt {- ^ 0 on success -} + +foreign export ccall "glirc_send_message" capiSendMessage :: Glirc_send_message + +capiSendMessage :: Glirc_send_message +capiSendMessage token msgPtr = + do mvar <- derefToken token + 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 + `catch` \SomeException{} -> return 1 + +------------------------------------------------------------------------ + +type Glirc_print = + Ptr () {- ^ api token -} -> + CInt {- ^ enum message_code -} -> + CString {- ^ message -} -> + CSize {- ^ message length -} -> + IO CInt {- ^ 0 on success -} + +foreign export ccall glirc_print :: Glirc_print + +glirc_print :: Glirc_print +glirc_print stab code msgPtr msgLen = + do mvar <- derefToken stab + txt <- Text.peekCStringLen (msgPtr, fromIntegral msgLen) + now <- getZonedTime + + let con | code == normalMessageCode = NormalBody + | otherwise = ErrorBody + msg = ClientMessage + { _msgBody = con txt + , _msgTime = now + , _msgNetwork = Text.empty + } + modifyMVar_ mvar $ \st -> + do return (recordNetworkMessage msg st) + return 0 + `catch` \SomeException{} -> return 1 + +------------------------------------------------------------------------ + +-- | The resulting strings and array of strings are malloc'd and the +-- caller must free them. NULL returned on failure. +type Glirc_list_networks = + Ptr () {- ^ api token -} -> + IO (Ptr CString) {- ^ null terminated array of null terminated strings -} + +foreign export ccall glirc_list_networks :: Glirc_list_networks + +glirc_list_networks :: Glirc_list_networks +glirc_list_networks stab = + do mvar <- derefToken stab + st <- readMVar mvar + let networks = views clientNetworkMap HashMap.keys st + strs <- traverse (newCString . Text.unpack) networks + newArray0 nullPtr strs + +------------------------------------------------------------------------ + +type Glirc_identifier_cmp = + CString {- ^ identifier 1 -} -> + CSize {- ^ identifier 1 len -} -> + CString {- ^ identifier 2 -} -> + CSize {- ^ identifier 2 len -} -> + IO CInt + +foreign export ccall glirc_identifier_cmp :: Glirc_identifier_cmp + +glirc_identifier_cmp :: Glirc_identifier_cmp +glirc_identifier_cmp p1 n1 p2 n2 = + do txt1 <- Text.peekCStringLen (p1, fromIntegral n1) + txt2 <- Text.peekCStringLen (p2, fromIntegral n2) + return $! case compare (mkId txt1) (mkId txt2) of + LT -> -1 + EQ -> 0 + GT -> 1 + +------------------------------------------------------------------------ + +-- | The resulting strings and array of strings are malloc'd and the +-- caller must free them. NULL returned on failure. +type Glirc_list_channels = + Ptr () {- ^ api token -} -> + CString {- ^ network -} -> + CSize {- ^ network len -} -> + IO (Ptr CString) {- ^ null terminated array of null terminated strings -} + +foreign export ccall glirc_list_channels :: Glirc_list_channels + +glirc_list_channels :: Glirc_list_channels +glirc_list_channels stab networkPtr networkLen = + do mvar <- derefToken stab + st <- readMVar mvar + network <- Text.peekCStringLen (networkPtr, fromIntegral networkLen) + case preview (clientConnection network . csChannels) st of + Nothing -> return nullPtr + Just m -> + do strs <- traverse (newCString . Text.unpack . idText) (HashMap.keys m) + newArray0 nullPtr strs + +------------------------------------------------------------------------ + +-- | The resulting strings and array of strings are malloc'd and the +-- caller must free them. NULL returned on failure. +type Glirc_list_channel_users = + Ptr () {- ^ api token -} -> + CString {- ^ network -} -> + CSize {- ^ network len -} -> + CString {- ^ channel -} -> + CSize {- ^ channel len -} -> + IO (Ptr CString) {- ^ null terminated array of null terminated strings -} + +foreign export ccall glirc_list_channel_users :: Glirc_list_channel_users + +glirc_list_channel_users :: Glirc_list_channel_users +glirc_list_channel_users stab networkPtr networkLen channelPtr channelLen = + do mvar <- derefToken stab + st <- readMVar mvar + network <- Text.peekCStringLen (networkPtr, fromIntegral networkLen) + channel <- Text.peekCStringLen (channelPtr, fromIntegral channelLen) + let mb = preview ( clientConnection network + . csChannels . ix (mkId channel) + . chanUsers + ) st + case mb of + Nothing -> return nullPtr + Just m -> + do strs <- traverse (newCString . Text.unpack . idText) (HashMap.keys m) + newArray0 nullPtr strs + +------------------------------------------------------------------------ + +-- | The resulting string is malloc'd and the caller must free it. +-- NULL returned on failure. +type Glirc_my_nick = + Ptr () {- ^ api token -} -> + CString {- ^ network name -} -> + CSize {- ^ network name length -} -> + IO CString + +foreign export ccall glirc_my_nick :: Glirc_my_nick + +glirc_my_nick :: Glirc_my_nick +glirc_my_nick stab networkPtr networkLen = + do mvar <- derefToken stab + st <- readMVar mvar + network <- Text.peekCStringLen (networkPtr, fromIntegral networkLen) + let mb = preview (clientConnection network . csNick) st + case mb of + Nothing -> return nullPtr + Just me -> newCString (Text.unpack (idText me)) diff --git a/src/Client/CApi/Types.hsc b/src/Client/CApi/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Client/CApi/Types.hsc @@ -0,0 +1,192 @@ +{-# Language ForeignFunctionInterface, RecordWildCards #-} + +{-| +Module : Client.CApi.Types +Description : Marshaling support for C API +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +Marshaling types and functions for the C API + +-} + +#include "glirc-api.h" + +module Client.CApi.Types + ( -- * Extension record + FgnExtension(..) + , StartExtension + , StopExtension + , ProcessMessage + , ProcessCommand + + -- * Strings + , FgnStringLen(..) + + -- * Messages + , FgnMsg(..) + + -- * Commands + , FgnCmd(..) + + -- * Function pointer calling + , Dynamic + , runStartExtension + , runStopExtension + , runProcessMessage + , runProcessCommand + + -- * report message codes + , normalMessageCode + , errorMessageCode + ) where + +import Foreign.C +import Foreign.Ptr +import Foreign.Storable + +normalMessageCode :: CInt +normalMessageCode = #const NORMAL_MESSAGE + +errorMessageCode :: CInt +errorMessageCode = #const ERROR_MESSAGE + +type StartExtension = + Ptr () {- ^ api token -} -> + CString {- ^ path to extension -} -> + IO (Ptr ()) {- ^ initialized extension state -} + +type StopExtension = + Ptr () {- ^ api token -} -> + Ptr () {- ^ extension state -} -> + IO () + +type ProcessMessage = + Ptr () {- ^ api token -} -> + Ptr () {- ^ extention state -} -> + Ptr FgnMsg {- ^ message to send -} -> + IO () + +type ProcessCommand = + Ptr () {- ^ api token -} -> + Ptr () {- ^ extension state -} -> + Ptr FgnCmd {- ^ command -} -> + IO () + +-- | Type of dynamic function pointer wrappers. +type Dynamic a = FunPtr a -> a + +foreign import ccall "dynamic" runStartExtension :: Dynamic StartExtension +foreign import ccall "dynamic" runStopExtension :: Dynamic StopExtension +foreign import ccall "dynamic" runProcessMessage :: Dynamic ProcessMessage +foreign import ccall "dynamic" runProcessCommand :: Dynamic ProcessCommand + +------------------------------------------------------------------------ + +-- | @struct glirc_extension@ +data FgnExtension = FgnExtension + { fgnStart :: FunPtr StartExtension -- ^ Optional callback + , fgnStop :: FunPtr StopExtension -- ^ Optional callback + , fgnMessage :: FunPtr ProcessMessage -- ^ Optional callback + , fgnCommand :: FunPtr ProcessCommand -- ^ Optional callback + , fgnName :: CString -- ^ Null-terminated name + , fgnMajorVersion, fgnMinorVersion :: CInt + } + +instance Storable FgnExtension where + alignment _ = #alignment struct glirc_extension + sizeOf _ = #size struct glirc_extension + peek p = FgnExtension + <$> (#peek struct glirc_extension, start ) p + <*> (#peek struct glirc_extension, stop ) p + <*> (#peek struct glirc_extension, process_message) p + <*> (#peek struct glirc_extension, process_command) p + <*> (#peek struct glirc_extension, name ) p + <*> (#peek struct glirc_extension, major_version ) p + <*> (#peek struct glirc_extension, minor_version ) p + poke p FgnExtension{..} = + do (#poke struct glirc_extension, start ) p fgnStart + (#poke struct glirc_extension, stop ) p fgnStop + (#poke struct glirc_extension, process_message) p fgnMessage + (#poke struct glirc_extension, process_command) p fgnCommand + (#poke struct glirc_extension, name ) p fgnName + (#poke struct glirc_extension, major_version ) p fgnMajorVersion + (#poke struct glirc_extension, minor_version ) p fgnMinorVersion + +------------------------------------------------------------------------ + +-- | @struct glirc_message@ +data FgnMsg = FgnMsg + { fmNetwork :: FgnStringLen + , fmPrefixNick :: FgnStringLen + , fmPrefixUser :: FgnStringLen + , fmPrefixHost :: FgnStringLen + , fmCommand :: FgnStringLen + , fmParams :: Ptr FgnStringLen -- ^ array + , fmParamN :: CSize -- ^ array length + , fmTagKeys :: Ptr FgnStringLen -- ^ array + , fmTagVals :: Ptr FgnStringLen -- ^ array + , fmTagN :: CSize -- ^ array length + } + +instance Storable FgnMsg where + alignment _ = #alignment struct glirc_message + sizeOf _ = #size struct glirc_message + peek p = FgnMsg + <$> (#peek struct glirc_message, network ) p + <*> (#peek struct glirc_message, prefix_nick) p + <*> (#peek struct glirc_message, prefix_user) p + <*> (#peek struct glirc_message, prefix_host) p + <*> (#peek struct glirc_message, command ) p + <*> (#peek struct glirc_message, params ) p + <*> (#peek struct glirc_message, params_n) p + <*> (#peek struct glirc_message, tagkeys ) p + <*> (#peek struct glirc_message, tagvals ) p + <*> (#peek struct glirc_message, tags_n ) p + + poke p FgnMsg{..} = + do (#poke struct glirc_message, network ) p fmNetwork + (#poke struct glirc_message, prefix_nick) p fmPrefixNick + (#poke struct glirc_message, prefix_user) p fmPrefixUser + (#poke struct glirc_message, prefix_host) p fmPrefixHost + (#poke struct glirc_message, command ) p fmCommand + (#poke struct glirc_message, params ) p fmParams + (#poke struct glirc_message, params_n) p fmParamN + (#poke struct glirc_message, tagkeys ) p fmTagKeys + (#poke struct glirc_message, tagvals ) p fmTagVals + (#poke struct glirc_message, tags_n ) p fmTagN + +------------------------------------------------------------------------ + +-- | @struct glirc_command@ +data FgnCmd = FgnCmd + { fcParams :: Ptr FgnStringLen -- ^ array + , fcParamN :: CSize -- ^ array length + } + +instance Storable FgnCmd where + alignment _ = #alignment struct glirc_command + sizeOf _ = #size struct glirc_command + peek p = FgnCmd + <$> (#peek struct glirc_command, params ) p + <*> (#peek struct glirc_command, params_n) p + + poke p FgnCmd{..} = + do (#poke struct glirc_command, params ) p fcParams + (#poke struct glirc_command, params_n) p fcParamN + +------------------------------------------------------------------------ + +-- | @struct glirc_string@ +data FgnStringLen = FgnStringLen !CString !CSize + +instance Storable FgnStringLen where + alignment _ = #alignment struct glirc_string + sizeOf _ = #size struct glirc_string + peek p = FgnStringLen + <$> (#peek struct glirc_string, str) p + <*> (#peek struct glirc_string, len) p + poke p (FgnStringLen x y) = + do (#poke struct glirc_string, str) p x + (#poke struct glirc_string, len) p y diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -18,23 +18,25 @@ , tabCompletion ) where +import Client.CApi +import Client.ChannelState +import Client.Configuration.ServerSettings import Client.Commands.Interpolation +import Client.Commands.WordCompletion import Client.Configuration import Client.ConnectionState import qualified Client.EditBox as Edit +import Client.Focus import Client.Message -import Client.ServerSettings -import Client.ChannelState import Client.State import Client.Window -import Client.WordCompletion import Control.Lens import Control.Monad import Data.Char -import Data.List.Split import Data.Foldable -import Data.HashSet (HashSet) import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.List.Split import qualified Data.HashMap.Strict as HashMap import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -55,7 +57,7 @@ -- ^ Continue running the client, consume input if command was from input | CommandFailure ClientState -- ^ Continue running the client, report an error - | CommandQuit -- ^ Client should close + | CommandQuit ClientState -- ^ Client should close -- | Type of commands that always work type ClientCommand = @@ -140,7 +142,7 @@ case res of CommandSuccess st1 -> process cs st1 CommandFailure st1 -> process cs st1 -- ? - CommandQuit -> return CommandQuit + CommandQuit st1 -> return (CommandQuit st1) -- | Respond to the TAB key being pressed. This can dispatch to a command -- specific completion mode when relevant. Otherwise this will complete @@ -159,12 +161,12 @@ | Just !cs <- preview (clientConnection network) st -> do now <- getZonedTime let msgTxt = Text.pack $ takeWhile (/='\n') msg - ircMsg = rawIrcMsg "PRIVMSG" [idText channel, msgTxt] + ircMsg = ircPrivmsg channel msgTxt myNick = UserInfo (view csNick cs) "" "" entry = ClientMessage - { _msgTime = now + { _msgTime = now , _msgNetwork = network - , _msgBody = IrcBody (Privmsg myNick channel msgTxt) + , _msgBody = IrcBody (Privmsg myNick channel msgTxt) } sendMsg cs ircMsg commandSuccess $ recordChannelMessage network channel entry st @@ -236,6 +238,7 @@ , (["reconnect" ], ClientCommand cmdReconnect noClientTab) , (["ignore" ], ClientCommand cmdIgnore simpleClientTab) , (["reload" ], ClientCommand cmdReload tabReload) + , (["extension" ], ClientCommand cmdExtension simpleClientTab) , (["quote" ], NetworkCommand cmdQuote simpleNetworkTab) , (["j","join" ], NetworkCommand cmdJoin simpleNetworkTab) @@ -296,7 +299,7 @@ commandSuccess (nickTabCompletion isReversed st) cmdExit :: ClientCommand -cmdExit _ _ = return CommandQuit +cmdExit st _ = return (CommandQuit st) -- | When used on a channel that the user is currently -- joined to this command will clear the messages but @@ -752,7 +755,8 @@ case res of Left{} -> commandFailure st Right cfg -> - commandSuccess $! set clientConfig cfg st + do st1 <- clientStartExtensions (set clientConfig cfg st) + commandSuccess st1 -- | Support file name tab completion when providing an alternative -- configuration file. @@ -824,14 +828,22 @@ ClientState -> [Identifier] activeNicks st = - toListOf - ( clientWindows . ix focus - . winMessages . folded - . wlBody . _IrcBody - . folding msgActor . to userNick) st - where - focus = view clientFocus st + case view clientFocus st of + focus@(ChannelFocus network channel) -> + toListOf + ( clientWindows . ix focus + . winMessages . folded + . wlBody . _IrcBody + . folding msgActor . to userNick + . filtered isActive) st + where + isActive n = HashMap.member n userMap + userMap = view ( clientConnection network + . csChannels . ix channel + . chanUsers) st + _ -> [] + -- | Use the *!*@host masks of users for channel lists when setting list modes -- -- Use the channel's mask list for removing modes @@ -885,7 +897,7 @@ = fromMaybe st $ clientTextBox (wordComplete (++": ") isReversed hint completions) st where - hint = activeNicks st + hint = activeNicks st completions = currentCompletionList st -- | Used to send commands that require ops to perform. @@ -907,3 +919,14 @@ useChanServ channel cs = channel `elem` view (csSettings . ssChanservChannels) cs && not (iHaveOp channel cs) + +cmdExtension :: ClientCommand +cmdExtension st rest = + case Text.words (Text.pack rest) of + name:params + | Just ae <- find (\ae -> aeName ae == name) (view clientExtensions st) -> + do (st',_) <- withStableMVar st $ \stab -> + commandExtension stab params ae + commandSuccess st' + _ -> commandFailure st + diff --git a/src/Client/Commands/Interpolation.hs b/src/Client/Commands/Interpolation.hs --- a/src/Client/Commands/Interpolation.hs +++ b/src/Client/Commands/Interpolation.hs @@ -23,9 +23,10 @@ import qualified Data.Text as Text import Data.Text (Text) +-- | Parsed chunk of an expandable command data ExpansionChunk - = LiteralChunk Text -- ^ regular text - | VariableChunk Text -- ^ inline variable @$x@ or @${x y}@ + = LiteralChunk Text -- ^ regular text + | VariableChunk Text -- ^ inline variable @$x@ or @${x y}@ | IntegerChunk Integer -- ^ inline variable @$1@ or @${1}@ deriving Show diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/WordCompletion.hs @@ -0,0 +1,101 @@ +{-| +Module : Client.Commands.WordCompletion +Description : Tab-completion logic +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module provides the tab-completion logic used for nicknames and channels. + +-} +module Client.Commands.WordCompletion + ( wordComplete + ) where + +import Irc.Identifier +import Control.Applicative +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Set as Set +import Data.Char +import Data.List +import Control.Lens +import qualified Client.EditBox as Edit +import Control.Monad + +-- | Perform word completion on a text box. +-- +-- The leading update operation is applied to the result of tab-completion +-- when tab completing from the beginning of the text box. This is useful +-- when auto-completing a nick and including a trailing colon. +-- +-- The @reversed@ parameter indicates that tab-completion should return the +-- previous entry. When starting a fresh tab completion the priority completions +-- will be considered in order before resorting to the set of possible +-- completions. +wordComplete :: + (String -> String) {- ^ leading update operation -} -> + Bool {- ^ reversed -} -> + [Identifier] {- ^ priority completions -} -> + [Identifier] {- ^ possible completions -} -> + Edit.EditBox -> Maybe Edit.EditBox +wordComplete leadingCase isReversed hint vals box = + do let current = currentWord box + guard (not (null current)) + let cur = mkId (Text.pack current) + case view Edit.tabSeed box of + Just patternStr + | idPrefix pat cur -> + + do next <- tabSearch isReversed pat cur vals + Just $ replaceWith leadingCase (idString next) box + where + pat = mkId (Text.pack patternStr) + + _ -> + do next <- find (idPrefix cur) hint <|> + tabSearch isReversed cur cur vals + Just $ set Edit.tabSeed (Just current) + $ replaceWith leadingCase (idString next) box + +replaceWith :: (String -> String) -> String -> Edit.EditBox -> Edit.EditBox +replaceWith leadingCase str box = + let box1 = Edit.killWordBackward False box + str1 | view Edit.pos box1 == 0 = leadingCase str + | otherwise = str + in over Edit.content (Edit.insertString str1) box1 + +idString :: Identifier -> String +idString = Text.unpack . idText + +currentWord :: Edit.EditBox -> String +currentWord box + = reverse + $ takeWhile (not . isSpace) + $ dropWhile (\x -> x==' ' || x==':') + $ reverse + $ take n txt + where Edit.Line n txt = view (Edit.content . Edit.current) box + +class Prefix a where isPrefix :: a -> a -> Bool +instance Prefix Identifier where isPrefix = idPrefix +instance Prefix Text where isPrefix = Text.isPrefixOf +instance Eq a => Prefix [a] where isPrefix = isPrefixOf + +tabSearch :: (Ord a, Prefix a) => Bool -> a -> a -> [a] -> Maybe a +tabSearch isReversed pat cur vals + | Just next <- advanceFun cur valSet + , isPrefix pat next + = Just next + + | isReversed = find (isPrefix pat) (reverse (Set.toList valSet)) + + | otherwise = do x <- Set.lookupGE pat valSet + guard (isPrefix pat x) + Just x + where + valSet = Set.fromList vals + + advanceFun | isReversed = Set.lookupLT + | otherwise = Set.lookupGT + diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -25,6 +25,7 @@ , configNickPadding , configConfigPath , configMacros + , configExtensions -- * Loading configuration , loadConfiguration @@ -35,8 +36,8 @@ import Client.Image.Palette import Client.Configuration.Colors +import Client.Configuration.ServerSettings import Client.Commands.Interpolation -import Client.ServerSettings import Control.Exception import Control.Monad import Config @@ -67,6 +68,7 @@ , _configConfigPath :: Maybe FilePath -- ^ manually specified configuration path, used for reloading , _configMacros :: HashMap Text [[ExpansionChunk]] -- ^ command macros + , _configExtensions :: [FilePath] -- ^ paths to shared library } deriving Show @@ -175,6 +177,9 @@ _configMacros <- fromMaybe HashMap.empty <$> sectionOptWith parseMacroMap "macros" + + _configExtensions <- fromMaybe [] + <$> sectionOptWith (parseList parseString) "extensions" _configNickPadding <- sectionOpt "nick-padding" for_ _configNickPadding (\padding -> diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs new file mode 100644 --- /dev/null +++ b/src/Client/Configuration/ServerSettings.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Client.Configuration.ServerSettings +Description : Settings for an individual IRC connection +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module defines the settings used for an individual IRC connection. +These are static settings that are not expected change over the lifetime +of a connection. +-} + +module Client.Configuration.ServerSettings + ( + -- * Server settings type + ServerSettings(..) + , ssNick + , ssUser + , ssReal + , ssUserInfo + , ssPassword + , ssSaslUsername + , ssSaslPassword + , ssHostName + , ssPort + , ssTls + , ssTlsInsecure + , ssTlsClientCert + , ssTlsClientKey + , ssConnectCmds + , ssSocksHost + , ssSocksPort + , ssServerCerts + , ssChanservChannels + , ssFloodPenalty + , ssFloodThreshold + , ssMessageHooks + , ssName + + -- * Load function + , loadDefaultServerSettings + + ) where + +import Control.Lens +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Irc.Identifier (Identifier) +import System.Environment +import qualified Data.Text as Text + +import Network.Socket (HostName, PortNumber) + +-- | Static server-level settings +data ServerSettings = ServerSettings + { _ssNick :: !Text -- ^ connection nickname + , _ssUser :: !Text -- ^ connection username + , _ssReal :: !Text -- ^ connection realname / GECOS + , _ssUserInfo :: !Text -- ^ CTCP userinfo + , _ssPassword :: !(Maybe Text) -- ^ server password + , _ssSaslUsername :: !(Maybe Text) -- ^ SASL username + , _ssSaslPassword :: !(Maybe Text) -- ^ SASL password + , _ssHostName :: !HostName -- ^ server hostname + , _ssPort :: !(Maybe PortNumber) -- ^ server port + , _ssTls :: !Bool -- ^ use TLS to connect + , _ssTlsInsecure :: !Bool -- ^ disable certificate checking + , _ssTlsClientCert :: !(Maybe FilePath) -- ^ path to client TLS certificate + , _ssTlsClientKey :: !(Maybe FilePath) -- ^ path to client TLS key + , _ssConnectCmds :: ![Text] -- ^ raw IRC messages to transmit upon successful connection + , _ssSocksHost :: !(Maybe HostName) -- ^ hostname of SOCKS proxy + , _ssSocksPort :: !PortNumber -- ^ port of SOCKS proxy + , _ssServerCerts :: ![FilePath] -- ^ additional CA certificates for validating server + , _ssChanservChannels :: ![Identifier] -- ^ Channels with chanserv permissions + , _ssFloodPenalty :: !Rational -- ^ Flood limiter penalty (seconds) + , _ssFloodThreshold :: !Rational -- ^ Flood limited threshold (seconds) + , _ssMessageHooks :: ![Text] -- ^ Initial message hooks + , _ssName :: !(Maybe Text) -- ^ The name referencing the server in commands + } + deriving Show + +makeLenses ''ServerSettings + +-- | Load the defaults for server settings based on the environment +-- variables. +-- +-- @USER@, @IRCPASSSWORD@, and @SASLPASSWORD@ are used. +loadDefaultServerSettings :: IO ServerSettings +loadDefaultServerSettings = + do env <- getEnvironment + let username = Text.pack (fromMaybe "guest" (lookup "USER" env)) + return ServerSettings + { _ssNick = username + , _ssUser = username + , _ssReal = username + , _ssUserInfo = username + , _ssPassword = Text.pack <$> lookup "IRCPASSWORD" env + , _ssSaslUsername = Nothing + , _ssSaslPassword = Text.pack <$> lookup "SASLPASSWORD" env + , _ssHostName = "" + , _ssPort = Nothing + , _ssTls = False + , _ssTlsInsecure = False + , _ssTlsClientCert = Nothing + , _ssTlsClientKey = Nothing + , _ssConnectCmds = [] + , _ssSocksHost = Nothing + , _ssSocksPort = 1080 + , _ssServerCerts = [] + , _ssChanservChannels = [] + , _ssFloodPenalty = 2 -- RFC 1459 defaults + , _ssFloodThreshold = 10 + , _ssMessageHooks = [] + , _ssName = Nothing + } diff --git a/src/Client/Connect.hs b/src/Client/Connect.hs deleted file mode 100644 --- a/src/Client/Connect.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{-| -Module : Client.Connect -Description : Interface to the connection package -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module is responsible for creating 'Connection' values -for a particular server as specified by a 'ServerSettings'. -This involves setting up certificate stores an mapping -network settings from the client configuration into the -network connection library. --} - -module Client.Connect - ( withConnection - ) where - -import Client.Configuration -import Client.ServerSettings -import Control.Exception (bracket) -import Control.Lens -import Control.Monad -import Data.Default.Class (def) -import Data.Monoid ((<>)) -import Data.X509 (CertificateChain(..)) -import Data.X509.CertificateStore (CertificateStore, makeCertificateStore) -import Data.X509.File (readSignedObject, readKeyFile) -import Network.Connection -import Network.Socket (PortNumber) -import Network.TLS -import Network.TLS.Extra (ciphersuite_all) -import System.X509 (getSystemCertificateStore) - -buildConnectionParams :: ServerSettings -> IO ConnectionParams -buildConnectionParams args = - do useSecure <- if view ssTls args - then fmap Just (buildTlsSettings args) - else return Nothing - - let proxySettings = view ssSocksHost args <&> \host -> - SockSettingsSimple - host - (view ssSocksPort args) - - return ConnectionParams - { connectionHostname = view ssHostName args - , connectionPort = ircPort args - , connectionUseSecure = useSecure - , connectionUseSocks = proxySettings - } - -ircPort :: ServerSettings -> PortNumber -ircPort args = - case view ssPort args of - Just p -> fromIntegral p - Nothing | view ssTls args -> 6697 - | otherwise -> 6667 - -buildCertificateStore :: ServerSettings -> IO CertificateStore -buildCertificateStore args = - do systemStore <- getSystemCertificateStore - userCerts <- traverse (readSignedObject <=< resolveConfigurationPath) - (view ssServerCerts args) - let userStore = makeCertificateStore (concat userCerts) - return (userStore <> systemStore) - -buildTlsSettings :: ServerSettings -> IO TLSSettings -buildTlsSettings args = - do store <- buildCertificateStore args - - let noValidation = - ValidationCache - (\_ _ _ -> return ValidationCachePass) - (\_ _ _ -> return ()) - - return $ TLSSettings ClientParams - { clientWantSessionResume = Nothing - , clientUseMaxFragmentLength = Nothing - , clientServerIdentification = - error "buildTlsSettings: field initialized by connectTo" - , clientUseServerNameIndication = True - , clientShared = def - { sharedCAStore = store - , sharedValidationCache = - if view ssTlsInsecure args then noValidation else def - } - , clientHooks = def - { onCertificateRequest = \_ -> loadClientCredentials args } - , clientSupported = def - { supportedCiphers = ciphersuite_all } - , clientDebug = def - } - -loadClientCredentials :: ServerSettings -> IO (Maybe (CertificateChain, PrivKey)) -loadClientCredentials args = - case view ssTlsClientCert args of - Nothing -> return Nothing - Just certPath -> - do certPath' <- resolveConfigurationPath certPath - cert <- readSignedObject certPath' - - keyPath <- case view ssTlsClientKey args of - Nothing -> return certPath' - Just keyPath -> resolveConfigurationPath keyPath - keys <- readKeyFile keyPath - case keys of - [key] -> return (Just (CertificateChain cert, key)) - [] -> fail "No private keys found" - _ -> fail "Too many private keys found" - --- | Create a new 'Connection' which will be closed when the continuation finishes. -withConnection :: ConnectionContext -> ServerSettings -> (Connection -> IO a) -> IO a -withConnection cxt settings k = - do params <- buildConnectionParams settings - bracket (connectTo cxt params) connectionClose k diff --git a/src/Client/ConnectionState.hs b/src/Client/ConnectionState.hs --- a/src/Client/ConnectionState.hs +++ b/src/Client/ConnectionState.hs @@ -65,8 +65,8 @@ ) where import Client.ChannelState -import Client.NetworkConnection -import Client.ServerSettings +import Client.Configuration.ServerSettings +import Client.Network.Async import Control.Lens import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -559,7 +559,9 @@ applyOne modes (False, mode, _) = delete mode modes supportedCaps :: ConnectionState -> [Text] -supportedCaps cs = sasl ++ ["multi-prefix", "znc.in/playback", "znc.in/server-time-iso", "znc.in/self-message"] +supportedCaps cs = + sasl ++ ["multi-prefix", "znc.in/batch", "znc.in/playback", + "znc.in/server-time-iso", "znc.in/self-message"] where ss = view csSettings cs sasl = ["sasl" | isJust (view ssSaslUsername ss) diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -15,18 +15,18 @@ ( eventLoop ) where +import Client.CApi import Client.Commands import Client.Configuration +import Client.Configuration.ServerSettings import Client.ConnectionState import qualified Client.EditBox as Edit import Client.Hook import Client.Hooks import Client.Image import Client.Message -import Client.NetworkConnection -import Client.ServerSettings +import Client.Network.Async import Client.State -import Client.Window import Control.Concurrent.STM import Control.Exception import Control.Lens @@ -35,8 +35,8 @@ import Data.Foldable import qualified Data.IntMap as IntMap import Data.List -import qualified Data.Map as Map import Data.Maybe +import Data.Monoid import Data.Ord import Data.Text (Text) import qualified Data.Text as Text @@ -126,7 +126,7 @@ msg = ClientMessage { _msgTime = time , _msgNetwork = view csNetwork cs - , _msgBody = ExitBody + , _msgBody = NormalBody "connection closed" } in eventLoop $ recordNetworkMessage msg st' @@ -142,7 +142,7 @@ msg = ClientMessage { _msgTime = time , _msgNetwork = view csNetwork cs - , _msgBody = ErrorBody (show ex) + , _msgBody = ErrorBody (Text.pack (show ex)) } in eventLoop $ recordNetworkMessage msg st' @@ -161,15 +161,18 @@ let network = view csNetwork cs in case parseRawIrcMsg (asUtf8 line) of Nothing -> - do let msg = ClientMessage - { _msgTime = time + do let txt = Text.pack ("Malformed message: " ++ show line) + msg = ClientMessage + { _msgTime = time , _msgNetwork = network - , _msgBody = ErrorBody ("Malformed message: " ++ show line) + , _msgBody = ErrorBody txt } eventLoop (recordNetworkMessage msg st) Just raw -> - do let time' = computeEffectiveTime time (view msgTags raw) + do (st1,_) <- withStableMVar st $ \ptr -> + notifyExtensions ptr network raw (view clientExtensions st) + let time' = computeEffectiveTime time (view msgTags raw) (stateHook, viewHook) = over both applyMessageHooks @@ -179,15 +182,15 @@ messageHooks case stateHook (cookIrcMsg raw) of - Nothing -> eventLoop st -- Message ignored + Nothing -> eventLoop st1 -- Message ignored Just irc -> do traverse_ (sendMsg cs) replies - st2 <- clientResponse time' irc cs st1 - eventLoop st2 + st3 <- clientResponse time' irc cs st2 + eventLoop st3 where -- state with message recorded recSt = case viewHook irc of - Nothing -> st -- Message hidden - Just irc' -> recordIrcMessage network target msg st + Nothing -> st1 -- Message hidden + Just irc' -> recordIrcMessage network target msg st1 where myNick = view csNick cs target = msgTarget myNick irc @@ -198,7 +201,7 @@ } -- record messages *before* applying the changes - (replies, st1) = applyMessageToClientState time irc networkId cs recSt + (replies, st2) = applyMessageToClientState time irc networkId cs recSt -- | Client-level responses to specific IRC messages. -- This is in contrast to the connection state tracking logic in @@ -224,7 +227,7 @@ return $! case res of CommandFailure st -> reportConnectCmdError now cs cmdTxt st CommandSuccess st -> st - CommandQuit -> st0 -- not supported + CommandQuit st -> st -- not supported reportConnectCmdError :: @@ -237,7 +240,7 @@ recordNetworkMessage ClientMessage { _msgTime = now , _msgNetwork = view csNetwork cs - , _msgBody = ErrorBody ("Bad connect-cmd: " ++ Text.unpack cmdTxt) + , _msgBody = ErrorBody ("Bad connect-cmd: " <> cmdTxt) } -- | Find the ZNC provided server time @@ -346,48 +349,12 @@ doCommandResult :: Bool -> CommandResult -> IO () doCommandResult clearOnSuccess res = case res of - CommandQuit -> return () + CommandQuit st -> clientShutdown st CommandSuccess st -> eventLoop (if clearOnSuccess then consumeInput st else st) CommandFailure st -> eventLoop (set clientBell True st) executeInput :: ClientState -> IO CommandResult executeInput st = execute (clientFirstLine st) st - --- | Scroll the current buffer to show older messages -pageUp :: ClientState -> ClientState -pageUp st = over clientScroll (+ scrollAmount st) st - --- | Scroll the current buffer to show newer messages -pageDown :: ClientState -> ClientState -pageDown st = over clientScroll (max 0 . subtract (scrollAmount st)) st - --- | Compute the number of lines in a page at the current window size -scrollAmount :: ClientState -> Int -scrollAmount st = max 1 (view clientHeight st - 2) - --- | Jump the focus of the client to a buffer that has unread activity. --- Some events like errors or chat messages mentioning keywords are --- considered important and will be jumped to first. -jumpToActivity :: ClientState -> ClientState -jumpToActivity st = - case mplus highPriority lowPriority of - Just (focus,_) -> changeFocus focus st - Nothing -> st - where - windowList = views clientWindows Map.toList st - highPriority = find (view winMention . snd) windowList - lowPriority = find (\x -> view winUnread (snd x) > 0) windowList - --- | Jump the focus directly to a window based on its zero-based index. -jumpFocus :: - Int {- ^ zero-based window index -} -> - ClientState -> ClientState -jumpFocus i st - | 0 <= i, i < Map.size windows = changeFocus focus st - | otherwise = st - where - windows = view clientWindows st - (focus,_) = Map.elemAt i windows -- | Respond to a timer event. diff --git a/src/Client/Focus.hs b/src/Client/Focus.hs new file mode 100644 --- /dev/null +++ b/src/Client/Focus.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : Client.Focus +Description : Types for representing the current window being displayed +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +The client has a primary message window whose contents are determined +by a 'ClientFocus'. In order to provide different views of channels +the 'ClientSubfocus' breaks down channel focus into different subviews. +-} + +module Client.Focus + ( -- * Types + ClientFocus(..) + , ClientSubfocus(..) + + -- * Focus operations + , focusNetwork + + -- * Focus Prisms + , _ChannelFocus + , _NetworkFocus + , _Unfocused + + -- * Subfocus Prisms + , _FocusMessages + , _FocusInfo + , _FocusUsers + , _FocusMasks + ) where + +import Control.Lens +import Data.Monoid ((<>)) +import Data.Text (Text) +import Irc.Identifier + +-- | Currently focused window +data ClientFocus + = Unfocused -- ^ No network + | NetworkFocus !Text -- ^ Network + | ChannelFocus !Text !Identifier -- ^ Network Channel/Nick + deriving (Eq,Show) + +makePrisms ''ClientFocus + +-- | Subfocus for a channel view +data ClientSubfocus + = FocusMessages -- ^ Show chat messages + | FocusInfo -- ^ Show channel metadata + | FocusUsers -- ^ Show user list + | FocusMasks !Char -- ^ Show mask list for given mode + deriving (Eq,Show) + +makePrisms ''ClientSubfocus + +-- | Unfocused first, followed by focuses sorted by network. +-- Within the same network the network focus comes first and +-- then the channels are ordered by channel identifier +instance Ord ClientFocus where + compare Unfocused Unfocused = EQ + compare (NetworkFocus x) (NetworkFocus y ) = compare x y + compare (ChannelFocus x1 x2) (ChannelFocus y1 y2) = compare x1 y1 <> compare x2 y2 + + compare Unfocused _ = LT + compare _ Unfocused = GT + + compare (NetworkFocus x ) (ChannelFocus y _) = compare x y <> LT + compare (ChannelFocus x _) (NetworkFocus y ) = compare x y <> GT + +-- | Return the network associated with the current focus +focusNetwork :: ClientFocus -> Maybe Text {- ^ network -} +focusNetwork Unfocused = Nothing +focusNetwork (NetworkFocus network) = Just network +focusNetwork (ChannelFocus network _) = Just network diff --git a/src/Client/Hook/Znc/Buffextras.hs b/src/Client/Hook/Znc/Buffextras.hs --- a/src/Client/Hook/Znc/Buffextras.hs +++ b/src/Client/Hook/Znc/Buffextras.hs @@ -57,6 +57,7 @@ , Nick pfx . mkId <$ skipToken "is now known as" <*> simpleTokenParser , Mode pfx chan <$ skipToken "set mode:" <*> allTokens , Kick pfx chan <$ skipToken "kicked" <*> parseId <* skipToken "Reason:" <*> parseReason + , Topic pfx chan <$ skipToken "changed the topic to:" <*> P.takeText ] allTokens :: Parser [Text] diff --git a/src/Client/Image.hs b/src/Client/Image.hs --- a/src/Client/Image.hs +++ b/src/Client/Image.hs @@ -15,18 +15,19 @@ import Client.Configuration import Client.ConnectionState import qualified Client.EditBox as Edit +import Client.Focus import Client.Image.ChannelInfo import Client.Image.MaskList import Client.Image.Message +import Client.Image.MircFormatting import Client.Image.Palette import Client.Image.UserList import Client.Message -import Client.MircFormatting import Client.State import Client.Window import Control.Lens import qualified Data.Map.Strict as Map -import Data.Maybe (isJust) +import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text import Graphics.Vty (Picture(..), Cursor(..), picForImage) @@ -111,35 +112,39 @@ windowLinesToImages :: ClientState -> [WindowLine] -> [Image] windowLinesToImages st wwls = - case wwls of - [] -> [] - wl:wls - | Just (img,ident) <- metadataWindowLine st wl -> windowLinesToImagesMd st img ident wls - | otherwise -> view wlImage wl : windowLinesToImages st wls + case windowLinesToImagesMd st wwls of + Just (img, _, wls) -> img : windowLinesToImages st wls + Nothing -> + case wwls of + [] -> [] + wl:wls -> view wlImage wl : windowLinesToImages st wls -windowLinesToImagesMd :: ClientState -> Image -> Maybe Identifier -> [WindowLine] -> [Image] -windowLinesToImagesMd st acc who wwls = - case wwls of - wl:wls - | Just (img,ident) <- metadataWindowLine st wl -> - if isJust ident && who == ident - then windowLinesToImagesMd st (acc <|> img) who wls - else windowLinesToImagesMd st (finish <|> char defAttr ' ' <|> img) ident wls - _ -> finish : windowLinesToImages st wwls - where - palette = view (clientConfig . configPalette) st - finish = acc <|> maybe emptyImage (quietIdentifier palette) who +windowLinesToImagesMd :: + ClientState -> [WindowLine] -> Maybe (Image, Identifier, [WindowLine]) +windowLinesToImagesMd st wwls = + do w:wls <- Just wwls + (img, ident, mbnext) <- metadataWindowLine st w + let palette = view (clientConfig . configPalette) st + (acc1, wls2) = + case windowLinesToImagesMd st wls of + Nothing -> (quietIdentifier palette ident <|> img, wls) + Just (acc, prevident, wls') -> (acc <|> transition <|> img, wls') + where + transition + | ident == prevident = emptyImage + | otherwise = char defAttr ' ' <|> quietIdentifier palette ident -metadataWindowLine :: ClientState -> WindowLine -> Maybe (Image, Maybe Identifier) + let transition2 = foldMap (quietIdentifier palette) mbnext + Just (acc1 <|> transition2, fromMaybe ident mbnext, wls2) + +metadataWindowLine :: ClientState -> WindowLine -> Maybe (Image, Identifier, Maybe Identifier) metadataWindowLine st wl = case view wlBody wl of IrcBody irc - | Just who <- ircIgnorable irc st -> Just (ignoreImage, Just who) - | otherwise -> metadataImg palette irc + | Just who <- ircIgnorable irc st -> Just (ignoreImage, who, Nothing) + | otherwise -> metadataImg irc _ -> Nothing - where - palette = view (clientConfig . configPalette) st lineWrap :: Int -> Image -> Image lineWrap w img diff --git a/src/Client/Image/ChannelInfo.hs b/src/Client/Image/ChannelInfo.hs --- a/src/Client/Image/ChannelInfo.hs +++ b/src/Client/Image/ChannelInfo.hs @@ -21,7 +21,7 @@ import Client.ConnectionState import Client.Image.Palette import Client.Image.Message -import Client.MircFormatting +import Client.Image.MircFormatting import Client.State import Control.Lens import Data.Text (Text) diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -22,25 +22,25 @@ , coloredIdentifier ) where +import Client.Image.MircFormatting import Client.Image.Palette import Client.Message -import Client.MircFormatting import Control.Lens -import Data.Time -import Graphics.Vty.Image -import Irc.Codes -import Irc.Identifier -import Irc.Message -import Irc.RawIrcMsg -import Irc.UserInfo import Data.Char import Data.Hashable (hash) import qualified Data.HashSet as HashSet import Data.List import Data.Maybe -import qualified Data.Text as Text import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time import qualified Data.Vector as Vector +import Graphics.Vty.Image +import Irc.Codes +import Irc.Identifier +import Irc.Message +import Irc.RawIrcMsg +import Irc.UserInfo -- | Parameters used when rendering messages data MessageRendererParams = MessageRendererParams @@ -78,13 +78,22 @@ errorImage :: MessageRendererParams -> - String {- ^ error message -} -> + Text {- ^ error message -} -> Image errorImage params txt = horizCat - [ text' (view palError (rendPalette params)) "Error " - , string defAttr txt + [ text' (view palError (rendPalette params)) "error " + , text' defAttr txt ] +normalImage :: + MessageRendererParams -> + Text {- ^ message -} -> + Image +normalImage params txt = horizCat + [ text' (view palLabel (rendPalette params)) "client " + , text' defAttr txt + ] + -- | Render the given time according to the current mode and palette. renderTime :: RenderMode -> Palette -> ZonedTime -> Image renderTime DetailedRender = datetimeImage @@ -108,9 +117,9 @@ MessageBody -> Image bodyImage rm params body = case body of - IrcBody irc -> ircLineImage rm params irc - ErrorBody txt -> errorImage params txt - ExitBody -> string defAttr "Thread finished" + IrcBody irc -> ircLineImage rm params irc + ErrorBody txt -> errorImage params txt + NormalBody txt -> normalImage params txt -- | Render a 'ZonedTime' as time using quiet attributes -- @@ -168,7 +177,7 @@ detail (string quietAttr "nick ") <|> string (view palSigil pal) sigils <|> coloredUserInfo pal rm myNicks old <|> - string defAttr " became " <|> + string defAttr " is now known as " <|> coloredIdentifier pal NormalIdentifier myNicks new Join nick _chan -> @@ -199,23 +208,24 @@ parseIrcText reason Topic src _dst txt -> + detail (string quietAttr "tpic ") <|> coloredUserInfo pal rm myNicks src <|> - string defAttr " changed topic to " <|> + string defAttr " changed the topic to: " <|> parseIrcText txt Notice src _dst txt -> detail (string quietAttr "note ") <|> - string (view palSigil pal) sigils <|> rightPad rm (rendNickPadding rp) - (coloredUserInfo pal rm myNicks src) <|> + (string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks src) <|> string (withForeColor defAttr red) ": " <|> parseIrcTextWithNicks pal myNicks nicks txt Privmsg src _dst txt -> detail (string quietAttr "chat ") <|> - string (view palSigil pal) sigils <|> rightPad rm (rendNickPadding rp) - (coloredUserInfo pal rm myNicks src) <|> + (string (view palSigil pal) sigils <|> + coloredUserInfo pal rm myNicks src) <|> string defAttr ": " <|> parseIrcTextWithNicks pal myNicks nicks txt @@ -286,8 +296,6 @@ text' defAttr ": " <|> separatedParams args - Authenticate{} -> string defAttr "AUTHENTICATE ***" - Mode nick _chan params -> detail (string quietAttr "mode ") <|> string (view palSigil pal) sigils <|> @@ -295,6 +303,11 @@ string defAttr " set mode: " <|> separatedParams params + Authenticate{} -> string defAttr "AUTHENTICATE ***" + BatchStart{} -> string defAttr "BATCH +" + BatchEnd{} -> string defAttr "BATCH -" + + renderCapCmd :: CapCmd -> Text renderCapCmd cmd = case cmd of @@ -416,17 +429,15 @@ -- | Returns image and identifier to be used when collapsing metadata -- messages. -metadataImg :: Palette -> IrcMsg -> Maybe (Image, Maybe Identifier) -metadataImg palette msg = +metadataImg :: IrcMsg -> Maybe (Image, Identifier, Maybe Identifier) +metadataImg msg = case msg of - Quit who _ -> Just (char (withForeColor defAttr red ) 'x', Just (userNick who)) - Part who _ _ -> Just (char (withForeColor defAttr red ) '-', Just (userNick who)) - Join who _ -> Just (char (withForeColor defAttr green) '+', Just (userNick who)) + Quit who _ -> Just (char (withForeColor defAttr red ) 'x', userNick who, Nothing) + Part who _ _ -> Just (char (withForeColor defAttr red ) '-', userNick who, Nothing) + Join who _ -> Just (char (withForeColor defAttr green) '+', userNick who, Nothing) Ctcp who _ cmd _ | cmd /= "ACTION" -> - Just (char (withForeColor defAttr white) 'C', Just (userNick who)) - Nick old new -> Just (quietIdentifier palette (userNick old) <|> - char (withForeColor defAttr yellow) '-' <|> - quietIdentifier palette new, Nothing) + Just (char (withForeColor defAttr white) 'C', userNick who, Nothing) + Nick old new -> Just (char (withForeColor defAttr yellow) '>', userNick old, Just new) _ -> Nothing -- | Image used when treating ignored chat messages as metadata diff --git a/src/Client/Image/MircFormatting.hs b/src/Client/Image/MircFormatting.hs new file mode 100644 --- /dev/null +++ b/src/Client/Image/MircFormatting.hs @@ -0,0 +1,154 @@ +{-# Language TemplateHaskell #-} + +{-| +Module : Client.Image.MircFormatting +Description : Parser for mIRC's text formatting encoding +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module parses mIRC encoded text and generates VTY images. + +-} +module Client.Image.MircFormatting + ( parseIrcText + , parseIrcTextExplicit + ) where + +import Control.Applicative ((<|>)) +import Control.Lens +import Data.Attoparsec.Text as Parse +import Data.Char +import Data.Maybe +import Data.Text (Text) +import Graphics.Vty hiding ((<|>)) +import qualified Graphics.Vty as Vty + +data FormatState = FormatState + { _fmtFore :: Maybe Color + , _fmtBack :: Maybe Color + , _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse :: !Bool + } + +makeLenses '' FormatState + +formatAttr :: FormatState -> Attr +formatAttr fmt + = doStyle (view fmtBold fmt) bold + $ doStyle (view fmtUnderline fmt) underline + $ doStyle (view fmtReverse fmt) reverseVideo + $ doColor withForeColor (view fmtFore fmt) + $ doColor withBackColor (view fmtBack fmt) + $ defAttr + + where + doStyle False _ attr = attr + doStyle True style attr = withStyle attr style + + doColor _ Nothing attr = attr + doColor with (Just x) attr = with attr x + +defaultFormatState :: FormatState +defaultFormatState = FormatState Nothing Nothing False False False False + +-- | Parse mIRC encoded format characters and hide the control characters. +parseIrcText :: Text -> Image +parseIrcText = parseIrcText' False + +-- | Parse mIRC encoded format characters and render the control characters +-- explicitly. This view is useful when inputting control characters to make +-- it clear where they are in the text. +parseIrcTextExplicit :: Text -> Image +parseIrcTextExplicit = parseIrcText' True + +parseIrcText' :: Bool -> Text -> Image +parseIrcText' explicit = either (Vty.string defAttr) id + . parseOnly (pIrcLine explicit defaultFormatState) + +data Segment = TextSegment Text | ControlSegment Char + +pSegment :: Parser Segment +pSegment = TextSegment <$> takeWhile1 (not . isControl) + <|> ControlSegment <$> satisfy isControl + +pIrcLine :: Bool -> FormatState -> Parser Image +pIrcLine explicit fmt = + do seg <- option Nothing (Just <$> pSegment) + case seg of + Nothing -> return emptyImage + Just (TextSegment txt) -> + do rest <- pIrcLine explicit fmt + return (text' (formatAttr fmt) txt Vty.<|> rest) + Just (ControlSegment '\^C') -> + do (numberText, colorNumbers) <- match pColorNumbers + rest <- pIrcLine explicit (applyColors colorNumbers fmt) + return $ if explicit + then Vty.char controlAttr 'C' + Vty.<|> text' defAttr numberText + Vty.<|> rest + else rest + Just (ControlSegment c) + -- always render control codes that we don't understand + | isNothing mbFmt' || explicit -> + do rest <- next + return (Vty.char controlAttr (controlName c) Vty.<|> rest) + | otherwise -> next + where + mbFmt' = applyControlEffect c fmt + next = pIrcLine explicit (fromMaybe fmt mbFmt') + +pColorNumbers :: Parser (Maybe Int, Maybe Int) +pColorNumbers = option (Nothing,Nothing) $ + do n <- pNumber + m <- optional (Parse.char ',' *> pNumber) + return (Just n,m) + + where + pNumber = do d1 <- digit + ds <- option [] (return <$> digit) + return $! read (d1:ds) + +optional :: Parser a -> Parser (Maybe a) +optional p = option Nothing (Just <$> p) + +applyColors :: (Maybe Int, Maybe Int) -> FormatState -> FormatState +applyColors (fore, back) = aux fmtFore fore . aux fmtBack back + where + aux _ Nothing = id + aux l (Just x) = set l (mircColor x) + +mircColor :: Int -> Maybe Color +mircColor 0 = Just (white ) -- white +mircColor 1 = Just (black ) -- black +mircColor 2 = Just (blue ) -- blue +mircColor 3 = Just (green ) -- green +mircColor 4 = Just (red ) -- red +mircColor 5 = Just (rgbColor' 127 0 0 ) -- brown +mircColor 6 = Just (rgbColor' 156 0 156 ) -- purple +mircColor 7 = Just (rgbColor' 252 127 0 ) -- yellow +mircColor 8 = Just (yellow ) -- yellow +mircColor 9 = Just (brightGreen ) -- green +mircColor 10 = Just (cyan ) -- brightBlue +mircColor 11 = Just (brightCyan ) -- brightCyan +mircColor 12 = Just (brightBlue ) -- brightBlue +mircColor 13 = Just (rgbColor' 255 0 255 ) -- brightRed +mircColor 14 = Just (rgbColor' 127 127 127) -- brightBlack +mircColor 15 = Just (rgbColor' 210 210 210) -- brightWhite +mircColor _ = Nothing + +rgbColor' :: Int -> Int -> Int -> Color +rgbColor' = rgbColor -- fix the type to Int + +applyControlEffect :: Char -> FormatState -> Maybe FormatState +applyControlEffect '\^B' = Just . over fmtBold not +applyControlEffect '\^O' = Just . const defaultFormatState +applyControlEffect '\^V' = Just . over fmtReverse not +applyControlEffect '\^]' = Just . over fmtItalic not +applyControlEffect '\^_' = Just . over fmtUnderline not +applyControlEffect _ = const Nothing + +controlAttr :: Attr +controlAttr = defAttr `withStyle` reverseVideo + +controlName :: Char -> Char +controlName c = chr (ord '@' + ord c) diff --git a/src/Client/Message.hs b/src/Client/Message.hs --- a/src/Client/Message.hs +++ b/src/Client/Message.hs @@ -22,7 +22,7 @@ , MessageBody(..) , _IrcBody , _ErrorBody - , _ExitBody + , _NormalBody -- * Client message operations , msgText @@ -30,11 +30,13 @@ import Control.Lens import Data.Text (Text) -import qualified Data.Text as Text import Data.Time (ZonedTime) import Irc.Message -data MessageBody = IrcBody !IrcMsg | ErrorBody !String | ExitBody +data MessageBody + = IrcBody !IrcMsg + | ErrorBody {-# UNPACK #-} !Text + | NormalBody {-# UNPACK #-} !Text makePrisms ''MessageBody @@ -48,6 +50,6 @@ -- | Compute a searchable text representation of the message msgText :: MessageBody -> Text -msgText (IrcBody irc) = ircMsgText irc -msgText (ErrorBody str) = Text.pack str -msgText ExitBody = Text.empty +msgText (IrcBody irc) = ircMsgText irc +msgText (ErrorBody txt) = txt +msgText (NormalBody txt) = txt diff --git a/src/Client/MircFormatting.hs b/src/Client/MircFormatting.hs deleted file mode 100644 --- a/src/Client/MircFormatting.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# Language TemplateHaskell #-} - -{-| -Module : Client.MircFormatting -Description : Parser for mIRC's text formatting encoding -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module parses mIRC encoded text and generates VTY images. - --} -module Client.MircFormatting - ( parseIrcText - , parseIrcTextExplicit - ) where - -import Control.Applicative ((<|>)) -import Control.Lens -import Data.Attoparsec.Text as Parse -import Data.Char -import Data.Maybe -import Data.Text (Text) -import Graphics.Vty hiding ((<|>)) -import qualified Graphics.Vty as Vty - -data FormatState = FormatState - { _fmtFore :: Maybe Color - , _fmtBack :: Maybe Color - , _fmtBold, _fmtItalic, _fmtUnderline, _fmtReverse :: !Bool - } - -makeLenses '' FormatState - -formatAttr :: FormatState -> Attr -formatAttr fmt - = doStyle (view fmtBold fmt) bold - $ doStyle (view fmtUnderline fmt) underline - $ doStyle (view fmtReverse fmt) reverseVideo - $ doColor withForeColor (view fmtFore fmt) - $ doColor withBackColor (view fmtBack fmt) - $ defAttr - - where - doStyle False _ attr = attr - doStyle True style attr = withStyle attr style - - doColor _ Nothing attr = attr - doColor with (Just x) attr = with attr x - -defaultFormatState :: FormatState -defaultFormatState = FormatState Nothing Nothing False False False False - --- | Parse mIRC encoded format characters and hide the control characters. -parseIrcText :: Text -> Image -parseIrcText = parseIrcText' False - --- | Parse mIRC encoded format characters and render the control characters --- explicitly. This view is useful when inputting control characters to make --- it clear where they are in the text. -parseIrcTextExplicit :: Text -> Image -parseIrcTextExplicit = parseIrcText' True - -parseIrcText' :: Bool -> Text -> Image -parseIrcText' explicit = either (Vty.string defAttr) id - . parseOnly (pIrcLine explicit defaultFormatState) - -data Segment = TextSegment Text | ControlSegment Char - -pSegment :: Parser Segment -pSegment = TextSegment <$> takeWhile1 (not . isControl) - <|> ControlSegment <$> satisfy isControl - -pIrcLine :: Bool -> FormatState -> Parser Image -pIrcLine explicit fmt = - do seg <- option Nothing (Just <$> pSegment) - case seg of - Nothing -> return emptyImage - Just (TextSegment txt) -> - do rest <- pIrcLine explicit fmt - return (text' (formatAttr fmt) txt Vty.<|> rest) - Just (ControlSegment '\^C') -> - do (numberText, colorNumbers) <- match pColorNumbers - rest <- pIrcLine explicit (applyColors colorNumbers fmt) - return $ if explicit - then Vty.char controlAttr 'C' - Vty.<|> text' defAttr numberText - Vty.<|> rest - else rest - Just (ControlSegment c) - -- always render control codes that we don't understand - | isNothing mbFmt' || explicit -> - do rest <- next - return (Vty.char controlAttr (controlName c) Vty.<|> rest) - | otherwise -> next - where - mbFmt' = applyControlEffect c fmt - next = pIrcLine explicit (fromMaybe fmt mbFmt') - -pColorNumbers :: Parser (Maybe Int, Maybe Int) -pColorNumbers = option (Nothing,Nothing) $ - do n <- pNumber - m <- optional (Parse.char ',' *> pNumber) - return (Just n,m) - - where - pNumber = do d1 <- digit - ds <- option [] (return <$> digit) - return $! read (d1:ds) - -optional :: Parser a -> Parser (Maybe a) -optional p = option Nothing (Just <$> p) - -applyColors :: (Maybe Int, Maybe Int) -> FormatState -> FormatState -applyColors (fore, back) = aux fmtFore fore . aux fmtBack back - where - aux _ Nothing = id - aux l (Just x) = set l (mircColor x) - -mircColor :: Int -> Maybe Color -mircColor 0 = Just (white ) -- white -mircColor 1 = Just (black ) -- black -mircColor 2 = Just (blue ) -- blue -mircColor 3 = Just (green ) -- green -mircColor 4 = Just (red ) -- red -mircColor 5 = Just (rgbColor' 127 0 0 ) -- brown -mircColor 6 = Just (rgbColor' 156 0 156 ) -- purple -mircColor 7 = Just (rgbColor' 252 127 0 ) -- yellow -mircColor 8 = Just (yellow ) -- yellow -mircColor 9 = Just (brightGreen ) -- green -mircColor 10 = Just (cyan ) -- brightBlue -mircColor 11 = Just (brightCyan ) -- brightCyan -mircColor 12 = Just (brightBlue ) -- brightBlue -mircColor 13 = Just (rgbColor' 255 0 255 ) -- brightRed -mircColor 14 = Just (rgbColor' 127 127 127) -- brightBlack -mircColor 15 = Just (rgbColor' 210 210 210) -- brightWhite -mircColor _ = Nothing - -rgbColor' :: Int -> Int -> Int -> Color -rgbColor' = rgbColor -- fix the type to Int - -applyControlEffect :: Char -> FormatState -> Maybe FormatState -applyControlEffect '\^B' = Just . over fmtBold not -applyControlEffect '\^O' = Just . const defaultFormatState -applyControlEffect '\^V' = Just . over fmtReverse not -applyControlEffect '\^]' = Just . over fmtItalic not -applyControlEffect '\^_' = Just . over fmtUnderline not -applyControlEffect _ = const Nothing - -controlAttr :: Attr -controlAttr = defAttr `withStyle` reverseVideo - -controlName :: Char -> Char -controlName c = chr (ord '@' + ord c) diff --git a/src/Client/Network/Async.hs b/src/Client/Network/Async.hs new file mode 100644 --- /dev/null +++ b/src/Client/Network/Async.hs @@ -0,0 +1,159 @@ +{-# Options_GHC -Wno-unused-do-bind #-} + +{-| +Module : Client.Network.Async +Description : Event-based network IO +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module creates network connections and thread to manage those connections. +Events on these connections will be written to a given event queue, and +outgoing messages are recieved on an incoming event queue. + +These network connections are rate limited for outgoing messages per the +rate limiting algorithm given in the IRC RFC. + +Incoming network event messages are assumed to be framed by newlines. + +When a network connection terminates normally its final messages will be +'NetworkClose'. When it terminates abnormally its final message will be +'NetworkError'. + +-} + +module Client.Network.Async + ( NetworkConnection + , NetworkId + , NetworkEvent(..) + , createConnection + , abortConnection + , send + ) where + +import Client.Configuration.ServerSettings +import Client.Network.Connect +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception +import Control.Lens +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Time +import Irc.RateLimit +import Network.Connection + + +-- | Identifier used to match connection events to connections. +type NetworkId = Int + +-- | Handle for a network connection +data NetworkConnection = NetworkConnection + { connOutQueue :: !(TQueue ByteString) + , connAsync :: !(Async ()) + } + +-- | The sum of incoming events from a network connection. All events +-- are annotated with a network ID matching that given when the connection +-- was created as well as the time at which the message was recieved. +data NetworkEvent + = NetworkLine !NetworkId !ZonedTime !ByteString + -- ^ Event for a new recieved line (newline removed) + | NetworkError !NetworkId !ZonedTime !SomeException + -- ^ Final message indicating the network connection failed + | NetworkClose !NetworkId !ZonedTime + -- ^ Final message indicating the network connection finished + +instance Show NetworkConnection where + showsPrec p _ = showParen (p > 10) + $ showString "NetworkConnection _" + +-- | Schedule a message to be transmitted on the network connection. +-- These messages are sent unmodified. The message should contain a +-- newline terminator. +send :: NetworkConnection -> ByteString -> IO () +send c msg = atomically (writeTQueue (connOutQueue c) msg) + +-- | Force the given connection to terminate. +abortConnection :: NetworkConnection -> IO () +abortConnection = cancel . connAsync + +-- | Initiate a new network connection according to the given 'ServerSettings'. +-- All events on this connection will be added to the given queue. The resulting +-- 'NetworkConnection' value can be used for sending outgoing messages and for +-- early termination of the connection. +createConnection :: + NetworkId {- ^ Identifier to be used on incoming events -} -> + ConnectionContext -> + ServerSettings -> + TQueue NetworkEvent {- Queue for incoming events -} -> + IO NetworkConnection +createConnection network cxt settings inQueue = + do outQueue <- atomically newTQueue + + supervisor <- async (startConnection network cxt settings inQueue outQueue) + + -- Having this reporting thread separate from the supervisor ensures + -- that canceling the supervisor with abortConnection doesn't interfere + -- with carefully reporting the outcome + forkIO $ do outcome <- waitCatch supervisor + case outcome of + Right{} -> recordNormalExit + Left e -> recordFailure e + + return NetworkConnection + { connOutQueue = outQueue + , connAsync = supervisor + } + where + recordFailure :: SomeException -> IO () + recordFailure ex = + do now <- getZonedTime + atomically (writeTQueue inQueue (NetworkError network now ex)) + + recordNormalExit :: IO () + recordNormalExit = + do now <- getZonedTime + atomically (writeTQueue inQueue (NetworkClose network now)) + + +startConnection :: + NetworkId -> + ConnectionContext -> + ServerSettings -> + TQueue NetworkEvent -> + TQueue ByteString -> + IO () +startConnection network cxt settings onInput outQueue = + do rate <- newRateLimit + (view ssFloodPenalty settings) + (view ssFloodThreshold settings) + withConnection cxt settings $ \h -> + withAsync (sendLoop h outQueue rate) $ \sender -> + withAsync (receiveLoop network h onInput) $ \receiver -> + do res <- waitEitherCatch sender receiver + case res of + Left Right{} -> fail "PANIC: sendLoop returned" + Right Right{} -> return () + Left (Left e) -> throwIO e + Right (Left e) -> throwIO e + +sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO () +sendLoop h outQueue rate = + forever $ + do msg <- atomically (readTQueue outQueue) + tickRateLimit rate + connectionPut h msg + +ircMaxMessageLength :: Int +ircMaxMessageLength = 512 + +receiveLoop :: NetworkId -> Connection -> TQueue NetworkEvent -> IO () +receiveLoop network h inQueue = + do msg <- connectionGetLine ircMaxMessageLength h + unless (B.null msg) $ + do now <- getZonedTime + atomically (writeTQueue inQueue (NetworkLine network now (B.init msg))) + receiveLoop network h inQueue diff --git a/src/Client/Network/Connect.hs b/src/Client/Network/Connect.hs new file mode 100644 --- /dev/null +++ b/src/Client/Network/Connect.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : Client.Network.Connect +Description : Interface to the connection package +Copyright : (c) Eric Mertens, 2016 +License : ISC +Maintainer : emertens@gmail.com + +This module is responsible for creating 'Connection' values +for a particular server as specified by a 'ServerSettings'. +This involves setting up certificate stores an mapping +network settings from the client configuration into the +network connection library. +-} + +module Client.Network.Connect + ( withConnection + ) where + +import Client.Configuration +import Client.Configuration.ServerSettings +import Control.Exception (bracket) +import Control.Lens +import Control.Monad +import Data.Default.Class (def) +import Data.Monoid ((<>)) +import Data.X509 (CertificateChain(..)) +import Data.X509.CertificateStore (CertificateStore, makeCertificateStore) +import Data.X509.File (readSignedObject, readKeyFile) +import Network.Connection +import Network.Socket (PortNumber) +import Network.TLS +import Network.TLS.Extra (ciphersuite_strong) +import System.X509 (getSystemCertificateStore) + +buildConnectionParams :: ServerSettings -> IO ConnectionParams +buildConnectionParams args = + do useSecure <- if view ssTls args + then fmap Just (buildTlsSettings args) + else return Nothing + + let proxySettings = view ssSocksHost args <&> \host -> + SockSettingsSimple + host + (view ssSocksPort args) + + return ConnectionParams + { connectionHostname = view ssHostName args + , connectionPort = ircPort args + , connectionUseSecure = useSecure + , connectionUseSocks = proxySettings + } + +ircPort :: ServerSettings -> PortNumber +ircPort args = + case view ssPort args of + Just p -> fromIntegral p + Nothing | view ssTls args -> 6697 + | otherwise -> 6667 + +buildCertificateStore :: ServerSettings -> IO CertificateStore +buildCertificateStore args = + do systemStore <- getSystemCertificateStore + userCerts <- traverse (readSignedObject <=< resolveConfigurationPath) + (view ssServerCerts args) + let userStore = makeCertificateStore (concat userCerts) + return (userStore <> systemStore) + +buildTlsSettings :: ServerSettings -> IO TLSSettings +buildTlsSettings args = + do store <- buildCertificateStore args + + let noValidation = + ValidationCache + (\_ _ _ -> return ValidationCachePass) + (\_ _ _ -> return ()) + + return $ TLSSettings ClientParams + { clientWantSessionResume = Nothing + , clientUseMaxFragmentLength = Nothing + , clientServerIdentification = + error "buildTlsSettings: field initialized by connectTo" + , clientUseServerNameIndication = False + , clientShared = def + { sharedCAStore = store + , sharedValidationCache = + if view ssTlsInsecure args then noValidation else def + } + , clientHooks = def + { onCertificateRequest = \_ -> loadClientCredentials args } + , clientSupported = def + { supportedCiphers = ciphersuite_strong } + , clientDebug = def + } + +loadClientCredentials :: ServerSettings -> IO (Maybe (CertificateChain, PrivKey)) +loadClientCredentials args = + case view ssTlsClientCert args of + Nothing -> return Nothing + Just certPath -> + do certPath' <- resolveConfigurationPath certPath + cert <- readSignedObject certPath' + + keyPath <- case view ssTlsClientKey args of + Nothing -> return certPath' + Just keyPath -> resolveConfigurationPath keyPath + keys <- readKeyFile keyPath + case keys of + [key] -> return (Just (CertificateChain cert, key)) + [] -> fail "No private keys found" + _ -> fail "Too many private keys found" + +-- | Create a new 'Connection' which will be closed when the continuation finishes. +withConnection :: ConnectionContext -> ServerSettings -> (Connection -> IO a) -> IO a +withConnection cxt settings k = + do params <- buildConnectionParams settings + bracket (connectTo cxt params) connectionClose k diff --git a/src/Client/NetworkConnection.hs b/src/Client/NetworkConnection.hs deleted file mode 100644 --- a/src/Client/NetworkConnection.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# Options_GHC -Wno-unused-do-bind #-} - -{-| -Module : Client.NetworkConnection -Description : Event-based network IO -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module creates network connections and thread to manage those connections. -Events on these connections will be written to a given event queue, and -outgoing messages are recieved on an incoming event queue. - -These network connections are rate limited for outgoing messages per the -rate limiting algorithm given in the IRC RFC. - -Incoming network event messages are assumed to be framed by newlines. - -When a network connection terminates normally its final messages will be -'NetworkClose'. When it terminates abnormally its final message will be -'NetworkError'. - --} - -module Client.NetworkConnection - ( NetworkConnection - , NetworkId - , NetworkEvent(..) - , createConnection - , abortConnection - , send - ) where - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Concurrent.Async -import Control.Exception -import Control.Lens -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Time -import Network.Connection - -import Irc.RateLimit -import Client.Connect -import Client.ServerSettings - --- | Identifier used to match connection events to connections. -type NetworkId = Int - --- | Handle for a network connection -data NetworkConnection = NetworkConnection - { connOutQueue :: !(TQueue ByteString) - , connAsync :: !(Async ()) - } - --- | The sum of incoming events from a network connection. All events --- are annotated with a network ID matching that given when the connection --- was created as well as the time at which the message was recieved. -data NetworkEvent - = NetworkLine !NetworkId !ZonedTime !ByteString - -- ^ Event for a new recieved line (newline removed) - | NetworkError !NetworkId !ZonedTime !SomeException - -- ^ Final message indicating the network connection failed - | NetworkClose !NetworkId !ZonedTime - -- ^ Final message indicating the network connection finished - -instance Show NetworkConnection where - showsPrec p _ = showParen (p > 10) - $ showString "NetworkConnection _" - --- | Schedule a message to be transmitted on the network connection. --- These messages are sent unmodified. The message should contain a --- newline terminator. -send :: NetworkConnection -> ByteString -> IO () -send c msg = atomically (writeTQueue (connOutQueue c) msg) - --- | Force the given connection to terminate. -abortConnection :: NetworkConnection -> IO () -abortConnection = cancel . connAsync - --- | Initiate a new network connection according to the given 'ServerSettings'. --- All events on this connection will be added to the given queue. The resulting --- 'NetworkConnection' value can be used for sending outgoing messages and for --- early termination of the connection. -createConnection :: - NetworkId {- ^ Identifier to be used on incoming events -} -> - ConnectionContext -> - ServerSettings -> - TQueue NetworkEvent {- Queue for incoming events -} -> - IO NetworkConnection -createConnection network cxt settings inQueue = - do outQueue <- atomically newTQueue - - supervisor <- async (startConnection network cxt settings inQueue outQueue) - - -- Having this reporting thread separate from the supervisor ensures - -- that canceling the supervisor with abortConnection doesn't interfere - -- with carefully reporting the outcome - forkIO $ do outcome <- waitCatch supervisor - case outcome of - Right{} -> recordNormalExit - Left e -> recordFailure e - - return NetworkConnection - { connOutQueue = outQueue - , connAsync = supervisor - } - where - recordFailure :: SomeException -> IO () - recordFailure ex = - do now <- getZonedTime - atomically (writeTQueue inQueue (NetworkError network now ex)) - - recordNormalExit :: IO () - recordNormalExit = - do now <- getZonedTime - atomically (writeTQueue inQueue (NetworkClose network now)) - - -startConnection :: - NetworkId -> - ConnectionContext -> - ServerSettings -> - TQueue NetworkEvent -> - TQueue ByteString -> - IO () -startConnection network cxt settings onInput outQueue = - do rate <- newRateLimit - (view ssFloodPenalty settings) - (view ssFloodThreshold settings) - withConnection cxt settings $ \h -> - withAsync (sendLoop h outQueue rate) $ \sender -> - withAsync (receiveLoop network h onInput) $ \receiver -> - do res <- waitEitherCatch sender receiver - case res of - Left Right{} -> fail "PANIC: sendLoop returned" - Right Right{} -> return () - Left (Left e) -> throwIO e - Right (Left e) -> throwIO e - -sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO () -sendLoop h outQueue rate = - forever $ - do msg <- atomically (readTQueue outQueue) - tickRateLimit rate - connectionPut h msg - -ircMaxMessageLength :: Int -ircMaxMessageLength = 512 - -receiveLoop :: NetworkId -> Connection -> TQueue NetworkEvent -> IO () -receiveLoop network h inQueue = - do msg <- connectionGetLine ircMaxMessageLength h - unless (B.null msg) $ - do now <- getZonedTime - atomically (writeTQueue inQueue (NetworkLine network now (B.init msg))) - receiveLoop network h inQueue diff --git a/src/Client/ServerSettings.hs b/src/Client/ServerSettings.hs deleted file mode 100644 --- a/src/Client/ServerSettings.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{-| -Module : Client.ServerSettings -Description : Settings for an individual IRC connection -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module defines the settings used for an individual IRC connection. -These are static settings that are not expected change over the lifetime -of a connection. --} - -module Client.ServerSettings - ( - -- * Server settings type - ServerSettings(..) - , ssNick - , ssUser - , ssReal - , ssUserInfo - , ssPassword - , ssSaslUsername - , ssSaslPassword - , ssHostName - , ssPort - , ssTls - , ssTlsInsecure - , ssTlsClientCert - , ssTlsClientKey - , ssConnectCmds - , ssSocksHost - , ssSocksPort - , ssServerCerts - , ssChanservChannels - , ssFloodPenalty - , ssFloodThreshold - , ssMessageHooks - , ssName - - -- * Load function - , loadDefaultServerSettings - - ) where - -import Control.Lens -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Irc.Identifier (Identifier) -import System.Environment -import qualified Data.Text as Text - -import Network.Socket (HostName, PortNumber) - --- | Static server-level settings -data ServerSettings = ServerSettings - { _ssNick :: !Text -- ^ connection nickname - , _ssUser :: !Text -- ^ connection username - , _ssReal :: !Text -- ^ connection realname / GECOS - , _ssUserInfo :: !Text -- ^ CTCP userinfo - , _ssPassword :: !(Maybe Text) -- ^ server password - , _ssSaslUsername :: !(Maybe Text) -- ^ SASL username - , _ssSaslPassword :: !(Maybe Text) -- ^ SASL password - , _ssHostName :: !HostName -- ^ server hostname - , _ssPort :: !(Maybe PortNumber) -- ^ server port - , _ssTls :: !Bool -- ^ use TLS to connect - , _ssTlsInsecure :: !Bool -- ^ disable certificate checking - , _ssTlsClientCert :: !(Maybe FilePath) -- ^ path to client TLS certificate - , _ssTlsClientKey :: !(Maybe FilePath) -- ^ path to client TLS key - , _ssConnectCmds :: ![Text] -- ^ raw IRC messages to transmit upon successful connection - , _ssSocksHost :: !(Maybe HostName) -- ^ hostname of SOCKS proxy - , _ssSocksPort :: !PortNumber -- ^ port of SOCKS proxy - , _ssServerCerts :: ![FilePath] -- ^ additional CA certificates for validating server - , _ssChanservChannels :: ![Identifier] -- ^ Channels with chanserv permissions - , _ssFloodPenalty :: !Rational -- ^ Flood limiter penalty (seconds) - , _ssFloodThreshold :: !Rational -- ^ Flood limited threshold (seconds) - , _ssMessageHooks :: ![Text] -- ^ Initial message hooks - , _ssName :: !(Maybe Text) -- ^ The name referencing the server in commands - } - deriving Show - -makeLenses ''ServerSettings - --- | Load the defaults for server settings based on the environment --- variables. --- --- @USER@, @IRCPASSSWORD@, and @SASLPASSWORD@ are used. -loadDefaultServerSettings :: IO ServerSettings -loadDefaultServerSettings = - do env <- getEnvironment - let username = Text.pack (fromMaybe "guest" (lookup "USER" env)) - return ServerSettings - { _ssNick = username - , _ssUser = username - , _ssReal = username - , _ssUserInfo = username - , _ssPassword = Text.pack <$> lookup "IRCPASSWORD" env - , _ssSaslUsername = Nothing - , _ssSaslPassword = Text.pack <$> lookup "SASLPASSWORD" env - , _ssHostName = "" - , _ssPort = Nothing - , _ssTls = False - , _ssTlsInsecure = False - , _ssTlsClientCert = Nothing - , _ssTlsClientKey = Nothing - , _ssConnectCmds = [] - , _ssSocksHost = Nothing - , _ssSocksPort = 1080 - , _ssServerCerts = [] - , _ssChanservChannels = [] - , _ssFloodPenalty = 2 -- RFC 1459 defaults - , _ssFloodThreshold = 10 - , _ssMessageHooks = [] - , _ssName = Nothing - } diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -32,7 +32,10 @@ , clientIgnores , clientConnection , clientBell + , clientExtensions , initialClientState + , clientShutdown + , clientStartExtensions -- * Client operations , clientMatcher @@ -52,43 +55,46 @@ , recordNetworkMessage , recordIrcMessage - -- * Focus information - , ClientFocus(..) - , _ChannelFocus - , _NetworkFocus - , _Unfocused - , ClientSubfocus(..) - , focusNetwork + -- * Focus manipulation , changeFocus , changeSubfocus , advanceFocus , retreatFocus + , jumpToActivity + , jumpFocus + -- * Scrolling + , pageUp + , pageDown + ) where +import Client.CApi import Client.ChannelState import Client.Configuration +import Client.Configuration.ServerSettings import Client.ConnectionState import qualified Client.EditBox as Edit +import Client.Focus import Client.Image.Message import Client.Message -import Client.NetworkConnection -import Client.ServerSettings +import Client.Network.Async import Client.Window import Control.Concurrent.STM import Control.DeepSeq +import Control.Exception 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) import qualified Data.HashSet as HashSet import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map -import Data.Monoid import Data.Text (Text) import qualified Data.Text as Text import Data.Time @@ -99,42 +105,11 @@ import Irc.RawIrcMsg import Irc.UserInfo import LensUtils +import Network.Connection (ConnectionContext, initConnectionContext) import Text.Regex.TDFA import Text.Regex.TDFA.String (compile) import Text.Regex.TDFA.Text () -- RegexLike Regex Text orphan -import Network.Connection --- | Currently focused window -data ClientFocus - = Unfocused -- ^ No network - | NetworkFocus !Text -- ^ Network - | ChannelFocus !Text !Identifier -- ^ Network Channel/Nick - deriving Eq - -makePrisms ''ClientFocus - --- | Subfocus for a channel view -data ClientSubfocus - = FocusMessages -- ^ Show chat messages - | FocusInfo -- ^ Show channel metadata - | FocusUsers -- ^ Show user list - | FocusMasks !Char -- ^ Show mask list for given mode - deriving Eq - --- | Unfocused first, followed by focuses sorted by network. --- Within the same network the network focus comes first and --- then the channels are ordered by channel identifier -instance Ord ClientFocus where - compare Unfocused Unfocused = EQ - compare (NetworkFocus x) (NetworkFocus y ) = compare x y - compare (ChannelFocus x1 x2) (ChannelFocus y1 y2) = compare x1 y1 <> compare x2 y2 - - compare Unfocused _ = LT - compare _ Unfocused = GT - - compare (NetworkFocus x ) (ChannelFocus y _) = compare x y <> LT - compare (ChannelFocus x _) (NetworkFocus y ) = compare x y <> GT - -- | All state information for the IRC client data ClientState = ClientState { _clientWindows :: !(Map ClientFocus Window) -- ^ client message buffers @@ -157,6 +132,8 @@ , _clientBell :: !Bool -- ^ sound a bell next draw , _clientIgnores :: !(HashSet Identifier) -- ^ ignored nicknames + + , _clientExtensions :: [ActiveExtension] -- ^ Active extensions } makeLenses ''ClientState @@ -180,12 +157,6 @@ clientLine :: ClientState -> (Int, String) {- ^ line number, line content -} clientLine = views (clientTextBox . Edit.line) (\(Edit.Line n t) -> (n, t)) --- | Return the network associated with the current focus -focusNetwork :: ClientFocus -> Maybe Text {- ^ network -} -focusNetwork Unfocused = Nothing -focusNetwork (NetworkFocus network) = Just network -focusNetwork (ChannelFocus network _) = Just network - -- | Construct an initial 'ClientState' using default values. initialClientState :: Configuration -> Vty -> IO ClientState initialClientState cfg vty = @@ -194,22 +165,23 @@ events <- atomically newTQueue return ClientState { _clientWindows = _Empty # () + , _clientNetworkMap = _Empty # () + , _clientIgnores = _Empty # () + , _clientConnections = _Empty # () , _clientTextBox = Edit.empty - , _clientConnections = IntMap.empty , _clientWidth = width , _clientHeight = height , _clientVty = vty , _clientEvents = events , _clientFocus = Unfocused + , _clientSubfocus = FocusMessages , _clientConnectionContext = cxt , _clientConfig = cfg , _clientScroll = 0 , _clientDetailView = False - , _clientSubfocus = FocusMessages , _clientNextConnectionId = 0 - , _clientNetworkMap = HashMap.empty - , _clientIgnores = HashSet.empty , _clientBell = False + , _clientExtensions = [] } -- | Forcefully terminate the connection currently associated @@ -249,6 +221,17 @@ (statusModes, channel') = splitStatusMsgModes possibleStatusModes channel importance = msgImportance msg st + +-- | Extract the status mode sigils from a message target. +splitStatusMsgModes :: + [Char] {- ^ possible modes -} -> + Identifier {- ^ target -} -> + ([Char], Identifier) {- ^ actual modes, actual target -} +splitStatusMsgModes possible ident = (Text.unpack modes, mkId ident') + where + (modes, ident') = Text.span (`elem` possible) (idText ident) + + -- | Compute the importance of a message to be used when computing -- change notifications in the client. msgImportance :: ClientMessage -> ClientState -> WindowLineImportance @@ -261,8 +244,8 @@ _ -> WLNormal in case view msgBody msg of - ExitBody -> WLImportant - ErrorBody _ -> WLImportant + NormalBody{} -> WLImportant + ErrorBody{} -> WLImportant IrcBody irc | squelchIrcMsg irc -> WLBoring | isJust (ircIgnorable irc st) -> WLBoring @@ -334,15 +317,6 @@ Just m -> [chan | (chan, cs) <- HashMap.toList m , HashMap.member user (view chanUsers cs) ] --- | Extract the status mode sigils from a message target. -splitStatusMsgModes :: - [Char] {- ^ possible modes -} -> - Identifier {- ^ target -} -> - ([Char], Identifier) {- ^ actual modes, actual target -} -splitStatusMsgModes possible ident = (Text.unpack modes, mkId ident') - where - (modes, ident') = Text.span (`elem` possible) (idText ident) - -- | Compute the sigils of the user who sent a message. computeMsgLineSigils :: Text {- ^ network -} -> @@ -371,7 +345,9 @@ recordNetworkMessage :: ClientMessage -> ClientState -> ClientState recordNetworkMessage msg st = recordWindowLine focus importance wl st where - focus = NetworkFocus (view msgNetwork msg) + network = view msgNetwork msg + focus | Text.null network = Unfocused + | otherwise = NetworkFocus (view msgNetwork msg) importance = msgImportance msg st wl = toWindowLine' cfg msg @@ -423,33 +399,6 @@ consumeInput :: ClientState -> ClientState consumeInput = over clientTextBox Edit.success --- | Step focus to the next window when on message view. Otherwise --- switch to message view. -advanceFocus :: ClientState -> ClientState -advanceFocus = stepFocus False - --- | Step focus to the previous window when on message view. Otherwise --- switch to message view. -retreatFocus :: ClientState -> ClientState -retreatFocus = stepFocus True - --- | Step focus to the next window when on message view. Otherwise --- switch to message view. Reverse the step order when argument is 'True'. -stepFocus :: Bool {- ^ reversed -} -> ClientState -> ClientState -stepFocus isReversed st - | view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st - - | isReversed, Just ((k,_),_) <- Map.maxViewWithKey l = changeFocus k st - | isReversed, Just ((k,_),_) <- Map.maxViewWithKey r = changeFocus k st - - | isForward , Just ((k,_),_) <- Map.minViewWithKey r = changeFocus k st - | isForward , Just ((k,_),_) <- Map.minViewWithKey l = changeFocus k st - - | otherwise = st - where - isForward = not isReversed - (l,r) = Map.split (view clientFocus st) (view clientWindows st) - -- | Returns the current network's channels and current channel's users. currentCompletionList :: ClientState -> [Identifier] currentCompletionList st = @@ -474,17 +423,6 @@ channelUserList network channel = views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys -changeFocus :: ClientFocus -> ClientState -> ClientState -changeFocus focus - = set clientScroll 0 - . set clientFocus focus - . set clientSubfocus FocusMessages - -changeSubfocus :: ClientSubfocus -> ClientState -> ClientState -changeSubfocus focus - = set clientScroll 0 - . set clientSubfocus focus - -- | Construct a text matching predicate used to filter the message window. clientMatcher :: ClientState -> Text -> Bool clientMatcher st = @@ -580,3 +518,122 @@ | otherwise = x applyWindowRenames _ _ st = st + +clientShutdown :: ClientState -> IO () +clientShutdown st = () <$ clientStopExtensions st + -- other shutdown stuff might be added here later + +clientStopExtensions :: ClientState -> IO ClientState +clientStopExtensions st = + do let (aes,st1) = (clientExtensions <<.~ []) st + (st2,_) <- withStableMVar 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) <- withStableMVar st1 $ \ptr -> + traverse (try . activateExtension ptr <=< resolveConfigurationPath) + (view configExtensions cfg) + + let (errors, exts) = partitionEithers res + st3 <- recordErrors errors st2 + return $! set clientExtensions 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 +------------------------------------------------------------------------ + +-- | Scroll the current buffer to show older messages +pageUp :: ClientState -> ClientState +pageUp st = over clientScroll (+ scrollAmount st) st + +-- | Scroll the current buffer to show newer messages +pageDown :: ClientState -> ClientState +pageDown st = over clientScroll (max 0 . subtract (scrollAmount st)) st + +-- | Compute the number of lines in a page at the current window size +scrollAmount :: ClientState -> Int +scrollAmount st = max 1 (view clientHeight st - 2) + + +------------------------------------------------------------------------ +-- Focus Management +------------------------------------------------------------------------ + +-- | Jump the focus of the client to a buffer that has unread activity. +-- Some events like errors or chat messages mentioning keywords are +-- considered important and will be jumped to first. +jumpToActivity :: ClientState -> ClientState +jumpToActivity st = + case mplus highPriority lowPriority of + Just (focus,_) -> changeFocus focus st + Nothing -> st + where + windowList = views clientWindows Map.toList st + highPriority = find (view winMention . snd) windowList + lowPriority = find (\x -> view winUnread (snd x) > 0) windowList + +-- | Jump the focus directly to a window based on its zero-based index. +jumpFocus :: + Int {- ^ zero-based window index -} -> + ClientState -> ClientState +jumpFocus i st + | 0 <= i, i < Map.size windows = changeFocus focus st + | otherwise = st + where + windows = view clientWindows st + (focus,_) = Map.elemAt i windows + +changeFocus :: ClientFocus -> ClientState -> ClientState +changeFocus focus + = set clientScroll 0 + . set clientFocus focus + . set clientSubfocus FocusMessages + +changeSubfocus :: ClientSubfocus -> ClientState -> ClientState +changeSubfocus focus + = set clientScroll 0 + . set clientSubfocus focus + +-- | Step focus to the next window when on message view. Otherwise +-- switch to message view. +advanceFocus :: ClientState -> ClientState +advanceFocus = stepFocus False + +-- | Step focus to the previous window when on message view. Otherwise +-- switch to message view. +retreatFocus :: ClientState -> ClientState +retreatFocus = stepFocus True + +-- | Step focus to the next window when on message view. Otherwise +-- switch to message view. Reverse the step order when argument is 'True'. +stepFocus :: Bool {- ^ reversed -} -> ClientState -> ClientState +stepFocus isReversed st + | view clientSubfocus st /= FocusMessages = changeSubfocus FocusMessages st + + | isReversed, Just ((k,_),_) <- Map.maxViewWithKey l = changeFocus k st + | isReversed, Just ((k,_),_) <- Map.maxViewWithKey r = changeFocus k st + + | isForward , Just ((k,_),_) <- Map.minViewWithKey r = changeFocus k st + | isForward , Just ((k,_),_) <- Map.minViewWithKey l = changeFocus k st + + | otherwise = st + where + isForward = not isReversed + (l,r) = Map.split (view clientFocus st) (view clientWindows st) diff --git a/src/Client/Window.hs b/src/Client/Window.hs --- a/src/Client/Window.hs +++ b/src/Client/Window.hs @@ -43,7 +43,7 @@ -- | A single message to be displayed in a window data WindowLine = WindowLine { _wlBody :: !MessageBody -- ^ Original Haskell value - , _wlText :: !Text -- ^ Searchable text form + , _wlText :: {-# UNPACK #-} !Text -- ^ Searchable text form , _wlImage :: !Image -- ^ Normal rendered image , _wlFullImage :: !Image -- ^ Detailed rendered image } @@ -77,10 +77,12 @@ -- | Adds a given line to a window as the newest message. Window's -- unread count will be updated according to the given importance. addToWindow :: WindowLineImportance -> WindowLine -> Window -> Window -addToWindow importance msg !win = Window +addToWindow importance !msg !win = Window { _winMessages = msg : _winMessages win - , _winUnread = _winUnread win + (if importance == WLBoring then 0 else 1) - , _winMention = _winMention win || importance == WLImportant + , _winUnread = _winUnread win + + (if importance == WLBoring then 0 else 1) + , _winMention = _winMention win + || importance == WLImportant } -- | Update the window clearing the unread count and important flag. diff --git a/src/Client/WordCompletion.hs b/src/Client/WordCompletion.hs deleted file mode 100644 --- a/src/Client/WordCompletion.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-| -Module : Client.WordCompletion -Description : Tab-completion logic -Copyright : (c) Eric Mertens, 2016 -License : ISC -Maintainer : emertens@gmail.com - -This module provides the tab-completion logic used for nicknames and channels. - --} -module Client.WordCompletion - ( wordComplete - ) where - -import Irc.Identifier -import Control.Applicative -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Set as Set -import Data.Char -import Data.List -import Control.Lens -import qualified Client.EditBox as Edit -import Control.Monad - --- | Perform word completion on a text box. --- --- The leading update operation is applied to the result of tab-completion --- when tab completing from the beginning of the text box. This is useful --- when auto-completing a nick and including a trailing colon. --- --- The @reversed@ parameter indicates that tab-completion should return the --- previous entry. When starting a fresh tab completion the priority completions --- will be considered in order before resorting to the set of possible --- completions. -wordComplete :: - (String -> String) {- ^ leading update operation -} -> - Bool {- ^ reversed -} -> - [Identifier] {- ^ priority completions -} -> - [Identifier] {- ^ possible completions -} -> - Edit.EditBox -> Maybe Edit.EditBox -wordComplete leadingCase isReversed hint vals box = - do let current = currentWord box - guard (not (null current)) - let cur = mkId (Text.pack current) - case view Edit.tabSeed box of - Just patternStr - | idPrefix pat cur -> - - do next <- tabSearch isReversed pat cur vals - Just $ replaceWith leadingCase (idString next) box - where - pat = mkId (Text.pack patternStr) - - _ -> - do next <- find (idPrefix cur) hint <|> - tabSearch isReversed cur cur vals - Just $ set Edit.tabSeed (Just current) - $ replaceWith leadingCase (idString next) box - -replaceWith :: (String -> String) -> String -> Edit.EditBox -> Edit.EditBox -replaceWith leadingCase str box = - let box1 = Edit.killWordBackward False box - str1 | view Edit.pos box1 == 0 = leadingCase str - | otherwise = str - in over Edit.content (Edit.insertString str1) box1 - -idString :: Identifier -> String -idString = Text.unpack . idText - -currentWord :: Edit.EditBox -> String -currentWord box - = reverse - $ takeWhile (not . isSpace) - $ dropWhile (\x -> x==' ' || x==':') - $ reverse - $ take n txt - where Edit.Line n txt = view (Edit.content . Edit.current) box - -class Prefix a where isPrefix :: a -> a -> Bool -instance Prefix Identifier where isPrefix = idPrefix -instance Prefix Text where isPrefix = Text.isPrefixOf -instance Eq a => Prefix [a] where isPrefix = isPrefixOf - -tabSearch :: (Ord a, Prefix a) => Bool -> a -> a -> [a] -> Maybe a -tabSearch isReversed pat cur vals - | Just next <- advanceFun cur valSet - , isPrefix pat next - = Just next - - | isReversed = find (isPrefix pat) (reverse (Set.toList valSet)) - - | otherwise = do x <- Set.lookupGE pat valSet - guard (isPrefix pat x) - Just x - where - valSet = Set.fromList vals - - advanceFun | isReversed = Set.lookupLT - | otherwise = Set.lookupGT - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -17,12 +17,14 @@ import Data.Default.Class import Data.Text (Text) import Graphics.Vty -import System.IO import System.Exit +import System.IO -import Client.EventLoop -import Client.Configuration +import Client.CApi.Exports () -- foreign exports import Client.CommandArguments +import Client.Configuration +import Client.EventLoop +import Client.Focus import Client.State -- | Initialize a 'Vty' value and run a continuation. Shutdown the 'Vty' @@ -37,9 +39,10 @@ cfg <- loadConfiguration' (view cmdArgConfigFile args) withVty $ \vty -> runInUnboundThread $ - do st <- initialClientState cfg vty - st' <- addInitialNetworks (view cmdArgInitialNetworks args) st - eventLoop st' + initialClientState cfg vty >>= + clientStartExtensions >>= + addInitialNetworks (view cmdArgInitialNetworks args) >>= + eventLoop -- | Load configuration and handle errors along the way. loadConfiguration' :: Maybe FilePath -> IO Configuration