diohsc-0.1.16: GeminiProtocol.hs
-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module GeminiProtocol where
import Control.Concurrent
import Control.Exception
import Control.Monad (guard, mplus, msum, unless, void,
when)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.Default.Class (def)
import Data.Hourglass
import Data.List (intercalate, intersperse,
isPrefixOf, stripPrefix, transpose)
import Data.Maybe (fromMaybe, isJust)
import Network.Simple.TCP (closeSock, connectSock,
connectSockSOCKS5)
import Network.Socket (Socket)
import Network.TLS as TLS
import Network.TLS.Extra.Cipher
import Network.URI (isIPv4address, isIPv6address)
import Safe
import System.FilePath
import System.IO.Error (catchIOError)
import Time.System
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.X509 as X
import qualified Data.X509.CertificateStore as X
import qualified Data.X509.Validation as X
import qualified Codec.MIME.Parse as MIME
import qualified Codec.MIME.Type as MIME
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Text as TS
import qualified Data.Text.Encoding as TS
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as T
import ANSIColour
import BoundedBSChan
import ClientCert
import ClientSessionManager
import Fingerprint
import Identity
import Mundanities
import Request
import ServiceCerts
import URI
import Util
#ifdef DRUNKEN_BISHOP
import Data.Digest.DrunkenBishop
#endif
defaultGeminiPort :: Int
defaultGeminiPort = 1965
data MimedData = MimedData {mimedMimetype :: MIME.Type, mimedBody :: BL.ByteString}
deriving (Eq,Ord,Show)
showMimeType :: MimedData -> String
showMimeType = TS.unpack . MIME.showMIMEType . MIME.mimeType . mimedMimetype
data ResponseMalformation
= BadHeaderTermination
| BadStatus String
| BadMetaSeparator
| BadMetaLength
| BadUri String
| BadMime String
deriving (Eq,Ord,Show)
data Response
= Input { inputHidden :: Bool, inputPrompt :: String }
| Success { successData :: MimedData }
| Redirect { permanent :: Bool, redirectTo :: URIRef }
| Failure { failureCode :: Int, failureInfo :: String }
| MalformedResponse { responseMalformation :: ResponseMalformation }
deriving (Eq,Ord,Show)
data InteractionCallbacks = InteractionCallbacks
{ icbDisplayInfo :: [String] -> IO ()
, icbDisplayWarning :: [String] -> IO ()
, icbWaitKey :: String -> IO Bool -- ^return False on interrupt, else True
, icbPromptYN :: Bool -- ^default answer
-> String -- ^prompt
-> IO Bool
}
data SocksProxy
= NoSocksProxy
| Socks5Proxy String String
-- Note: we're forced to resort to mvars because the tls library (tls-1.5.4 at
-- least) uses IO rather than MonadIO in the onServerCertificate callback.
data RequestContext = RequestContext
InteractionCallbacks
X.CertificateStore
(MVar (Set.Set (Fingerprint, X.ServiceID)))
(MVar (Set.Set Fingerprint))
(MVar (Set.Set Fingerprint))
(MVar (Set.Set String))
FilePath
Bool
SocksProxy
ClientSessions
initRequestContext :: InteractionCallbacks -> FilePath -> Bool -> SocksProxy -> IO RequestContext
initRequestContext callbacks path readOnly socksProxy =
let certPath = path </> "trusted_certs"
serviceCertsPath = path </> "known_hosts"
in do
unless readOnly $ do
mkdirhier certPath
mkdirhier serviceCertsPath
certStore <- fromMaybe (X.makeCertificateStore []) <$> X.readCertificateStore certPath
mTrusted <- newMVar Set.empty
mIgnoredCertErrors <- newMVar Set.empty
mWarnedCA <- newMVar Set.empty
mIgnoredCCertWarnings <- newMVar Set.empty
RequestContext callbacks certStore mTrusted mIgnoredCertErrors mWarnedCA mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy <$> newClientSessions
requestOfProxiesAndUri :: M.Map String Host -> URI -> Maybe Request
requestOfProxiesAndUri proxies uri =
let scheme = uriScheme uri
in if scheme == "file"
then let filePath path
| ('/':_) <- path = Just path
| Just path' <- stripPrefix "localhost" path, ('/':_) <- path' = Just path'
| otherwise = Nothing
in LocalFileRequest . unescapeUriString <$> filePath (uriPath uri)
else do
host <- M.lookup scheme proxies `mplus` do
guard $ scheme == "gemini" || "gemini+" `isPrefixOf` scheme
-- ^people keep suggesting "gemini+foo" schemes for variations
-- on gemini. On the basis that this naming convention should
-- indicate that the scheme is backwards-compatible with
-- actual gemini, we handle them the same as gemini.
hostname <- decodeIPv6 <$> uriRegName uri
let port = fromMaybe defaultGeminiPort $ uriPort uri
return $ Host hostname port
return . NetworkRequest host . stripUriForGemini $ uri
where
decodeIPv6 :: String -> String
decodeIPv6 ('[':rest) | last rest == ']', addr <- init rest, isIPv6address addr = addr
decodeIPv6 h = h
newtype RequestException = ExcessivelyLongUri Int
deriving Show
instance Exception RequestException
-- |On success, returns `Right (lazyResp,terminate)`. `lazyResp` is a `Response`
-- with lazy IO, so attempts to read it may block while data is received. If
-- the full response is not needed, for example because of an error, the IO
-- action `terminate` should be called to close the connection.
makeRequest :: RequestContext
-> Maybe Identity -- ^client certificate to offer
-> Int -- ^bound in bytes for response stream buffering
-> Bool -- ^whether to display extra information about connection
-> Request -> IO (Either SomeException (Response, IO ()))
makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ promptYN)
certStore mTrusted mIgnoredCertErrors mWarnedCA mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy clientSessions) mIdent bound verboseConnection (NetworkRequest (Host hostname port) uri) =
let requestBytes = TS.encodeUtf8 . TS.pack $ show uri ++ "\r\n"
uriLength = BS.length requestBytes - 2
ccfp = clientCertFingerprint . identityCert <$> mIdent
in if uriLength > 1024 then return . Left . toException $ ExcessivelyLongUri uriLength
else handle handleAll $ do
session <- lookupClientSession hostname ccfp clientSessions
let serverId = if port == defaultGeminiPort then BS.empty else TS.encodeUtf8 . TS.pack . (':':) $ show port
sessionManager = clientSessionManager 3600 clientSessions ccfp
params = (TLS.defaultParamsClient hostname serverId)
{ clientSupported = def
{ supportedCiphers = gemini_ciphersuite
, supportedExtendedMainSecret = AllowEMS
}
-- |RFC6066 disallows SNI with literal IP addresses
, clientUseServerNameIndication = not $ isIPv4address hostname || isIPv6address hostname
, clientHooks = def
{ onServerCertificate = checkServerCert
, onCertificateRequest = \(_,pairs,_) -> case mIdent of
Nothing -> return Nothing
Just ident@(Identity idName (ClientCert chain key)) -> do
-- Note: I have once seen this way of detecting
-- pre-tls1.3 give a false positive.
let is13 = maybe False ((HashIntrinsic,SignatureEd25519) `elem`) pairs
allow <- if isTemporary ident || is13 then return True else do
ignored <- (idName `Set.member`) <$> readMVar mIgnoredCCertWarnings
if ignored then return True else do
displayWarning ["This may be a pre-TLS1.3 server: identity "
<> idName <> " might be revealed to eavesdroppers!"]
conf <- promptYN False "Identify anyway?"
when conf $ modifyMVar_ mIgnoredCCertWarnings
(return . Set.insert idName)
return conf
return $ if allow then Just (chain,key) else Nothing
}
, clientShared = def
{ sharedCAStore = certStore
, sharedSessionManager = sessionManager }
, clientUseEarlyData = True -- ^Send early data (RTT0) if server session allows it
, clientWantSessionResume = session
}
(sock,context) <- do
let retryNoResume (HandshakeFailed (Error_Protocol _ HandshakeFailure))
| isJust session = do
-- Work around a mysterious problem seen with dezhemini+libssl:
displayWarning [ "Handshake failure when resuming TLS session; retrying with full handshake." ]
sock <- openSocket
c <- TLS.contextNew sock $ params { clientWantSessionResume = Nothing }
handshake c >> return (sock,c)
retryNoResume e = throw e
sock <- openSocket
c <- TLS.contextNew sock params
handle retryNoResume $ handshake c >> return (sock,c)
void . runMaybeT $ do
info <- MaybeT $ contextGetInformation context
when (infoVersion info == TLS12 && not (infoExtendedMainSecret info) && isJust mIdent) $ do
lift $ displayWarning [ "TLS1.2 server without EMS support is vulnerable to triple-handshake attack." ]
when verboseConnection $ do
lift . displayInfo $ [ "TLS version " ++ show (infoVersion info) ++
", cipher " ++ cipherName (infoCipher info) ]
mode <- MaybeT . return $ infoTLS13HandshakeMode info
lift . displayInfo $ [ "Handshake mode " ++ show mode ]
sendData context $ BL.fromStrict requestBytes
chan <- newBSChan bound
let recvAllLazily = do
r <- recvData context
unless (BS.null r) $ writeBSChan chan r >> recvAllLazily
ignoreIOError = (`catchIOError` (const $ return ()))
recvThread <- forkFinally recvAllLazily $ \_ ->
-- |XXX: note that writeBSChan can't block when writing BS.empty
writeBSChan chan BS.empty
>> ignoreIOError (bye context)
>> closeSock sock
lazyResp <- parseResponse . BL.fromChunks . takeWhile (not . BS.null) <$> getBSChanContents chan
return $ Right (lazyResp, killThread recvThread)
where
handleAll :: SomeException -> IO (Either SomeException a)
handleAll = return . Left
openSocket :: IO Socket
openSocket = case socksProxy of
NoSocksProxy -> fst <$> connectSock hostname (show port)
Socks5Proxy socksHostname socksPort -> do
sock <- fst <$> connectSock socksHostname socksPort
_ <- connectSockSOCKS5 sock hostname (show port)
return sock
checkServerCert store cache service chain@(X.CertificateChain signedCerts) = do
errors <- doTofu =<< X.validate X.HashSHA256 X.defaultHooks
(X.defaultChecks { X.checkExhaustive = True , X.checkLeafV3 = False }) store cache service chain
if null errors || any isTrustError errors || null signedCerts
then return errors
else do
ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredCertErrors
if ignored then return [] else do
displayWarning [
"Certificate chain has trusted root, but validation errors: "
++ show errors ]
displayWarning $ showChain signedCerts
ignore <- promptYN False "Ignore errors?"
if ignore
then modifyMVar_ mIgnoredCertErrors (return . Set.insert tailFingerprint) >> return []
else return errors
where
isTrustError = (`elem` [X.UnknownCA, X.SelfSigned, X.NotAnAuthority])
-- |error pertaining to the tail certificate, to be ignored if the
-- user explicitly trusts the certificate for this service.
-- These don't actually affect the TOFU-trustworthiness of a
-- certificate, but we warn the user about them anyway.
isTrustableError X.LeafNotV3 = True
isTrustableError (X.NameMismatch _) = True
isTrustableError _ = False
tailSigned = head signedCerts
tailFingerprint = fingerprint tailSigned
chainSigsFail :: Maybe X.SignatureFailure
chainSigsFail =
let verify (signed:signing:rest) = msum [
case X.verifySignedSignature signed . X.certPubKey $ X.getCertificate signing of
X.SignaturePass -> Nothing
X.SignatureFailed failure -> Just failure
, verify (signing:rest) ]
verify _ = Nothing
in verify signedCerts
doTofu errors = if not . any isTrustError $ errors
then do
(tailFingerprint `Set.member`) <$> readMVar mWarnedCA >>! do
displayInfo [ "Accepting valid certificate chain with trusted root CA: " <>
showIssuerDN signedCerts ]
when verboseConnection . displayInfo $ showChain signedCerts
modifyMVar_ mWarnedCA (return . Set.insert tailFingerprint)
return errors
else do
trust <- checkTrust $ filter isTrustableError errors
return $ if trust
then filter (\e -> not $ isTrustError e || isTrustableError e) errors
else errors
checkTrust :: [X.FailedReason] -> IO Bool
checkTrust errors = do
trusted <- ((tailFingerprint, service) `Set.member`) <$> readMVar mTrusted
if trusted then return True else do
trust <- checkTrust' errors
when trust $ modifyMVar_ mTrusted (return . Set.insert (tailFingerprint, service))
return trust
checkTrust' :: [X.FailedReason] -> IO Bool
checkTrust' _ | Just sigFail <- chainSigsFail = do
displayWarning [ "Invalid signature in certificate chain: " ++ show sigFail ]
return False
checkTrust' errors = do
let certs = map X.getCertificate signedCerts
tailCert = head certs
tailHex = "SHA256:" <> fingerprintHex tailFingerprint
serviceString = serviceToString service
warnErrors = unless (null errors) . displayWarning $
[ "WARNING: tail certificate has verification errors: " <> show errors ]
known <- loadServiceCert serviceCertsPath service
if known == Just tailSigned then do
displayInfo [ "Accepting previously trusted certificate " ++ take 8 (fingerprintHex tailFingerprint) ++ "; expires " ++ printExpiry tailCert ++ "." ]
when verboseConnection . displayInfo $ fingerprintPicture tailFingerprint
return True
else do
displayInfo $ showChain signedCerts
let promptTrust df pprompt tprompt = do
p <- promptYN df pprompt
if p then return (True,True) else
(False,) <$> promptYN df tprompt
tempTimes <- loadTempServiceInfo serviceCertsPath service >>= \case
Just (n,tempHex) | tempHex == tailHex -> pure n
_ -> pure 0
(saveCert,trust) <- case known of
Nothing -> do
displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ]
warnErrors
when (tempTimes > 0) $ displayInfo [
"This certificate has been temporarily trusted " <>
show tempTimes <> " times." ]
let prompt = "provided certificate (" ++
take 8 (fingerprintHex tailFingerprint) ++ ")?"
promptTrust True ("Permanently trust " ++ prompt)
("Temporarily trust " ++ prompt)
Just trustedSignedCert -> do
currentTime <- timeConvert <$> timeCurrent
let trustedCert = X.getCertificate trustedSignedCert
expired = currentTime > (snd . X.certValidity) trustedCert
samePubKey = X.certPubKey trustedCert == X.certPubKey tailCert
oldFingerprint = fingerprint trustedSignedCert
oldHex = "SHA256:" <> fingerprintHex oldFingerprint
oldInfo = [ "Fingerprint of old certificate: " <> oldHex ]
++ fingerprintPicture oldFingerprint
++ [ "Old certificate " ++ (if expired then "expired" else "expires") ++
": " ++ printExpiry trustedCert ]
signedByOld = X.SignaturePass `elem`
((`X.verifySignedSignature` X.certPubKey trustedCert) <$> signedCerts)
if signedByOld
then displayInfo $
("The new certificate chain is signed by " ++
(if expired then "an EXPIRED" else "a") ++
" key previously trusted for this host.") : oldInfo
else if expired || samePubKey
then displayInfo $
("A different " ++ (if expired then "expired " else "non-expired ") ++
"certificate " ++ (if samePubKey then "with the same public key " else "") ++
"for " ++ serviceString ++ " was previously explicitly trusted.") : oldInfo
else displayWarning $
("CAUTION: A certificate with a different public key for " ++ serviceString ++
" was previously explicitly trusted and has not expired!") : oldInfo
when (tempTimes > 0) $ displayInfo [
"The new certificate has been temporarily trusted " <>
show tempTimes <> " times." ]
warnErrors
promptTrust (signedByOld || expired || samePubKey)
("Permanently trust new certificate" <>
(if readOnly then ""
else " (replacing old certificate (which will be backed up))") <> "?")
("Temporarily trust new certificate" <>
(if readOnly then ""
else " (but keep old certificate)") <> "?")
when (saveCert && not readOnly) $
saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr
when (trust && not saveCert && not readOnly) $
saveTempServiceInfo serviceCertsPath service (tempTimes + 1, tailHex) `catch` printIOErr
pure trust
printExpiry :: X.Certificate -> String
printExpiry = timePrint ISO8601_Date . snd . X.certValidity
showCN :: X.DistinguishedName -> String
showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . X.getCharacterStringRawData) . X.getDnElement X.DnCommonName
showIssuerDN :: [X.SignedCertificate] -> String
showIssuerDN signed = case lastMay signed of
Nothing -> ""
Just headSigned -> showCN . X.certIssuerDN $ X.getCertificate headSigned
showChain :: [X.SignedCertificate] -> [String]
showChain [] = [""]
showChain signed = let
sigChain = reverse signed
certs = X.getCertificate <$> sigChain
issuerCN = showCN . X.certIssuerDN $ head certs
subjectCNs = showCN . X.certSubjectDN <$> certs
hexes = ("SHA256:" <>) . fingerprintHex . fingerprint <$> sigChain
pics = fingerprintPicture . fingerprint <$> sigChain
expStrs = ("Expires " ++) . printExpiry <$> certs
picsWithInfo = ((centre 23 <$>) <$>) $ zipWith (++) pics $ transpose [subjectCNs, expStrs]
centre n s = take n $ replicate ((n - length s) `div` 2) ' ' ++ s ++ repeat ' '
tweenCol = replicate 6 " " ++ [" >>> "] ++ replicate 6 " "
sideBySide = (concat <$>) . transpose
in [ "Certificate chain: " ++ intercalate " >>> " (issuerCN:subjectCNs) ]
++ (sideBySide . intersperse tweenCol $ picsWithInfo)
++ zipWith (++) ("": repeat ">>> ") hexes
printIOErr :: IOError -> IO ()
printIOErr = displayWarning . (:[]) . show
fingerprintHex :: Fingerprint -> String
fingerprintHex (Fingerprint fp) = concatMap hexWord8 $ BS.unpack fp
where hexWord8 w =
let (a,b) = quotRem w 16
hex = ("0123456789abcdef" !!) . fromIntegral
in hex a : hex b : ""
fingerprintPicture :: Fingerprint -> [String]
#ifdef DRUNKEN_BISHOP
fingerprintPicture (Fingerprint fp) = boxedDrunkenBishop fp where
boxedDrunkenBishop :: BS.ByteString -> [String]
boxedDrunkenBishop s = ["+-----[X509]------+"]
++ (map (('|':) . (++"|")) . lines $ drunkenBishopPreHashed s)
++ ["+----[SHA256]-----+"]
drunkenBishopPreHashed :: BS.ByteString -> String
drunkenBishopPreHashed = drunkenBishopWithOptions $
drunkenBishopDefaultOptions { drunkenBishopHash = id }
#else
fingerprintPicture _ = []
#endif
-- |those ciphers from ciphersuite_default fitting the requirements
-- recommended by the gemini "best practices" document:
-- require ECDHE/DHE (for PFS), and >=SHA2, and AES/CHACHA20.
-- Some of these were subsequently commented out once tls-2.0 dropped
-- support for them.
gemini_ciphersuite :: [Cipher]
gemini_ciphersuite =
[ -- First the PFS + GCM + SHA2 ciphers
cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384
, cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256
, cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384
, cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256
--, cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384
--, cipher_DHE_RSA_CHACHA20POLY1305_SHA256
, -- Next the PFS + CCM + SHA2 ciphers
cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256
--, cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256
-- Next the PFS + CBC + SHA2 ciphers
--, cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384
--, cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384
--, cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256
-- TLS13 (listed at the end but version is negotiated first)
, cipher_TLS13_AES128GCM_SHA256
, cipher_TLS13_AES256GCM_SHA384
, cipher_TLS13_CHACHA20POLY1305_SHA256
, cipher_TLS13_AES128CCM_SHA256
]
parseResponse :: BL.ByteString -> Response
parseResponse resp =
let (header, rest) = BLC.break (== '\r') resp
body = BL.drop 2 rest
statusString = T.unpack . stripControl . T.decodeUtf8 . BL.take 2 $ header
separator = BL.take 1 . BL.drop 2 $ header
meta = T.unpack . stripControl . T.decodeUtf8 . BL.drop 3 $ header
in
if BL.take 2 rest /= "\r\n" then MalformedResponse BadHeaderTermination
else if separator `notElem` [""," ","\t"] -- ^allow \t for now, though it's against latest spec
then MalformedResponse BadMetaSeparator
else if BL.length header > 1024+3 then MalformedResponse BadMetaLength
else case readMay statusString of
Just status | status >= 10 && status < 70 ->
let (status1,status2) = divMod status 10
in case status1 of
1 -> Input (status2 == 1) meta
2 -> maybe (MalformedResponse (BadMime meta))
(\mime -> Success $ MimedData mime body) $
MIME.parseMIMEType (TS.pack $
if null meta then "text/gemini; charset=utf-8" else meta)
3 -> maybe (MalformedResponse (BadUri meta))
(Redirect (status2 == 1)) $ parseUriReference meta
_ -> Failure status meta
_ -> MalformedResponse (BadStatus statusString)
makeRequest _ _ _ _ (LocalFileRequest _) = error "File requests not handled by makeRequest"