{-# LANGUAGE ApplicativeDo, TemplateHaskell, OverloadedStrings #-}
module Client.Configuration.ServerSettings
(
ServerSettings(..)
, serverSpec
, identifierSpec
, ssNicks
, ssUser
, ssReal
, ssUserInfo
, ssPassword
, ssSaslUsername
, ssSaslPassword
, ssSaslEcdsaFile
, ssHostName
, ssPort
, ssTls
, ssTlsClientCert
, ssTlsClientKey
, ssTlsServerCert
, ssTlsCiphers
, ssConnectCmds
, ssSocksHost
, ssSocksPort
, ssChanservChannels
, ssFloodPenalty
, ssFloodThreshold
, ssMessageHooks
, ssName
, ssReconnectAttempts
, ssAutoconnect
, ssNickCompletion
, ssLogDir
, ssProtocolFamily
, ssSts
, ssTlsPubkeyFingerprint
, ssTlsCertFingerprint
, loadDefaultServerSettings
, UseTls(..)
, Fingerprint(..)
) where
import Client.Commands.Interpolation
import Client.Commands.WordCompletion
import Client.Configuration.Macros (macroCommandSpec)
import Config.Schema.Spec
import Control.Lens
import qualified Data.ByteString as B
import Data.Functor.Alt ((<!>))
import Data.List.NonEmpty (NonEmpty)
import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Text (Text)
import Data.List.Split (chunksOf, splitOn)
import qualified Data.Text as Text
import Data.Word (Word8)
import Irc.Identifier (Identifier, mkId)
import Network.Socket (HostName, PortNumber, Family(..))
import Numeric (readHex)
import System.Environment
data ServerSettings = ServerSettings
{ _ssNicks :: !(NonEmpty Text)
, _ssUser :: !Text
, _ssReal :: !Text
, _ssUserInfo :: !Text
, _ssPassword :: !(Maybe Text)
, _ssSaslUsername :: !(Maybe Text)
, _ssSaslPassword :: !(Maybe Text)
, _ssSaslEcdsaFile :: !(Maybe FilePath)
, _ssHostName :: !HostName
, _ssPort :: !(Maybe PortNumber)
, _ssTls :: !UseTls
, _ssTlsClientCert :: !(Maybe FilePath)
, _ssTlsClientKey :: !(Maybe FilePath)
, _ssTlsServerCert :: !(Maybe FilePath)
, _ssTlsCiphers :: String
, _ssConnectCmds :: ![[ExpansionChunk]]
, _ssSocksHost :: !(Maybe HostName)
, _ssSocksPort :: !PortNumber
, _ssChanservChannels :: ![Identifier]
, _ssFloodPenalty :: !Rational
, _ssFloodThreshold :: !Rational
, _ssMessageHooks :: ![Text]
, _ssName :: !(Maybe Text)
, _ssReconnectAttempts:: !Int
, _ssAutoconnect :: !Bool
, _ssNickCompletion :: WordCompletionMode
, _ssLogDir :: Maybe FilePath
, _ssProtocolFamily :: Maybe Family
, _ssSts :: !Bool
, _ssTlsPubkeyFingerprint :: !(Maybe Fingerprint)
, _ssTlsCertFingerprint :: !(Maybe Fingerprint)
}
deriving Show
data UseTls
= UseTls
| UseInsecureTls
| UseInsecure
deriving Show
data Fingerprint
= FingerprintSha1 ByteString
| FingerprintSha256 ByteString
| FingerprintSha512 ByteString
deriving Show
makeLenses ''ServerSettings
loadDefaultServerSettings :: IO ServerSettings
loadDefaultServerSettings =
do env <- getEnvironment
let username = Text.pack (fromMaybe "guest" (lookup "USER" env))
return ServerSettings
{ _ssNicks = pure username
, _ssUser = username
, _ssReal = username
, _ssUserInfo = username
, _ssPassword = Text.pack <$> lookup "IRCPASSWORD" env
, _ssSaslUsername = Nothing
, _ssSaslPassword = Text.pack <$> lookup "SASLPASSWORD" env
, _ssSaslEcdsaFile = Nothing
, _ssHostName = ""
, _ssPort = Nothing
, _ssTls = UseInsecure
, _ssTlsClientCert = Nothing
, _ssTlsClientKey = Nothing
, _ssTlsServerCert = Nothing
, _ssTlsCiphers = "HIGH"
, _ssConnectCmds = []
, _ssSocksHost = Nothing
, _ssSocksPort = 1080
, _ssChanservChannels = []
, _ssFloodPenalty = 2
, _ssFloodThreshold = 10
, _ssMessageHooks = []
, _ssName = Nothing
, _ssReconnectAttempts= 6
, _ssAutoconnect = False
, _ssNickCompletion = defaultNickWordCompleteMode
, _ssLogDir = Nothing
, _ssProtocolFamily = Nothing
, _ssSts = True
, _ssTlsPubkeyFingerprint = Nothing
, _ssTlsCertFingerprint = Nothing
}
serverSpec :: ValueSpecs (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 :: [SectionSpecs (Maybe (ServerSettings -> ServerSettings))]
settings =
[ opt "name" ssName valuesSpec
"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 valuesSpec
"Server password"
, req "username" ssUser valuesSpec
"Second component of _!_@_ usermask"
, req "realname" ssReal valuesSpec
"\"GECOS\" name sent to server visible in /whois"
, req "userinfo" ssUserInfo valuesSpec
"CTCP userinfo (currently unused)"
, opt "sasl-username" ssSaslUsername valuesSpec
"Username for SASL authentication to NickServ"
, opt "sasl-password" ssSaslPassword valuesSpec
"Password for SASL authentication to NickServ"
, opt "sasl-ecdsa-key" ssSaslEcdsaFile stringSpec
"Path to ECDSA key for non-password SASL authentication"
, req "tls" ssTls useTlsSpec
"Set to `yes` to enable secure connect. Set to `yes-insecure` to disable certificate checking."
, opt "tls-client-cert" ssTlsClientCert stringSpec
"Path to TLS client certificate"
, opt "tls-client-key" ssTlsClientKey stringSpec
"Path to TLS client key"
, 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 valuesSpec
"RFC 1459 rate limiting, seconds of penalty per message (default 2)"
, req "flood-threshold" ssFloodThreshold valuesSpec
"RFC 1459 rate limiting, seconds of allowed penalty accumulation (default 10)"
, req "message-hooks" ssMessageHooks valuesSpec
"Special message hooks to enable: \"buffextras\" available"
, req "reconnect-attempts" ssReconnectAttempts valuesSpec
"Number of reconnection attempts on lost connection"
, 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 "protocol-family" ssProtocolFamily protocolFamilySpec
"IP protocol family to use for this connection"
, 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"
]
fingerprintSpec :: ValueSpecs Fingerprint
fingerprintSpec =
customSpec "fingerprint" stringSpec $ \str ->
do bytes <- B.pack <$> traverse readWord8 (byteStrs str)
case B.length bytes of
20 -> Just (FingerprintSha1 bytes)
32 -> Just (FingerprintSha256 bytes)
64 -> Just (FingerprintSha512 bytes)
_ -> Nothing
where
readWord8 :: String -> Maybe Word8
readWord8 i =
case readHex i of
[(x,"")] | 0 <= x, x < 256 -> Just (fromIntegral (x :: Integer))
_ -> Nothing
byteStrs :: String -> [String]
byteStrs str
| ':' `elem` str = splitOn ":" str
| otherwise = chunksOf 2 str
protocolFamilySpec :: ValueSpecs Family
protocolFamilySpec =
AF_INET <$ atomSpec "inet"
<!> AF_INET6 <$ atomSpec "inet6"
nicksSpec :: ValueSpecs (NonEmpty Text)
nicksSpec = oneOrNonemptySpec valuesSpec
useTlsSpec :: ValueSpecs UseTls
useTlsSpec =
UseTls <$ atomSpec "yes"
<!> UseInsecureTls <$ atomSpec "yes-insecure"
<!> UseInsecure <$ atomSpec "no"
nickCompletionSpec :: ValueSpecs WordCompletionMode
nickCompletionSpec =
defaultNickWordCompleteMode <$ atomSpec "default"
<!> slackNickWordCompleteMode <$ atomSpec "slack"
identifierSpec :: ValueSpecs Identifier
identifierSpec = mkId <$> valuesSpec