diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for glirc2 +## 2.20 + +* Move from `tls` to `HsOpenSSL` support via the new `hookup` package + ## 2.19 * Smarter text box tracks "scroll" position independently from cursor diff --git a/glirc.cabal b/glirc.cabal --- a/glirc.cabal +++ b/glirc.cabal @@ -1,5 +1,5 @@ name: glirc -version: 2.19 +version: 2.20 synopsis: Console IRC client description: Console IRC client . @@ -123,13 +123,13 @@ attoparsec >=0.13 && <0.14, bytestring >=0.10.8 && <0.11, config-value >=0.5 && <0.6, - connection >=0.2.6 && <0.3, containers >=0.5.7 && <0.6, data-default-class >=0.1.2 && <0.2, directory >=1.2.6 && <1.3, filepath >=1.4.1 && <1.5, gitrev >=1.2 && <1.3, hashable >=1.2.4 && <1.3, + HsOpenSSL >=0.11 && <0.12, irc-core >=2.2 && <2.3, lens >=4.14 && <4.15, kan-extensions >=5.0 && <5.1, @@ -142,15 +142,12 @@ stm >=2.4 && <2.5, text >=1.2.2 && <1.3, 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.10 && <5.12, - x509 >=1.6.3 && <1.7, - x509-store >=1.6.1 && <1.7, - x509-system >=1.6.3 && <1.7 + hookup >=0.1 && <0.2 if flag(ExportCApi) cpp-options: -DEXPORT_GLIRC_CAPI diff --git a/src/Client/Authentication/Ecdsa.hs b/src/Client/Authentication/Ecdsa.hs --- a/src/Client/Authentication/Ecdsa.hs +++ b/src/Client/Authentication/Ecdsa.hs @@ -29,16 +29,34 @@ import System.IO.Error (IOError) import System.Process (readProcess) + +-- | Identifier for SASL ECDSA challenge response authentication +-- using curve NIST256P. +-- +-- @ECDSA-NIST256P-CHALLENGE@ authenticationMode :: Text authenticationMode = "ECDSA-NIST256P-CHALLENGE" -encodeUsername :: Text -> Text + +-- | Encode a username as specified in this authentication mode. +encodeUsername :: + Text {- ^ username -} -> + Text {- ^ base-64 encoded username -} encodeUsername = Text.decodeUtf8 . convertToBase Base64 . Text.encodeUtf8 -computeResponse :: FilePath -> Text -> IO (Either String Text) + +-- | Compute the response for a given challenge using the @ecdsatool@ +-- executable which must be available in @PATH@. +computeResponse :: + FilePath {- ^ private key file -} -> + Text {- ^ challenge string -} -> + IO (Either String Text) {- ^ error message or response string -} computeResponse privateKeyFile challenge = do path <- resolveConfigurationPath privateKeyFile - res <- try (readProcess "ecdsatool" ["sign", path, Text.unpack challenge] "") + res <- try $ readProcess + "ecdsatool" + ["sign", path, Text.unpack challenge] + "" -- stdin return $! case words <$> res of Right [resp] -> Right $! Text.pack resp Right _ -> Left "bad sasl ecdsa response message" diff --git a/src/Client/CApi/Types.hsc b/src/Client/CApi/Types.hsc --- a/src/Client/CApi/Types.hsc +++ b/src/Client/CApi/Types.hsc @@ -76,7 +76,7 @@ Ptr () {- ^ extension state -} -> IO () --- | Type of @typedef enum process_result process_message(void *glirc, void *S, const struct glirc_message *);@ +-- | @typedef enum process_result process_message(void *glirc, void *S, const struct glirc_message *);@ type ProcessMessage = Ptr () {- ^ api token -} -> Ptr () {- ^ extention state -} -> diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -276,6 +276,8 @@ commands :: Recognizer Command commands = fromCommands (expandAliases commandsList) + +-- | Raw list of commands in the order used for @/help@ commandsList :: [Command] commandsList = -- diff --git a/src/Client/Commands/WordCompletion.hs b/src/Client/Commands/WordCompletion.hs --- a/src/Client/Commands/WordCompletion.hs +++ b/src/Client/Commands/WordCompletion.hs @@ -35,12 +35,18 @@ { wcmStartPrefix, wcmStartSuffix, wcmMiddlePrefix, wcmMiddleSuffix :: String } deriving Show + +-- | Word completion without adding any prefix or suffix plainWordCompleteMode :: WordCompletionMode plainWordCompleteMode = WordCompletionMode "" "" "" "" + +-- | Word completion adding a ": " suffix at the beginning of lines defaultNickWordCompleteMode :: WordCompletionMode defaultNickWordCompleteMode = WordCompletionMode "" ": " "" "" + +-- | Word completion using a "@" prefix intended slackNickWordCompleteMode :: WordCompletionMode slackNickWordCompleteMode = WordCompletionMode "@" " " "@" "" @@ -87,6 +93,10 @@ | otherwise = mpfx ++ str ++ msfx in over Edit.content (Edit.insertString str1) box1 + +-- | Find the word preceeding the cursor skipping over any +-- characters that can be found in the prefix and suffix for +-- the current completion mode. currentWord :: WordCompletionMode -> Edit.EditBox -> String currentWord (WordCompletionMode spfx ssfx mpfx msfx) box = dropWhile (`elem`pfx) @@ -124,6 +134,8 @@ toString = Text.unpack +-- | Find the next entry in a list of possible choices using an alphabetical +-- ordering. tabSearch :: Prefix a => Bool {- ^ reversed -} -> diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -270,7 +270,8 @@ "tls" -> setFieldWith ssTls parseUseTls "tls-client-cert" -> setFieldWithMb ssTlsClientCert parseString "tls-client-key" -> setFieldWithMb ssTlsClientKey parseString - "server-certificates" -> setFieldWith ssServerCerts (parseList parseString) + "tls-server-cert" -> setFieldWithMb ssTlsServerCert parseString + "tls-ciphers" -> setFieldWith ssTlsCiphers parseString "connect-cmds" -> setFieldWith ssConnectCmds (parseList parseMacroCommand) "socks-host" -> setFieldWithMb ssSocksHost parseString "socks-port" -> setFieldWith ssSocksPort parseNum @@ -293,8 +294,10 @@ return $! set l x ss setFieldWithMb l p = - do x <- p v - return $! set l (Just x) ss + do x <- case v of + Atom "clear" -> return Nothing + _ -> Just <$> p v + return $! set l x ss parseNicks :: Value -> ConfigParser (NonEmpty Text) parseNicks (Text nick) = return (nick NonEmpty.:| []) 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 @@ -31,10 +31,11 @@ , ssTls , ssTlsClientCert , ssTlsClientKey + , ssTlsServerCert + , ssTlsCiphers , ssConnectCmds , ssSocksHost , ssSocksPort - , ssServerCerts , ssChanservChannels , ssFloodPenalty , ssFloodThreshold @@ -80,10 +81,11 @@ , _ssTls :: !UseTls -- ^ use TLS to connect , _ssTlsClientCert :: !(Maybe FilePath) -- ^ path to client TLS certificate , _ssTlsClientKey :: !(Maybe FilePath) -- ^ path to client TLS key + , _ssTlsServerCert :: !(Maybe FilePath) -- ^ additional CA certificates for validating server + , _ssTlsCiphers :: String -- ^ OpenSSL cipher suite , _ssConnectCmds :: ![[ExpansionChunk]] -- ^ commands to execute 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) @@ -126,10 +128,11 @@ , _ssTls = UseInsecure , _ssTlsClientCert = Nothing , _ssTlsClientKey = Nothing + , _ssTlsServerCert = Nothing + , _ssTlsCiphers = "HIGH" , _ssConnectCmds = [] , _ssSocksHost = Nothing , _ssSocksPort = 1080 - , _ssServerCerts = [] , _ssChanservChannels = [] , _ssFloodPenalty = 2 -- RFC 1459 defaults , _ssFloodThreshold = 10 diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -54,7 +54,7 @@ import Irc.Message import Irc.RawIrcMsg import LensUtils -import Network.Connection +import Hookup -- | Sum of the three possible event types the event loop handles @@ -203,8 +203,8 @@ shouldReconnect = case view csPingStatus cs of PingConnecting n _ | n == 0 || n > reconnectAttempts -> False - _ | Just HostNotResolved{} <- fromException ex -> True - | Just HostCannotConnect{} <- fromException ex -> True + _ | Just ConnectionFailure{} <- fromException ex -> True + | Just HostnameResolutionFailure{} <- fromException ex -> True | Just PingTimeout <- fromException ex -> True | Just ResourceVanished <- ioe_type <$> fromException ex -> True | Just NoSuchThing <- ioe_type <$> fromException ex -> True diff --git a/src/Client/EventLoop/Errors.hs b/src/Client/EventLoop/Errors.hs --- a/src/Client/EventLoop/Errors.hs +++ b/src/Client/EventLoop/Errors.hs @@ -16,9 +16,9 @@ import Control.Exception import Data.List.NonEmpty (NonEmpty(..)) -import Network.Connection -import Network.TLS import Network.Socks5 +import OpenSSL.Session +import Hookup -- | Compute the message message text to be used for a connection error exceptionToLines :: @@ -36,17 +36,14 @@ NonEmpty String {- ^ client lines -} exceptionToLines' ex - -- TLS package errors - | Just tls <- fromException ex = explainTLSException tls - -- connection package errors - | Just (HostNotResolved str) <- fromException ex = - ("Host not resolved: " ++ str) :| [] - - | Just (HostCannotConnect str exs) <- fromException ex = - ("Host cannot connect: " ++ str) :| map explainIOError exs + | Just err <- fromException ex = explainHookupError err - | Just LineTooLong <- fromException ex = "Server IRC message too long" :| [] + -- HsOpenSSL errors + | Just err <- fromException ex :: Maybe ConnectionAbruptlyTerminated = + "Connection abruptly terminated" :| [] + | Just (ProtocolError e) <- fromException ex = + ("TLS protocol error: " ++ e) :| [] -- socks package errors | Just err <- fromException ex = explainSocksError err :| [] @@ -61,35 +58,21 @@ explainIOError :: IOError -> String explainIOError ioe = "IO error: " ++ displayException ioe -explainTLSException :: TLSException -> NonEmpty String -explainTLSException ex = - case ex of - ConnectionNotEstablished -> - "Attempt to use connection out of order" :| [] - Terminated _ _ tlsError -> - "Connection closed due to early-termination in TLS layer" - :| explainTLSError tlsError - HandshakeFailed (Error_Packet_Parsing str) -> - "Connection closed due to handshake failure in TLS layer" :| - [ "Packet parse error: " ++ str - , "Please verify you're using a TLS enabled port" - ] - HandshakeFailed tlsError -> - "Connection closed due to handshake failure in TLS layer" - :| explainTLSError tlsError +explainHookupError :: ConnectionFailure -> NonEmpty String +explainHookupError e = + case e of + HostnameResolutionFailure ioe -> + ("Host not resolved: " ++ displayException ioe) :| [] -explainTLSError :: TLSError -> [String] -explainTLSError ex = - case ex of - Error_Misc str -> ["Miscellaneous error: " ++ str] - Error_Protocol (str, _, _desc) -> ["Protocol error: " ++ str] - Error_Certificate str -> ["Certificate error: " ++ str] - Error_HandshakePolicy str -> ["Handshake policy: " ++ str] - Error_EOF -> ["Unexpected end of connection"] - Error_Packet str -> ["Packet error: " ++ str] - Error_Packet_unexpected msg expect -> ("Packet unexpected: " ++ msg) - : [ expect | not (null expect) ] - Error_Packet_Parsing str -> ["Packet parse error: " ++ str] + ConnectionFailure exs -> + "Connect failed" :| map explainIOError exs + + LineTooLong -> + "IRC message too long" :| [] + + LineTruncated -> + "IRC message incomplete" :| [] + explainSocksError :: SocksError -> String explainSocksError ex = diff --git a/src/Client/Image/StatusLine.hs b/src/Client/Image/StatusLine.hs --- a/src/Client/Image/StatusLine.hs +++ b/src/Client/Image/StatusLine.hs @@ -50,6 +50,9 @@ , latencyImage st ] + +-- | The minor status line is used when rendering the @/splits@ and +-- @/mentions@ views to show the associated window name. minorStatusLineImage :: Focus -> ClientState -> Image minorStatusLineImage focus st = content <|> charFill defAttr '─' fillSize 1 @@ -58,6 +61,7 @@ fillSize = max 0 (view clientWidth st - imageWidth content) +-- | Indicate when the client is scrolling and old messages are being shown. scrollImage :: ClientState -> Image scrollImage st | 0 == view clientScroll st = emptyImage @@ -66,6 +70,9 @@ pal = clientPalette st attr = view palLabel pal + +-- | Indicate when the client is potentially showing a subset of the +-- available chat messages. filterImage :: ClientState -> Image filterImage st = case clientActiveRegex st of @@ -75,6 +82,10 @@ pal = clientPalette st attr = view palLabel pal + +-- | Indicate the current connection health. This will either indicate +-- that the connection is being established or that a ping has been +-- sent or long the previous ping round-trip was. latencyImage :: ClientState -> Image latencyImage st | Just network <- views clientFocus focusNetwork st @@ -95,9 +106,14 @@ where pal = clientPalette st + +-- | Wrap some text in parentheses to make it suitable for inclusion in the +-- status line. infoBubble :: Image -> Image infoBubble img = string defAttr "─(" <|> img <|> string defAttr ")" + +-- | Indicate that the client is in the /detailed/ view. detailImage :: ClientState -> Image detailImage st | view clientDetailView st = infoBubble (string attr "detail") @@ -106,6 +122,9 @@ pal = clientPalette st attr = view palLabel pal + +-- | Indicate that the client isn't showing the metadata lines in /normal/ +-- view. nometaImage :: ClientState -> Image nometaImage st | view clientShowMetadata st = emptyImage diff --git a/src/Client/Log.hs b/src/Client/Log.hs --- a/src/Client/Log.hs +++ b/src/Client/Log.hs @@ -31,13 +31,17 @@ import System.Directory import System.FilePath + +-- | Log entry queued in client to be written by the event loop data LogLine = LogLine - { logBaseDir :: FilePath - , logDay :: Day - , logTarget :: Text - , logLine :: L.Text + { logBaseDir :: FilePath -- ^ log directory from server settings + , logDay :: Day -- ^ localtime day + , logTarget :: Text -- ^ channel or nickname + , logLine :: L.Text -- ^ formatted log message text } + +-- | Write the given log entry to the filesystem. writeLogLine :: LogLine {- ^ log line -} -> IO () @@ -50,9 +54,14 @@ createDirectoryIfMissing recursiveFlag dir' L.appendFile file (logLine ll) + +-- | Ignore all 'IOErrors' ignoreProblems :: IO () -> IO () ignoreProblems m = () <$ (try m :: IO (Either IOError ())) + +-- | Construct a 'LogLine' for the given 'ClientMessage' when appropriate. +-- Only chat messages result in a log line. renderLogLine :: ClientMessage {- ^ message -} -> FilePath {- ^ log directory -} -> diff --git a/src/Client/Network/Async.hs b/src/Client/Network/Async.hs --- a/src/Client/Network/Async.hs +++ b/src/Client/Network/Async.hs @@ -27,7 +27,7 @@ , NetworkId , NetworkEvent(..) , createConnection - , send + , Client.Network.Async.send -- * Abort connections , abortConnection @@ -44,9 +44,10 @@ import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as B +import Data.Foldable import Data.Time import Irc.RateLimit -import Network.Connection +import Hookup -- | Identifier used to match connection events to connections. @@ -102,16 +103,15 @@ createConnection :: Int {- ^ delay in seconds -} -> NetworkId {- ^ Identifier to be used on incoming events -} -> - ConnectionContext -> ServerSettings -> TQueue NetworkEvent {- Queue for incoming events -} -> IO NetworkConnection -createConnection delay network cxt settings inQueue = +createConnection delay network settings inQueue = do outQueue <- atomically newTQueue supervisor <- async $ threadDelay (delay * 1000000) >> - startConnection network cxt settings inQueue outQueue + startConnection network settings inQueue outQueue -- Having this reporting thread separate from the supervisor ensures -- that canceling the supervisor with abortConnection doesn't interfere @@ -139,16 +139,15 @@ startConnection :: NetworkId -> - ConnectionContext -> ServerSettings -> TQueue NetworkEvent -> TQueue ByteString -> IO () -startConnection network cxt settings inQueue outQueue = +startConnection network settings inQueue outQueue = do rate <- newRateLimit (view ssFloodPenalty settings) (view ssFloodThreshold settings) - withConnection cxt settings $ \h -> + withConnection settings $ \h -> do reportNetworkOpen network inQueue withAsync (sendLoop h outQueue rate) $ \sender -> withAsync (receiveLoop network h inQueue) $ \receiver -> @@ -169,15 +168,16 @@ forever $ do msg <- atomically (readTQueue outQueue) tickRateLimit rate - connectionPut h msg + Hookup.send 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 mb <- recvLine h (2*ircMaxMessageLength) + for_ mb $ \msg -> do now <- getZonedTime - atomically (writeTQueue inQueue (NetworkLine network now (B.init msg))) + atomically $ writeTQueue inQueue + $ NetworkLine network now msg receiveLoop network h inQueue diff --git a/src/Client/Network/Connect.hs b/src/Client/Network/Connect.hs --- a/src/Client/Network/Connect.hs +++ b/src/Client/Network/Connect.hs @@ -20,38 +20,45 @@ import Client.Configuration import Client.Configuration.ServerSettings +import Control.Applicative 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) +import Hookup buildConnectionParams :: ServerSettings -> IO ConnectionParams buildConnectionParams args = - do useSecure <- case view ssTls args of - UseInsecure -> return Nothing - _ -> Just <$> buildTlsSettings args + do let resPath = traverse resolveConfigurationPath - let proxySettings = view ssSocksHost args <&> \host -> - SockSettingsSimple + tlsParams <- TlsParams + <$> resPath (view ssTlsClientCert args) + <*> resPath (view ssTlsClientKey args <|> + view ssTlsClientCert args) + <*> resPath (view ssTlsServerCert args) + <*> pure (view ssTlsCiphers args) + + let useSecure = + case view ssTls args of + UseInsecure -> Nothing + UseInsecureTls -> Just (tlsParams True) + UseTls -> Just (tlsParams False) + + proxySettings = view ssSocksHost args <&> \host -> + SocksParams host (view ssSocksPort args) return ConnectionParams - { connectionHostname = view ssHostName args - , connectionPort = ircPort args - , connectionUseSecure = useSecure - , connectionUseSocks = proxySettings + { cpHost = view ssHostName args + , cpPort = ircPort args + , cpTls = useSecure + , cpSocks = proxySettings } + ircPort :: ServerSettings -> PortNumber ircPort args = case view ssPort args of @@ -61,62 +68,10 @@ UseInsecure -> 6667 _ -> 6697 -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 = - case view ssTls args of - UseInsecureTls -> noValidation - _ -> 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 = +-- | Create a new 'Connection' which will be closed when the continuation +-- finishes. +withConnection :: ServerSettings -> (Connection -> IO a) -> IO a +withConnection settings k = do params <- buildConnectionParams settings - bracket (connectTo cxt params) connectionClose k + bracket (connect params) close k diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -26,7 +26,6 @@ , clientFocus , clientPrevFocus , clientExtraFocus - , clientConnectionContext , clientConfig , clientScroll , clientDetailView @@ -140,7 +139,6 @@ import Irc.RawIrcMsg import Irc.UserInfo import LensUtils -import Network.Connection (ConnectionContext, initConnectionContext) import Text.Regex.TDFA import Text.Regex.TDFA.String (compile) @@ -149,12 +147,11 @@ { _clientWindows :: !(Map Focus Window) -- ^ client message buffers , _clientPrevFocus :: !Focus -- ^ previously focused buffer , _clientFocus :: !Focus -- ^ currently focused buffer - , _clientSubfocus :: !Subfocus -- ^ sec + , _clientSubfocus :: !Subfocus -- ^ current view mode , _clientExtraFocus :: ![Focus] -- ^ extra messages windows to view , _clientConnections :: !(IntMap NetworkState) -- ^ state of active connections - , _clientNextConnectionId :: !Int - , _clientConnectionContext :: !ConnectionContext -- ^ network connection context + , _clientNextConnectionId :: !NetworkId -- ^ next available 'NetworkId' , _clientEvents :: !(TQueue NetworkEvent) -- ^ incoming network event queue , _clientNetworkMap :: !(HashMap Text NetworkId) -- ^ network name to connection ID @@ -179,16 +176,24 @@ , _clientLogQueue :: ![LogLine] -- ^ log lines ready to write } + +-- | State of the extension API including loaded extensions and the mechanism used +-- to support reentry into the Haskell runtime from the C API. data ExtensionState = ExtensionState - { _esActive :: [ActiveExtension] - , _esMVar :: MVar ClientState - , _esStablePtr :: StablePtr (MVar ClientState) + { _esActive :: [ActiveExtension] -- ^ active extensions + , _esMVar :: MVar ClientState -- ^ 'MVar' used to with 'clientPark' + , _esStablePtr :: StablePtr (MVar ClientState) -- ^ 'StablePtr' used with 'clientPark' } makeLenses ''ClientState makeLenses ''ExtensionState -clientPark :: ClientState -> (Ptr () -> IO a) -> IO (ClientState, a) + +-- | Prepare the client to support reentry from the extension API. +clientPark :: + ClientState {- ^ client state -} -> + (Ptr () -> IO a) {- ^ continuation using the stable pointer to the client -} -> + IO (ClientState, a) clientPark st k = do let mvar = view (clientExtensions . esMVar) st putMVar mvar st @@ -222,8 +227,7 @@ withExtensionState $ \exts -> - do cxt <- initConnectionContext - events <- atomically newTQueue + do events <- atomically newTQueue k ClientState { _clientWindows = _Empty # () , _clientNetworkMap = _Empty # () @@ -238,7 +242,6 @@ , _clientFocus = Unfocused , _clientSubfocus = FocusMessages , _clientExtraFocus = [] - , _clientConnectionContext = cxt , _clientConfig = cfg , _clientScroll = 0 , _clientDetailView = False @@ -386,7 +389,13 @@ | identIgnored (userNick who) st = Just (userNick who) | otherwise = Nothing -identIgnored :: Identifier -> ClientState -> Bool + + +-- | Predicate for nicknames to determine if messages should be ignored. +identIgnored :: + Identifier {- ^ nickname -} -> + ClientState {- ^ client state -} -> + Bool {- ^ is ignored -} identIgnored who st = HashSet.member who (view clientIgnores st) @@ -552,7 +561,12 @@ channelUserList network channel = views (clientConnection network . csChannels . ix channel . chanUsers) HashMap.keys -clientMatcher :: ClientState -> Text -> Bool + +-- | Returns the current filtering predicate. +clientMatcher :: + ClientState {- ^ client state -} -> + Text {- ^ text to match -} -> + Bool {- ^ is match -} clientMatcher st = case clientActiveRegex st of Nothing -> const True @@ -586,6 +600,7 @@ _ -> Nothing +-- | Regular expression for matching HTTP/HTTPS URLs in chat text. urlPattern :: Regex Right urlPattern = compile @@ -594,6 +609,9 @@ "https?://([[:alnum:]-]+\\.)*([[:alnum:]-]+)(:[[:digit:]]+)?(/[^[:cntrl:][:space:]]*)|\ \]*>" + +-- | Find all the URL matches using 'urlPattern' in a given 'Text' suitable +-- for being opened. Surrounding @<@ and @>@ are removed. urlMatches :: Text -> [Text] urlMatches txt = removeBrackets . extractText . (^?! ix 0) <$> matchAll urlPattern (Text.unpack txt) @@ -643,7 +661,6 @@ c <- createConnection delay i - (view clientConnectionContext st') settings (view clientEvents st') @@ -697,10 +714,14 @@ applyWindowRenames _ _ st = st + +-- | Actions to be run when exiting the client. clientShutdown :: ClientState -> IO () clientShutdown st = () <$ clientStopExtensions st -- other shutdown stuff might be added here later + +-- | Unload all active extensions. clientStopExtensions :: ClientState -> IO ClientState clientStopExtensions st = do let (aes,st1) = (clientExtensions . esActive <<.~ []) st