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 OverloadedStrings #-}
  12
  13 module GeminiProtocol where
  14
  15 import Control.Concurrent
  16 import Control.Exception
  17 import Control.Monad (guard, mplus, unless, when)
  18 import Data.Default.Class (def)
  19 import Data.List (intercalate, intersperse, isPrefixOf, stripPrefix, transpose)
  20 import Data.Maybe (fromMaybe)
  21 import Data.Hourglass
  22 import Data.X509
  23 import Data.X509.Validation hiding (Fingerprint(..), getFingerprint)
  24 import Data.X509.CertificateStore
  25 import Network.Socket (AddrInfo(..), Socket, SocketType(..), SocketOption(..)
  26     , close, connect, defaultHints, getAddrInfo, setSocketOption, socket)
  27 import Network.TLS as TLS
  28 import Network.TLS.Extra.Cipher
  29 import Safe
  30 import System.FilePath
  31 import Time.System
  32
  33 import qualified Data.ByteString as BS
  34 import qualified Data.ByteString.Lazy as BL
  35 import qualified Data.ByteString.Lazy.Char8 as BLC
  36
  37 import qualified Codec.MIME.Type as MIME
  38 import qualified Codec.MIME.Parse as MIME
  39 import qualified Data.Map as M
  40 import qualified Data.Set as Set
  41 import qualified Data.Text as TS
  42 import qualified Data.Text.Encoding as TS
  43 import qualified Data.Text.Lazy as T
  44 import qualified Data.Text.Lazy.Encoding as T
  45
  46 import BoundedBSChan
  47 import ClientCert
  48 import ClientSessionManager
  49 import Fingerprint
  50 import Mundanities
  51 import Request
  52 import ServiceCerts
  53
  54 import URI
  55
  56 import Data.Digest.DrunkenBishop
  57
  58 defaultGeminiPort :: Int
  59 defaultGeminiPort = 1965
  60
  61 data MimedData = MimedData {mimedMimetype :: MIME.Type, mimedBody :: BL.ByteString}
  62     deriving (Eq,Ord,Show)
  63
  64 showMimeType :: MimedData -> String
  65 showMimeType = TS.unpack . MIME.showMIMEType . MIME.mimeType . mimedMimetype
  66
  67 data ResponseMalformation
  68     = BadHeaderTermination
  69     | BadStatus String
  70     | BadMetaSeparator
  71     | BadMetaLength
  72     | BadUri String
  73     | BadMime String
  74     deriving (Eq,Ord,Show)
  75
  76 data Response
  77     = Input { inputHidden :: Bool, inputPrompt :: String }
  78     | Success { successData :: MimedData }
  79     | Redirect { permanent :: Bool, redirectTo :: URIRef }
  80     | Failure { failureCode :: Int, failureInfo :: String }
  81     | MalformedResponse { responseMalformation :: ResponseMalformation }
  82     deriving (Eq,Ord,Show)
  83
  84 data InteractionCallbacks = InteractionCallbacks
  85     { icbDisplayInfo :: [String] -> IO ()
  86     , icbDisplayWarning :: [String] -> IO ()
  87     , icbWaitKey :: String -> IO Bool -- ^return False on interrupt, else True
  88     , icbPromptYN :: Bool -- ^default answer
  89         -> String -- ^prompt
  90         -> IO Bool
  91     }
  92
  93 -- Note: we're forced to resort to mvars because the tls library (tls-1.5.4 at
  94 -- least) uses IO rather than MonadIO in the onServerCertificate callback.
  95 data RequestContext = RequestContext
  96     InteractionCallbacks
  97     CertificateStore
  98     (MVar (Set.Set Fingerprint))
  99     (MVar (Set.Set Fingerprint))
 100     FilePath
 101     ClientSessions
 102
 103 initRequestContext :: InteractionCallbacks -> FilePath -> IO RequestContext
 104 initRequestContext callbacks path =
 105     let certPath = path </> "trusted_certs"
 106         serviceCertsPath = path </> "known_hosts"
 107     in do
 108         mkdirhier certPath
 109         mkdirhier serviceCertsPath
 110         certStore <- fromMaybe (makeCertificateStore []) <$> readCertificateStore certPath
 111         mTrusted <- newMVar Set.empty
 112         mIgnoredErrors <- newMVar Set.empty
 113         RequestContext callbacks certStore mTrusted mIgnoredErrors serviceCertsPath <$> newClientSessions
 114
 115 requestOfProxiesAndUri :: M.Map String Host -> URI -> Maybe Request
 116 requestOfProxiesAndUri proxies uri =
 117     let scheme = uriScheme uri
 118     in if scheme == "file"
 119     then let filePath path
 120                 | ('/':_) <- path = Just path
 121                 | Just path' <- stripPrefix "localhost" path, ('/':_) <- path' = Just path'
 122                 | otherwise = Nothing
 123         in LocalFileRequest . unescapeUriString <$> filePath (uriPath uri)
 124     else do
 125         host <- M.lookup scheme proxies `mplus` do
 126             guard $ scheme == "gemini" || "gemini+" `isPrefixOf` scheme
 127                 -- ^people keep suggesting "gemini+foo" schemes for variations
 128                 -- on gemini. On the basis that this naming convention should
 129                 -- indicate that the scheme is backwards-compatible with
 130                 -- actual gemini, we handle them the same as gemini.
 131             hostname <- uriRegName uri
 132             let port = fromMaybe defaultGeminiPort $ uriPort uri
 133             return $ Host hostname port
 134         return . NetworkRequest host $ uri
 135
 136
 137 newtype RequestException = ExcessivelyLongUri Int
 138     deriving Show
 139 instance Exception RequestException
 140
 141 -- |On success, returns `Right lazyResp terminate`. `lazyResp` is a `Response`
 142 -- with lazy IO, so attempts to read it may block while data is received. If
 143 -- the full response is not needed, for example because of an error, the IO
 144 -- action `terminate` should be called to close the connection.
 145 makeRequest :: RequestContext
 146     -> Maybe ClientCert -- ^client certificate to offer
 147     -> Int -- ^bound in bytes for response stream buffering
 148     -> Request -> IO (Either SomeException (Response, IO ()))
 149 makeRequest (RequestContext (InteractionCallbacks displayInfo displayWarning _ promptYN)
 150         certStore mTrusted mIgnoredErrors serviceCertsPath clientSessions) clientCert bound (NetworkRequest host uri) =
 151     let requestBytes = TS.encodeUtf8 . TS.pack $ show uri ++ "\r\n"
 152         uriLength = BS.length requestBytes - 2
 153         ccfp = clientCertFingerprint <$> clientCert
 154     in if uriLength > 1024 then return . Left . toException $ ExcessivelyLongUri uriLength
 155     else handle handleAll $ do
 156         session <- lookupClientSession (hostName host) ccfp clientSessions
 157         let serverId = case uriPort uri of
 158                 Just port | port /= defaultGeminiPort -> TS.encodeUtf8 . TS.pack . (':':) $ show port
 159                 _ -> BS.empty
 160             sessionManager = clientSessionManager 3600 clientSessions ccfp
 161             params = (TLS.defaultParamsClient (hostName host) serverId)
 162                 { clientSupported = def { supportedCiphers = gemini_ciphersuite }
 163                 , clientHooks = def
 164                     { onServerCertificate = checkServerCert
 165                     , onCertificateRequest = const . return $
 166                         (\(ClientCert chain key) -> (chain,key)) <$> clientCert }
 167                 , clientShared = def
 168                     { sharedCAStore = certStore
 169                     , sharedSessionManager = sessionManager }
 170                 , clientEarlyData = Just requestBytes  -- ^Send early data (RTT0) if server session allows it
 171                 , clientWantSessionResume = session
 172                 }
 173         sock <- openSocket host
 174         context <- TLS.contextNew sock params
 175         handshake context
 176         sentEarly <- (== Just True) . (infoIsEarlyDataAccepted <$>) <$> contextGetInformation context
 177         unless sentEarly . sendData context $ BL.fromStrict requestBytes
 178         -- print =<< (infoTLS13HandshakeMode <$>) <$> contextGetInformation context
 179         chan <- newBSChan bound
 180         let recvAllLazily = do
 181                 r <- recvData context
 182                 unless (BS.null r) $ writeBSChan chan r >> recvAllLazily
 183         recvThread <- forkFinally recvAllLazily $ \_ ->
 184             -- |XXX: note that writeBSChan can't block when writing BS.empty
 185             writeBSChan chan BS.empty >> bye context >> close sock
 186         lazyResp <- parseResponse . BL.fromChunks . takeWhile (not . BS.null) <$> getBSChanContents chan
 187         return $ Right (lazyResp, killThread recvThread)
 188     where
 189     handleAll :: SomeException -> IO (Either SomeException a)
 190     handleAll = return . Left
 191
 192
 193     checkServerCert store cache service chain@(CertificateChain signedCerts) = do
 194         errors <- doTofu =<< validate Data.X509.HashSHA256 defaultHooks
 195             (defaultChecks { checkExhaustive = True }) store cache service chain
 196         if null errors || exists isTrustError errors || null signedCerts
 197         then return errors
 198         else do
 199             ignored <- (tailFingerprint `Set.member`) <$> readMVar mIgnoredErrors
 200             if ignored then return [] else do
 201                 displayWarning [
 202                     "Certificate chain has trusted root, but validation errors: "
 203                     ++ show errors ]
 204                 displayWarning $ showChain signedCerts
 205                 ignore <- promptYN False "Ignore errors?"
 206                 if ignore
 207                 then modifyMVar_ mIgnoredErrors (return . Set.insert tailFingerprint) >> return []
 208                 else return errors
 209         where
 210         exists p = not . all (not . p)
 211
 212         isTrustError = (`elem` [UnknownCA, SelfSigned])
 213
 214         -- |error pertaining to the tail certificate, to be ignored if the
 215         -- user explicitly trusts the certificate for this service.
 216         isTrustableError LeafNotV3 = True
 217         isTrustableError (NameMismatch _) = True
 218         isTrustableError _ = False
 219
 220         tailSigned = head signedCerts
 221         tailFingerprint = fingerprint tailSigned
 222
 223         doTofu errors = if not . exists isTrustError $ errors
 224             then return errors
 225             else do
 226                 trust <- checkTrust $ filter isTrustableError errors
 227                 return $ if trust
 228                     then filter (\e -> not $ isTrustError e || isTrustableError e) errors
 229                     else errors
 230
 231         checkTrust :: [FailedReason] -> IO Bool
 232         checkTrust errors = do
 233             trusted <- (tailFingerprint `Set.member`) <$> readMVar mTrusted
 234             if trusted then return True else do
 235                 trust <- checkTrust' errors
 236                 when trust $ modifyMVar_ mTrusted (return . Set.insert tailFingerprint)
 237                 return trust
 238         checkTrust' :: [FailedReason] -> IO Bool
 239         checkTrust' errors = do
 240             let certs = map getCertificate signedCerts
 241                 tailCert = head certs
 242                 serviceString = serviceToString service
 243                 warnErrors = unless (null errors) . displayWarning $
 244                     [ "WARNING: tail certificate has verification errors: " <> show errors ]
 245             known <- loadServiceCert serviceCertsPath service `catch` ((>> return Nothing) . printIOErr)
 246             if known == Just tailSigned then do
 247                 displayInfo $ fingerprintPicture tailFingerprint ++ [ "Expires " ++ printExpiry tailCert ]
 248                 return True
 249             else do
 250                 displayInfo $ showChain signedCerts
 251                 trust <- case known of
 252                     Nothing -> do
 253                         displayInfo [ "No certificate previously seen for " ++ serviceString ++ "." ]
 254                         warnErrors
 255                         promptYN (null errors) $
 256                             "Trust provided certificate (" ++ take 8 (fingerprintHex tailFingerprint) ++ ")?"
 257                     Just trustedSignedCert -> do
 258                         currentTime <- timeConvert <$> timeCurrent
 259                         let trustedCert = getCertificate trustedSignedCert
 260                             expired = currentTime > (snd . certValidity) trustedCert
 261                             samePubKey = certPubKey trustedCert == certPubKey tailCert
 262                             oldFingerprint = fingerprint trustedSignedCert
 263                             oldInfo = [ "Fingerprint of old certificate: " ++ fingerprintHex oldFingerprint ]
 264                                 ++ fingerprintPicture oldFingerprint
 265                                 ++ [ "Old certificate " ++ (if expired then "expired" else "expires") ++
 266                                     ": " ++ printExpiry trustedCert ]
 267                         if expired || samePubKey
 268                             then displayInfo $
 269                                 ("A different " ++ (if expired then "expired " else "non-expired ") ++
 270                                 "certificate " ++ (if samePubKey then "with the same public key " else "") ++
 271                                 "for " ++ serviceString ++ " was previously explicitly trusted.") : oldInfo
 272                             else displayWarning $
 273                                 ("CAUTION: A certificate with a different public key for " ++ serviceString ++
 274                                 " was previously explicitly trusted and has not expired!") : oldInfo
 275                         warnErrors
 276                         promptYN (expired || samePubKey) "Trust new certificate (and delete old certificate)?"
 277                 when trust $
 278                     saveServiceCert serviceCertsPath service tailSigned `catch` printIOErr
 279                 return trust
 280
 281         printExpiry :: Certificate -> String
 282         printExpiry = timePrint ISO8601_Date . snd . certValidity
 283
 284         showChain :: [SignedCertificate] -> [String]
 285         showChain [] = [""]
 286         showChain signed = let
 287             sigChain = reverse signed
 288             certs = map getCertificate sigChain
 289             showCN = maybe "[Unspecified CN]" (TS.unpack . TS.decodeUtf8 . getCharacterStringRawData) . getDnElement DnCommonName
 290             issuerCN = showCN . certIssuerDN $ head certs
 291             subjectCNs = map (showCN . certSubjectDN) certs
 292             hexes = map (fingerprintHex . fingerprint) sigChain
 293             pics = map (fingerprintPicture . fingerprint) sigChain
 294             expStrs = map (("Expires " ++) . printExpiry) certs
 295             picsWithInfo = map (map $ centre 23) $ zipWith (++) pics $ transpose [subjectCNs, expStrs]
 296             centre n s = take n $ replicate ((n - length s) `div` 2) ' ' ++ s ++ repeat ' '
 297             tweenCol = replicate 6 "     " ++ [" >>> "] ++ replicate 6 "     "
 298             sideBySide = map concat . transpose
 299             in [ "Certificate chain: " ++ intercalate " >>> " (issuerCN:subjectCNs) ]
 300                 ++ (sideBySide . intersperse tweenCol $ picsWithInfo)
 301                 ++ zipWith (++) ("": repeat ">>> ") hexes
 302
 303     printIOErr :: IOError -> IO ()
 304     printIOErr = displayWarning . (:[]) . show
 305
 306     fingerprintHex :: Fingerprint -> String
 307     fingerprintHex (Fingerprint fp) = concat $ hexWord8 <$> BS.unpack fp
 308         where hexWord8 w =
 309                 let (a,b) = quotRem w 16
 310                     hex = ("0123456789abcdef" !!) . fromIntegral
 311                 in hex a : hex b : ""
 312     fingerprintPicture :: Fingerprint -> [String]
 313     fingerprintPicture (Fingerprint fp) = boxedDrunkenBishop fp where
 314         boxedDrunkenBishop :: BS.ByteString -> [String]
 315         boxedDrunkenBishop s = ["+-----[X509]------+"]
 316             ++ (map (('|':) . (++"|")) . lines $ drunkenBishopPreHashed s)
 317             ++ ["+----[SHA256]-----+"]
 318         drunkenBishopPreHashed :: BS.ByteString -> String
 319         drunkenBishopPreHashed = drunkenBishopWithOptions $
 320             drunkenBishopDefaultOptions { drunkenBishopHash = id }
 321
 322     -- |those ciphers from ciphersuite_default fitting the requirements
 323     -- recommended by the gemini "best practices" document:
 324     -- require ECDHE/DHE (for PFS), and >=SHA2, and AES/CHACHA20.
 325     gemini_ciphersuite :: [Cipher]
 326     gemini_ciphersuite =
 327         [        -- First the PFS + GCM + SHA2 ciphers
 328           cipher_ECDHE_ECDSA_AES128GCM_SHA256, cipher_ECDHE_ECDSA_AES256GCM_SHA384
 329         , cipher_ECDHE_ECDSA_CHACHA20POLY1305_SHA256
 330         , cipher_ECDHE_RSA_AES128GCM_SHA256, cipher_ECDHE_RSA_AES256GCM_SHA384
 331         , cipher_ECDHE_RSA_CHACHA20POLY1305_SHA256
 332         , cipher_DHE_RSA_AES128GCM_SHA256, cipher_DHE_RSA_AES256GCM_SHA384
 333         , cipher_DHE_RSA_CHACHA20POLY1305_SHA256
 334         ,        -- Next the PFS + CCM + SHA2 ciphers
 335           cipher_ECDHE_ECDSA_AES128CCM_SHA256, cipher_ECDHE_ECDSA_AES256CCM_SHA256
 336         , cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES256CCM_SHA256
 337                  -- Next the PFS + CBC + SHA2 ciphers
 338         , cipher_ECDHE_ECDSA_AES128CBC_SHA256, cipher_ECDHE_ECDSA_AES256CBC_SHA384
 339         , cipher_ECDHE_RSA_AES128CBC_SHA256, cipher_ECDHE_RSA_AES256CBC_SHA384
 340         , cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256
 341                 -- TLS13 (listed at the end but version is negotiated first)
 342         , cipher_TLS13_AES128GCM_SHA256
 343         , cipher_TLS13_AES256GCM_SHA384
 344         , cipher_TLS13_CHACHA20POLY1305_SHA256
 345         , cipher_TLS13_AES128CCM_SHA256
 346         ]
 347
 348     openSocket :: Host -> IO Socket
 349     openSocket (Host hostname port) = do
 350         let hints = defaultHints { addrSocketType = Stream }
 351         addr:_ <- getAddrInfo (Just hints) (Just hostname) (Just $ show port)
 352         sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
 353         ignoreIOErr $
 354             -- set SO_KEEPALIVE so we detect when a stream connection goes down:
 355             setSocketOption sock KeepAlive 1
 356         connect sock $ addrAddress addr
 357         return sock
 358
 359     parseResponse :: BL.ByteString -> Response
 360     parseResponse resp =
 361         let (header, rest) = BLC.break (== '\r') resp
 362             body = BL.drop 2 rest
 363             statusString = T.unpack . T.decodeUtf8 . BL.take 2 $ header
 364             separator = BL.take 1 . BL.drop 2 $ header
 365             meta = T.unpack . T.decodeUtf8 . BL.drop 3 $ header
 366         in
 367         if BL.take 2 rest /= "\r\n" then MalformedResponse BadHeaderTermination
 368         else if separator `notElem` [""," ","\t"] -- ^allow \t for now, though it's against latest spec
 369         then MalformedResponse BadMetaSeparator
 370         else if BL.length header > 1024+3 then MalformedResponse BadMetaLength
 371         else case readMay statusString of
 372             Just status | status >= 10 && status < 80 ->
 373                 let (status1,status2) = divMod status 10
 374                 in case status1 of
 375                     1 -> Input (status2 == 1) meta
 376                     2 -> maybe (MalformedResponse (BadMime meta))
 377                         (\mime -> Success $ MimedData mime body) $
 378                         MIME.parseMIMEType (TS.pack $
 379                             if null meta then "text/gemini; charset=utf-8" else meta)
 380                     3 -> maybe (MalformedResponse (BadUri meta))
 381                         (Redirect (status2 == 1)) $ parseUriReference meta
 382                     _ -> Failure status meta
 383             _ -> MalformedResponse (BadStatus statusString)
 384
 385 makeRequest _ _ _ (LocalFileRequest _) = error "File requests not handled by makeRequest"