diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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`** 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.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 diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs --- a/src/Client/Commands.hs +++ b/src/Client/Commands.hs @@ -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) diff --git a/src/Client/Commands/Arguments/Spec.hs b/src/Client/Commands/Arguments/Spec.hs --- a/src/Client/Commands/Arguments/Spec.hs +++ b/src/Client/Commands/Arguments/Spec.hs @@ -18,6 +18,7 @@ , numberArg , optionalNumberArg , extensionArg + , tokenArg , ArgumentShape(..) , Arg(..) diff --git a/src/Client/Commands/Certificate.hs b/src/Client/Commands/Certificate.hs new file mode 100644 --- /dev/null +++ b/src/Client/Commands/Certificate.hs @@ -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") "" diff --git a/src/Client/Commands/Types.hs b/src/Client/Commands/Types.hs --- a/src/Client/Commands/Types.hs +++ b/src/Client/Commands/Types.hs @@ -84,4 +84,3 @@ commandFailureMsg :: Text -> ClientState -> IO CommandResult commandFailureMsg e st = return $! CommandFailure $! set clientErrorMsg (Just e) st - diff --git a/src/Client/Configuration.hs b/src/Client/Configuration.hs --- a/src/Client/Configuration.hs +++ b/src/Client/Configuration.hs @@ -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. 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 @@ -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 = diff --git a/src/Client/EventLoop.hs b/src/Client/EventLoop.hs --- a/src/Client/EventLoop.hs +++ b/src/Client/EventLoop.hs @@ -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 diff --git a/src/Client/EventLoop/Network.hs b/src/Client/EventLoop/Network.hs --- a/src/Client/EventLoop/Network.hs +++ b/src/Client/EventLoop/Network.hs @@ -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 diff --git a/src/Client/Hook/Snotice.hs b/src/Client/Hook/Snotice.hs --- a/src/Client/Hook/Snotice.hs +++ b/src/Client/Hook/Snotice.hs @@ -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\)$|]), 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 @@ -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 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 @@ -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 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 @@ -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. diff --git a/src/Client/Options.hs b/src/Client/Options.hs --- a/src/Client/Options.hs +++ b/src/Client/Options.hs @@ -119,7 +119,7 @@ printConfigFormat :: IO () printConfigFormat = - do path <- getNewConfigPath + do path <- getConfigPath putStrLn "" putStrLn ("Default configuration file path: " ++ path) putStrLn "" diff --git a/src/Client/State.hs b/src/Client/State.hs --- a/src/Client/State.hs +++ b/src/Client/State.hs @@ -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 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 @@ -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 diff --git a/src/Client/View/Cert.hs b/src/Client/View/Cert.hs --- a/src/Client/View/Cert.hs +++ b/src/Client/View/Cert.hs @@ -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 diff --git a/src/Client/View/Mentions.hs b/src/Client/View/Mentions.hs --- a/src/Client/View/Mentions.hs +++ b/src/Client/View/Mentions.hs @@ -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