diohsc-0.1.3: 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 OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module GeminiProtocol where
import Control.Concurrent
import Control.Exception
import Control.Monad (guard, mplus, unless, when)
import Data.Default.Class (def)
import Data.Hourglass
import Data.List (intercalate, intersperse,
isPrefixOf, stripPrefix, transpose)
import Data.Maybe (fromMaybe)
import Data.X509
import Data.X509.CertificateStore
import Data.X509.Validation hiding (Fingerprint (..),
getFingerprint)
import Network.Socket (AddrInfo (..), Socket,
SocketOption (..), SocketType (..),
close, connect, defaultHints,
getAddrInfo, setSocketOption,
socket)
import Network.TLS as TLS
import Network.TLS.Extra.Cipher
import Safe
import System.FilePath
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 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 BoundedBSChan
import ClientCert
import ClientSessionManager
import Fingerprint
import Identity
import Mundanities
import Request
import ServiceCerts
import URI
import Data.Digest.DrunkenBishop
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
}
-- 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
CertificateStore
(MVar (Set.Set Fingerprint))
(MVar (Set.Set Fingerprint))
FilePath
Bool
ClientSessions
initRequestContext :: InteractionCallbacks -> FilePath -> Bool -> IO RequestContext
initRequestContext callbacks path readOnly =
let certPath = path </> "trusted_certs"
serviceCertsPath = path </> "known_hosts"
in do
mkdirhier certPath
mkdirhier serviceCertsPath
certStore <- fromMaybe (makeCertificateStore []) <$> readCertificateStore certPath
mTrusted <- newMVar Set.empty
mIgnoredErrors <- newMVar Set.empty
RequestContext callbacks certStore mTrusted mIgnoredErrors serviceCertsPath readOnly <$> 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 <- uriRegName uri
let port = fromMaybe defaultGeminiPort $ uriPort uri
return $ Host hostname port
return . NetworkRequest host $ uri
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
-> Request -> IO (Either SomeException (Response, IO ()))
makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ promptYN)
certStore mTrusted mIgnoredErrors serviceCertsPath readOnly clientSessions) mIdent bound (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 }
, clientHooks = def
{ onServerCertificate = checkServerCert
, onCertificateRequest = \(_,pairs,_) -> case mIdent of
Nothing -> return Nothing
Just ident@(Identity idName (ClientCert chain key)) -> do
let is13 = maybe False ((HashIntrinsic,SignatureEd25519) `elem`) pairs
conf <- if isTemporary ident || is13 then return True else do
displayWarning ["Pre-TLS1.3 server: identity " <> idName <> " might be revealed to eavesdroppers!"]
promptYN False "Identify anyway?"
return $ if conf then Just (chain,key) else Nothing
}
, clientShared = def
{ sharedCAStore = certStore
, sharedSessionManager = sessionManager }
, clientEarlyData = Just requestBytes -- ^Send early data (RTT0) if server session allows it
, clientWantSessionResume = session
}
sock <- openSocket
context <- TLS.contextNew sock params
handshake context
sentEarly <- (== Just True) . (infoIsEarlyDataAccepted <$>) <$> contextGetInformation context
unless sentEarly . sendData context $ BL.fromStrict requestBytes
-- print =<< (infoTLS13HandshakeMode <$>) <$> contextGetInformation context
chan <- newBSChan bound
let recvAllLazily = do
r <- recvData context
unless (BS.null r) $ writeBSChan chan r >> recvAllLazily
recvThread <- forkFinally recvAllLazily $ \_ ->
-- |XXX: note that writeBSChan can't block when writing BS.empty
writeBSChan chan BS.empty >> bye context >> close 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 = do
let hints = defaultHints { addrSocketType = Stream }
addr:_ <- getAddrInfo (Just hints) (Just hostname) (Just $ show port)
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
ignoreIOErr $
-- set SO_KEEPALIVE so we detect when a stream connection goes down:
setSocketOption sock KeepAlive 1
connect sock $ addrAddress addr
return sock
checkServerCert store cache service chain@(CertificateChain signedCerts) = do
errors <- doTofu =<< validate Data.X509.HashSHA256 defaultHooks
(defaultChecks { checkExhaustive = True , checkLeafV3 = False }) store cache service chain
if null errors || any isTrustError errors || null signedCerts
then return errors
else do
ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredErrors
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_ mIgnoredErrors (return . Set.insert tailFingerprint) >> return []
else return errors
where
isTrustError = (`elem` [UnknownCA, SelfSigned])
-- |error pertaining to the tail certificate, to be ignored if the
-- user explicitly trusts the certificate for this service.
isTrustableError LeafNotV3 = True
isTrustableError (NameMismatch _) = True
isTrustableError _ = False
tailSigned = head signedCerts
tailFingerprint = fingerprint tailSigned
doTofu errors = if not . any isTrustError $ errors
then return errors
else do
trust <- checkTrust $ filter isTrustableError errors
return $ if trust
then filter (\e -> not $ isTrustError e || isTrustableError e) errors
else errors
checkTrust :: [FailedReason] -> IO Bool
checkTrust errors = do
trusted <- (tailFingerprint `Set.member`) <$> readMVar mTrusted
if trusted then return True else do
trust <- checkTrust' errors
when trust $ modifyMVar_ mTrusted (return . Set.insert tailFingerprint)
return trust
checkTrust' :: [FailedReason] -> IO Bool
checkTrust' errors = do
let certs = map getCertificate signedCerts
tailCert = head certs
serviceString = serviceToString service
warnErrors = unless (null errors) . displayWarning $
[ "WARNING: tail certificate has verification errors: " <> show errors ]
known <- loadServiceCert serviceCertsPath service `catch` ((>> return Nothing) . printIOErr)
if known == Just tailSigned then do
displayInfo [ "Accepting previously trusted certificate " ++ take 8 (fingerprintHex tailFingerprint) ++ "; expires " ++ printExpiry tailCert ++ "." ]
return True
else do
displayInfo $ showChain signedCerts
let promptTrust def pprompt tprompt = do
p <- promptYN def pprompt
if p then return (True,True) else
(False,) <$> promptYN def tprompt
(saveCert,trust) <- case known of
Nothing -> do
displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ]
warnErrors
let prompt = "provided certificate (" ++
take 8 (fingerprintHex tailFingerprint) ++ ")?"
promptTrust (null errors) ("Permamently trust " ++ prompt)
("Temporarily trust " ++ prompt)
Just trustedSignedCert -> do
currentTime <- timeConvert <$> timeCurrent
let trustedCert = getCertificate trustedSignedCert
expired = currentTime > (snd . certValidity) trustedCert
samePubKey = certPubKey trustedCert == certPubKey tailCert
oldFingerprint = fingerprint trustedSignedCert
oldInfo = [ "Fingerprint of old certificate: " ++ fingerprintHex oldFingerprint ]
++ fingerprintPicture oldFingerprint
++ [ "Old certificate " ++ (if expired then "expired" else "expires") ++
": " ++ printExpiry trustedCert ]
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
warnErrors
promptTrust (expired || samePubKey)
("Permanently trust new certificate" <>
(if readOnly then "" else " (and delete old certificate)") <> "?")
("Temporarily trust new certificate" <>
(if readOnly then "" else " (but keep old certificate)") <> "?")
when (saveCert && not readOnly) $
saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr
return trust
printExpiry :: Certificate -> String
printExpiry = timePrint ISO8601_Date . snd . certValidity
showChain :: [SignedCertificate] -> [String]
showChain [] = [""]
showChain signed = let
sigChain = reverse signed
certs = map getCertificate sigChain
showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . getCharacterStringRawData) . getDnElement DnCommonName
issuerCN = showCN . certIssuerDN $ head certs
subjectCNs = map (showCN . certSubjectDN) certs
hexes = map (fingerprintHex . fingerprint) sigChain
pics = map (fingerprintPicture . fingerprint) sigChain
expStrs = map (("Expires " ++) . printExpiry) certs
picsWithInfo = map (map $ 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 = map 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) = concat $ hexWord8 <$> BS.unpack fp
where hexWord8 w =
let (a,b) = quotRem w 16
hex = ("0123456789abcdef" !!) . fromIntegral
in hex a : hex b : ""
fingerprintPicture :: Fingerprint -> [String]
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 }
-- |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.
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 . T.decodeUtf8 . BL.take 2 $ header
separator = BL.take 1 . BL.drop 2 $ header
meta = T.unpack . 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 < 80 ->
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"