From 0836606622d85d93c5aa9177efbe01b09eba4f4f Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 31 Jul 2022 20:08:31 +1200 Subject: [PATCH] Switch cryptography library & implement HSTS. --- hurl.cabal | 6 +- src/Network/URI/Cache.hs | 109 ++++++++++++++++++++++++++++++++---- src/Network/URI/Fetch.hs | 102 ++++++++++++++++++++++++--------- src/Network/URI/Messages.hs | 53 +++++++++++++++++- 4 files changed, 228 insertions(+), 42 deletions(-) diff --git a/hurl.cabal b/hurl.cabal index 501fa5a..b4e24d4 100644 --- a/hurl.cabal +++ b/hurl.cabal @@ -113,12 +113,12 @@ library if flag(http) CPP-options: -DWITH_HTTP_URI - build-depends: http-client, http-types >= 0.12 && <0.13, - http-client-openssl, HsOpenSSL, time, cookie + build-depends: http-client, http-types >= 0.12 && <0.13, publicsuffixlist >= 0.1, + http-client-tls, time, cookie other-modules: Network.URI.Cache, Network.URI.CookiesDB if flag(gemini) CPP-options: -DWITH_GEMINI_URI -DWITH_RAW_CONNECTIONS - build-depends: HsOpenSSL, openssl-streams >= 1.2 && < 1.3, io-streams >= 1.5 && < 1.6 + build-depends: connection, tls, data-default-class if flag(file) CPP-options: -DWITH_FILE_URI if flag(data) diff --git a/src/Network/URI/Cache.hs b/src/Network/URI/Cache.hs index 179848d..973064a 100644 --- a/src/Network/URI/Cache.hs +++ b/src/Network/URI/Cache.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Network.URI.Cache(shouldCacheHTTP, cacheHTTP, readCacheHTTP, cleanCacheHTTP) where +module Network.URI.Cache(shouldCacheHTTP, cacheHTTP, readCacheHTTP, cleanCacheHTTP, + writeHSTS, readHSTS, appendHSTS, appendHSTSFromHeader, removeHSTS, testHSTS) where import Network.HTTP.Client import Network.HTTP.Types.Status import Network.HTTP.Types.Header @@ -18,7 +19,7 @@ import System.Directory import qualified Data.Text as Txt import Data.Maybe -import Data.Char (isSpace) +import Data.Char (isSpace, isDigit, toLower) import Data.List as L import Control.Monad (forM, void, when) import Text.Read (readMaybe) @@ -130,14 +131,16 @@ openKV key mode act = do readKV key = openKV key ReadMode parseHeaders parseHeaders h = do - line <- IO.hGetLine h - case L.break isSpace $ strip' line of - ("", "") -> do - body <- Lazy.hGetContents h - return ([], body) - (key, value) -> do - (headers, body) <- parseHeaders h - return ((key, strip' value):headers, body) + isEnd <- IO.hIsEOF h + if isEnd then return ([], "") else do + line <- IO.hGetLine h + case L.break isSpace $ strip' line of + ("", "") -> do + body <- Lazy.hGetContents h + return ([], body) + (key, value) -> do + (headers, body) <- parseHeaders h + return ((key, strip' value):headers, body) strip' = L.dropWhile isSpace . L.dropWhileEnd isSpace writeKV key (headers, body) = void $ openKV key WriteMode $ \h -> do @@ -147,3 +150,89 @@ writeKV key (headers, body) = void $ openKV key WriteMode $ \h -> do Lazy.hPut h body deleteKV key = pathKV key >>= removeFile + +-------- +---- HSTS Support +-------- +readHSTS :: IO [(String, Bool, UTCTime)] +readHSTS = do + (headers, _) <- fromMaybe ([], "") <$> readKV ".HSTS" + -- Remove expired & duplicate entries on startup via `nubHSTS` + now <- getCurrentTime + let db = nubHSTS now (L.reverse $ mapMaybe parseRecord headers) [] + writeHSTS $ seq (L.length db) db -- Ensure the file is fully read before being written. + return db + where + parseRecord ('*':domain, value) | Just expires <- readMaybe value = Just (domain, True, expires) + parseRecord (domain, value) | Just expires <- readMaybe value = Just (domain, False, expires) + parseRecord _ = Nothing +appendHSTS :: (String, Bool, UTCTime) -> IO () +appendHSTS = void . openKV ".HSTS" AppendMode . flip appendHSTS' +appendHSTS' h (domain, True, expires) = IO.hPutStrLn h ('*':domain ++ ' ':show expires) +appendHSTS' h (domain, False, expires) = IO.hPutStrLn h (domain ++ ' ':show expires) +writeHSTS :: [(String, Bool, UTCTime)] -> IO () +writeHSTS domains = void . openKV ".HSTS" WriteMode $ \h -> forM domains (appendHSTS' h) + +-- Directly disregards IETF RFC6797 section 12.1 +-- I prefer not to give up on designing a proper consent UI. +removeHSTS :: [(String, Bool, UTCTime)] -> String -> IO [(String, Bool, UTCTime)] +removeHSTS db badDomain = do + now <- getCurrentTime -- Clear out expired records while we're at it... + let ret = nubHSTS now db [badDomain] + writeHSTS ret + return ret + +nubHSTS now (x@(domain, _, expires):db) filter + | domain `L.elem` filter = nubHSTS now db (domain:filter) + -- Filter out expired entries while we're at it. + | now >= expires = nubHSTS now db (domain:filter) + | otherwise = x:nubHSTS now db (domain:filter) +nubHSTS _ [] _ = [] + +appendHSTSFromHeader :: String -> Strict.ByteString -> IO (Maybe (String, Bool, UTCTime)) +appendHSTSFromHeader domain header = + let dirs = parseDirectives $ C.split ';' header + in if validateHSTS dirs then do + expiry <- secondsFromNow $ fromMaybe 0 (readMaybe =<< lookup "max-age" dirs) + -- FIXME: Is it right I'm ignoring if this has a value. + let subdomains = isJust $ lookup "includesubdomains" dirs + appendHSTS (domain, subdomains, expiry) + return $ Just (domain, subdomains, expiry) + else return Nothing + +parseDirectives (dir:dirs) = case L.break (== '=') $ C.unpack dir of + (key, '=':'"':quoted) | Just (value, dirs') <- parseString quoted dirs + -> (lowercase $ strip key, value):parseDirectives dirs' + (_, '=':'"':_) -> [("", "")] -- Represents error... + (key, '=':value) -> (lowercase $ strip key, strip value):parseDirectives dirs + (key, _) -> (lowercase $ strip key, ""):parseDirectives dirs + where + parseString ('\\':c:str) tail = appendC c $ parseString str tail + parseString ("\"") tail = Just ("", tail) + parseString ('"':_) _ = Nothing -- Disallow trailing text + parseString (c:str) tail = appendC c $ parseString str tail + -- Handle the naive split-by-semicolon above. + parseString "" (extra:tail) = appendC ';' $ parseString (C.unpack extra) tail + parseString "" [] = Nothing + appendC c (Just (str, tail)) = Just (c:str, tail) + appendC _ Nothing = Nothing + + strip = L.dropWhile isSpace . L.dropWhileEnd isSpace + lowercase = L.map toLower +parseDirectives [] = [] + +validateHSTS directives + | Just _ <- lookup "" directives = False -- indicates empty key or malformed string + | Nothing <- lookup "max-age" directives = False -- mandatory field + | Just val <- lookup "max-age" directives, L.any (not . isDigit) val = False -- invalid value + | otherwise = validateHSTS' directives -- check no duplicate keys +validateHSTS' ((dir, _):dirs) | Just _ <- lookup dir dirs = False + | otherwise = validateHSTS' dirs +validateHSTS' [] = True + +testHSTS :: UTCTime -> String -> [(String, Bool, UTCTime)] -> Bool +testHSTS now key ((_, _, expires):db) | now > expires = testHSTS now key db +testHSTS _ key ((domain, _, _):db) | key == domain = True +testHSTS _ key ((domain, True, _):db) | ('.':domain) `L.isSuffixOf` key = True +testHSTS now key (_:db) = testHSTS now key db +testHSTS _ _ [] = False diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs index ca4f941..ba45df7 100644 --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -2,7 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} -- | Retrieves documents for a URL, supporting multiple URL schemes that can be -- disabled at build-time for reduced dependencies. -module Network.URI.Fetch(Session(locale, aboutPages, redirectCount, cachingEnabled), newSession, +module Network.URI.Fetch( + Session(locale, aboutPages, redirectCount, cachingEnabled, validateCertificates), + newSession, fetchURL, fetchURL', fetchURLs, submitURL, submitURL', mimeERR, htmlERR, dispatchByMIME, appsForMIME, Application(..), dispatchByApp, saveDownload, downloadToURI, @@ -49,9 +51,10 @@ import Data.List as L #ifdef WITH_HTTP_URI import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.MultipartFormData as HTTP -import qualified Network.HTTP.Client.OpenSSL as TLS -import qualified OpenSSL.Session as TLS +import qualified Network.HTTP.Client.TLS as TLS import Network.HTTP.Types +import Network.PublicSuffixList.Lookup (effectiveTLDPlusOne) + import Data.List (intercalate) import Control.Concurrent (forkIO) @@ -60,10 +63,10 @@ import Network.URI.CookiesDB #endif #ifdef WITH_RAW_CONNECTIONS -import qualified OpenSSL as TLS -import qualified OpenSSL.Session as TLS -import qualified System.IO.Streams.SSL as TLSConn -import System.IO.Streams +import qualified Network.Connection as Conn +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS +import Data.Default.Class (def) #endif #ifdef WITH_DATA_URI @@ -80,6 +83,9 @@ import Network.URI.XDG #ifdef WITH_PLUGIN_REWRITES import Network.URI.PlugIns.Rewriters #endif +#ifdef WITH_PLUGIN_EXEC +import System.Process +#endif -- | Data shared accross multiple URI requests. data Session = Session { @@ -88,9 +94,10 @@ data Session = Session { globalCookieJar :: MVar HTTP.CookieJar, cookiesPath :: FilePath, retroactiveCookies :: Maybe (MVar HTTP.CookieJar), + hstsDomains :: MVar [(String, Bool, UTCTime)], #endif #ifdef WITH_RAW_CONNECTIONS - connCtxt :: TLS.SSLContext, + connCtxt :: Conn.ConnectionContext, #endif #ifdef WITH_XDG apps :: XDGConfig, @@ -109,7 +116,9 @@ data Session = Session { -- | Whether to cache network responses, avoiding sending requests cachingEnabled :: Bool, -- | App-specific config subdirectory to check - appName :: String + appName :: String, + -- | Whether to validate the server is who they say they are on secured protocols. + validateCertificates :: Bool } data LogRecord = LogRecord { @@ -132,11 +141,7 @@ newSession' :: String -> IO Session newSession' appname = do (ietfLocale, unixLocale) <- rfc2616Locale #ifdef WITH_HTTP_URI - httpsCtxt <- TLS.context - TLS.contextSetDefaultCiphers httpsCtxt - TLS.contextSetCADirectory httpsCtxt "/etc/ssl/certs" - TLS.contextSetVerificationMode httpsCtxt $ TLS.VerifyPeer True True Nothing - managerHTTP' <- HTTP.newManager $ TLS.opensslManagerSettings $ return httpsCtxt + managerHTTP' <- HTTP.newManager $ TLS.tlsManagerSettings cookiesDir <- getXdgDirectory XdgData "nz.geek.adrian.hurl.cookies2" let cookiesPath' = cookiesDir appname @@ -144,13 +149,11 @@ newSession' appname = do now <- getCurrentTime cookieJar <- newMVar $ HTTP.evictExpiredCookies cookies' now cookieJar' <- newMVar $ HTTP.createCookieJar [] + + hstsDomains' <- newMVar =<< readHSTS #endif #ifdef WITH_RAW_CONNECTIONS - connCtxt <- TLS.context - TLS.contextSetDefaultCiphers connCtxt - TLS.contextSetCADirectory connCtxt "/etc/ssl/certs" - TLS.contextSetVerificationMode connCtxt $ - TLS.VerifyPeer True True $ Just $ \valid _ -> return valid -- FIXME: Implement Trust-On-First-Use + connCtxt <- Conn.initConnectionContext #endif #ifdef WITH_XDG apps' <- loadXDGConfig unixLocale @@ -165,6 +168,7 @@ newSession' appname = do globalCookieJar = cookieJar, cookiesPath = cookiesPath', retroactiveCookies = Just cookieJar', + hstsDomains = hstsDomains', #endif #ifdef WITH_RAW_CONNECTIONS connCtxt = connCtxt, @@ -180,6 +184,7 @@ newSession' appname = do requestLog = Nothing, redirectCount = 5, cachingEnabled = True, + validateCertificates = True, appName = appname } @@ -357,11 +362,25 @@ fetchURL' session accept uri | uriScheme uri `elem` ["http:", "https:"] = #ifdef WITH_GEMINI_URI fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { uriScheme = "gemini:", uriAuthority = Just (URIAuth _ host port) - } = TLSConn.withConnection ctxt host (parsePort 1965 port) $ \input output _ -> do - writeTo output $ Just $ C8.pack $ uriToString id uri "\r\n" - input' <- inputStreamToHandle input - header <- hGetLine input' - case parseHeader header of + } = do + let params = TLS.defaultParamsClient host "gmni" + conn <- Conn.connectTo ctxt Conn.ConnectionParams { + Conn.connectionHostname = host, + Conn.connectionPort = parsePort 1965 port, + -- FIXME Implement certificate validation that actually common geminispace certs... + Conn.connectionUseSecure = Just $ Conn.TLSSettings params { + TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default }, + TLS.clientShared = def { + TLS.sharedValidationCache = TLS.ValidationCache + (\_ _ _ -> return TLS.ValidationCachePass) + (\_ _ _ -> return ()) + } + }, + Conn.connectionUseSocks = Nothing + } + Conn.connectionPut conn $ C8.pack $ uriToString id uri "\r\n" + header <- Conn.connectionGetLine 1027 conn + case parseHeader $ C8.unpack header of -- NOTE: This case won't actually do anything until the caller (Rhapsode) implements forms. ('1', _, label) -> return (uri, "application/xhtml+xml", Left $ Txt.concat [ "
" ]) ('2', _, mime) -> do - body <- Strict.hGetContents input' + body <- B.fromChunks <$> connectionGetChunks conn let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime - return $ resolveCharset' uri mime' $ B.fromStrict body + return $ resolveCharset' uri mime' body ('3', _, redirect) | Just redirect' <- parseURIReference $ Txt.unpack redirect -> fetchURL' sess { redirectCount = redirectCount sess - 1 @@ -385,6 +404,9 @@ fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { parseHeader _ = ('4', '1', Txt.pack $ trans l MalformedResponse) handleIOErr :: IOError -> IO Strict.ByteString handleIOErr _ = return "" + connectionGetChunks conn = do + chunk <- Conn.connectionGetChunk conn `catch` handleIOErr + if Strict.null chunk then return [] else (chunk:) <$> connectionGetChunks conn #endif #ifdef WITH_FILE_URI @@ -453,8 +475,20 @@ dispatchByApp _ _ _ _ = return False #endif #ifdef WITH_HTTP_URI -fetchHTTPCached session shouldCache accept@(defaultMIME:_) uri cbReq cbResp = do +fetchHTTPCached session shouldCache accept@(defaultMIME:_) rawUri cbReq cbResp = do + now <- getCurrentTime + hsts <- readMVar $ hstsDomains session + uri <- case (uriScheme rawUri, uriAuthority rawUri) of { + (_, Just (URIAuth _ domain _)) | not $ validateCertificates session -> (do + modifyMVar_ (hstsDomains session) $ flip removeHSTS domain + return rawUri); + ("http:", Just (URIAuth _ domain _)) + | testHSTS now domain hsts -> return rawUri { uriScheme = "https:" }; + _ -> return rawUri + } + cached <- if shouldCache then readCacheHTTP uri else return (Nothing, Nothing) + response <- case cached of (Just (mime, body), Nothing) -> return $ Right (mime, body) (cached, cachingHeaders) -> do @@ -470,6 +504,18 @@ fetchHTTPCached session shouldCache accept@(defaultMIME:_) uri cbReq cbResp = do } response <- HTTP.httpLbs request' $ managerHTTP session cbResp response + case ( + uriScheme uri, + uriAuthority uri, + "strict-transport-security" `lookup` HTTP.responseHeaders response + ) of + ("https:", Just (URIAuth _ domain _), Just header) + | Just domain' <- effectiveTLDPlusOne $ Txt.pack domain -> do + record <- appendHSTSFromHeader (Txt.unpack domain') header + case record of + Just x -> modifyMVar_ (hstsDomains session) (return . (x:)) + _ -> return () + _ -> return () case ( HTTP.responseStatus response, HTTP.responseBody response, @@ -499,7 +545,7 @@ fetchHTTPCached session shouldCache accept@(defaultMIME:_) uri cbReq cbResp = do Right (mime, body) -> let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime in return $ resolveCharset' uri mime' body - `catch` \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e) + `catch` \e -> do return (rawUri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e) fetchHTTPCached session _ [] uri _ _ = return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ UnsupportedMIME "") #endif diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs index 15c27e8..6025553 100644 --- a/src/Network/URI/Messages.hs +++ b/src/Network/URI/Messages.hs @@ -17,6 +17,8 @@ import Data.Maybe (fromMaybe) #if WITH_HTTP_URI import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..)) import Control.Exception (displayException) +import Network.TLS (TLSException(..), TLSError(..), AlertDescription(..)) +import Control.Exception.Base (fromException) #endif trans _ (RawXML markup) = markup @@ -36,7 +38,56 @@ trans ("en":_) (Http (HttpExceptionRequest _ (TooManyRedirects _))) = "Too many trans ("en":_) (Http (HttpExceptionRequest _ ResponseTimeout)) = "The site took too long to respond!" trans ("en":_) (Http (HttpExceptionRequest _ ConnectionTimeout)) = "The site took too long to connect!" trans ("en":_) (Http (HttpExceptionRequest _ (ConnectionFailure err))) = "Could not connect: " ++ displayException err -trans ("en":_) (Http (HttpExceptionRequest _ _)) = "The site doesn't appear to speak the same language as me!" +trans ("en":_) (Http (HttpExceptionRequest _ (InternalException e))) = case fromException e of + Just (Terminated _ why _) -> "Secure session disconnected! " ++ why ++ "" + Just (HandshakeFailed (Error_Misc msg)) -> + "Failed to establish secure connection! " ++ msg ++ "" + Just (HandshakeFailed (Error_Protocol (_, _, CloseNotify))) -> + "Secure session disconnected!" + Just (HandshakeFailed (Error_Protocol (_, _, HandshakeFailure))) -> + "Failed to negotiate security parameters!" + Just (HandshakeFailed (Error_Protocol (_, _, BadCertificate))) -> + "

The site failed to prove it is who it says it is!

" + Just (HandshakeFailed (Error_Protocol (_, _, UnsupportedCertificate))) -> unlines [ + "

The site failed to prove it is who it says it is!

", + "

It has sent us a cryptographic certificate I failed to make sense of.

" + ] + Just (HandshakeFailed (Error_Protocol (_, _, CertificateExpired))) -> unlines [ + "

The site failed to prove it is who it says it is!

", + "

The cryptographic certificate it has sent to us has expired!

" + ] + Just (HandshakeFailed (Error_Protocol (_, _, CertificateRevoked))) -> unlines [ + "

The site failed to prove it is who it says it is!

", + "

The cryptographic certificate it has sent us has been revoked!

" + ] + Just (HandshakeFailed (Error_Protocol (_, _, CertificateUnknown))) -> unlines [ + "

The site failed to prove it is who it says it is!

", + "

The cryptographic certificate it has sent us belongs to someone else!

" + ] + Just (HandshakeFailed (Error_Protocol (_, _, UnknownCa))) -> unlines [ + "

The site failed to prove it is who it says it is!

", + "

The authority vouching for it is unknown to me!

" + ] + Just (HandshakeFailed (Error_Protocol (why, _, _desc))) -> + "Failed to establish secure connection! " ++ why ++ "" + Just (HandshakeFailed (Error_Certificate why)) -> unlines [ + "

The site failed to prove it is who it says it is!

", + "

" ++ why ++ "

" + ] + Just (HandshakeFailed (Error_HandshakePolicy why)) -> + "Invalid handshake policy: " ++ why ++ "" + Just (HandshakeFailed Error_EOF) -> "Secure session disconnected!" + Just (HandshakeFailed (Error_Packet why)) -> + "Invalid security packet: " ++ why ++ "" + Just (HandshakeFailed (Error_Packet_unexpected a b)) -> unlines [ + "

Invalid security packet: " ++ a ++ "

", + "

" ++ b ++ "

" + ] + Just (HandshakeFailed (Error_Packet_Parsing why)) -> + "Invalid security packet: " ++ why ++ "" + Just ConnectionNotEstablished -> + "Attempted to send or recieve data before establishing secure connection!" + Nothing -> "Internal error: " ++ displayException e #endif --- END LOCALIZATION -- 2.30.2