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