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