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