-- 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 #-} module GeminiProtocol where import Control.Concurrent import Control.Exception import Control.Monad (guard, mplus, unless, when) import Data.Default.Class (def) import Data.List (intercalate, intersperse, isPrefixOf, stripPrefix, transpose) import Data.Maybe (fromMaybe) import Data.Hourglass import Data.X509 import Data.X509.Validation hiding (Fingerprint(..), getFingerprint) import Data.X509.CertificateStore import Network.Socket (AddrInfo(..), Socket, SocketType(..), SocketOption(..) , 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.Type as MIME import qualified Codec.MIME.Parse 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 }) store cache service chain if null errors || exists 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 exists p = not . all (not . p) 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 . exists 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 $ fingerprintPicture tailFingerprint ++ [ "Expires " ++ printExpiry tailCert ] return True else do displayInfo $ showChain signedCerts trust <- case known of Nothing -> do displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ] warnErrors promptYN (null errors) $ "Trust provided certificate (" ++ take 8 (fingerprintHex tailFingerprint) ++ ")?" 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 promptYN (expired || samePubKey) $ "Trust new certificate" <> (if readOnly then "" else " (and delete old certificate)") <> "?" when (trust && 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"