glirc 2.36 → 2.37

raw patch · 19 files changed

+596/−328 lines, 19 filesdep +randomdep −mwc-randomdep ~HUnitdep ~base64-bytestringdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: random

Dependencies removed: mwc-random

Dependency ranges changed: HUnit, base64-bytestring, bytestring, config-schema, config-value, hookup, irc-core, vty

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• glirc.cabal +10/−9
• src/Client/Commands.hs +4/−10
• src/Client/Commands/Arguments/Spec.hs +1/−0
• src/Client/Commands/Certificate.hs +123/−0
• src/Client/Commands/Types.hs +0/−1
• src/Client/Configuration.hs +44/−72
• src/Client/Configuration/ServerSettings.hs +26/−17
• src/Client/EventLoop.hs +59/−13
• src/Client/EventLoop/Network.hs +6/−8
• src/Client/Hook/Snotice.hs +1/−0
• src/Client/Image/StatusLine.hs +1/−1
• src/Client/Network/Async.hs +114/−35
• src/Client/Network/Connect.hs +31/−37
• src/Client/Options.hs +1/−1
• src/Client/State.hs +21/−8
• src/Client/State/Network.hs +142/−112
• src/Client/View/Cert.hs +2/−2
• src/Client/View/Mentions.hs +2/−2

@@ -1,5 +1,13 @@ # Revision history for glirc +## 2.37++* Add `/new-self-signed-certificate PATH [keysize]` to make it easier to configure secure services logon+* Add STARTTLS support: `tls:` configuration settings are now: `yes`, `no`, `starttls`+* Add separate `tls-verify: no` setting for disabling hostname verification instead of old `tls: yes-insecure`+* Configuration file supports `$` macros and `@load` / `@splice` directives from config-value+* Updates for hookup library improvements to concurrent connect algorithm+ ## 2.36  * **Changed executable name to `glirc`**

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                glirc-version:             2.36+version:             2.37 synopsis:            Console IRC client description:         Console IRC client                      .@@ -67,6 +67,7 @@                        Client.Commands.Arguments.Spec                        Client.Commands.Channel                        Client.Commands.Chat+                       Client.Commands.Certificate                        Client.Commands.Connection                        Client.Commands.DCC                        Client.Commands.Exec@@ -153,21 +154,21 @@                        HsOpenSSL            >=0.11   && <0.12,                        async                >=2.2    && <2.3,                        attoparsec           >=0.13   && <0.14,-                       base64-bytestring    >=1.0.0.1&& <1.2,-                       bytestring           >=0.10.8 && <0.11,-                       config-schema        ^>=1.2.0.0,-                       config-value         ^>=0.7,+                       base64-bytestring    >=1.0.0.1&& <1.3,+                       bytestring           >=0.10.8 && <0.12,+                       config-schema        ^>=1.2.1.0,+                       config-value         ^>=0.8,                        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.4    && <0.5,-                       irc-core             >=2.8    && <2.9,+                       hookup               >=0.5    && <0.6,+                       irc-core             ^>=2.9,                        kan-extensions       >=5.0    && <5.3,                        lens                 >=4.14   && <4.20,-                       mwc-random           >=0.14   && <0.15,+                       random               >=1.2    && <1.3,                        network              >=2.6.2  && <3.2,                        process              >=1.4.2  && <1.7,                        psqueues             >=0.2.7  && <0.3,@@ -189,5 +190,5 @@   main-is:             Main.hs   hs-source-dirs:      test   build-depends:       base, glirc,-                       HUnit                >=1.3 && <1.7+                       HUnit                >=1.6 && <1.7   default-language:    Haskell2010

