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                 , clientUseEarlyData = True  -- ^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         sendData context $ BL.fromStrict requestBytes
 233         when verboseConnection . void . runMaybeT $ do
 234             info <- MaybeT $ contextGetInformation context
 235             lift . displayInfo $ [ "TLS version " ++ show (infoVersion info) ++
 236                 ", cipher " ++ cipherName (infoCipher info) ]
 237             mode <- MaybeT . return $ infoTLS13HandshakeMode info
 238             lift . displayInfo $ [ "Handshake mode " ++ show mode ]
 239         chan <- newBSChan bound
 240         let recvAllLazily = do
 241                 r <- recvData context
 242                 unless (BS.null r) $ writeBSChan chan r >> recvAllLazily
 243             ignoreIOError = (`catchIOError` (const $ return ()))
 244         recvThread <- forkFinally recvAllLazily $ \_ ->
 245             -- |XXX: note that writeBSChan can't block when writing BS.empty
 246             writeBSChan chan BS.empty
 247                 >> ignoreIOError (bye context)
 248                 >> closeSock sock
 249         lazyResp <- parseResponse . BL.fromChunks . takeWhile (not . BS.null) <$> getBSChanContents chan
 250         return $ Right (lazyResp, killThread recvThread)
 251     where
 252     handleAll :: SomeException -> IO (Either SomeException a)
 253     handleAll = return . Left
 254
 255     openSocket :: IO Socket
 256     openSocket = case socksProxy of
 257         NoSocksProxy -> fst <$> connectSock hostname (show port)
 258         Socks5Proxy socksHostname socksPort -> do
 259             sock <- fst <$> connectSock socksHostname socksPort
 260             _ <- connectSockSOCKS5 sock hostname (show port)
 261             return sock
 262
 263     checkServerCert store cache service chain@(CertificateChain signedCerts) = do
 264         errors <- doTofu =<< validate Data.X509.HashSHA256 defaultHooks
 265             (defaultChecks { checkExhaustive = True , checkLeafV3 = False }) store cache service chain
 266         if null errors || any isTrustError errors || null signedCerts
 267         then return errors
 268         else do
 269             ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredCertErrors
 270             if ignored then return [] else do
 271                 displayWarning [
 272                     "Certificate chain has trusted root, but validation errors: "
 273                     ++ show errors ]
 274                 displayWarning $ showChain signedCerts
 275                 ignore <- promptYN False "Ignore errors?"
 276                 if ignore
 277                 then modifyMVar_ mIgnoredCertErrors (return . Set.insert tailFingerprint) >> return []
 278                 else return errors
 279         where
 280         isTrustError = (`elem` [UnknownCA, SelfSigned, NotAnAuthority])
 281
 282         -- |error pertaining to the tail certificate, to be ignored if the
 283         -- user explicitly trusts the certificate for this service.
 284         -- These don't actually affect the TOFU-trustworthiness of a
 285         -- certificate, but we warn the user about them anyway.
 286         isTrustableError LeafNotV3        = True
 287         isTrustableError (NameMismatch _) = True
 288         isTrustableError _                = False
 289
 290         tailSigned = head signedCerts
 291         tailFingerprint = fingerprint tailSigned
 292
 293         chainSigsFail :: Maybe SignatureFailure
 294         chainSigsFail =
 295             let verify (signed:signing:rest) = msum [
 296                     case verifySignedSignature signed . certPubKey $ getCertificate signing of
 297                         SignaturePass           -> Nothing
 298                         SignatureFailed failure -> Just failure
 299                     , verify (signing:rest) ]
 300                 verify _ = Nothing
 301             in verify signedCerts
 302
 303         doTofu errors = if not . any isTrustError $ errors
 304             then do
 305                 (tailFingerprint `Set.member`) <$> readMVar mWarnedCA >>! do
 306                     displayInfo [ "Accepting valid certificate chain with trusted root CA: " <>
 307                         showIssuerDN signedCerts ]
 308                     when verboseConnection . displayInfo $ showChain signedCerts
 309                     modifyMVar_ mWarnedCA (return . Set.insert tailFingerprint)
 310                 return errors
 311             else do
 312                 trust <- checkTrust $ filter isTrustableError errors
 313                 return $ if trust
 314                     then filter (\e -> not $ isTrustError e || isTrustableError e) errors
 315                     else errors
 316
 317         checkTrust :: [FailedReason] -> IO Bool
 318         checkTrust errors = do
 319             trusted <- ((tailFingerprint, service) `Set.member`) <$> readMVar mTrusted
 320             if trusted then return True else do
 321                 trust <- checkTrust' errors
 322                 when trust $ modifyMVar_ mTrusted (return . Set.insert (tailFingerprint, service))
 323                 return trust
 324         checkTrust' :: [FailedReason] -> IO Bool
 325         checkTrust' _ | Just sigFail <- chainSigsFail = do
 326             displayWarning [ "Invalid signature in certificate chain: " ++ show sigFail ]
 327             return False
 328         checkTrust' errors = do
 329             let certs = map getCertificate signedCerts
 330                 tailCert = head certs
 331                 tailHex = "SHA256:" <> fingerprintHex tailFingerprint
 332                 serviceString = serviceToString service
 333                 warnErrors = unless (null errors) . displayWarning $
 334                     [ "WARNING: tail certificate has verification errors: " <> show errors ]
 335             known <- loadServiceCert serviceCertsPath service
 336             if known == Just tailSigned then do
 337                 displayInfo [ "Accepting previously trusted certificate " ++ take 8 (fingerprintHex tailFingerprint) ++ "; expires " ++ printExpiry tailCert ++ "." ]
 338                 when verboseConnection . displayInfo $ fingerprintPicture tailFingerprint
 339                 return True
 340             else do
 341                 displayInfo $ showChain signedCerts
 342                 let promptTrust df pprompt tprompt = do
 343                         p <- promptYN df pprompt
 344                         if p then return (True,True) else
 345                             (False,) <$> promptYN df tprompt
 346                 tempTimes <- loadTempServiceInfo serviceCertsPath service >>= \case
 347                     Just (n,tempHex) | tempHex == tailHex -> pure n
 348                     _                                     -> pure 0
 349                 (saveCert,trust) <- case known of
 350                     Nothing -> do
 351                         displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ]
 352                         warnErrors
 353                         when (tempTimes > 0) $ displayInfo [
 354                             "This certificate has been temporarily trusted " <>
 355                                 show tempTimes <> " times." ]
 356                         let prompt = "provided certificate (" ++
 357                                 take 8 (fingerprintHex tailFingerprint) ++ ")?"
 358                         promptTrust True ("Permanently trust " ++ prompt)
 359                             ("Temporarily trust " ++ prompt)
 360                     Just trustedSignedCert -> do
 361                         currentTime <- timeConvert <$> timeCurrent
 362                         let trustedCert = getCertificate trustedSignedCert
 363                             expired = currentTime > (snd . certValidity) trustedCert
 364                             samePubKey = certPubKey trustedCert == certPubKey tailCert
 365                             oldFingerprint = fingerprint trustedSignedCert
 366                             oldHex = "SHA256:" <> fingerprintHex oldFingerprint
 367                             oldInfo = [ "Fingerprint of old certificate: " <> oldHex ]
 368                                 ++ fingerprintPicture oldFingerprint
 369                                 ++ [ "Old certificate " ++ (if expired then "expired" else "expires") ++
 370                                     ": " ++ printExpiry trustedCert ]
 371                             signedByOld = SignaturePass `elem`
 372                                 ((`verifySignedSignature` certPubKey trustedCert) <$> signedCerts)
 373                         if signedByOld
 374                             then displayInfo $
 375                                 ("The new certificate chain is signed by " ++
 376                                 (if expired then "an EXPIRED" else "a") ++
 377                                 " key previously trusted for this host.") : oldInfo
 378                             else if expired || samePubKey
 379                             then displayInfo $
 380                                 ("A different " ++ (if expired then "expired " else "non-expired ") ++
 381                                 "certificate " ++ (if samePubKey then "with the same public key " else "") ++
 382                                 "for " ++ serviceString ++ " was previously explicitly trusted.") : oldInfo
 383                             else displayWarning $
 384                                 ("CAUTION: A certificate with a different public key for " ++ serviceString ++
 385                                 " was previously explicitly trusted and has not expired!") : oldInfo
 386                         when (tempTimes > 0) $ displayInfo [
 387                             "The new certificate has been temporarily trusted " <>
 388                                 show tempTimes <> " times." ]
 389                         warnErrors
 390                         promptTrust (signedByOld || expired || samePubKey)
 391                             ("Permanently trust new certificate" <>
 392                                 (if readOnly then ""
 393                                 else " (replacing old certificate (which will be backed up))") <> "?")
 394                             ("Temporarily trust new certificate" <>
 395                                 (if readOnly then ""
 396                                 else " (but keep old certificate)") <> "?")
 397                 when (saveCert && not readOnly) $
 398                     saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr
 399                 when (trust && not saveCert && not readOnly) $
 400                     saveTempServiceInfo serviceCertsPath service (tempTimes + 1, tailHex) `catch` printIOErr
 401                 pure trust
 402
 403         printExpiry :: Certificate -> String
 404         printExpiry = timePrint ISO8601_Date . snd . certValidity
 405
 406         showCN :: DistinguishedName -> String
 407         showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . getCharacterStringRawData) . getDnElement DnCommonName
 408
 409         showIssuerDN :: [SignedCertificate] -> String
 410         showIssuerDN signed = case lastMay signed of
 411             Nothing         -> ""
 412             Just headSigned -> showCN . certIssuerDN $ getCertificate headSigned
 413
 414         showChain :: [SignedCertificate] -> [String]
 415         showChain [] = [""]
 416         showChain signed = let
 417             sigChain = reverse signed
 418             certs = getCertificate <$> sigChain
 419             issuerCN = showCN . certIssuerDN $ head certs
 420             subjectCNs = showCN . certSubjectDN <$> certs
 421             hexes = ("SHA256:" <>) . fingerprintHex . fingerprint <$> sigChain
 422             pics = fingerprintPicture . fingerprint <$> sigChain
 423             expStrs = ("Expires " ++) . printExpiry <$> certs
 424             picsWithInfo = ((centre 23 <$>) <$>) $ zipWith (++) pics $ transpose [subjectCNs, expStrs]
 425             centre n s = take n $ replicate ((n - length s) `div` 2) ' ' ++ s ++ repeat ' '
 426             tweenCol = replicate 6 "     " ++ [" >>> "] ++ replicate 6 "     "
 427             sideBySide = (concat <$>) . transpose
 428             in [ "Certificate chain: " ++ intercalate " >>> " (issuerCN:subjectCNs) ]
 429                 ++ (sideBySide . intersperse tweenCol $ picsWithInfo)
 430                 ++ zipWith (++) ("": repeat ">>> ") hexes
 431
 432     printIOErr :: IOError -> IO ()
 433     printIOErr = displayWarning . (:[]) . show
 434
 435     fingerprintHex :: Fingerprint -> String
 436     fingerprintHex (Fingerprint fp) = concatMap hexWord8 $ BS.unpack fp
 437         where hexWord8 w =
 438                 let (a,b) = quotRem w 16
 439                     hex = ("0123456789abcdef" !!) . fromIntegral
 440                 in hex a : hex b : ""
 441     fingerprintPicture :: Fingerprint -> [String]
 442 #ifdef DRUNKEN_BISHOP
 443     fingerprintPicture (Fingerprint fp) = boxedDrunkenBishop fp where
 444         boxedDrunkenBishop :: BS.ByteString -> [String]
 445         boxedDrunkenBishop s = ["+-----[X509]------+"]
 446             ++ (map (('|':) . (++"|")) . lines $ drunkenBishopPreHashed s)
 447             ++ ["+----[SHA256]-----+"]
 448         drunkenBishopPreHashed :: BS.ByteString -> String
 449         drunkenBishopPreHashed = drunkenBishopWithOptions $
 450             drunkenBishopDefaultOptions { drunkenBishopHash = id }
 451 #else
 452     fingerprintPicture _ = []
 453 #endif
 454
 455     -- |those ciphers from ciphersuite_default fitting the requirements
 456     -- recommended by the gemini "best practices" document:
 457     -- require ECDHE/DHE (for PFS), and >=SHA2, and AES/CHACHA20.
 458     -- Some of these were subsequently commented out once tls-2.0 dropped
 459     -- support for them.
 460     gemini_ciphersuite :: [Cipher]
 461     gemini_ciphersuite =
 462         [        -- First the PFS + GCM + SHA2 ciphers
 463           cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384
 464         , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256
 465         , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384
 466         , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256
 467         --, cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384
 468         --, cipher_DHE_RSA_CHACHA20POLY1305_SHA256
 469         ,        -- Next the PFS + CCM + SHA2 ciphers
 470           cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256
 471         --, cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256
 472                  -- Next the PFS + CBC + SHA2 ciphers
 473         --, cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384
 474         --, cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384
 475         --, cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256
 476                 -- TLS13 (listed at the end but version is negotiated first)
 477         , cipher_TLS13_AES128GCM_SHA256
 478         , cipher_TLS13_AES256GCM_SHA384
 479         , cipher_TLS13_CHACHA20POLY1305_SHA256
 480         , cipher_TLS13_AES128CCM_SHA256
 481         ]
 482
 483     parseResponse :: BL.ByteString -> Response
 484     parseResponse resp =
 485         let (header, rest) = BLC.break (== '\r') resp
 486             body = BL.drop 2 rest
 487             statusString = T.unpack . stripControl . T.decodeUtf8 . BL.take 2 $ header
 488             separator = BL.take 1 . BL.drop 2 $ header
 489             meta = T.unpack . stripControl . T.decodeUtf8 . BL.drop 3 $ header
 490         in
 491         if BL.take 2 rest /= "\r\n" then MalformedResponse BadHeaderTermination
 492         else if separator `notElem` [""," ","\t"] -- ^allow \t for now, though it's against latest spec
 493         then MalformedResponse BadMetaSeparator
 494         else if BL.length header > 1024+3 then MalformedResponse BadMetaLength
 495         else case readMay statusString of
 496             Just status | status >= 10 && status < 80 ->
 497                 let (status1,status2) = divMod status 10
 498                 in case status1 of
 499                     1 -> Input (status2 == 1) meta
 500                     2 -> maybe (MalformedResponse (BadMime meta))
 501                         (\mime -> Success $ MimedData mime body) $
 502                         MIME.parseMIMEType (TS.pack $
 503                             if null meta then "text/gemini; charset=utf-8" else meta)
 504                     3 -> maybe (MalformedResponse (BadUri meta))
 505                         (Redirect (status2 == 1)) $ parseUriReference meta
 506                     _ -> Failure status meta
 507             _ -> MalformedResponse (BadStatus statusString)
 508
 509 makeRequest _ _ _ _ (LocalFileRequest _) = error "File requests not handled by makeRequest"