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