@@ -32,7 +32,6 @@ import           Client.Commands.Recognizer import           Client.Commands.WordCompletion import           Client.Configuration-import           Client.Message import           Client.State import           Client.State.Extensions import           Client.State.Focus@@ -45,7 +44,7 @@ import           Data.Foldable import           Data.Text (Text) import qualified Data.Text as Text-import           Data.Time (ZonedTime, getZonedTime)+import           Data.Time (getZonedTime) import           Irc.Commands import           Irc.Identifier import           Irc.RawIrcMsg@@ -54,6 +53,7 @@ import           System.Process  import           Client.Commands.Channel (channelCommands)+import           Client.Commands.Certificate (newCertificateCommand) import           Client.Commands.Chat (chatCommands, chatCommand', executeChat) import           Client.Commands.Connection (connectionCommands) import           Client.Commands.DCC (dccCommands)@@ -317,6 +317,8 @@       \ URL to open counting back from the most recent.\n"     $ ClientCommand cmdUrl noClientTab +  , newCertificateCommand+   , Command       (pure "help")       (optionalArg (simpleToken "[command]"))@@ -497,14 +499,6 @@      failure now es =       commandFailure $! foldl' (flip (recordError now "")) st (map Text.pack es)--recordSuccess :: ZonedTime -> ClientState -> Text -> ClientState-recordSuccess now ste m =-  recordNetworkMessage ClientMessage-    { _msgTime    = now-    , _msgBody    = NormalBody m-    , _msgNetwork = ""-    } ste   cmdUrl :: ClientCommand (Maybe Int)

@@ -18,6 +18,7 @@   , numberArg   , optionalNumberArg   , extensionArg+  , tokenArg    , ArgumentShape(..)   , Arg(..)

@@ -0,0 +1,123 @@+{-# Language OverloadedStrings #-}+{-|+Module      : Client.Commands.Certificate+Description : Certificate management commands+Copyright   : (c) Eric Mertens, 2016-2020+License     : ISC+Maintainer  : emertens@gmail.com+-}++module Client.Commands.Certificate (newCertificateCommand) where++import           Client.Commands.Arguments.Spec+import           Client.Commands.TabCompletion+import           Client.Commands.Types+import           Client.State+import           Control.Applicative+import           Control.Exception+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import           Data.Foldable (foldl')+import           Data.Maybe (fromMaybe)+import           Data.Text (Text)+import qualified Data.Text as Text+import           Data.Time+import           Hookup.OpenSSL (getPubKeyDer)+import qualified OpenSSL.RSA as RSA+import qualified OpenSSL.X509 as X509+import qualified OpenSSL.PEM as PEM+import qualified OpenSSL.EVP.Cipher as Cipher+import qualified OpenSSL.EVP.Digest as Digest+import           Text.Read (readMaybe)+import           Text.Printf (printf)++keysizeArg :: Args a (Maybe (Int, String))+keysizeArg = optionalArg (liftA2 (,) (tokenArg "[keysize]" (const parseSize)) (remainingArg "[passphrase]"))++parseSize :: String -> Maybe Int+parseSize str =+  case readMaybe str of+    Just n | 1024 <= n, n <= 8192 -> Just n+    _ -> Nothing++newCertificateCommand :: Command+newCertificateCommand =+  Command+    (pure "new-self-signed-cert")+    (liftA2 (,) (simpleToken "filename") keysizeArg)+      "\^BParameters:\^B\n\+      \\n\+      \    filename:   Certificate and private key PEM output\n\+      \    keysize:    Public-key size (default 2048, range 1024-8192)\n\+      \    passphrase: Optional AES-128 private key passphrase\n\+      \\n\+      \\^BDescription:\^B\n\+      \\n\+      \    Generate a new self-signed certificate for network service\n\+      \    identification.\n\+      \\n\+      \\^BExample command:\^B\n\+      \\n\+      \    /new-self-signed-cert /home/me/.glirc/config/my.pem 2048 SeCrEt\n\+      \\n\+      \\^BExample configuration:\^B\n\+      \    servers:\n\+      \      * name:                    \"fn\"\n\+      \        hostname:                \"chat.freenode.net\"\n\+      \        sasl: mechanism:         external\n\+      \        tls:                     yes\n\+      \        tls-client-cert:         \"my.pem\"\n\+      \        tls-client-key-password: \"SeCrEt\"\n"+    (ClientCommand cmdNewCert noClientTab)++cmdNewCert :: ClientCommand (String, Maybe (Int, String))+cmdNewCert st (path, mbExtra) =+  do now <- getZonedTime++     let size = case mbExtra of+                  Nothing -> 2048+                  Just (n,_) -> n+     pass <- case mbExtra of+               Just (_,p) | not (null p) ->+                 do cipher <- fromMaybe (error "No aes128!") <$> Cipher.getCipherByName "aes128"+                    pure (Just (cipher, PEM.PwStr p))+               _ -> pure Nothing++     rsa  <- RSA.generateRSAKey' size 65537+     x509 <- X509.newX509+     X509.setVersion      x509 2+     X509.setSerialNumber x509 1+     X509.setIssuerName   x509 [("CN","glirc")]+     X509.setSubjectName  x509 [("CN","glirc")]+     X509.setNotBefore    x509 (UTCTime (ModifiedJulianDay 40587) 0) -- 1970-01-01+     X509.setNotAfter     x509 (UTCTime (ModifiedJulianDay 77112) 0) -- 2070-01-01+     X509.setPublicKey    x509 rsa+     X509.signX509        x509 rsa Nothing++     ctder <- X509.writeDerX509 x509+     pkder <- getPubKeyDer x509+     msgss <- traverse (getFingerprint ctder pkder) ["sha1", "sha256", "sha512"]++     pem1 <- PEM.writePKCS8PrivateKey rsa pass+     pem2 <- PEM.writeX509 x509+     res  <- try (writeFile path (pem1 ++ pem2))++     case res of+       Left e ->+        commandFailure (recordError now "" (Text.pack (displayException (e :: IOError))) st)+       Right () ->+        do let msg = "Certificate saved: \x02" <> path <> "\x02"+           commandSuccess (foldl' (recordSuccess now) st (concat msgss ++ [Text.pack msg]))++getFingerprint :: L.ByteString -> B.ByteString -> String -> IO [Text]+getFingerprint crt pub name =+  do mb <- Digest.getDigestByName name+     pure $ case mb of+       Nothing -> []+       Just d  -> map Text.pack+         [printf "CERT %-6s fingerprint: \^C07%s" name (hexString (Digest.digestLBS d crt))+         ,printf "SPKI %-6s fingerprint: \^C07%s" name (hexString (Digest.digestBS  d pub))+         ]++hexString :: B.ByteString -> String+hexString = B.foldr (printf "%02x%s") ""

@@ -84,4 +84,3 @@ commandFailureMsg :: Text -> ClientState -> IO CommandResult commandFailureMsg e st =   return $! CommandFailure $! set clientErrorMsg (Just e) st-

@@ -52,7 +52,7 @@   , loadConfiguration    -- * Resolving paths-  , getNewConfigPath+  , getConfigPath    -- * Specification   , configurationSpec@@ -71,6 +71,7 @@ import           Client.EventLoop.Actions import           Client.Image.Palette import           Config+import           Config.Macro import           Config.Schema import           Control.Exception import           Control.Monad                       (unless)@@ -86,15 +87,14 @@ import           Data.Monoid                         (Endo(..)) import           Data.Text                           (Text) import qualified Data.Text                           as Text-import qualified Data.Text.IO                        as Text import qualified Data.Vector                         as Vector import           Graphics.Vty.Input.Events (Modifier(..), Key(..)) import           Graphics.Vty.Attributes             (Attr) import           Irc.Identifier                      (Identifier) import           System.Directory import           System.FilePath-import           System.IO.Error import           System.Posix.DynamicLinker          (RTLDFlags(..))+import           System.IO.Error  -- | Top-level client configuration information. When connecting to a -- server configuration from '_configServers' is used where possible,@@ -170,59 +170,12 @@ defaultWindowNames :: Text defaultWindowNames = "1234567890qwertyuiop!@#$%^&*()QWERTYUIOP" --- | Uses 'getAppUserDataDirectory' to find @~/.glirc/config@-getOldConfigPath :: IO FilePath-getOldConfigPath =-  do dir <- getAppUserDataDirectory "glirc"-     return (dir </> "config")- -- | Uses 'getXdgDirectory' 'XdgConfig' to find @~/.config/glirc/config@-getNewConfigPath :: IO FilePath-getNewConfigPath =+getConfigPath :: IO FilePath+getConfigPath =   do dir <- getXdgDirectory XdgConfig "glirc"      return (dir </> "config") --- | Empty configuration file used when no path is specified--- and the configuration file is missing.-emptyConfigFile :: Text-emptyConfigFile = "{}\n"---- | Attempt to read a file using the given handler when--- a file does not exist. On failure a 'ConfigurationReadFailed'--- exception is throw.-readFileCatchNotFound ::-  FilePath {- ^ file to read -} ->-  (IOError -> IO (FilePath, Text)) {- ^ error handler for not found case -} ->-  IO (FilePath, Text)-readFileCatchNotFound path onNotFound =-  do res <- try (Text.readFile path)-     case res of-       Left e | isDoesNotExistError e -> onNotFound e-              | otherwise -> throwIO (ConfigurationReadFailed (show e))-       Right txt -> return (path, txt)---- | Either read a configuration file from one of the default--- locations, in which case no configuration found is equivalent--- to an empty configuration, or from the specified file where--- no configuration found is an error.-readConfigurationFile ::-  Maybe FilePath {- ^ just file or use default search paths -} ->-  IO (FilePath, Text)-readConfigurationFile mbPath =-  case mbPath of--    Just path ->-      readFileCatchNotFound path $ \e ->-        throwIO (ConfigurationReadFailed (show e))--    Nothing ->-      do newPath <- getNewConfigPath-         readFileCatchNotFound newPath $ \_ ->-           do oldPath <- getOldConfigPath-              readFileCatchNotFound oldPath $ \_ ->-                return ("", emptyConfigFile)-- -- | Load the configuration file defaulting to @~/.glirc/config@. -- -- Given configuration path is optional and actual path used will@@ -231,37 +184,56 @@   Maybe FilePath {- ^ path to configuration file -} ->   IO (Either ConfigurationFailure (FilePath, Configuration)) loadConfiguration mbPath = try $-  do (path,txt) <- readConfigurationFile mbPath-     home <- getHomeDirectory+  do path <- case mbPath of+               Nothing -> getConfigPath+               Just p  -> pure p -     rawcfg <--       case parse txt of-         Left e -> throwIO (ConfigurationParseFailed path (displayException e))-         Right rawcfg -> return rawcfg+     ctx <- newFilePathContext path +     let toPath txt _ = pure (resolveFilePath ctx (Text.unpack txt))+     rawcfg <- loadFileWithMacros toPath path+        `catches`+        [Handler $ \e -> case e of+           LoadFileParseError fp pe -> throwIO (ConfigurationParseFailed fp (displayException pe))+           LoadFileMacroError (UndeclaredVariable a var) -> badMacro a ("undeclared variable: " ++ Text.unpack var)+           LoadFileMacroError (BadSplice a)              -> badMacro a "bad @splice"+           LoadFileMacroError (BadLoad a)                -> badMacro a "bad @load"+           LoadFileMacroError (UnknownDirective a dir)   -> badMacro a ("unknown directive: @" ++ Text.unpack dir)+        ,Handler $ \e ->+            if isDoesNotExistError e &&+               isNothing mbPath &&+               ioeGetFileName e == Just path+            then pure (Sections (FilePosition path (Position 0 0 0)) [])+            else throwIO (ConfigurationReadFailed (displayException e))+        ]+      case loadValue configurationSpec rawcfg of        Left e -> throwIO                $ ConfigurationMalformed path                $ displayException e        Right cfg ->-         do cfg' <- resolvePaths path (cfg defaultServerSettings home)-                    >>= validateDirectories path+         do cfg' <- validateDirectories path (resolvePaths ctx (cfg defaultServerSettings (fpHome ctx)))             return (path, cfg') +badMacro :: FilePosition -> String -> IO a+badMacro (FilePosition path posn) msg =+  throwIO $ ConfigurationMalformed path+          $ "line "    ++ show (posLine   posn) +++            " column " ++ show (posColumn posn) +++            ": "       ++ msg  -- | Resolve all the potentially relative file paths in the configuration file-resolvePaths :: FilePath -> Configuration -> IO Configuration-resolvePaths file cfg =-  do res <- resolveFilePath <$> newFilePathContext file-     let resolveServerFilePaths = over (ssTlsClientCert . mapped) res-                                . over (ssTlsClientKey  . mapped) res-                                . over (ssTlsServerCert . mapped) res-                                . over (ssSaslMechanism . mapped . _SaslEcdsa . _3) res-                                . over (ssLogDir        . mapped) res-     return $! over (configExtensions . mapped . extensionPath) res-             . over (configServers    . mapped) resolveServerFilePaths-             . over configDownloadDir res-             $ cfg+resolvePaths :: FilePathContext -> Configuration -> Configuration+resolvePaths ctx =+  let res = resolveFilePath ctx+      resolveServerFilePaths = over (ssTlsClientCert . mapped) res+                             . over (ssTlsClientKey  . mapped) res+                             . over (ssTlsServerCert . mapped) res+                             . over (ssSaslMechanism . mapped . _SaslEcdsa . _3) res+                             . over (ssLogDir        . mapped) res+  in over (configExtensions . mapped . extensionPath) res+   . over (configServers    . mapped) resolveServerFilePaths+   . over configDownloadDir res  -- | Check if the `download-dir` is actually a directory and writeable, --   throw a ConfigurationMalformed exception if it isn't.

@@ -29,6 +29,7 @@   , ssHostName   , ssPort   , ssTls+  , ssTlsVerify   , ssTlsClientCert   , ssTlsClientKey   , ssTlsClientKeyPassword@@ -71,6 +72,7 @@   -- * TLS settings   , UseTls(..)   , Fingerprint(..)+  , TlsMode(..)    -- * Regex wrapper   , KnownRegex(..)@@ -110,12 +112,16 @@   , _ssSaslMechanism    :: !(Maybe SaslMechanism) -- ^ SASL mechanism   , _ssHostName         :: !HostName -- ^ server hostname   , _ssPort             :: !(Maybe PortNumber) -- ^ server port-  , _ssTls              :: !UseTls -- ^ use TLS to connect+  , _ssTls              :: !TlsMode -- ^ use TLS to connect+  , _ssTlsVerify        :: !Bool -- ^ verify TLS hostname   , _ssTlsClientCert    :: !(Maybe FilePath) -- ^ path to client TLS certificate   , _ssTlsClientKey     :: !(Maybe FilePath) -- ^ path to client TLS key   , _ssTlsClientKeyPassword :: !(Maybe Secret) -- ^ client key PEM password   , _ssTlsServerCert    :: !(Maybe FilePath) -- ^ additional CA certificates for validating server   , _ssTlsCiphers       :: String            -- ^ OpenSSL cipher suite+  , _ssTlsPubkeyFingerprint :: !(Maybe Fingerprint) -- ^ optional acceptable public key fingerprint+  , _ssTlsCertFingerprint   :: !(Maybe Fingerprint) -- ^ optional acceptable certificate fingerprint+  , _ssSts              :: !Bool -- ^ Honor STS policies when true   , _ssConnectCmds      :: ![[ExpansionChunk]] -- ^ commands to execute upon successful connection   , _ssSocksHost        :: !(Maybe HostName) -- ^ hostname of SOCKS proxy   , _ssSocksPort        :: !PortNumber -- ^ port of SOCKS proxy@@ -130,14 +136,14 @@   , _ssNickCompletion   :: WordCompletionMode -- ^ Nick completion mode for this server   , _ssLogDir           :: Maybe FilePath -- ^ Directory to save logs of chat   , _ssBindHostName     :: Maybe HostName -- ^ Local bind host-  , _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 +data TlsMode = TlsYes | TlsNo | TlsStart+  deriving Show+ data Secret   = SecretText Text    -- ^ Constant text   | SecretCommand (NonEmpty Text) -- ^ Command to generate text@@ -190,12 +196,16 @@        , _ssSaslMechanism = Nothing        , _ssHostName      = ""        , _ssPort          = Nothing-       , _ssTls           = UseInsecure+       , _ssTls           = TlsNo+       , _ssTlsVerify     = True        , _ssTlsClientCert = Nothing        , _ssTlsClientKey  = Nothing        , _ssTlsClientKeyPassword = Nothing        , _ssTlsServerCert = Nothing        , _ssTlsCiphers    = "HIGH"+       , _ssTlsPubkeyFingerprint = Nothing+       , _ssTlsCertFingerprint   = Nothing+       , _ssSts              = True        , _ssConnectCmds   = []        , _ssSocksHost     = Nothing        , _ssSocksPort     = 1080@@ -210,9 +220,6 @@        , _ssNickCompletion   = defaultNickWordCompleteMode        , _ssLogDir           = Nothing        , _ssBindHostName     = Nothing-       , _ssSts              = True-       , _ssTlsPubkeyFingerprint = Nothing-       , _ssTlsCertFingerprint   = Nothing        , _ssShowAccounts     = False        , _ssCapabilities     = []        }@@ -260,9 +267,12 @@       , opt "sasl" ssSaslMechanism saslMechanismSpec         "SASL settings" -      , req "tls" ssTls useTlsSpec-        "Set to `yes` to enable secure connect. Set to `yes-insecure` to disable certificate checking."+      , req "tls" ssTls tlsModeSpec+        "Use TLS to connect (default no)" +      , req "tls-verify" ssTlsVerify yesOrNoSpec+        "Enable server certificate hostname verification (default yes)"+       , opt "tls-client-cert" ssTlsClientCert stringSpec         "Path to TLS client certificate" @@ -333,6 +343,12 @@         "Extra capabilities to unconditionally request from the server"       ] +tlsModeSpec :: ValueSpec TlsMode+tlsModeSpec =+  TlsYes   <$ atomSpec "yes"      <!>+  TlsNo    <$ atomSpec "no"       <!>+  TlsStart <$ atomSpec "starttls"+ saslMechanismSpec :: ValueSpec SaslMechanism saslMechanismSpec = plain <!> external <!> ecdsa   where@@ -392,13 +408,6 @@  nicksSpec :: ValueSpec (NonEmpty Text) nicksSpec = oneOrNonemptySpec anySpec--useTlsSpec :: ValueSpec UseTls-useTlsSpec =-      UseTls         <$ atomSpec "yes"-  <!> UseInsecureTls <$ atomSpec "yes-insecure"-  <!> UseInsecure    <$ atomSpec "no"-  nickCompletionSpec :: ValueSpec WordCompletionMode nickCompletionSpec =

@@ -55,6 +55,7 @@ import           GHC.IO.Exception (IOErrorType(..), ioe_type) import           Graphics.Vty import           Irc.Message+import           Irc.Codes import           Irc.RawIrcMsg import           LensUtils import           Hookup (ConnectionFailure(..))@@ -153,7 +154,8 @@   case networkEvent of     NetworkLine  time line -> doNetworkLine  net time line st     NetworkError time ex   -> doNetworkError net time ex st-    NetworkOpen  time msg  -> doNetworkOpen  net time msg st+    NetworkOpen  time      -> doNetworkOpen  net time st+    NetworkTLS   txts      -> doNetworkTLS   net txts st     NetworkClose time      -> doNetworkClose net time st  -- | Sound the terminal bell assuming that the @BEL@ control code@@ -169,10 +171,9 @@ doNetworkOpen ::   Text        {- ^ network name -} ->   ZonedTime   {- ^ event time   -} ->-  [Text]      {- ^ rendered certificate -} ->   ClientState {- ^ client state -} ->   IO ClientState-doNetworkOpen networkId time cert st =+doNetworkOpen networkId time st =   case view (clientConnections . at networkId) st of     Nothing -> error "doNetworkOpen: Network missing"     Just cs ->@@ -182,10 +183,21 @@                      , _msgBody    = NormalBody "connection opened"                      }          let cs' = cs & csLastReceived .~ (Just $! zonedTimeToUTC time)-                      & csCertificate  .~ cert          return $! recordNetworkMessage msg                  $ setStrict (clientConnections . ix networkId) cs' st +-- | Update the TLS certificates for a connection+doNetworkTLS ::+  Text   {- ^ network name      -} ->+  [Text] {- ^ certificate lines -} ->+  ClientState ->+  IO ClientState+doNetworkTLS network cert st =+  pure $! over (clientConnections . ix network) upd st+  where+    upd = set csCertificate cert+        . set (csPingStatus . _PingConnecting . _3) NoRestriction+ -- | Respond to a network connection closing normally. doNetworkClose ::   Text        {- ^ network name -} ->@@ -231,7 +243,7 @@   where     computeRetryInfo =       case view csPingStatus cs of-        PingConnecting n tm                   -> pure (n+1, tm)+        PingConnecting n tm _                 -> pure (n+1, tm)         _ | Just tm <- view csLastReceived cs -> pure (1, Just tm)           | otherwise                         -> do now <- getCurrentTime                                                     pure (1, Just now)@@ -240,7 +252,7 @@      shouldReconnect =       case view csPingStatus cs of-        PingConnecting n _ | n == 0 || n > reconnectAttempts          -> False+        PingConnecting n _ _ | n == 0 || n > reconnectAttempts        -> False         _ | Just ConnectionFailure{}         <-      fromException ex -> True           | Just HostnameResolutionFailure{} <-      fromException ex -> True           | Just PingTimeout         <-              fromException ex -> True@@ -263,9 +275,16 @@     Just cs ->       let network = view csNetwork cs in       case parseRawIrcMsg (asUtf8 line) of+        _ | PingConnecting _ _ WaitTLSRestriction <- view csPingStatus cs ->+          st <$ abortConnection StartTLSFailed (view csSocket cs)++        Just raw+          | PingConnecting _ _ StartTLSRestriction <- view csPingStatus cs ->+          startTLSLine networkId cs st raw+         Nothing ->           do let msg = Text.pack ("Malformed message: " ++ show line)-             return $! recordError time (view csNetwork cs) msg st+             return $! recordError time network msg st          Just raw ->           do (st1,passed) <- clientNotifyExtensions network raw st@@ -284,18 +303,22 @@                Just irc ->                  do -- state with message recorded                     -- record messages *before* applying state changes+                    -- so that quits, nick-changes, etc (TargetUser) will dispatch to+                    -- the correct window                     let st2 =                           case viewHook irc of-                            Nothing   -> st1 -- Message hidden-                            Just irc' -> recordIrcMessage network target msg st1+                            Nothing -> st1 -- Message hidden+                            Just irc'+                              | hideMessage irc' -> st1+                              | otherwise -> recordIrcMessage network target msg st1                               where                                 myNick = view csNick cs                                 target = msgTarget myNick irc                                 msg = ClientMessage-                                        { _msgTime    = time'-                                        , _msgNetwork = network-                                        , _msgBody    = IrcBody irc'-                                        }+                                      { _msgTime    = time'+                                      , _msgNetwork = network+                                      , _msgBody    = IrcBody irc'+                                      }                      let (replies, dccUp, st3) =                           applyMessageToClientState time irc networkId cs st2@@ -304,6 +327,29 @@                     traverse_ (sendMsg cs) replies                     clientResponse time' irc cs st3 +-- Highly restricted message handler for messages sent before STARTTLS+-- has completed.+startTLSLine :: Text -> NetworkState -> ClientState -> RawIrcMsg -> IO ClientState+startTLSLine network cs st raw =+  do now <- getZonedTime+     let irc = cookIrcMsg raw+         myNick = view csNick cs+         target = msgTarget myNick irc+         msg = ClientMessage+             { _msgTime    = now+             , _msgNetwork = network+             , _msgBody    = IrcBody irc+             }+         st1 = recordIrcMessage network target msg st++     case irc of+       Notice{} -> pure st1+       Reply RPL_STARTTLS _ ->+         do upgrade (view csSocket cs)+            pure (set ( clientConnections . ix network . csPingStatus+                      . _PingConnecting . _3)+                      WaitTLSRestriction st1)+       _ -> st1 <$ abortConnection StartTLSFailed (view csSocket cs)  -- | Find the ZNC provided server time computeEffectiveTime :: ZonedTime -> [TagEntry] -> ZonedTime

