-- This file is part of Diohsc -- Copyright (C) 2020 Martin Bays -- -- 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 Data.X509 import Data.X509.CertificateStore import Data.X509.Validation hiding (Fingerprint (..), getFingerprint) 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 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 CertificateStore (MVar (Set.Set (Fingerprint, 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 (makeCertificateStore []) <$> 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 } -- |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) sendData context $ BL.fromStrict requestBytes when verboseConnection . void . runMaybeT $ do info <- MaybeT $ contextGetInformation context lift . displayInfo $ [ "TLS version " ++ show (infoVersion info) ++ ", cipher " ++ cipherName (infoCipher info) ] mode <- MaybeT . return $ infoTLS13HandshakeMode info lift . displayInfo $ [ "Handshake mode " ++ show mode ] 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@(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 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` [UnknownCA, SelfSigned, 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 LeafNotV3 = True isTrustableError (NameMismatch _) = True isTrustableError _ = False tailSigned = head signedCerts tailFingerprint = fingerprint tailSigned chainSigsFail :: Maybe SignatureFailure chainSigsFail = let verify (signed:signing:rest) = msum [ case verifySignedSignature signed . certPubKey $ getCertificate signing of SignaturePass -> Nothing 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 :: [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' :: [FailedReason] -> IO Bool checkTrust' _ | Just sigFail <- chainSigsFail = do displayWarning [ "Invalid signature in certificate chain: " ++ show sigFail ] return False checkTrust' errors = do let certs = map 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 = getCertificate trustedSignedCert expired = currentTime > (snd . certValidity) trustedCert samePubKey = certPubKey trustedCert == 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 = SignaturePass `elem` ((`verifySignedSignature` 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 :: Certificate -> String printExpiry = timePrint ISO8601_Date . snd . certValidity showCN :: DistinguishedName -> String showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . getCharacterStringRawData) . getDnElement DnCommonName showIssuerDN :: [SignedCertificate] -> String showIssuerDN signed = case lastMay signed of Nothing -> "" Just headSigned -> showCN . certIssuerDN $ getCertificate headSigned showChain :: [SignedCertificate] -> [String] showChain [] = [""] showChain signed = let sigChain = reverse signed certs = getCertificate <$> sigChain issuerCN = showCN . certIssuerDN $ head certs subjectCNs = showCN . 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 < 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"