diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,14 @@ ## 2.32 +* Fixed cursor position with wide characters in input box +* Added ability to force request capabilities. +* Generalized `FreRelay` hook +* Add `show-accounts` setting to make account status visible +* Query channel modes on join + +## 2.32 + * Fix SASL EXTERNAL * Better /url matching * Support for config-schema improvements diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: glirc -version: 2.32 +version: 2.33 synopsis: Console IRC client description: Console IRC client . @@ -22,9 +22,9 @@ tested-with: GHC==8.6.5 custom-setup - setup-depends: base >=4.11 && <4.13, + setup-depends: base >=4.11 && <4.14, filepath >=1.4 && <1.5, - Cabal >=2.2 && <2.5, + Cabal >=2.2 && <4, source-repository head type: git @@ -54,7 +54,7 @@ includes: include/glirc-api.h install-includes: glirc-api.h default-language: Haskell2010 - build-tools: hsc2hs + build-tool-depends: hsc2hs:hsc2hs exposed-modules: Client.Authentication.Ecdsa Client.CApi @@ -106,6 +106,7 @@ Client.State.Focus Client.State.Network Client.State.Window + Client.UserHost Client.View Client.View.Cert Client.View.ChannelInfo @@ -136,24 +137,24 @@ autogen-modules: Paths_glirc Build_glirc - build-depends: base >=4.11 && <4.13, + build-depends: base >=4.11 && <4.14, HsOpenSSL >=0.11 && <0.12, async >=2.2 && <2.3, attoparsec >=0.13 && <0.14, base64-bytestring >=1.0.0.1&& <1.1, bytestring >=0.10.8 && <0.11, - config-schema ^>=1.1.0.0, - config-value ^>=0.6, + config-schema ^>=1.2.0.0, + config-value ^>=0.7, containers >=0.5.7 && <0.7, directory >=1.2.6 && <1.4, filepath >=1.4.1 && <1.5, free >=4.12 && <5.2, gitrev >=1.2 && <1.4, hashable >=1.2.4 && <1.4, - hookup >=0.2.3 && <0.3, + hookup >=0.2.3 && <0.4, irc-core >=2.7.1 && <2.8, kan-extensions >=5.0 && <5.3, - lens >=4.14 && <4.18, + lens >=4.14 && <4.19, network >=2.6.2 && <3.2, process >=1.4.2 && <1.7, psqueues >=0.2.7 && <0.3, @@ -162,7 +163,7 @@ semigroupoids >=5.1 && <5.4, split >=0.2 && <0.3, stm >=2.4 && <2.6, - template-haskell >=2.11 && <2.15, + template-haskell >=2.11 && <2.16, text >=1.2.2 && <1.3, time >=1.6 && <1.10, transformers >=0.5.2 && <0.6, diff --git a/src/Client/CApi/Exports.hs b/src/Client/CApi/Exports.hs --- a/src/Client/CApi/Exports.hs +++ b/src/Client/CApi/Exports.hs @@ -93,6 +93,7 @@ import Client.State.Focus import Client.State.Network import Client.State.Window +import Client.UserHost import Control.Concurrent.MVar import Control.Exception import Control.Lens diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -42,6 +42,7 @@ import Client.State.Focus import Client.State.Network import Client.State.Window +import Client.UserHost import Control.Applicative import Control.Concurrent.Async (cancel) import Control.Exception (displayException, try) diff --git a/src/Client/Configuration/ServerSettings.hs b/src/Client/Configuration/ServerSettings.hs --- a/src/Client/Configuration/ServerSettings.hs +++ b/src/Client/Configuration/ServerSettings.hs @@ -16,6 +16,7 @@ ( -- * Server settings type ServerSettings(..) + , HookConfig(..) , serverSpec , identifierSpec @@ -51,6 +52,8 @@ , ssSts , ssTlsPubkeyFingerprint , ssTlsCertFingerprint + , ssShowAccounts + , ssCapabilities -- * Load function , loadDefaultServerSettings @@ -68,7 +71,7 @@ import Control.Lens import qualified Data.ByteString as B import Data.Functor.Alt (()) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty((:|))) import Data.ByteString (ByteString) import Data.Maybe (fromMaybe) import Data.Monoid @@ -103,7 +106,7 @@ , _ssChanservChannels :: ![Identifier] -- ^ Channels with chanserv permissions , _ssFloodPenalty :: !Rational -- ^ Flood limiter penalty (seconds) , _ssFloodThreshold :: !Rational -- ^ Flood limited threshold (seconds) - , _ssMessageHooks :: ![Text] -- ^ Initial message hooks + , _ssMessageHooks :: ![HookConfig] -- ^ Initial message hooks , _ssName :: !(Maybe Text) -- ^ The name referencing the server in commands , _ssReconnectAttempts:: !Int -- ^ The number of reconnect attempts to make on error , _ssAutoconnect :: !Bool -- ^ Connect to this network on server startup @@ -113,9 +116,15 @@ , _ssSts :: !Bool -- ^ Honor STS policies when true , _ssTlsPubkeyFingerprint :: !(Maybe Fingerprint) -- ^ optional acceptable public key fingerprint , _ssTlsCertFingerprint :: !(Maybe Fingerprint) -- ^ optional acceptable certificate fingerprint + , _ssShowAccounts :: !Bool -- ^ Render account names + , _ssCapabilities :: ![Text] -- ^ Extra capabilities to unconditionally request } deriving Show +-- | Hook name and configuration arguments +data HookConfig = HookConfig Text [Text] + deriving Show + -- | Security setting for network connection data UseTls = UseTls -- ^ TLS connection @@ -172,6 +181,8 @@ , _ssSts = True , _ssTlsPubkeyFingerprint = Nothing , _ssTlsCertFingerprint = Nothing + , _ssShowAccounts = False + , _ssCapabilities = [] } serverSpec :: ValueSpec (ServerSettings -> ServerSettings) @@ -259,7 +270,7 @@ , req "flood-threshold" ssFloodThreshold anySpec "RFC 1459 rate limiting, seconds of allowed penalty accumulation (default 10)" - , req "message-hooks" ssMessageHooks anySpec + , req "message-hooks" ssMessageHooks (listSpec hookSpec) "Special message hooks to enable: \"buffextras\" available" , req "reconnect-attempts" ssReconnectAttempts anySpec @@ -285,7 +296,18 @@ , opt "tls-pubkey-fingerprint" ssTlsPubkeyFingerprint fingerprintSpec "Check SHA1, SHA256, or SHA512 public key fingerprint" + + , req "show-accounts" ssShowAccounts yesOrNoSpec + "Render account names alongside chat messages" + + , req "capabilities" ssCapabilities anySpec + "Extra capabilities to unconditionally request from the server" ] + +hookSpec :: ValueSpec HookConfig +hookSpec = + flip HookConfig [] <$> anySpec + (\(x:|xs) -> HookConfig x xs) <$> nonemptySpec anySpec -- | Match fingerprints in plain hex or colon-delimited bytes. -- SHA-1 is 20 bytes. SHA-2-256 is 32 bytes. SHA-2-512 is 64 bytes. diff --git a/src/Client/Configuration/Sts.hs b/src/Client/Configuration/Sts.hs --- a/src/Client/Configuration/Sts.hs +++ b/src/Client/Configuration/Sts.hs @@ -20,6 +20,7 @@ ) where import Config (Value(..), Section(..), parse, pretty) +import Config.Number (integerToNumber) import Config.Schema.Spec import Config.Schema.Load (loadValue) import Control.Exception (try) @@ -64,7 +65,7 @@ [ Section () "host" (Text () k), Section () "port" - (Number () 10 (fromIntegral (_stsPort v))), + (Number () (integerToNumber (fromIntegral (_stsPort v)))), Section () "until" (Text () (Text.pack diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -25,7 +25,6 @@ import Client.EventLoop.Errors (exceptionToLines) import Client.EventLoop.Network (clientResponse) import Client.Hook -import Client.Hooks import Client.Image import Client.Image.Layout (scrollAmount) import Client.Log @@ -279,9 +278,7 @@ (stateHook, viewHook) = over both applyMessageHooks $ partition (view messageHookStateful) - $ lookups - (view csMessageHooks cs) - messageHooks + $ view csMessageHooks cs case stateHook (cookIrcMsg raw) of Nothing -> return st1 -- Message ignored @@ -323,12 +320,6 @@ parseZncTime :: String -> Maybe UTCTime parseZncTime = parseTimeM True defaultTimeLocale $ iso8601DateFormat (Just "%T%Q%Z") - - --- | Returns the list of values that were stored at the given indexes, if --- a value was stored at that index. -lookups :: Ixed m => [Index m] -> m -> [IxValue m] -lookups ks m = mapMaybe (\k -> preview (ix k) m) ks -- | Update the height and width fields of the client state diff --git a/src/Client/Hook/FreRelay.hs b/src/Client/Hook/FreRelay.hs --- a/src/Client/Hook/FreRelay.hs +++ b/src/Client/Hook/FreRelay.hs @@ -29,15 +29,18 @@ import Irc.UserInfo (UserInfo(..)) import StrQuote (str) -freRelayHook :: MessageHook -freRelayHook = MessageHook "frerelay" False remap +-- | Hook for mapping frerelay messages in #dronebl on freenode +-- to appear like native messages. +freRelayHook :: [Text] -> Maybe MessageHook +freRelayHook args = Just (MessageHook "frerelay" False (remap (map mkId args))) -- | Remap messages from frerelay on #dronebl that match one of the -- rewrite rules. -remap :: IrcMsg -> MessageResult -remap (Privmsg (UserInfo "frerelay" _ _) chan@"#dronebl" msg) - | Just sub <- rules chan msg = RemapMessage sub -remap _ = PassMessage +remap :: [Identifier] -> IrcMsg -> MessageResult +remap nicks (Privmsg (UserInfo nick _ _) chan@"#dronebl" msg) + | nick `elem` nicks + , Just sub <- rules chan msg = RemapMessage sub +remap _ _ = PassMessage -- | Generate a replacement message for a chat message from frerelay -- when the message matches one of the replacement rules. @@ -53,6 +56,8 @@ , rule (partMsg chan) partRe msg , rule quitMsg quitRe msg , rule nickMsg nickRe msg + , rule (kickMsg chan) kickRe msg + , rule (modeMsg chan) modeRe msg ] -- | Match the message against the regular expression and use the given @@ -68,13 +73,15 @@ [_:xs] -> matchRule xs mk _ -> Nothing -chatRe, actionRe, joinRe, quitRe, nickRe, partRe :: Regex +chatRe, actionRe, joinRe, quitRe, nickRe, partRe, kickRe, modeRe :: Regex Right chatRe = compRe [str|^<([^>]+)> (.*)$|] Right actionRe = compRe [str|^\* ([^ ]+) (.*)$|] Right joinRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) \(([^@]+)@([^)]+)\) has joined the channel$|] Right quitRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has signed off \((.*)\)$|] Right nickRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) changed nick to ([^ ]+)$|] Right partRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has left the channel( \((.*)\))?$|] +Right kickRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) has been kicked by ([^ ]+) \((.*)\)$|] +Right modeRe = compRe [str|^\*\*\* \[([^]]+)\] ([^ ]+) sets mode (.*)$|] -- | Compile a regular expression for using in message matching. compRe :: @@ -153,6 +160,32 @@ (userInfo (old <> "@" <> srv)) (mkId (new <> "@" <> srv)) +kickMsg :: + Identifier {- ^ channel -} -> + Text {- ^ server -} -> + Text {- ^ kickee nick -} -> + Text {- ^ kicker nick -} -> + Text {- ^ reason -} -> + IrcMsg +kickMsg chan srv kickee kicker reason = + Kick + (userInfo (kicker <> "@" <> srv)) + chan + (mkId (kickee <> "@" <> srv)) + reason + +modeMsg :: + Identifier {- ^ channel -} -> + Text {- ^ server -} -> + Text {- ^ nickname -} -> + Text {- ^ modes -} -> + IrcMsg +modeMsg chan srv nick modes = + Mode + (userInfo (nick <> "@" <> srv)) + chan + (Text.words modes) + -- | Construct dummy user info when we don't know the user or host part. userInfo :: Text {- ^ nickname -} -> @@ -161,15 +194,12 @@ ------------------------------------------------------------------------ +-- | The class allows n-ary functions of the form +-- `Text -> Text -> ... -> IrcMsg` to be used to exhaustively consume the +-- matched elements of a regular expression. class Rule a where matchRule :: [Text] -> a -> Maybe IrcMsg -class RuleArg a where - matchArg :: Text -> Maybe a - -instance RuleArg Text where - matchArg = Just - instance (RuleArg a, Rule b) => Rule (a -> b) where matchRule tts f = do (t,ts) <- uncons tts @@ -180,3 +210,6 @@ matchRule args ircMsg | null args = Just ircMsg | otherwise = Nothing + +class RuleArg a where matchArg :: Text -> Maybe a +instance RuleArg Text where matchArg = Just diff --git a/src/Client/Hook/Znc/Buffextras.hs b/src/Client/Hook/Znc/Buffextras.hs --- a/src/Client/Hook/Znc/Buffextras.hs +++ b/src/Client/Hook/Znc/Buffextras.hs @@ -29,8 +29,12 @@ -- | Map ZNC's buffextras messages to native client messages. -- Set debugging to pass through buffextras messages that -- the hook doesn't understand. -buffextrasHook :: Bool {- ^ enable debugging -} -> MessageHook -buffextrasHook = MessageHook "buffextras" False . remap +buffextrasHook :: [Text] {- ^ arguments -} -> Maybe MessageHook +buffextrasHook args = + case args of + [] -> Just (MessageHook "buffextras" False (remap False)) + ["debug"] -> Just (MessageHook "buffextras" False (remap True)) + _ -> Nothing remap :: Bool {- ^ enable debugging -} -> diff --git a/src/Client/Hooks.hs b/src/Client/Hooks.hs --- a/src/Client/Hooks.hs +++ b/src/Client/Hooks.hs @@ -24,10 +24,9 @@ import Client.Hook.Znc.Buffextras -- | All the available message hooks. -messageHooks :: HashMap Text MessageHook +messageHooks :: HashMap Text ([Text] -> Maybe MessageHook) messageHooks = fromList - [ ("snotice", snoticeHook) - , ("buffextras", buffextrasHook False) - , ("buffextras-debug", buffextrasHook True) - , ("frerelay", freRelayHook) + [ ("snotice" , \_ -> Just snoticeHook) + , ("frerelay" , freRelayHook) + , ("buffextras", buffextrasHook) ] diff --git a/src/Client/Image/Message.hs b/src/Client/Image/Message.hs --- a/src/Client/Image/Message.hs +++ b/src/Client/Image/Message.hs @@ -36,9 +36,12 @@ import Client.Message import Client.State.DCC (isSend) import Client.State.Window +import Client.UserHost import Control.Lens import Data.Char import Data.Hashable (hash) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List @@ -61,6 +64,7 @@ , rendNicks :: HashSet Identifier -- ^ nicknames to highlight , rendMyNicks :: HashSet Identifier -- ^ nicknames to highlight in red , rendPalette :: Palette -- ^ nick color palette + , rendAccounts :: HashMap Identifier UserAndHost } -- | Default 'MessageRendererParams' with no sigils or nicknames specified @@ -71,6 +75,7 @@ , rendNicks = HashSet.empty , rendMyNicks = HashSet.empty , rendPalette = defaultPalette + , rendAccounts = HashMap.empty } @@ -207,8 +212,14 @@ myNicks = rendMyNicks rp rm = NormalRender - who n = string (view palSigil pal) sigils <> - coloredUserInfo pal rm myNicks n + who n = string (view palSigil pal) sigils <> ui + where + baseUI = coloredUserInfo pal rm myNicks n + ui = case rendAccounts rp ^? ix (userNick n) . uhAccount of + Just acct + | Text.null acct -> "~" <> baseUI + | mkId acct /= userNick n -> baseUI <> "(" <> text' defAttr (cleanText acct) <> ")" + _ -> baseUI in case body of Join {} -> mempty @@ -321,8 +332,19 @@ nicks = rendNicks rp rm = DetailedRender - who n = string (view palSigil pal) sigils <> - coloredUserInfo pal rm myNicks n + plainWho = coloredUserInfo pal rm myNicks + + who n = + -- sigils + string (view palSigil pal) sigils <> + + -- nick!user@host + plainWho n <> + + case rendAccounts rp ^? ix (userNick n) . uhAccount of + Just acct + | not (Text.null acct) -> text' quietAttr ("(" <> cleanText acct <> ")") + _ -> "" in case body of Nick old new -> @@ -333,21 +355,21 @@ Join nick _chan acct -> string quietAttr "join " <> - coloredUserInfo pal rm myNicks nick <> + plainWho nick <> if Text.null acct then mempty - else " " <> text' quietAttr (cleanText acct) + else text' quietAttr ("(" <> cleanText acct <> ")") Part nick _chan mbreason -> string quietAttr "part " <> - coloredUserInfo pal rm myNicks nick <> + who nick <> foldMap (\reason -> string quietAttr " (" <> parseIrcText reason <> string quietAttr ")") mbreason Quit nick mbreason -> string quietAttr "quit " <> - coloredUserInfo pal rm myNicks nick <> + who nick <> foldMap (\reason -> string quietAttr " (" <> parseIrcText reason <> string quietAttr ")") mbreason @@ -362,7 +384,7 @@ Topic src _dst txt -> string quietAttr "tpic " <> - coloredUserInfo pal rm myNicks src <> + who src <> " changed the topic: " <> parseIrcText txt diff --git a/src/Client/Image/Textbox.hs b/src/Client/Image/Textbox.hs --- a/src/Client/Image/Textbox.hs +++ b/src/Client/Image/Textbox.hs @@ -107,7 +107,9 @@ leftCur = take (view Edit.pos cur) (view Edit.text cur) -- ["one","two"] "three" --> "two one three" - leftLen = length leftCur + length leftImgs + sum (map imageWidth leftImgs) + leftLen = length leftImgs -- separators + + sum (map imageWidth leftImgs) + + imageWidth (parseIrcText' True (Text.pack leftCur)) rndr = renderLine st pal myNick nicks macros diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -325,15 +325,22 @@ , rendNicks = HashSet.fromList (channelUserList network channel' st) , rendMyNicks = highlights , rendPalette = clientPalette st + , rendAccounts = accounts } -- on failure returns mempty/"" - possibleStatusModes = view (clientConnection network . csStatusMsg) st + cs = st ^?! clientConnection network + possibleStatusModes = view csStatusMsg cs (statusModes, channel') = splitStatusMsgModes possibleStatusModes channel importance = msgImportance msg st highlights = clientHighlightsNetwork network st + accounts = + if view (csSettings . ssShowAccounts) cs + then view csUsers cs + else HashMap.empty + recordLogLine :: ClientMessage {- ^ message -} -> Identifier {- ^ target -} -> @@ -678,7 +685,7 @@ compile defaultCompOpt defaultExecOpt{captureGroups=False} - "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?=:@/;~#]*)?|\ + "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[-0-9a-zA-Z$_.+!*'(),%?&=:@/;~#]*)?|\ \]*>|\ \\\(https?://[^\\)]*\\)" diff --git a/src/Client/State/Network.hs b/src/Client/State/Network.hs --- a/src/Client/State/Network.hs +++ b/src/Client/State/Network.hs @@ -1,4 +1,4 @@ -{-# Language TemplateHaskell, OverloadedStrings, BangPatterns #-} +{-# Language BlockArguments, TemplateHaskell, OverloadedStrings, BangPatterns #-} {-| Module : Client.State.Network @@ -47,12 +47,6 @@ , csMessageHooks , csAuthenticationState - -- * User information - , UserAndHost(..) - , uhUser - , uhHost - , uhAccount - -- * Cross-message state , Transaction(..) @@ -83,6 +77,9 @@ import Client.Configuration.ServerSettings import Client.Network.Async import Client.State.Channel +import Client.UserHost +import Client.Hook (MessageHook) +import Client.Hooks (messageHooks) import Control.Lens import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -125,7 +122,7 @@ , _csUsers :: !(HashMap Identifier UserAndHost) -- ^ user and hostname for other nicks , _csModeCount :: !Int -- ^ maximum mode changes per MODE command , _csNetwork :: !Text -- ^ name of network connection - , _csMessageHooks :: ![Text] -- ^ names of message hooks to apply to this connection + , _csMessageHooks :: ![MessageHook] -- ^ names of message hooks to apply to this connection , _csAuthenticationState :: !AuthenticateState -- Timing information @@ -135,7 +132,6 @@ , _csLastReceived :: !(Maybe UTCTime) -- ^ time of last message received , _csCertificate :: ![Text] } - deriving Show -- | State of the authentication transaction data AuthenticateState @@ -146,14 +142,6 @@ | AS_ExternalStarted -- ^ EXTERNAL mode initiated deriving Show --- | Pair of username and hostname. Empty strings represent missing information. -data UserAndHost = UserAndHost - { _uhUser :: {-# UNPACK #-}!Text -- ^ username - , _uhHost :: {-# UNPACK #-}!Text -- ^ hostname - , _uhAccount :: {-# UNPACK #-}!Text -- ^ services account - } - deriving Show - -- | Status of the ping timer data PingStatus = PingSent !UTCTime -- ^ ping sent at given time, waiting for pong @@ -178,7 +166,6 @@ deriving Show makeLenses ''NetworkState -makeLenses ''UserAndHost makePrisms ''Transaction makePrisms ''PingStatus makePrisms ''TimedAction @@ -271,7 +258,7 @@ , _csModeCount = 3 , _csUsers = HashMap.empty , _csNetwork = network - , _csMessageHooks = view ssMessageHooks settings + , _csMessageHooks = buildMessageHooks (view ssMessageHooks settings) , _csAuthenticationState = AS_None , _csPingStatus = ping , _csLatency = Nothing @@ -280,6 +267,10 @@ , _csCertificate = [] } +buildMessageHooks :: [HookConfig] -> [MessageHook] +buildMessageHooks = mapMaybe \(HookConfig name args) -> + do hookFun <- HashMap.lookup name messageHooks + hookFun args -- | Used for updates to a 'NetworkState' that require no reply. -- @@ -304,10 +295,17 @@ Ping args -> ([ircPong args], cs) Pong _ -> noReply $ doPong msgWhen cs Join user chan acct -> - noReply - $ recordUser user acct + ( reply + , recordUser user acct $ overChannel chan (joinChannel (userNick user)) - $ createOnJoin user chan cs + $ createOnJoin user chan cs ) + where + showAccounts = view (csSettings . ssShowAccounts) cs + reply + | userNick user == view csNick cs = + ircMode chan [] : + [ircWho [idText chan, "%tuhna,616"] | showAccounts ] + | otherwise = [] Account user acct -> noReply @@ -691,7 +689,9 @@ NetworkState {- ^ network state -} -> [(Text, Maybe Text)] {- ^ server caps -} -> [Text] {- ^ caps to enable -} -selectCaps cs offered = supported `intersect` Map.keys capMap +selectCaps cs offered = (supported `intersect` Map.keys capMap) + `union` + view (csSettings . ssCapabilities) cs where capMap = Map.fromList offered diff --git a/src/Client/UserHost.hs b/src/Client/UserHost.hs new file mode 100644 --- /dev/null +++ b/src/Client/UserHost.hs @@ -0,0 +1,31 @@ +{-# Language TemplateHaskell #-} +{-| +Module : Client.UserHost +Description : Type for tracking user, host and account +Copyright : (c) Eric Mertens, 2019 +License : ISC +Maintainer : emertens@gmail.com + +-} + +module Client.UserHost + ( + -- * User information + UserAndHost(..) + , uhUser + , uhHost + , uhAccount + ) where + +import Control.Lens (makeLenses) +import Data.Text (Text) + +-- | Pair of username and hostname. Empty strings represent missing information. +data UserAndHost = UserAndHost + { _uhUser :: {-# UNPACK #-}!Text -- ^ username + , _uhHost :: {-# UNPACK #-}!Text -- ^ hostname + , _uhAccount :: {-# UNPACK #-}!Text -- ^ services account + } + deriving (Read, Show) + +makeLenses ''UserAndHost diff --git a/src/Client/View/UserList.hs b/src/Client/View/UserList.hs --- a/src/Client/View/UserList.hs +++ b/src/Client/View/UserList.hs @@ -19,6 +19,7 @@ import Client.State import Client.State.Channel import Client.State.Network +import Client.UserHost import Control.Lens import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map