-- 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 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 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 } 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)) (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 mIgnoredCCertWarnings <- newMVar Set.empty RequestContext callbacks certStore mTrusted mIgnoredCertErrors 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 $ 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 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 } , clientEarlyData = Just requestBytes -- ^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) sentEarly <- (== Just True) . (infoIsEarlyDataAccepted <$>) <$> contextGetInformation context unless sentEarly . 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 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' _ | 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 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 ++ "." ] 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 (saveCert,trust) <- case known of Nothing -> do displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ] warnErrors 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 oldInfo = [ "Fingerprint of old certificate: " ++ fingerprintHex oldFingerprint ] ++ 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 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 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"