@@ -73,7 +73,6 @@      _ -> return st - processSts ::   Text         {- ^ STS parameter string -} ->   NetworkState {- ^ network state        -} ->@@ -81,11 +80,10 @@   IO ClientState processSts txt cs st =   case view (csSettings . ssTls) cs of-    _ | views (csSettings . ssSts) not cs        -> return st -- sts disabled-    UseInsecure    | Just port     <- mbPort     -> upgradeConnection port-    UseTls         | Just duration <- mbDuration -> setStsPolicy duration-    UseInsecureTls | Just duration <- mbDuration -> setStsPolicy duration-    _                                            -> return st+    _      | views (csSettings . ssSts) not cs -> return st -- sts disabled+    TlsNo  | Just port     <- mbPort           -> upgradeConnection port+    TlsYes | Just duration <- mbDuration       -> setStsPolicy duration+    _                                          -> return st    where     entries    = splitEntry <$> Text.splitOn "," txt@@ -165,5 +163,5 @@  where  disco =    case view csPingStatus cs of-     PingConnecting _ tm -> tm-     _                   -> Nothing+     PingConnecting _ tm _ -> tm+     _                     -> Nothing

@@ -136,6 +136,7 @@     (1, "m", [str|^Rehashing .* by request of system console\.$|]),     (2, "m", [str|^Updating database by request of [^ ]+( \([^ ]+\))?\.$|]),     (2, "m", [str|^Rehashing .* by request of [^ ]+( \([^ ]+\))?\.$|]),+    (2, "m", [str|.* is rehashing server config file$|]),     (3, "m", [str|^".*", line [0-9+]|]), -- configuration syntax error!     (0, "m", [str|^Ignoring attempt from [^ ]+( \([^ ]+\))? to set login name for|]),     (1, "m", [str|^binding listener socket: 99 \(Cannot assign requested address\)$|]),

