GeminiProtocol.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE CPP               #-}
  12 {-# LANGUAGE LambdaCase        #-}
  13 {-# LANGUAGE OverloadedStrings #-}
  14 {-# LANGUAGE TupleSections     #-}
  15
  16 module GeminiProtocol where
  17
  18 import           Control.Concurrent
  19 import           Control.Exception
  20 import           Control.Monad              (guard, mplus, msum, unless, void,
  21                                              when)
  22 import           Control.Monad.Trans        (lift)
  23 import           Control.Monad.Trans.Maybe  (MaybeT (..), runMaybeT)
  24 import           Data.Default.Class         (def)
  25 import           Data.Hourglass
  26 import           Data.List                  (intercalate, intersperse,
  27                                              isPrefixOf, stripPrefix, transpose)
  28 import           Data.Maybe                 (fromMaybe, isJust)
  29 import           Data.X509
  30 import           Data.X509.CertificateStore
  31 import           Data.X509.Validation       hiding (Fingerprint (..),
  32                                              getFingerprint)
  33 import           Network.Simple.TCP         (closeSock, connectSock,
  34                                              connectSockSOCKS5)
  35 import           Network.Socket             (Socket)
  36 import           Network.TLS                as TLS
  37 import           Network.TLS.Extra.Cipher
  38 import           Network.URI                (isIPv4address, isIPv6address)
  39 import           Safe
  40 import           System.FilePath
  41 import           System.IO.Error            (catchIOError)
  42 import           Time.System
  43
  44 import qualified Data.ByteString            as BS
  45 import qualified Data.ByteString.Lazy       as BL
  46 import qualified Data.ByteString.Lazy.Char8 as BLC
  47
  48 import qualified Codec.MIME.Parse           as MIME
  49 import qualified Codec.MIME.Type            as MIME
  50 import qualified Data.Map                   as M
  51 import qualified Data.Set                   as Set
  52 import qualified Data.Text                  as TS
  53 import qualified Data.Text.Encoding         as TS
  54 import qualified Data.Text.Lazy             as T
  55 import qualified Data.Text.Lazy.Encoding    as T
  56
  57 import           ANSIColour
  58 import           BoundedBSChan
  59 import           ClientCert
  60 import           ClientSessionManager
  61 import           Fingerprint
  62 import           Identity
  63 import           Mundanities
  64 import           Request
  65 import           ServiceCerts
  66
  67 import           URI
  68 import           Util
  69
  70 #ifdef DRUNKEN_BISHOP
  71 import           Data.Digest.DrunkenBishop
  72 #endif
  73
  74 defaultGeminiPort :: Int
  75 defaultGeminiPort = 1965
  76
  77 data MimedData = MimedData {mimedMimetype :: MIME.Type, mimedBody :: BL.ByteString}
  78     deriving (Eq,Ord,Show)
  79
  80 showMimeType :: MimedData -> String
  81 showMimeType = TS.unpack . MIME.showMIMEType . MIME.mimeType . mimedMimetype
  82
  83 data ResponseMalformation
  84     = BadHeaderTermination
  85     | BadStatus String
  86     | BadMetaSeparator
  87     | BadMetaLength
  88     | BadUri String
  89     | BadMime String
  90     deriving (Eq,Ord,Show)
  91
  92 data Response
  93     = Input { inputHidden :: Bool, inputPrompt :: String }
  94     | Success { successData :: MimedData }
  95     | Redirect { permanent :: Bool, redirectTo :: URIRef }
  96     | Failure { failureCode :: Int, failureInfo :: String }
  97     | MalformedResponse { responseMalformation :: ResponseMalformation }
  98     deriving (Eq,Ord,Show)
  99
 100 data InteractionCallbacks = InteractionCallbacks
 101     { icbDisplayInfo :: [String] -> IO ()
 102     , icbDisplayWarning :: [String] -> IO ()
 103     , icbWaitKey :: String -> IO Bool -- ^return False on interrupt, else True
 104     , icbPromptYN :: Bool -- ^default answer
 105         -> String -- ^prompt
 106         -> IO Bool
 107     }
 108
 109 data SocksProxy
 110     = NoSocksProxy
 111     | Socks5Proxy String String
 112
 113 -- Note: we're forced to resort to mvars because the tls library (tls-1.5.4 at
 114 -- least) uses IO rather than MonadIO in the onServerCertificate callback.
 115 data RequestContext = RequestContext
 116     InteractionCallbacks
 117     CertificateStore
 118     (MVar (Set.Set (Fingerprint, ServiceID)))
 119     (MVar (Set.Set Fingerprint))
 120     (MVar (Set.Set Fingerprint))
 121     (MVar (Set.Set String))
 122     FilePath
 123     Bool
 124     SocksProxy
 125     ClientSessions
 126
 127 initRequestContext :: InteractionCallbacks -> FilePath -> Bool -> SocksProxy -> IO RequestContext
 128 initRequestContext callbacks path readOnly socksProxy =
 129     let certPath = path </> "trusted_certs"
 130         serviceCertsPath = path </> "known_hosts"
 131     in do
 132         unless readOnly $ do
 133             mkdirhier certPath
 134             mkdirhier serviceCertsPath
 135         certStore <- fromMaybe (makeCertificateStore []) <$> readCertificateStore certPath
 136         mTrusted <- newMVar Set.empty
 137         mIgnoredCertErrors <- newMVar Set.empty
 138         mWarnedCA <- newMVar Set.empty
 139         mIgnoredCCertWarnings <- newMVar Set.empty
 140         RequestContext callbacks certStore mTrusted mIgnoredCertErrors mWarnedCA mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy <$> newClientSessions
 141
 142 requestOfProxiesAndUri :: M.Map String Host -> URI -> Maybe Request
 143 requestOfProxiesAndUri proxies uri =
 144     let scheme = uriScheme uri
 145     in if scheme == "file"
 146     then let filePath path
 147                 | ('/':_) <- path = Just path
 148                 | Just path' <- stripPrefix "localhost" path, ('/':_) <- path' = Just path'
 149                 | otherwise = Nothing
 150         in LocalFileRequest . unescapeUriString <$> filePath (uriPath uri)
 151     else do
 152         host <- M.lookup scheme proxies `mplus` do
 153             guard $ scheme == "gemini" || "gemini+" `isPrefixOf` scheme
 154                 -- ^people keep suggesting "gemini+foo" schemes for variations
 155                 -- on gemini. On the basis that this naming convention should
 156                 -- indicate that the scheme is backwards-compatible with
 157                 -- actual gemini, we handle them the same as gemini.
 158             hostname <- decodeIPv6 <$> uriRegName uri
 159             let port = fromMaybe defaultGeminiPort $ uriPort uri
 160             return $ Host hostname port
 161         return . NetworkRequest host . stripUriForGemini $ uri
 162     where
 163     decodeIPv6 :: String -> String
 164     decodeIPv6 ('[':rest) | last rest == ']', addr <- init rest, isIPv6address addr = addr
 165     decodeIPv6 h = h
 166
 167
 168 newtype RequestException = ExcessivelyLongUri Int
 169     deriving Show
 170 instance Exception RequestException
 171
 172 -- |On success, returns `Right (lazyResp,terminate)`. `lazyResp` is a `Response`
 173 -- with lazy IO, so attempts to read it may block while data is received. If
 174 -- the full response is not needed, for example because of an error, the IO
 175 -- action `terminate` should be called to close the connection.
 176 makeRequest :: RequestContext
 177     -> Maybe Identity -- ^client certificate to offer
 178     -> Int -- ^bound in bytes for response stream buffering
 179     -> Bool -- ^whether to display extra information about connection
 180     -> Request -> IO (Either SomeException (Response, IO ()))
 181 makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ promptYN)
 182         certStore mTrusted mIgnoredCertErrors mWarnedCA mIgnoredCCertWarnings serviceCertsPath readOnly socksProxy clientSessions) mIdent bound verboseConnection (NetworkRequest (Host hostname port) uri) =
 183     let requestBytes = TS.encodeUtf8 . TS.pack $ show uri ++ "\r\n"
 184         uriLength = BS.length requestBytes - 2
 185         ccfp = clientCertFingerprint . identityCert <$> mIdent
 186     in if uriLength > 1024 then return . Left . toException $ ExcessivelyLongUri uriLength
 187     else handle handleAll $ do
 188         session <- lookupClientSession hostname ccfp clientSessions
 189         let serverId = if port == defaultGeminiPort then BS.empty else TS.encodeUtf8 . TS.pack . (':':) $ show port
 190             sessionManager = clientSessionManager 3600 clientSessions ccfp
 191             params = (TLS.defaultParamsClient hostname serverId)
 192                 { clientSupported = def { supportedCiphers = gemini_ciphersuite }
 193                 -- |RFC6066 disallows SNI with literal IP addresses
 194                 , clientUseServerNameIndication = not $ isIPv4address hostname || isIPv6address hostname
 195                 , clientHooks = def
 196                     { onServerCertificate = checkServerCert
 197                     , onCertificateRequest = \(_,pairs,_) -> case mIdent of
 198                         Nothing -> return Nothing
 199                         Just ident@(Identity idName (ClientCert chain key)) -> do
 200                             -- Note: I have once seen this way of detecting
 201                             -- pre-tls1.3 give a false positive.
 202                             let is13 = maybe False ((HashIntrinsic,SignatureEd25519) `elem`) pairs
 203                             allow <- if isTemporary ident || is13 then return True else do
 204                                     ignored <- (idName `Set.member`) <$> readMVar mIgnoredCCertWarnings
 205                                     if ignored then return True else do
 206                                         displayWarning ["This may be a pre-TLS1.3 server: identity "
 207                                             <> idName <> " might be revealed to eavesdroppers!"]
 208                                         conf <- promptYN False "Identify anyway?"
 209                                         when conf $ modifyMVar_ mIgnoredCCertWarnings
 210                                             (return . Set.insert idName)
 211                                         return conf
 212                             return $ if allow then Just (chain,key) else Nothing
 213                     }
 214                 , clientShared = def
 215                     { sharedCAStore = certStore
 216                     , sharedSessionManager = sessionManager }
 217                 , clientEarlyData = Just requestBytes  -- ^Send early data (RTT0) if server session allows it
 218                 , clientWantSessionResume = session
 219                 }
 220         (sock,context) <- do
 221             let retryNoResume (HandshakeFailed (Error_Protocol (_,_,HandshakeFailure)))
 222                         | isJust session = do
 223                     -- Work around a mysterious problem seen with dezhemini+libssl:
 224                     displayWarning [ "Handshake failure when resuming TLS session; retrying with full handshake." ]
 225                     sock <- openSocket
 226                     c <- TLS.contextNew sock $ params { clientWantSessionResume = Nothing }
 227                     handshake c >> return (sock,c)
 228                 retryNoResume e = throw e
 229             sock <- openSocket
 230             c <- TLS.contextNew sock params
 231             handle retryNoResume $ handshake c >> return (sock,c)
 232         sentEarly <- (== Just True) . (infoIsEarlyDataAccepted <$>) <$> contextGetInformation context
 233         unless sentEarly . sendData context $ BL.fromStrict requestBytes
 234         when verboseConnection . void . runMaybeT $ do
 235             info <- MaybeT $ contextGetInformation context
 236             lift . displayInfo $ [ "TLS version " ++ show (infoVersion info) ++
 237                 ", cipher " ++ cipherName (infoCipher info) ]
 238             mode <- MaybeT . return $ infoTLS13HandshakeMode info
 239             lift . displayInfo $ [ "Handshake mode " ++ show mode ]
 240         chan <- newBSChan bound
 241         let recvAllLazily = do
 242                 r <- recvData context
 243                 unless (BS.null r) $ writeBSChan chan r >> recvAllLazily
 244             ignoreIOError = (`catchIOError` (const $ return ()))
 245         recvThread <- forkFinally recvAllLazily $ \_ ->
 246             -- |XXX: note that writeBSChan can't block when writing BS.empty
 247             writeBSChan chan BS.empty
 248                 >> ignoreIOError (bye context)
 249                 >> closeSock sock
 250         lazyResp <- parseResponse . BL.fromChunks . takeWhile (not . BS.null) <$> getBSChanContents chan
 251         return $ Right (lazyResp, killThread recvThread)
 252     where
 253     handleAll :: SomeException -> IO (Either SomeException a)
 254     handleAll = return . Left
 255
 256     openSocket :: IO Socket
 257     openSocket = case socksProxy of
 258         NoSocksProxy -> fst <$> connectSock hostname (show port)
 259         Socks5Proxy socksHostname socksPort -> do
 260             sock <- fst <$> connectSock socksHostname socksPort
 261             _ <- connectSockSOCKS5 sock hostname (show port)
 262             return sock
 263
 264     checkServerCert store cache service chain@(CertificateChain signedCerts) = do
 265         errors <- doTofu =<< validate Data.X509.HashSHA256 defaultHooks
 266             (defaultChecks { checkExhaustive = True , checkLeafV3 = False }) store cache service chain
 267         if null errors || any isTrustError errors || null signedCerts
 268         then return errors
 269         else do
 270             ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredCertErrors
 271             if ignored then return [] else do
 272                 displayWarning [
 273                     "Certificate chain has trusted root, but validation errors: "
 274                     ++ show errors ]
 275                 displayWarning $ showChain signedCerts
 276                 ignore <- promptYN False "Ignore errors?"
 277                 if ignore
 278                 then modifyMVar_ mIgnoredCertErrors (return . Set.insert tailFingerprint) >> return []
 279                 else return errors
 280         where
 281         isTrustError = (`elem` [UnknownCA, SelfSigned, NotAnAuthority])
 282
 283         -- |error pertaining to the tail certificate, to be ignored if the
 284         -- user explicitly trusts the certificate for this service.
 285         -- These don't actually affect the TOFU-trustworthiness of a
 286         -- certificate, but we warn the user about them anyway.
 287         isTrustableError LeafNotV3        = True
 288         isTrustableError (NameMismatch _) = True
 289         isTrustableError _                = False
 290
 291         tailSigned = head signedCerts
 292         tailFingerprint = fingerprint tailSigned
 293
 294         chainSigsFail :: Maybe SignatureFailure
 295         chainSigsFail =
 296             let verify (signed:signing:rest) = msum [
 297                     case verifySignedSignature signed . certPubKey $ getCertificate signing of
 298                         SignaturePass           -> Nothing
 299                         SignatureFailed failure -> Just failure
 300                     , verify (signing:rest) ]
 301                 verify _ = Nothing
 302             in verify signedCerts
 303
 304         doTofu errors = if not . any isTrustError $ errors
 305             then do
 306                 (tailFingerprint `Set.member`) <$> readMVar mWarnedCA >>! do
 307                     displayInfo [ "Accepting valid certificate chain with trusted root CA: " <>
 308                         showIssuerDN signedCerts ]
 309                     when verboseConnection . displayInfo $ showChain signedCerts
 310                     modifyMVar_ mWarnedCA (return . Set.insert tailFingerprint)
 311                 return errors
 312             else do
 313                 trust <- checkTrust $ filter isTrustableError errors
 314                 return $ if trust
 315                     then filter (\e -> not $ isTrustError e || isTrustableError e) errors
 316                     else errors
 317
 318         checkTrust :: [FailedReason] -> IO Bool
 319         checkTrust errors = do
 320             trusted <- ((tailFingerprint, service) `Set.member`) <$> readMVar mTrusted
 321             if trusted then return True else do
 322                 trust <- checkTrust' errors
 323                 when trust $ modifyMVar_ mTrusted (return . Set.insert (tailFingerprint, service))
 324                 return trust
 325         checkTrust' :: [FailedReason] -> IO Bool
 326         checkTrust' _ | Just sigFail <- chainSigsFail = do
 327             displayWarning [ "Invalid signature in certificate chain: " ++ show sigFail ]
 328             return False
 329         checkTrust' errors = do
 330             let certs = map getCertificate signedCerts
 331                 tailCert = head certs
 332                 tailHex = "SHA256:" <> fingerprintHex tailFingerprint
 333                 serviceString = serviceToString service
 334                 warnErrors = unless (null errors) . displayWarning $
 335                     [ "WARNING: tail certificate has verification errors: " <> show errors ]
 336             known <- loadServiceCert serviceCertsPath service
 337             if known == Just tailSigned then do
 338                 displayInfo [ "Accepting previously trusted certificate " ++ take 8 (fingerprintHex tailFingerprint) ++ "; expires " ++ printExpiry tailCert ++ "." ]
 339                 when verboseConnection . displayInfo $ fingerprintPicture tailFingerprint
 340                 return True
 341             else do
 342                 displayInfo $ showChain signedCerts
 343                 let promptTrust df pprompt tprompt = do
 344                         p <- promptYN df pprompt
 345                         if p then return (True,True) else
 346                             (False,) <$> promptYN df tprompt
 347                 tempTimes <- loadTempServiceInfo serviceCertsPath service >>= \case
 348                     Just (n,tempHex) | tempHex == tailHex -> pure n
 349                     _                                     -> pure 0
 350                 (saveCert,trust) <- case known of
 351                     Nothing -> do
 352                         displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ]
 353                         warnErrors
 354                         when (tempTimes > 0) $ displayInfo [
 355                             "This certificate has been temporarily trusted " <>
 356                                 show tempTimes <> " times." ]
 357                         let prompt = "provided certificate (" ++
 358                                 take 8 (fingerprintHex tailFingerprint) ++ ")?"
 359                         promptTrust True ("Permanently trust " ++ prompt)
 360                             ("Temporarily trust " ++ prompt)
 361                     Just trustedSignedCert -> do
 362                         currentTime <- timeConvert <$> timeCurrent
 363                         let trustedCert = getCertificate trustedSignedCert
 364                             expired = currentTime > (snd . certValidity) trustedCert
 365                             samePubKey = certPubKey trustedCert == certPubKey tailCert
 366                             oldFingerprint = fingerprint trustedSignedCert
 367                             oldHex = "SHA256:" <> fingerprintHex oldFingerprint
 368                             oldInfo = [ "Fingerprint of old certificate: " <> oldHex ]
 369                                 ++ fingerprintPicture oldFingerprint
 370                                 ++ [ "Old certificate " ++ (if expired then "expired" else "expires") ++
 371                                     ": " ++ printExpiry trustedCert ]
 372                             signedByOld = SignaturePass `elem`
 373                                 ((`verifySignedSignature` certPubKey trustedCert) <$> signedCerts)
 374                         if signedByOld
 375                             then displayInfo $
 376                                 ("The new certificate chain is signed by " ++
 377                                 (if expired then "an EXPIRED" else "a") ++
 378                                 " key previously trusted for this host.") : oldInfo
 379                             else if expired || samePubKey
 380                             then displayInfo $
 381                                 ("A different " ++ (if expired then "expired " else "non-expired ") ++
 382                                 "certificate " ++ (if samePubKey then "with the same public key " else "") ++
 383                                 "for " ++ serviceString ++ " was previously explicitly trusted.") : oldInfo
 384                             else displayWarning $
 385                                 ("CAUTION: A certificate with a different public key for " ++ serviceString ++
 386                                 " was previously explicitly trusted and has not expired!") : oldInfo
 387                         when (tempTimes > 0) $ displayInfo [
 388                             "The new certificate has been temporarily trusted " <>
 389                                 show tempTimes <> " times." ]
 390                         warnErrors
 391                         promptTrust (signedByOld || expired || samePubKey)
 392                             ("Permanently trust new certificate" <>
 393                                 (if readOnly then ""
 394                                 else " (replacing old certificate (which will be backed up))") <> "?")
 395                             ("Temporarily trust new certificate" <>
 396                                 (if readOnly then ""
 397                                 else " (but keep old certificate)") <> "?")
 398                 when (saveCert && not readOnly) $
 399                     saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr
 400                 when (trust && not saveCert && not readOnly) $
 401                     saveTempServiceInfo serviceCertsPath service (tempTimes + 1, tailHex) `catch` printIOErr
 402                 pure trust
 403
 404         printExpiry :: Certificate -> String
 405         printExpiry = timePrint ISO8601_Date . snd . certValidity
 406
 407         showCN :: DistinguishedName -> String
 408         showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . getCharacterStringRawData) . getDnElement DnCommonName
 409
 410         showIssuerDN :: [SignedCertificate] -> String
 411         showIssuerDN signed = case lastMay signed of
 412             Nothing         -> ""
 413             Just headSigned -> showCN . certIssuerDN $ getCertificate headSigned
 414
 415         showChain :: [SignedCertificate] -> [String]
 416         showChain [] = [""]
 417         showChain signed = let
 418             sigChain = reverse signed
 419             certs = getCertificate <$> sigChain
 420             issuerCN = showCN . certIssuerDN $ head certs
 421             subjectCNs = showCN . certSubjectDN <$> certs
 422             hexes = ("SHA256:" <>) . fingerprintHex . fingerprint <$> sigChain
 423             pics = fingerprintPicture . fingerprint <$> sigChain
 424             expStrs = ("Expires " ++) . printExpiry <$> certs
 425             picsWithInfo = ((centre 23 <$>) <$>) $ zipWith (++) pics $ transpose [subjectCNs, expStrs]
 426             centre n s = take n $ replicate ((n - length s) `div` 2) ' ' ++ s ++ repeat ' '
 427             tweenCol = replicate 6 "     " ++ [" >>> "] ++ replicate 6 "     "
 428             sideBySide = (concat <$>) . transpose
 429             in [ "Certificate chain: " ++ intercalate " >>> " (issuerCN:subjectCNs) ]
 430                 ++ (sideBySide . intersperse tweenCol $ picsWithInfo)
 431                 ++ zipWith (++) ("": repeat ">>> ") hexes
 432
 433     printIOErr :: IOError -> IO ()
 434     printIOErr = displayWarning . (:[]) . show
 435
 436     fingerprintHex :: Fingerprint -> String
 437     fingerprintHex (Fingerprint fp) = concatMap hexWord8 $ BS.unpack fp
 438         where hexWord8 w =
 439                 let (a,b) = quotRem w 16
 440                     hex = ("0123456789abcdef" !!) . fromIntegral
 441                 in hex a : hex b : ""
 442     fingerprintPicture :: Fingerprint -> [String]
 443 #ifdef DRUNKEN_BISHOP
 444     fingerprintPicture (Fingerprint fp) = boxedDrunkenBishop fp where
 445         boxedDrunkenBishop :: BS.ByteString -> [String]
 446         boxedDrunkenBishop s = ["+-----[X509]------+"]
 447             ++ (map (('|':) . (++"|")) . lines $ drunkenBishopPreHashed s)
 448             ++ ["+----[SHA256]-----+"]
 449         drunkenBishopPreHashed :: BS.ByteString -> String
 450         drunkenBishopPreHashed = drunkenBishopWithOptions $
 451             drunkenBishopDefaultOptions { drunkenBishopHash = id }
 452 #else
 453     fingerprintPicture _ = []
 454 #endif
 455
 456     -- |those ciphers from ciphersuite_default fitting the requirements
 457     -- recommended by the gemini "best practices" document:
 458     -- require ECDHE/DHE (for PFS), and >=SHA2, and AES/CHACHA20.
 459     gemini_ciphersuite :: [Cipher]
 460     gemini_ciphersuite =
 461         [        -- First the PFS + GCM + SHA2 ciphers
 462           cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384
 463         , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256
 464         , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384
 465         , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256
 466         , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384
 467         , cipher_DHE_RSA_CHACHA20POLY1305_SHA256
 468         ,        -- Next the PFS + CCM + SHA2 ciphers
 469           cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256
 470         , cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256
 471                  -- Next the PFS + CBC + SHA2 ciphers
 472         , cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384
 473         , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384
 474         , cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256
 475                 -- TLS13 (listed at the end but version is negotiated first)
 476         , cipher_TLS13_AES128GCM_SHA256
 477         , cipher_TLS13_AES256GCM_SHA384
 478         , cipher_TLS13_CHACHA20POLY1305_SHA256
 479         , cipher_TLS13_AES128CCM_SHA256
 480         ]
 481
 482     parseResponse :: BL.ByteString -> Response
 483     parseResponse resp =
 484         let (header, rest) = BLC.break (== '\r') resp
 485             body = BL.drop 2 rest
 486             statusString = T.unpack . stripControl . T.decodeUtf8 . BL.take 2 $ header
 487             separator = BL.take 1 . BL.drop 2 $ header
 488             meta = T.unpack . stripControl . T.decodeUtf8 . BL.drop 3 $ header
 489         in
 490         if BL.take 2 rest /= "\r\n" then MalformedResponse BadHeaderTermination
 491         else if separator `notElem` [""," ","\t"] -- ^allow \t for now, though it's against latest spec
 492         then MalformedResponse BadMetaSeparator
 493         else if BL.length header > 1024+3 then MalformedResponse BadMetaLength
 494         else case readMay statusString of
 495             Just status | status >= 10 && status < 80 ->
 496                 let (status1,status2) = divMod status 10
 497                 in case status1 of
 498                     1 -> Input (status2 == 1) meta
 499                     2 -> maybe (MalformedResponse (BadMime meta))
 500                         (\mime -> Success $ MimedData mime body) $
 501                         MIME.parseMIMEType (TS.pack $
 502                             if null meta then "text/gemini; charset=utf-8" else meta)
 503                     3 -> maybe (MalformedResponse (BadUri meta))
 504                         (Redirect (status2 == 1)) $ parseUriReference meta
 505                     _ -> Failure status meta
 506             _ -> MalformedResponse (BadStatus statusString)
 507
 508 makeRequest _ _ _ _ (LocalFileRequest _) = error "File requests not handled by makeRequest"