glirc 2.8 → 2.9

raw patch · 31 files changed

+1737/−919 lines, 31 filesdep +unixdep ~irc-core

Dependencies added: unix

Dependency ranges changed: irc-core

Files

• ChangeLog.md +7/−0
• README.md +14/−6
• exported_symbols.txt +9/−0
• glirc.cabal +21/−8
• src/Client/CApi.hs +186/−0
• src/Client/CApi/Exports.hs +247/−0
• src/Client/CApi/Types.hsc +192/−0
• src/Client/Commands.hs +43/−20
• src/Client/Commands/Interpolation.hs +3/−2
• src/Client/Commands/WordCompletion.hs +101/−0
• src/Client/Configuration.hs +6/−1
• src/Client/Configuration/ServerSettings.hs +116/−0
• src/Client/Connect.hs +0/−118
• src/Client/ConnectionState.hs +5/−3
• src/Client/EventLoop.hs +22/−55
• src/Client/Focus.hs +77/−0
• src/Client/Hook/Znc/Buffextras.hs +1/−0
• src/Client/Image.hs +29/−24
• src/Client/Image/ChannelInfo.hs +1/−1
• src/Client/Image/Message.hs +43/−32
• src/Client/Image/MircFormatting.hs +154/−0
• src/Client/Message.hs +8/−6
• src/Client/MircFormatting.hs +0/−154
• src/Client/Network/Async.hs +159/−0
• src/Client/Network/Connect.hs +118/−0
• src/Client/NetworkConnection.hs +0/−159
• src/Client/ServerSettings.hs +0/−116
• src/Client/State.hs +160/−103
• src/Client/Window.hs +6/−4
• src/Client/WordCompletion.hs +0/−101
• src/Main.hs +9/−6

@@ -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`

@@ -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 <path>` - Load a new configuration file+* `/extension <extension name> <params>` - 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

@@ -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;+};

@@ -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

@@ -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

@@ -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))

@@ -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

@@ -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+

@@ -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 

@@ -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+

@@ -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 ->

@@ -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+       }

@@ -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

@@ -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)

@@ -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.

@@ -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

@@ -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]

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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-       }

@@ -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)

@@ -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.

@@ -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-

@@ -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