@@ -147,7 +147,7 @@         PingSent {} -> latencyBubble "wait" -       PingConnecting n _ ->+       PingConnecting n _ _ ->          infoBubble (string (view palLatency pal) "connecting" <> retryImage n)         PingNone -> mempty -- just connected no ping sent yet

@@ -28,6 +28,7 @@   , createConnection   , Client.Network.Async.send   , Client.Network.Async.recv+  , upgrade    -- * Abort connections   , abortConnection@@ -45,15 +46,19 @@ import           Data.ByteString (ByteString) import qualified Data.ByteString as B import           Data.Foldable-import           Data.Time import           Data.List-import           Irc.RateLimit-import           Hookup+import           Data.List.Split (chunksOf) import           Data.Text (Text) import qualified Data.Text as Text+import           Data.Time+import           Data.Traversable import           Data.Word (Word8)+import           Hookup+import           Hookup.OpenSSL (getPubKeyDer)+import           Irc.RateLimit import           Numeric (showHex)-import           OpenSSL.X509 (X509, printX509)+import qualified OpenSSL.EVP.Digest as Digest+import           OpenSSL.X509 (X509, printX509, writeDerX509)   -- | Handle for a network connection@@ -61,14 +66,22 @@   { connOutQueue :: TQueue ByteString   , connInQueue  :: TQueue NetworkEvent   , connAsync    :: Async ()+  , connUpgrade  :: MVar (IO ())   } +-- | Signals that the server is ready to initiate the TLS handshake.+-- This is a no-op when not in a starttls state.+upgrade :: NetworkConnection -> IO ()+upgrade c = join (swapMVar (connUpgrade c) (pure ()))+ -- | 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   -- | Event for successful connection to host (certificate lines)-  = NetworkOpen  !ZonedTime [Text]+  = NetworkOpen  !ZonedTime+  -- | Event indicating TLS is in effect+  | NetworkTLS  [Text]   -- | Event for a new recieved line (newline removed)   | NetworkLine  !ZonedTime !ByteString   -- | Report an error on network connection network connection failed@@ -85,6 +98,7 @@   = PingTimeout      -- ^ sent when ping timer expires   | ForcedDisconnect -- ^ sent when client commands force disconnect   | StsUpgrade       -- ^ sent when the client disconnects due to sts policy+  | StartTLSFailed   -- ^ STARTTLS was expected by server had an error   | BadCertFingerprint ByteString (Maybe ByteString)   | BadPubkeyFingerprint ByteString (Maybe ByteString)   deriving Show@@ -93,6 +107,7 @@   displayException PingTimeout      = "connection killed due to ping timeout"   displayException ForcedDisconnect = "connection killed by client command"   displayException StsUpgrade       = "connection killed by sts policy"+  displayException StartTLSFailed   = "connection killed due to failed STARTTLS"   displayException (BadCertFingerprint expect got) =        "Expected certificate fingerprint: " ++ formatDigest expect ++        "; got: "    ++ maybe "none" formatDigest got@@ -125,9 +140,12 @@    do outQueue <- newTQueueIO       inQueue  <- newTQueueIO +      upgradeMVar <- newEmptyMVar+       supervisor <- async $                       threadDelay (delay * 1000000) >>-                      startConnection settings inQueue outQueue+                      withConnection settings+                        (startConnection settings inQueue outQueue upgradeMVar)        let recordFailure :: SomeException -> IO ()           recordFailure ex =@@ -151,6 +169,7 @@         { connOutQueue = outQueue         , connInQueue  = inQueue         , connAsync    = supervisor+        , connUpgrade  = upgradeMVar         }  @@ -158,27 +177,57 @@   ServerSettings ->   TQueue NetworkEvent ->   TQueue ByteString ->+  MVar (IO ()) ->+  Connection ->   IO ()-startConnection settings inQueue outQueue =-  do rate <- newRateLimit-               (view ssFloodPenalty settings)-               (view ssFloodThreshold settings)-     withConnection settings $ \h ->-       do for_ (view ssTlsCertFingerprint settings)-            (checkCertFingerprint h)-          for_ (view ssTlsPubkeyFingerprint settings)-            (checkPubkeyFingerprint h)+startConnection settings inQueue outQueue upgradeMVar h =+  do reportNetworkOpen inQueue+     ready <- presend+     when ready $+       do checkFingerprints+          race_ receiveMain sendMain+  where+    receiveMain = receiveLoop h inQueue -          reportNetworkOpen h inQueue-          withAsync (sendLoop h outQueue rate) $ \sender ->-            withAsync (receiveLoop h inQueue) $ \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+    sendMain =+      do rate <- newRateLimit (view ssFloodPenalty   settings)+                              (view ssFloodThreshold settings)+         sendLoop h outQueue rate +    presend =+      case view ssTls settings of+        TlsNo  -> True <$ putMVar upgradeMVar (pure ())+        TlsYes ->+          do txts <- describeCertificates h+             putMVar upgradeMVar (pure ())+             atomically (writeTQueue inQueue (NetworkTLS txts))+             pure True+        TlsStart ->+          do Hookup.send h "STARTTLS\n"+             r <- withAsync receiveMain $ \t ->+                    do putMVar upgradeMVar (cancel t)+                       waitCatch t+             case r of+               -- network connection closed+               Right () -> pure False++               -- pre-receiver was killed by a call to 'upgrade'+               Left e | Just AsyncCancelled <- fromException e ->+                  do Hookup.upgradeTls (tlsParams settings) (view ssHostName settings) h+                     txts <- describeCertificates h+                     atomically (writeTQueue inQueue (NetworkTLS txts))+                     pure True++               -- something else went wrong with network IO+               Left e -> throwIO e++    checkFingerprints =+      case view ssTls settings of+        TlsNo -> pure ()+        _ ->+          do for_ (view ssTlsCertFingerprint   settings) (checkCertFingerprint   h)+             for_ (view ssTlsPubkeyFingerprint settings) (checkPubkeyFingerprint h)+ checkCertFingerprint :: Connection -> Fingerprint -> IO () checkCertFingerprint h fp =   do (expect, got) <-@@ -199,15 +248,18 @@      unless (Just expect == got)        (throwIO (BadPubkeyFingerprint expect got)) -reportNetworkOpen :: Connection -> TQueue NetworkEvent -> IO ()-reportNetworkOpen h inQueue =+reportNetworkOpen :: TQueue NetworkEvent -> IO ()+reportNetworkOpen inQueue =   do now <- getZonedTime-     mbServer <- getPeerCertificate h-     let mbClient = getClientCertificate h+     atomically (writeTQueue inQueue (NetworkOpen now))++describeCertificates :: Connection -> IO [Text]+describeCertificates h =+  do mbServer <- getPeerCertificate h+     mbClient <- getClientCertificate h      cTxts <- certText "Server" mbServer      sTxts <- certText "Client" mbClient-     let txts = cTxts ++ sTxts-     atomically (writeTQueue inQueue (NetworkOpen now txts))+     pure (reverse (cTxts ++ sTxts))  certText :: String -> Maybe X509 -> IO [Text] certText label mbX509 =@@ -215,8 +267,35 @@     Nothing -> pure []     Just x509 ->       do str <- printX509 x509-         return $! reverse (Text.lines (Text.pack ("<<" ++ label ++ ">>\n" ++ str)))+         fps <- getFingerprints x509+         pure $ map Text.pack+              $ ('\^B' : label)+              : map colorize (lines str ++ fps)+  where+    colorize x@(' ':_) = x+    colorize xs = "\^C07" ++ xs +getFingerprints :: X509 -> IO [String]+getFingerprints x509 =+  do certDer <- writeDerX509 x509+     spkiDer <- getPubKeyDer x509+     xss <- for ["sha1", "sha256", "sha512"] $ \alg ->+              do mb <- Digest.getDigestByName alg+                 pure $ case mb of+                   Nothing -> []+                   Just d ->+                       ("Certificate " ++ alg ++ " fingerprint:")+                     : fingerprintLines (Digest.digestLBS d certDer)+                    ++ ("SPKI " ++ alg ++ " fingerprint:")+                     : fingerprintLines (Digest.digestBS d spkiDer)+     pure (concat xss)++fingerprintLines :: ByteString -> [String]+fingerprintLines+  = map ("    "++)+  . chunksOf (16*3)+  . formatDigest+ formatDigest :: ByteString -> String formatDigest   = intercalate ":"@@ -228,12 +307,12 @@   | x < 0x10  = '0' : showHex x ""   | otherwise = showHex x "" -sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO ()+sendLoop :: Connection -> TQueue ByteString -> RateLimit -> IO a sendLoop h outQueue rate =   forever $-    do msg <- atomically (readTQueue outQueue)-       tickRateLimit rate-       Hookup.send h msg+  do msg <- atomically (readTQueue outQueue)+     tickRateLimit rate+     Hookup.send h msg  ircMaxMessageLength :: Int ircMaxMessageLength = 512

