{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings #-}
module Client.Configuration.ServerSettings
(
ServerSettings(..)
, HookConfig(..)
, serverSpec
, identifierSpec
, ssNicks
, ssUser
, ssReal
, ssPassword
, ssSaslMechanism
, ssHostName
, ssPort
, ssTls
, ssTlsVerify
, ssTlsClientCert
, ssTlsClientKey
, ssTlsClientKeyPassword
, ssTlsServerCert
, ssTlsCiphers
, ssConnectCmds
, ssSocksHost
, ssSocksPort
, ssChanservChannels
, ssFloodPenalty
, ssFloodThreshold
, ssMessageHooks
, ssName
, ssReconnectAttempts
, ssReconnectError
, ssAutoconnect
, ssNickCompletion
, ssLogDir
, ssBindHostName
, ssSts
, ssTlsPubkeyFingerprint
, ssTlsCertFingerprint
, ssShowAccounts
, ssCapabilities
, SaslMechanism(..)
, _SaslExternal
, _SaslEcdsa
, _SaslPlain
, Secret(..)
, SecretException(..)
, loadSecrets
, defaultServerSettings
, UseTls(..)
, Fingerprint(..)
, TlsMode(..)
, KnownRegex(..)
, getRegex
) where
import Client.Commands.Interpolation
import Client.Commands.WordCompletion
import Client.Configuration.Macros (macroCommandSpec)
import Config.Schema.Spec
import Control.Exception (Exception, displayException, throwIO, try)
import Control.Lens
import Control.Monad ((>=>))
import qualified Data.ByteString as B
import Data.Functor.Alt ((<!>))
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.ByteString (ByteString)
import Data.Monoid
import Data.Text (Text)
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.Split (chunksOf, splitOn)
import qualified Data.Text as Text
import Irc.Identifier (Identifier, mkId)
import Network.Socket (HostName, PortNumber)
import Numeric (readHex)
import qualified System.Exit as Exit
import qualified System.Process as Process
import Text.Regex.TDFA
import Text.Regex.TDFA.Text (compile)
data ServerSettings = ServerSettings
{ _ssNicks :: !(NonEmpty Text)
, _ssUser :: !Text
, _ssReal :: !Text
, _ssPassword :: !(Maybe Secret)
, _ssSaslMechanism :: !(Maybe SaslMechanism)
, _ssHostName :: !HostName
, _ssPort :: !(Maybe PortNumber)
, _ssTls :: !TlsMode
, _ssTlsVerify :: !Bool
, _ssTlsClientCert :: !(Maybe FilePath)
, _ssTlsClientKey :: !(Maybe FilePath)
, _ssTlsClientKeyPassword :: !(Maybe Secret)
, _ssTlsServerCert :: !(Maybe FilePath)
, _ssTlsCiphers :: String
, _ssTlsPubkeyFingerprint :: !(Maybe Fingerprint)
, _ssTlsCertFingerprint :: !(Maybe Fingerprint)
, _ssSts :: !Bool
, _ssConnectCmds :: ![[ExpansionChunk]]
, _ssSocksHost :: !(Maybe HostName)
, _ssSocksPort :: !PortNumber
, _ssChanservChannels :: ![Identifier]
, _ssFloodPenalty :: !Rational
, _ssFloodThreshold :: !Rational
, _ssMessageHooks :: ![HookConfig]
, _ssName :: !(Maybe Text)
, _ssReconnectAttempts:: !Int
, _ssReconnectError :: !(Maybe KnownRegex)
, _ssAutoconnect :: !Bool
, _ssNickCompletion :: WordCompletionMode
, _ssLogDir :: Maybe FilePath
, _ssBindHostName :: Maybe HostName
, _ssShowAccounts :: !Bool
, _ssCapabilities :: ![Text]
}
deriving Show
data TlsMode = TlsYes | TlsNo | TlsStart
deriving Show
data Secret
= SecretText Text
| SecretCommand (NonEmpty Text)
deriving Show
data SaslMechanism
= SaslPlain (Maybe Text) Text Secret
| SaslEcdsa (Maybe Text) Text FilePath
| SaslExternal (Maybe Text)
deriving Show
data KnownRegex = KnownRegex Text Regex
getRegex :: KnownRegex -> Regex
getRegex (KnownRegex _ r) = r
instance Show KnownRegex where show (KnownRegex x _) = show x
data HookConfig = HookConfig Text [Text]
deriving Show
data UseTls
= UseTls
| UseInsecureTls
| UseInsecure
deriving Show
data Fingerprint
= FingerprintSha1 ByteString
| FingerprintSha256 ByteString
| FingerprintSha512 ByteString
deriving Show
makeLenses ''ServerSettings
makePrisms ''SaslMechanism
defaultServerSettings :: ServerSettings
defaultServerSettings =
ServerSettings
{ _ssNicks = pure "guest"
, _ssUser = "username"
, _ssReal = "realname"
, _ssPassword = Nothing
, _ssSaslMechanism = Nothing
, _ssHostName = ""
, _ssPort = Nothing
, _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
, _ssChanservChannels = []
, _ssFloodPenalty = 2
, _ssFloodThreshold = 10
, _ssMessageHooks = []
, _ssName = Nothing
, _ssReconnectAttempts= 6
, _ssReconnectError = Nothing
, _ssAutoconnect = False
, _ssNickCompletion = defaultNickWordCompleteMode
, _ssLogDir = Nothing
, _ssBindHostName = Nothing
, _ssShowAccounts = False
, _ssCapabilities = []
}
serverSpec :: ValueSpec (ServerSettings -> ServerSettings)
serverSpec = sectionsSpec "server-settings" $
composeMaybe <$> sequenceA settings
where
composeMaybe :: [Maybe (a -> a)] -> a -> a
composeMaybe = ala Endo (foldMap . foldMap)
req name l s info
= optSection' name ?? info
$ set l <$> s
opt name l s info
= optSection' name ?? info
$ set l . Just <$> s <!>
set l Nothing <$ atomSpec "clear"
settings :: [SectionsSpec (Maybe (ServerSettings -> ServerSettings))]
settings =
[ opt "name" ssName anySpec
"The name used to identify this server in the client"
, req "hostname" ssHostName stringSpec
"Hostname of server"
, opt "port" ssPort numSpec
"Port number of server. Default 6667 without TLS or 6697 with TLS"
, req "nick" ssNicks nicksSpec
"Nicknames to connect with in order"
, opt "password" ssPassword anySpec
"Server password"
, req "username" ssUser anySpec
"Second component of _!_@_ usermask"
, req "realname" ssReal anySpec
"\"GECOS\" name sent to server visible in /whois"
, opt "sasl" ssSaslMechanism saslMechanismSpec
"SASL settings"
, 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"
, opt "tls-client-key" ssTlsClientKey stringSpec
"Path to TLS client key"
, opt "tls-client-key-password" ssTlsClientKeyPassword anySpec
"Password for decrypting TLS client key PEM file"
, opt "tls-server-cert" ssTlsServerCert stringSpec
"Path to CA certificate bundle"
, req "tls-ciphers" ssTlsCiphers stringSpec
"OpenSSL cipher specification. Default to \"HIGH\""
, opt "socks-host" ssSocksHost stringSpec
"Hostname of SOCKS5 proxy server"
, req "socks-port" ssSocksPort numSpec
"Port number of SOCKS5 proxy server"
, req "connect-cmds" ssConnectCmds (listSpec macroCommandSpec)
"Command to be run upon successful connection to server"
, req "chanserv-channels" ssChanservChannels (listSpec identifierSpec)
"Channels with ChanServ permissions available"
, req "flood-penalty" ssFloodPenalty anySpec
"RFC 1459 rate limiting, seconds of penalty per message (default 2)"
, req "flood-threshold" ssFloodThreshold anySpec
"RFC 1459 rate limiting, seconds of allowed penalty accumulation (default 10)"
, req "message-hooks" ssMessageHooks (listSpec hookSpec)
"Special message hooks to enable: \"buffextras\" available"
, req "reconnect-attempts" ssReconnectAttempts anySpec
"Number of reconnection attempts on lost connection"
, opt "reconnect-error" ssReconnectError regexSpec
"Regular expression for disconnect messages that trigger reconnect."
, req "autoconnect" ssAutoconnect yesOrNoSpec
"Set to `yes` to automatically connect at client startup"
, req "nick-completion" ssNickCompletion nickCompletionSpec
"Behavior for nickname completion with TAB"
, opt "log-dir" ssLogDir stringSpec
"Path to log file directory for this server"
, opt "bind-hostname" ssBindHostName stringSpec
"Source address to bind to before connecting"
, req "sts" ssSts yesOrNoSpec
"Honor server STS policies forcing TLS connections"
, opt "tls-cert-fingerprint" ssTlsCertFingerprint fingerprintSpec
"Check SHA1, SHA256, or SHA512 certificate fingerprint"
, opt "tls-pubkey-fingerprint" ssTlsPubkeyFingerprint fingerprintSpec
"Check SHA1, SHA256, or SHA512 public key fingerprint"
, req "show-accounts" ssShowAccounts yesOrNoSpec
"Render account names alongside chat messages"
, req "capabilities" ssCapabilities anySpec
"Extra capabilities to unconditionally request from the server"
]
tlsModeSpec :: ValueSpec TlsMode
tlsModeSpec =
TlsYes <$ atomSpec "yes" <!>
TlsNo <$ atomSpec "no" <!>
TlsStart <$ atomSpec "starttls"
saslMechanismSpec :: ValueSpec SaslMechanism
saslMechanismSpec = plain <!> external <!> ecdsa
where
mech m = reqSection' "mechanism" (atomSpec m) "Mechanism"
authzid = optSection "authzid" "Authorization identity"
username = reqSection "username" "Authentication identity"
plain =
sectionsSpec "sasl-plain" $ SaslPlain <$
optSection' "mechanism" (atomSpec "plain") "Mechanism" <*>
authzid <*> username <*> reqSection "password" "Password"
external =
sectionsSpec "sasl-external" $ SaslExternal <$ mech "external" <*>
authzid
ecdsa =
sectionsSpec "sasl-ecdsa-nist256p-challenge-mech" $
SaslEcdsa <$ mech "ecdsa-nist256p-challenge" <*>
authzid <*> username <*>
reqSection' "private-key" stringSpec "Private key file"
hookSpec :: ValueSpec HookConfig
hookSpec =
flip HookConfig [] <$> anySpec <!>
(\(x:|xs) -> HookConfig x xs) <$> nonemptySpec anySpec
fingerprintSpec :: ValueSpec Fingerprint
fingerprintSpec =
customSpec "fingerprint" stringSpec $ \str ->
do bytes <- B.pack <$> traverse readWord8 (byteStrs str)
case B.length bytes of
20 -> Right (FingerprintSha1 bytes)
32 -> Right (FingerprintSha256 bytes)
64 -> Right (FingerprintSha512 bytes)
_ -> Left "expected 20, 32, or 64 bytes"
where
readWord8 i =
case readHex i of
[(x,"")]
| 0 <= x, x < 256 -> Right (fromIntegral (x :: Integer))
| otherwise -> Left "byte out-of-bounds"
_ -> Left "bad hex-encoded byte"
byteStrs :: String -> [String]
byteStrs str
| ':' `elem` str = splitOn ":" str
| otherwise = chunksOf 2 str
nicksSpec :: ValueSpec (NonEmpty Text)
nicksSpec = oneOrNonemptySpec anySpec
nickCompletionSpec :: ValueSpec WordCompletionMode
nickCompletionSpec =
defaultNickWordCompleteMode <$ atomSpec "default"
<!> slackNickWordCompleteMode <$ atomSpec "slack"
identifierSpec :: ValueSpec Identifier
identifierSpec = mkId <$> anySpec
regexSpec :: ValueSpec KnownRegex
regexSpec = customSpec "regex" anySpec $ \str ->
case compile defaultCompOpt ExecOption{captureGroups = False} str of
Left e -> Left (Text.pack e)
Right r -> Right (KnownRegex str r)
instance HasSpec Secret where
anySpec = SecretText <$> textSpec <!>
SecretCommand <$> sectionsSpec "command" (reqSection "command" "Command and arguments to execute to secret")
data SecretException = SecretException String String
deriving Show
instance Exception SecretException
loadSecrets :: ServerSettings -> IO ServerSettings
loadSecrets =
traverseOf (ssPassword . _Just ) (loadSecret "server password") >=>
traverseOf (ssSaslMechanism . _Just . _SaslPlain . _3) (loadSecret "SASL password") >=>
traverseOf (ssTlsClientKeyPassword . _Just ) (loadSecret "TLS key password")
loadSecret :: String -> Secret -> IO Secret
loadSecret _ (SecretText txt) = pure (SecretText txt)
loadSecret label (SecretCommand (cmd NonEmpty.:| args)) =
do let u = Text.unpack
res <- try (Process.readProcessWithExitCode (u cmd) (map u args) "")
case res of
Right (Exit.ExitSuccess,out,_) -> pure (SecretText (Text.pack (takeWhile ('\n' /=) out)))
Right (Exit.ExitFailure{},_,err) -> throwIO (SecretException label err)
Left ioe -> throwIO (SecretException label (displayException (ioe::IOError)))