@@ -17,6 +17,7 @@ module Client.Network.Connect   ( withConnection   , ircPort+  , tlsParams   ) where  import           Client.Configuration.ServerSettings@@ -27,42 +28,35 @@ import           Network.Socket (PortNumber) import           Hookup -buildConnectionParams :: ServerSettings -> ConnectionParams-buildConnectionParams args =--  let tlsParams insecure = TlsParams-        { tpClientCertificate  = view ssTlsClientCert args-        , tpClientPrivateKey   = view ssTlsClientKey args <|> view ssTlsClientCert args-        , tpClientPrivateKeyPassword = privateKeyPassword-        , tpServerCertificate  = view ssTlsServerCert args-        , tpCipherSuite        = view ssTlsCiphers args-        , tpInsecure           = insecure-        }--      privateKeyPassword =-        case view ssTlsClientKeyPassword args of-          Just (SecretText str) -> PwBS (Text.encodeUtf8 str)-          _                     -> PwNone--      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)+tlsParams :: ServerSettings -> TlsParams+tlsParams ss = TlsParams+  { tpClientCertificate  = view ssTlsClientCert ss+  , tpClientPrivateKey   = view ssTlsClientKey ss <|> view ssTlsClientCert ss+  , tpServerCertificate  = view ssTlsServerCert ss+  , tpCipherSuite        = view ssTlsCiphers ss+  , tpInsecure           = not (view ssTlsVerify ss)+  , tpClientPrivateKeyPassword =+      case view ssTlsClientKeyPassword ss of+        Just (SecretText str) -> Just (Text.encodeUtf8 str)+        _                     -> Nothing+  } -  in ConnectionParams-    { cpHost  = view ssHostName args-    , cpPort  = ircPort args-    , cpTls   = useSecure-    , cpSocks = proxySettings-    , cpBind  = view ssBindHostName args-    }+proxyParams :: ServerSettings -> Maybe SocksParams+proxyParams ss =+  view ssSocksHost ss <&> \host ->+  SocksParams host (view ssSocksPort ss) +buildConnectionParams :: ServerSettings -> ConnectionParams+buildConnectionParams ss = ConnectionParams+  { cpHost  = view ssHostName ss+  , cpPort  = ircPort ss+  , cpTls   = case view ssTls ss of+                TlsYes   -> Just (tlsParams ss)+                TlsNo    -> Nothing+                TlsStart -> Nothing+  , cpSocks = proxyParams ss+  , cpBind  = view ssBindHostName ss+  }  ircPort :: ServerSettings -> PortNumber ircPort args =@@ -70,9 +64,9 @@     Just p -> fromIntegral p     Nothing ->       case view ssTls args of-        UseInsecure -> 6667-        _           -> 6697-+        TlsYes   -> 6697+        TlsNo    -> 6667+        TlsStart -> 6667  -- | Create a new 'Connection' which will be closed when the continuation -- finishes.

@@ -119,7 +119,7 @@  printConfigFormat :: IO () printConfigFormat =-  do path <- getNewConfigPath+  do path <- getConfigPath      putStrLn ""      putStrLn ("Default configuration file path: " ++ path)      putStrLn ""

@@ -82,6 +82,7 @@   , recordNetworkMessage   , recordError   , recordIrcMessage+  , recordSuccess    -- * Focus manipulation   , changeFocus@@ -156,7 +157,7 @@ import           Irc.UserInfo import           LensUtils import           RtsStats (Stats)-import qualified System.Random.MWC as Random+import qualified System.Random as Random import           Text.Regex.TDFA import           Text.Regex.TDFA.String (compile) @@ -308,6 +309,13 @@                   -- unassociate this network name from this network id                   return $! over clientConnections (sans network) st +recordSuccess :: ZonedTime -> ClientState -> Text -> ClientState+recordSuccess now ste m =+  recordNetworkMessage ClientMessage+    { _msgTime    = now+    , _msgBody    = NormalBody m+    , _msgNetwork = ""+    } ste  -- | Add a message to the window associated with a given channel recordChannelMessage ::@@ -400,6 +408,7 @@           | isMe tgt  -> WLImportant           | otherwise -> checkTxt txt         Ctcp{} -> WLNormal+        Wallops{} -> WLImportant         Part who _ _ | isMe (userNick who) -> WLImportant                      | otherwise           -> WLBoring         Kick _ _ kicked _ | isMe kicked -> WLImportant@@ -454,7 +463,6 @@ recordIrcMessage network target msg st =   updateTransientError (NetworkFocus network) msg $   case target of-    TargetHidden      -> st     TargetNetwork     -> recordNetworkMessage msg st     TargetWindow chan -> recordChannelMessage network chan msg st     TargetUser user   ->@@ -662,8 +670,8 @@     Nothing -> xs     Just m  ->       filterContext+        (matcherAfter m) -- client messages are stored in descending order         (matcherBefore m)-        (matcherAfter m)         (matcherPred m . f)         xs @@ -781,8 +789,13 @@             -- don't bother delaying on the first reconnect             let delay = 15 * max 0 (attempts - 1)             c <- createConnection delay settings1-            seed <- Random.withSystemRandom (Random.asGenIO Random.save)-            let cs = newNetworkState network settings1 c (PingConnecting attempts lastTime) seed+            seed <- Random.newStdGen+            let restrict = case view ssTls settings1 of+                             TlsStart -> StartTLSRestriction+                             TlsYes   -> WaitTLSRestriction+                             TlsNo    -> NoRestriction+                cs = newNetworkState network settings1 c+                       (PingConnecting attempts lastTime restrict) seed             traverse_ (sendMsg cs) (initialMessages cs)             pure (set (clientConnections . at network) (Just cs) st) @@ -791,7 +804,7 @@   do now <- getCurrentTime      let stsUpgrade'            | Just{} <- stsUpgrade = stsUpgrade-           | UseInsecure <- view ssTls settings+           | TlsNo <- view ssTls settings            , let host = Text.pack (view ssHostName settings)            , Just policy <- view (clientStsPolicy . at host) st            , now < view stsExpiration policy@@ -799,7 +812,7 @@            | otherwise = Nothing      pure $ case stsUpgrade' of               Just port -> set ssPort (Just (fromIntegral port))-                         $ set ssTls UseTls settings+                         $ set ssTls TlsYes settings               Nothing   -> settings  applyMessageToClientState ::@@ -812,7 +825,7 @@ applyMessageToClientState time irc network cs st =   cs' `seq` (reply, dccUp, st')   where-    (reply, cs') = applyMessage time irc cs+    Apply reply cs' = applyMessage time irc cs     (st', dccUp) = queueDCCTransfer network irc                  $ applyWindowRenames network irc                  $ set (clientConnections . ix network) cs' st

@@ -21,6 +21,7 @@   -- * Connection state     NetworkState(..)   , AuthenticateState(..)+  , ConnectRestriction(..)   , newNetworkState    -- * Lenses@@ -58,9 +59,13 @@   -- * Messages interactions   , sendMsg   , initialMessages-  , applyMessage   , squelchIrcMsg +  -- * NetworkState update+  , Apply(..)+  , applyMessage+  , hideMessage+   -- * Timer information   , PingStatus(..)   , _PingConnecting@@ -82,7 +87,6 @@ import           Client.Hook (MessageHook) import           Client.Hooks (messageHooks) import           Control.Lens-import qualified Control.Monad.ST as ST import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet@@ -107,7 +111,7 @@ import           Irc.RawIrcMsg import           Irc.UserInfo import           LensUtils-import qualified System.Random.MWC as Random+import qualified System.Random as Random  -- | State tracked for each IRC connection data NetworkState = NetworkState@@ -136,7 +140,7 @@   , _csCertificate  :: ![Text]    -- Randomization-  , _csSeed         :: Random.Seed+  , _csSeed         :: Random.StdGen   }  -- | State of the authentication transaction@@ -152,9 +156,15 @@ data PingStatus   = PingSent !UTCTime -- ^ ping sent at given time, waiting for pong   | PingNone          -- ^ not waiting for a pong-  | PingConnecting !Int !(Maybe UTCTime) -- ^ number of attempts, last known connection time+  | PingConnecting !Int !(Maybe UTCTime) !ConnectRestriction -- ^ number of attempts, last known connection time   deriving Show +data ConnectRestriction+  = NoRestriction       -- ^ no message restriction+  | StartTLSRestriction -- ^ STARTTLS hasn't finished+  | WaitTLSRestriction  -- ^ No messages allowed until TLS starts+  deriving Show+ -- | Timer-based events data TimedAction   = TimedDisconnect    -- ^ terminate the connection due to timeout@@ -247,7 +257,7 @@   ServerSettings    {- ^ server settings           -} ->   NetworkConnection {- ^ active network connection -} ->   PingStatus        {- ^ initial ping status       -} ->-  Random.Seed       {- ^ initial random seed       -} ->+  Random.StdGen     {- ^ initial random seed       -} ->   NetworkState      {- ^ new network state         -} newNetworkState network settings sock ping seed = NetworkState   { _csUserInfo     = UserInfo "*" "" ""@@ -279,36 +289,50 @@   do hookFun <- HashMap.lookup name messageHooks      hookFun args +data Apply = Apply [RawIrcMsg] NetworkState++hideMessage :: IrcMsg -> Bool+hideMessage m =+  case m of+    Authenticate{} -> True+    BatchStart{} -> True+    BatchEnd{} -> True+    Ping{} -> True+    Pong{} -> True+    Reply RPL_WHOSPCRPL [_,"616",_,_,_,_] -> True+    _ -> False+ -- | Used for updates to a 'NetworkState' that require no reply.------ @noReply x = ([], x)@-noReply :: NetworkState -> ([RawIrcMsg], NetworkState)-noReply x = ([], x)+noReply :: NetworkState -> Apply+noReply = reply [] +reply :: [RawIrcMsg] -> NetworkState -> Apply+reply = Apply+ overChannel :: Identifier -> (ChannelState -> ChannelState) -> NetworkState -> NetworkState overChannel chan = overStrict (csChannels . ix chan)  overChannels :: (ChannelState -> ChannelState) -> NetworkState -> NetworkState overChannels = overStrict (csChannels . traverse) -applyMessage :: ZonedTime -> IrcMsg -> NetworkState -> ([RawIrcMsg], NetworkState)+applyMessage :: ZonedTime -> IrcMsg -> NetworkState -> Apply applyMessage msgWhen msg cs   = applyMessage' msgWhen msg   $ set csLastReceived (Just $! zonedTimeToUTC msgWhen) cs -applyMessage' :: ZonedTime -> IrcMsg -> NetworkState -> ([RawIrcMsg], NetworkState)+applyMessage' :: ZonedTime -> IrcMsg -> NetworkState -> Apply applyMessage' msgWhen msg cs =   case msg of-    Ping args -> ([ircPong args], cs)-    Pong _    -> noReply $ doPong msgWhen cs+    Ping args -> reply [ircPong args] cs+    Pong _    -> noReply (doPong msgWhen cs)     Join user chan acct _ ->-         ( reply-         , recordUser user acct+         reply response+         $ recordUser user acct          $ overChannel chan (joinChannel (userNick user))-         $ createOnJoin user chan cs )+         $ createOnJoin user chan cs      where        showAccounts = view (csSettings . ssShowAccounts) cs-       reply+       response          | userNick user == view csNick cs =               ircMode chan [] :               [ircWho [idText chan, "%tuhna,616"] | showAccounts ]@@ -338,8 +362,8 @@          $ overChannels (nickChange (userNick oldNick) newNick) cs      Reply RPL_WELCOME (me:_) -> doWelcome msgWhen (mkId me) cs-    Reply RPL_SASLSUCCESS _ -> ([ircCapEnd], cs)-    Reply RPL_SASLFAIL _ -> ([ircCapEnd], cs)+    Reply RPL_SASLSUCCESS _ -> reply [ircCapEnd] cs+    Reply RPL_SASLFAIL _ -> reply [ircCapEnd] cs      Reply ERR_NICKNAMEINUSE (_:badnick:_)       | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs@@ -347,6 +371,8 @@       | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs     Reply ERR_ERRONEUSNICKNAME (_:badnick:_)       | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs+    Reply ERR_UNAVAILRESOURCE (_:badnick:_)+      | PingConnecting{} <- view csPingStatus cs -> doBadNick badnick cs      Reply RPL_HOSTHIDDEN (_:host:_) ->         noReply (set (csUserInfo . uiHost) host cs)@@ -356,10 +382,10 @@        let acct' = if acct == "0" then "*" else acct        in noReply (recordUser (UserInfo (mkId nick) user host) acct' cs) -    Reply code args        -> noReply (doRpl code msgWhen args cs)+    Reply code args        -> doRpl code msgWhen args cs     Cap cmd                -> doCap cmd cs     Authenticate param     -> doAuthenticate param cs-    Mode who target (modes:params)  -> doMode msgWhen who target modes params cs+    Mode who target (modes:params) -> doMode msgWhen who target modes params cs     Topic user chan topic  -> noReply (doTopic msgWhen user chan topic cs)     _                      -> noReply cs   where@@ -384,7 +410,8 @@ doWelcome ::   ZonedTime  {- ^ message received -} ->   Identifier {- ^ my nickname      -} ->-  NetworkState -> ([RawIrcMsg], NetworkState)+  NetworkState ->+  Apply doWelcome msgWhen me   = noReply   . set csNick me@@ -395,26 +422,23 @@ doBadNick ::   Text {- ^ bad nickname -} ->   NetworkState ->-  ([RawIrcMsg], NetworkState) {- ^ replies, updated state -}+  Apply doBadNick badNick cs =   case NonEmpty.dropWhile (badNick/=) (view (csSettings . ssNicks) cs) of-    _:next:_ -> ([ircNick next], cs)+    _:next:_ -> reply [ircNick next] cs     _        -> doRandomNick cs  -- | Pick a random nickname now that we've run out of choices-doRandomNick :: NetworkState -> ([RawIrcMsg], NetworkState)-doRandomNick cs = ([ircNick candidate], cs')+doRandomNick :: NetworkState -> Apply+doRandomNick cs = reply [ircNick candidate] cs'   where     limit       = 9 -- RFC 2812 puts the maximum nickname length as low as 9!     range       = (0, 99999::Int) -- up to 5 random digits     suffix      = show n     primaryNick = NonEmpty.head (view (csSettings . ssNicks) cs)     candidate   = Text.take (limit-length suffix) primaryNick <> Text.pack suffix-    cs'         = set csSeed seed' cs -    (n, seed')  = ST.runST (do gen <- Random.restore (view csSeed cs)-                               (,) <$> Random.uniformR range gen <*> Random.save gen-                           )+    (n, cs')    = cs & csSeed %%~ Random.uniformR range  doTopic :: ZonedTime -> UserInfo -> Identifier -> Text -> NetworkState -> NetworkState doTopic when user chan topic =@@ -432,36 +456,38 @@       Just $! posixSecondsToUTCTime (fromInteger i)     _ -> Nothing -doRpl :: ReplyCode -> ZonedTime -> [Text] -> NetworkState -> NetworkState-doRpl cmd msgWhen args =+doRpl :: ReplyCode -> ZonedTime -> [Text] -> NetworkState -> Apply+doRpl cmd msgWhen args cs =   case cmd of     RPL_UMODEIS ->-      \ns ->       case args of         _me:modes:params-          | Just xs <- splitModes (view csUmodeTypes ns) modes params ->-                 doMyModes xs-               $ set csModes "" ns -- reset modes-        _ -> ns+          | Just xs <- splitModes (view csUmodeTypes cs) modes params ->+                 noReply+               $ doMyModes xs+               $ set csModes "" cs -- reset modes+        _ -> noReply cs      RPL_SNOMASK ->       case args of         _me:snomask0:_           | Just snomask <- Text.stripPrefix "+" snomask0 ->-           set csSnomask (Text.unpack snomask)-        _             -> id+           noReply (set csSnomask (Text.unpack snomask) cs)+        _ -> noReply cs      RPL_NOTOPIC ->       case args of-        _me:chan:_ -> overChannel+        _me:chan:_ -> noReply+                    $ overChannel                         (mkId chan)                         (setTopic "" . set chanTopicProvenance Nothing)-        _          -> id+                        cs+        _ -> noReply cs      RPL_TOPIC ->       case args of-        _me:chan:topic:_ -> overChannel (mkId chan) (setTopic topic)-        _                -> id+        _me:chan:topic:_ -> noReply (overChannel (mkId chan) (setTopic topic) cs)+        _                -> noReply cs      RPL_TOPICWHOTIME ->       case args of@@ -470,99 +496,102 @@                        { _topicAuthor = parseUserInfo who                        , _topicTime   = when                        }-          in overChannel (mkId chan) (set chanTopicProvenance (Just prov))-        _ -> id+          in noReply (overChannel (mkId chan) (set chanTopicProvenance (Just prov)) cs)+        _ -> noReply cs      RPL_CREATIONTIME ->       case args of         _me:chan:whenTxt:_ | Just when <- parseTimeParam whenTxt ->-          overChannel (mkId chan) (set chanCreation (Just when))-        _ -> id+          noReply (overChannel (mkId chan) (set chanCreation (Just when)) cs)+        _ -> noReply cs      RPL_CHANNEL_URL ->       case args of         _me:chan:urlTxt:_ ->-          overChannel (mkId chan) (set chanUrl (Just urlTxt))-        _ -> id+          noReply (overChannel (mkId chan) (set chanUrl (Just urlTxt)) cs)+        _ -> noReply cs -    RPL_MYINFO -> myinfo args+    RPL_MYINFO -> noReply (myinfo args cs) -    RPL_ISUPPORT -> isupport args+    RPL_ISUPPORT -> noReply (isupport args cs)      RPL_NAMREPLY ->       case args of         _me:_sym:_tgt:x:_ ->+           noReply $            over csTransaction                 (\t -> let xs = view _NamesTransaction t                        in xs `seq` NamesTransaction (x:xs))-        _ -> id+                cs+        _ -> noReply cs      RPL_ENDOFNAMES ->       case args of-        _me:tgt:_ -> loadNamesList (mkId tgt)-        _         -> id+        _me:tgt:_ -> noReply (loadNamesList (mkId tgt) cs)+        _         -> noReply cs      RPL_BANLIST ->       case args of-        _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt-        _                           -> id+        _me:_tgt:mask:who:whenTxt:_ -> noReply (recordListEntry mask who whenTxt cs)+        _                           -> noReply cs      RPL_ENDOFBANLIST ->       case args of-        _me:tgt:_ -> saveList 'b' tgt-        _         -> id+        _me:tgt:_ -> noReply (saveList 'b' tgt cs)+        _         -> noReply cs      RPL_QUIETLIST ->       case args of-        _me:_tgt:_q:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt-        _                              -> id+        _me:_tgt:_q:mask:who:whenTxt:_ -> noReply (recordListEntry mask who whenTxt cs)+        _                              -> noReply cs      RPL_ENDOFQUIETLIST ->       case args of-        _me:tgt:_ -> saveList 'q' tgt-        _         -> id+        _me:tgt:_ -> noReply (saveList 'q' tgt cs)+        _         -> noReply cs      RPL_INVEXLIST ->       case args of-        _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt-        _                           -> id+        _me:_tgt:mask:who:whenTxt:_ -> noReply (recordListEntry mask who whenTxt cs)+        _                           -> noReply cs      RPL_ENDOFINVEXLIST ->       case args of-        _me:tgt:_ -> saveList 'I' tgt-        _         -> id+        _me:tgt:_ -> noReply (saveList 'I' tgt cs)+        _         -> noReply cs      RPL_EXCEPTLIST ->       case args of-        _me:_tgt:mask:who:whenTxt:_ -> recordListEntry mask who whenTxt-        _                           -> id+        _me:_tgt:mask:who:whenTxt:_ -> noReply (recordListEntry mask who whenTxt cs)+        _                           -> noReply cs      RPL_ENDOFEXCEPTLIST ->       case args of-        _me:tgt:_ -> saveList 'e' tgt-        _         -> id+        _me:tgt:_ -> noReply (saveList 'e' tgt cs)+        _         -> noReply cs      RPL_WHOREPLY ->       case args of         _me:_tgt:uname:host:_server:nick:_ ->-          over csTransaction $ \t ->+          noReply $+          over csTransaction (\t ->             let !x  = UserInfo (mkId nick) uname host                 !xs = view _WhoTransaction t-            in WhoTransaction (x : xs)-        _ -> id+            in WhoTransaction (x : xs))+            cs+        _ -> noReply cs -    RPL_ENDOFWHO -> massRegistration+    RPL_ENDOFWHO -> noReply (massRegistration cs)      RPL_CHANNELMODEIS ->       case args of         _me:chan:modes:params ->-              snd -- channel mode reply shouldn't trigger messages-            . doMode msgWhen who chanId modes params-            . set (csChannels . ix chanId . chanModes) Map.empty+              doMode msgWhen who chanId modes params+            $ set (csChannels . ix chanId . chanModes) Map.empty cs             where chanId = mkId chan                   !who = UserInfo "*" "" ""-        _ -> id-    _ -> id+        _ -> noReply cs+    _ -> noReply cs   -- | Add an entry to a mode list transaction@@ -641,23 +670,21 @@   Identifier {- ^ channel        -} ->   Text       {- ^ mode flags     -} ->   [Text]     {- ^ mode parameters -} ->-  NetworkState -> ([RawIrcMsg], NetworkState)+  NetworkState ->+  Apply doMode when who target modes args cs   | view csNick cs == target   , Just xs <- splitModes (view csUmodeTypes cs) modes args =         noReply (doMyModes xs cs)    | isChannelIdentifier cs target-  , Just xs <- splitModes (view csModeTypes cs) modes args =-        let cs' = doChannelModes when who target xs cs--            finish | iHaveOp target cs' = popQueue-                   | otherwise          = noReply+  , Just xs <- splitModes (view csModeTypes cs) modes args+  , let cs' = doChannelModes when who target xs cs = -        in finish cs'-  where-    popQueue :: NetworkState -> ([RawIrcMsg], NetworkState)-    popQueue = csChannels . ix target . chanQueuedModeration <<.~ []+    if iHaveOp target cs'+      then let (response, cs_) = cs' & csChannels . ix target . chanQueuedModeration <<.~ []+           in reply response cs_+      else noReply cs'  doMode _ _ _ _ _ cs = noReply cs -- ignore bad mode command @@ -738,39 +765,42 @@     ss = view csSettings cs     sasl = ["sasl" | isJust (view ssSaslMechanism ss) ] -doAuthenticate :: Text -> NetworkState -> ([RawIrcMsg], NetworkState)+doAuthenticate :: Text -> NetworkState -> Apply doAuthenticate param cs =   case view csAuthenticationState cs of     AS_PlainStarted       | "+" <- param       , Just (SaslPlain mbAuthz authc (SecretText pass)) <- view ssSaslMechanism ss       , let authz = fromMaybe "" mbAuthz-      -> (ircAuthenticates (encodePlainAuthentication authz authc pass),-          set csAuthenticationState AS_None cs)+      -> reply+           (ircAuthenticates (encodePlainAuthentication authz authc pass))+           (set csAuthenticationState AS_None cs)      AS_ExternalStarted       | "+" <- param       , Just (SaslExternal mbAuthz) <- view ssSaslMechanism ss       , let authz = fromMaybe "" mbAuthz-      -> (ircAuthenticates (encodeExternalAuthentication authz),-          set csAuthenticationState AS_None cs)+      -> reply+           (ircAuthenticates (encodeExternalAuthentication authz))+           (set csAuthenticationState AS_None cs)      AS_EcdsaStarted       | "+" <- param       , Just (SaslEcdsa mbAuthz authc _) <- view ssSaslMechanism ss       , let authz = fromMaybe authc mbAuthz-      -> (ircAuthenticates (Ecdsa.encodeAuthentication authz authc),-          set csAuthenticationState AS_EcdsaWaitChallenge cs)+      -> reply+           (ircAuthenticates (Ecdsa.encodeAuthentication authz authc))+           (set csAuthenticationState AS_EcdsaWaitChallenge cs) -    AS_EcdsaWaitChallenge -> ([], cs) -- handled in Client.EventLoop!+    AS_EcdsaWaitChallenge -> noReply cs -- handled in Client.EventLoop! -    _ -> ([ircCapEnd], cs) -- really shouldn't happen+    _ -> reply [ircCapEnd] cs -- really shouldn't happen    where     ss = view csSettings cs  -doCap :: CapCmd -> NetworkState -> ([RawIrcMsg], NetworkState)+doCap :: CapCmd -> NetworkState -> Apply doCap cmd cs =   case cmd of     (CapLs CapMore caps) ->@@ -779,19 +809,19 @@         prevCaps = view (csTransaction . _CapLsTransaction) cs      CapLs CapDone caps-      | null reqCaps -> ([ircCapEnd], cs')-      | otherwise    -> ([ircCapReq reqCaps], cs')+      | null reqCaps -> reply [ircCapEnd] cs'+      | otherwise    -> reply [ircCapReq reqCaps] cs'       where         reqCaps = selectCaps cs (caps ++ view (csTransaction . _CapLsTransaction) cs)         cs' = set csTransaction NoTransaction cs      CapNew caps-      | null reqCaps -> ([], cs)-      | otherwise    -> ([ircCapReq reqCaps], cs)+      | null reqCaps -> noReply cs+      | otherwise    -> reply [ircCapReq reqCaps] cs       where         reqCaps = selectCaps cs caps -    CapDel _ -> ([],cs)+    CapDel _ -> noReply cs      CapAck caps       | let ss = view csSettings cs@@ -799,16 +829,16 @@       , Just mech <- view ssSaslMechanism ss ->         case mech of           SaslEcdsa{} ->-            ([ircAuthenticate Ecdsa.authenticationMode],-             set csAuthenticationState AS_EcdsaStarted cs)+            reply [ircAuthenticate Ecdsa.authenticationMode]+                  (set csAuthenticationState AS_EcdsaStarted cs)           SaslPlain{} ->-            ([ircAuthenticate "PLAIN"],-             set csAuthenticationState AS_PlainStarted cs)+            reply [ircAuthenticate "PLAIN"]+                  (set csAuthenticationState AS_PlainStarted cs)           SaslExternal{} ->-            ([ircAuthenticate "EXTERNAL"],-             set csAuthenticationState AS_ExternalStarted cs)+            reply [ircAuthenticate "EXTERNAL"]+                  (set csAuthenticationState AS_ExternalStarted cs) -    _ -> ([ircCapEnd], cs)+    _ -> reply [ircCapEnd] cs  initialMessages :: NetworkState -> [RawIrcMsg] initialMessages cs

@@ -14,12 +14,12 @@  import           Client.Image.PackedImage import           Client.Image.Palette+import           Client.Image.MircFormatting import           Client.State import           Client.State.Focus import           Client.State.Network import           Control.Lens import           Data.Text (Text)-import           Graphics.Vty.Attributes  -- | Render the lines used in a channel mask list certViewLines ::@@ -29,7 +29,7 @@   , Just cs <- preview (clientConnection network) st   , let xs = view csCertificate cs   , not (null xs)-  = text' defAttr <$> xs+  = parseIrcText <$> xs    | otherwise = [text' (view palError pal) "No certificate available"]   where

@@ -42,8 +42,8 @@     palette = clientPalette st      filt-      | clientIsFiltered st = filter (\x -> WLImportant == view wlImportance x)-      | otherwise           = clientFilter st (view wlText)+      | clientIsFiltered st = clientFilter st (view wlText)+      | otherwise           = filter (\x -> WLImportant == view wlImportance x)      entries = merge               [windowEntries filt palette w padAmt detail n focus v