diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,11 @@ # Revision history for hurl -## 2.1.1.0 -- 2021-07-22 -* Add support for submitting forms (fallsback to normal URL resolution). -* Allow setting cookies in response HTTP POST, including retroactively for the sake of CSRF protections. +## 2.2.0.0 -- 2022-08-06 +* Fix webform submission, refine API, & support multiple encodings. +* Switch from OpenSSL to `tls`/Cryptonite for a cryptographic backend for better error reporting & to fix Gemini implementation +* Support clientside certificates in Gemini & HTTPS +* Support HSTS with bypass +* Allow overriding HURL's error-reporting localization ## 2.1.0.1 -- 2021-03-09 * Fixes a build failure. diff --git a/Main2.hs b/Main2.hs new file mode 100644 --- /dev/null +++ b/Main2.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Network.URI.Fetch +-- Input parsing +import System.Environment (getArgs) +import Network.URI (parseURI, nullURI) +import Data.Maybe (fromJust) +-- Where to save files +import System.Directory (getCurrentDirectory) +import qualified Data.ByteString.Char8 as C8 + +main :: IO () +main = do + url:encoding:args <- getArgs + let url' = fromJust $ parseURI url + putStrLn encoding + session <- newSession + dir <- getCurrentDirectory + + resp <- submitURL' session ["*/*"] url' "POST" (C8.pack encoding) $map parseArg args + res <- saveDownload nullURI dir resp + putStrLn $ show res + +parseArg ('-':arg) | (key, '=':value) <- break (== '=') arg = (key, Left value) + | otherwise = (arg, Left "") +parseArg ('+':arg) | (key, '=':value) <- break (== '=') arg = (key, Right value) + | otherwise = (arg, Left "") +parseArg arg | (key, '=':value) <- break (== '=') arg = (key, Left value) + | otherwise = (arg, Left "") diff --git a/hurl.cabal b/hurl.cabal --- a/hurl.cabal +++ b/hurl.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 2.1.1.0 +version: 2.2.0.0 -- A short (one-line) description of the package. synopsis: Haskell URL resolver @@ -113,12 +113,12 @@ if flag(http) CPP-options: -DWITH_HTTP_URI - build-depends: http-client, http-types >= 0.12 && <0.13, - http-client-openssl, HsOpenSSL - other-modules: Network.URI.Cache + build-depends: http-client, http-types >= 0.12 && <0.13, publicsuffixlist >= 0.1, + http-client-tls, time, cookie, connection, tls, data-default-class + 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) @@ -152,3 +152,18 @@ default-language: Haskell2010 ghc-options: -threaded + +executable hurl-post + -- .hs file containing the Main module + main-is: Main2.hs + + -- Other library packages from which modules are imported + build-depends: base >= 4.9 && <5, hurl, network-uri, directory, bytestring + + -- Directories containing source files. + hs-source-dirs: . + + -- Base languages which the package is written in. + default-language: Haskell2010 + + ghc-options: -threaded diff --git a/src/Network/URI/Cache.hs b/src/Network/URI/Cache.hs --- 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 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 @@ 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 @@ 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/CookiesDB.hs b/src/Network/URI/CookiesDB.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/CookiesDB.hs @@ -0,0 +1,135 @@ +-- | Read & write Netscape Navigator cookies format. +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +module Network.URI.CookiesDB (readCookies, writeCookies) where +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Network.HTTP.Client +import System.Directory (doesFileExist) + +import Web.Cookie (formatCookieExpires, parseCookieExpires) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Time.Clock (nominalDay, getCurrentTime, addUTCTime, UTCTime) + +readCookies :: FilePath -> IO CookieJar +readCookies filepath = do + exists <- doesFileExist filepath + if exists then do + file <- B.readFile filepath + now <- getCurrentTime + return $ createCookieJar $ readCookies' now file + else return $ createCookieJar [] +readCookies' :: UTCTime -> B.ByteString -> [Cookie] +readCookies' now = mapMaybe (readCookie' now) . C.lines +readCookie' :: UTCTime -> B.ByteString -> Maybe Cookie +readCookie' now = readCookie now . C.split '\t' +readCookie :: UTCTime -> [B.ByteString] -> Maybe Cookie +readCookie now [domain, _, path, secure, expiration, name, value] = + Just Cookie { + cookie_domain = domain, + cookie_path = path, + cookie_secure_only = b secure, + cookie_expiry_time = fromMaybe (addUTCTime nominalDay now) $ parseCookieExpires expiration, + cookie_name = name, + cookie_value = value, + + cookie_creation_time = now, + cookie_last_access_time = now, + cookie_persistent = True, + cookie_host_only = False, + cookie_http_only = False + } +readCookie now [domain, _, path, secure, expiration, name, value, httpOnly, session] = + Just Cookie { + cookie_domain = domain, + cookie_path = path, + cookie_secure_only = b secure, + cookie_expiry_time = fromMaybe (addUTCTime nominalDay now) $ parseCookieExpires expiration, + cookie_name = name, + cookie_value = value, + cookie_http_only = b httpOnly, + cookie_persistent = not $ b session, + + cookie_creation_time = now, + cookie_last_access_time = now, + cookie_host_only = False + } +readCookie now [domain, _, path, secure, expiration, name, value, + httpOnly, session, sameSite] = Just Cookie { + cookie_domain = domain, + cookie_path = path, + cookie_secure_only = b secure, + cookie_expiry_time = fromMaybe (addUTCTime nominalDay now) $ parseCookieExpires expiration, + cookie_name = name, + cookie_value = value, + cookie_http_only = b httpOnly, + cookie_persistent = not $ b session, + cookie_host_only = sameSite == "STRICT", + + cookie_creation_time = now, + cookie_last_access_time = now + } +readCookie now [domain, _, path, secure, expiration, name, value, + httpOnly, session, sameSite, _] = Just Cookie { + cookie_domain = domain, + cookie_path = path, + cookie_secure_only = b secure, + cookie_expiry_time = fromMaybe (addUTCTime nominalDay now) $ parseCookieExpires expiration, + cookie_name = name, + cookie_value = value, + cookie_http_only = b httpOnly, + cookie_persistent = not $ b session, + cookie_host_only = sameSite == "STRICT", + + cookie_creation_time = now, + cookie_last_access_time = now + } +readCookie now [domain, _, path, secure, expiration, name, value, + httpOnly, session, sameSite, _, creation] = Just Cookie { + cookie_domain = domain, + cookie_path = path, + cookie_secure_only = b secure, + cookie_expiry_time = fromMaybe (addUTCTime nominalDay now) $ parseCookieExpires expiration, + cookie_name = name, + cookie_value = value, + cookie_http_only = b httpOnly, + cookie_persistent = not $ b session, + cookie_host_only = sameSite == "STRICT", + cookie_creation_time = fromMaybe now $ parseCookieExpires creation, + cookie_last_access_time = fromMaybe now $ parseCookieExpires creation + } +readCookie now (domain:_:path:secure:expiration:name:value: + httpOnly:session:sameSite:_:creation:access:_) = Just Cookie { + cookie_domain = domain, + cookie_path = path, + cookie_secure_only = b secure, + cookie_expiry_time = fromMaybe (addUTCTime nominalDay now) $ parseCookieExpires expiration, + cookie_name = name, + cookie_value = value, + cookie_http_only = b httpOnly, + cookie_persistent = not $ b session, + cookie_host_only = sameSite == "STRICT", + cookie_creation_time = fromMaybe now $ parseCookieExpires creation, + cookie_last_access_time = fromMaybe now $ parseCookieExpires access + } +readCookie _ _ = Nothing +b "TRUE" = True +b _ = False + +writeCookies :: FilePath -> CookieJar -> Bool -> IO () +writeCookies filepath cookies isSession = do + B.writeFile filepath $ writeCookies' isSession $ destroyCookieJar cookies +writeCookies' :: Bool -> [Cookie] -> B.ByteString +writeCookies' isSession = C.unlines . map writeCookie' . filter shouldSaveCookie + where + shouldSaveCookie | isSession = cookie_persistent + | otherwise = const True +writeCookie' :: Cookie -> B.ByteString +writeCookie' Cookie {..} = C.intercalate "\t" [ + cookie_domain, "TRUE", cookie_path, b' cookie_secure_only, + formatCookieExpires cookie_expiry_time, cookie_name, cookie_value, + b' cookie_http_only, b' $ not cookie_persistent, + if cookie_host_only then "STRICT" else "LAX", "MEDIUM", + formatCookieExpires cookie_creation_time, + formatCookieExpires cookie_last_access_time] +b' True = "TRUE" +b' False = "FALSE" diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs --- a/src/Network/URI/Fetch.hs +++ b/src/Network/URI/Fetch.hs @@ -2,8 +2,10 @@ {-# 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, - fetchURL, fetchURL', fetchURLs, submitURL, mimeERR, htmlERR, +module Network.URI.Fetch( + Session(locale, aboutPages, redirectCount, cachingEnabled, validateCertificates, credentials), + newSession, + fetchURL, fetchURL', fetchURLs, submitURL, submitURL', mimeERR, htmlERR, dispatchByMIME, appsForMIME, Application(..), dispatchByApp, saveDownload, downloadToURI, -- logging API @@ -13,16 +15,20 @@ import qualified Data.Text as Txt import Data.Text (Text) +import qualified Data.Text.Encoding as Txt import Network.URI import qualified Data.ByteString as Strict import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Builder as Builder import Network.URI.Charset import Control.Exception import System.IO.Error (isEOFError) import Control.Concurrent.Async (forConcurrently) +import qualified Data.Maybe as M + -- for about: URIs & port parsing, all standard lib import Data.Maybe (fromMaybe, listToMaybe, isJust) import Data.Either (isLeft) @@ -44,20 +50,23 @@ #ifdef WITH_HTTP_URI import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Client.OpenSSL as TLS -import qualified OpenSSL.Session as TLS +import qualified Network.HTTP.Client.MultipartFormData as HTTP +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) import Network.URI.Cache +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 +#if WITH_HTTP_URI || WITH_RAW_CONNECTIONS +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 @@ -74,17 +83,22 @@ #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 { #ifdef WITH_HTTP_URI managerHTTP :: HTTP.Manager, + managerHTTPNoValidate :: HTTP.Manager, 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, @@ -94,6 +108,8 @@ #endif -- | The languages (RFC2616-encoded) to which responses should be localized. locale :: [String], + -- | Callback function for localizing error messages, or throwing exceptions + trans' :: Errors -> String, -- | Additional files to serve from about: URIs. aboutPages :: [(FilePath, ByteString)], -- | Log of timestamped/profiled URL requests @@ -103,7 +119,12 @@ -- | 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, + -- | Bytestrings or files containing the client certificate to use for logging into the server. + credentials :: Maybe (Either (FilePath, FilePath) (C8.ByteString, C8.ByteString)), + credentials' :: MVar (Maybe (Either (FilePath, FilePath) (C8.ByteString, C8.ByteString))) } data LogRecord = LogRecord { @@ -125,28 +146,36 @@ newSession' :: String -> IO Session newSession' appname = do (ietfLocale, unixLocale) <- rfc2616Locale + credentialsMVar <- newMVar Nothing #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 + let httpsSettings = (TLS.defaultParamsClient "example.com" "https") { + TLS.clientSupported = def { TLS.supportedCiphers = TLS.ciphersuite_default }, + TLS.clientHooks = def { + TLS.onCertificateRequest = deliverCredentials credentialsMVar + } + } + let httpsSettingsNoValidate = httpsSettings { + TLS.clientShared = def { + TLS.sharedValidationCache = TLS.ValidationCache + (\_ _ _ -> return TLS.ValidationCachePass) + (\_ _ _ -> return ()) + } + } + managerHTTP' <- HTTP.newManager $ TLS.mkManagerSettings (Conn.TLSSettings httpsSettings) Nothing + managerHTTPnovalidate' <- HTTP.newManager $ TLS.mkManagerSettings + (Conn.TLSSettings httpsSettingsNoValidate) Nothing - cookiesDir <- getXdgDirectory XdgData "nz.geek.adrian.hurl.cookies" + cookiesDir <- getXdgDirectory XdgData "nz.geek.adrian.hurl.cookies2" let cookiesPath' = cookiesDir appname - cookiesExist <- doesFileExist cookiesPath' - cookies <- if cookiesExist then readMaybe <$> readFile cookiesPath' else return Nothing + cookies' <- readCookies cookiesPath' now <- getCurrentTime - let cookies' = HTTP.createCookieJar $ fromMaybe [] cookies 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 @@ -158,9 +187,11 @@ return Session { #ifdef WITH_HTTP_URI managerHTTP = managerHTTP', + managerHTTPNoValidate = managerHTTPnovalidate', globalCookieJar = cookieJar, cookiesPath = cookiesPath', retroactiveCookies = Just cookieJar', + hstsDomains = hstsDomains', #endif #ifdef WITH_RAW_CONNECTIONS connCtxt = connCtxt, @@ -172,11 +203,15 @@ rewriter = rewriters, #endif locale = ietfLocale, + trans' = trans ietfLocale, aboutPages = [], requestLog = Nothing, redirectCount = 5, cachingEnabled = True, - appName = appname + validateCertificates = True, + appName = appname, + credentials = Nothing, + credentials' = credentialsMVar } llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key] @@ -217,29 +252,83 @@ htmlERR = "html/x-error\t" submitURL :: Session -> [String] -> URI -> Text -> String -> IO (URI, String, Either Text ByteString) +-- | See submitURL', preserved for backwards compatability. +-- This is a little more cumbersome to use, & doesn't support file uploads. +-- Was designed naively based on convenience of initial caller. +submitURL s a u m q = + submitURL' s a u (Txt.encodeUtf8 m) "application/x-www-form-urlencoded" $ + Prelude.map parseQuery $ Txt.splitOn "&" $ Txt.pack q + where + parseQuery q = let (key, value) = Txt.breakOn "=" q in if Txt.null value + then (decode key, Left "") + else (decode key, Left $ decode $ Txt.tail value) + decode = unEscapeString . Txt.unpack +-- | Uploads given key-value pairs to the specified URL using the specified HTTP method & encoding. +-- The key-value pairs may specify filepaths, in which case the method must be "POST" +-- and the encoding must be "multipart/form-data" for that data to get sent. +-- +-- Unsupported encodings (values other than "application/x-www-form-urlencoded", +-- "text/plain", or "multipart/form-data") omits the key-value pairs from the request. +submitURL' :: Session -> [String] -> URI -> Strict.ByteString -> Strict.ByteString -> + [(String, Either String FilePath)] -> IO (URI, String, Either Text ByteString) #ifdef WITH_HTTP_URI -submitURL session accept uri "POST" query | uriScheme uri `elem` ["http:", "https:"] = do +addHTTPBody mime body req = return req { + HTTP.requestHeaders = (hContentType, mime) : + Prelude.filter (\(x, _) -> x /= hContentType) (HTTP.requestHeaders req), + HTTP.requestBody = HTTP.RequestBodyBS $ C8.pack body + } +packQuery :: [(String, Either String FilePath)] -> C8.ByteString -> HTTP.Request -> IO HTTP.Request +packQuery query mime@"application/x-www-form-urlencoded" = + addHTTPBody mime $ encodeQuery query +packQuery query mime@"text/plain" = addHTTPBody mime $ + Prelude.unlines [value | (key, Left value) <- query, not $ null value] +packQuery q "multipart/form-data" = HTTP.formDataBody $ Prelude.map encodePart q + where + encodePart (key, Left value) = HTTP.partBS (Txt.pack key) (C8.pack value) + encodePart (key, Right value) = + -- C:\fakepath\ is part of the webstandards now & I might as well use it. + -- Ancient browsers exposed the full filepath which was a security vulnerability. + -- Now to avoid breaking servers relying on this behaviour we send + -- a fake Windows filepath. + HTTP.partFileRequestBodyM (Txt.pack key) ("C:\\fakepath\\" ++ takeFileName value) $ do + size <- fromInteger <$> withBinaryFile value ReadMode hFileSize + body <- B.readFile value + return $ HTTP.RequestBodyBuilder size $ Builder.lazyByteString body +packQuery _ _ = return -- Do not upload data if requested to do so in an invalid format. +submitURL' session mimes uri method "GET" query = fetchURL' session mimes uri { + uriQuery = '?': encodeQuery query } -- Specialcase GET! +submitURL' session accept uri method encoding query | uriScheme uri `elem` ["http:", "https:"] = do -- HURL is very strict on when it allows cookies to be set: Only POST HTTP requests are considered consent. -- For the sake of most webframeworks' CSRF protection, cookies from retrieving the form are retroactively set. csrfCookies <- case retroactiveCookies session of { Just cookies -> Just <$> readMVar cookies; Nothing -> return Nothing } - fetchHTTPCached session accept uri (\req -> req { + fetchHTTPCached session False accept uri (\req -> do + ret <- packQuery query encoding req + return ret { HTTP.cookieJar = firstJust csrfCookies $ HTTP.cookieJar req, - HTTP.method = "POST", - HTTP.requestBody = HTTP.RequestBodyBS $ C8.pack query + HTTP.method = method }) $ \resp -> do let cookies = HTTP.responseCookieJar resp - putMVar (globalCookieJar session) cookies - writeFile (cookiesPath session) $ show $ HTTP.destroyCookieJar cookies + swapMVar (globalCookieJar session) cookies + writeCookies (cookiesPath session) cookies False #endif -submitURL session mimes uri _method query = fetchURL' session mimes uri { uriQuery = '?':query } +submitURL' session mimes uri _method _encoding query = fetchURL' session mimes uri { + uriQuery = '?':encodeQuery query } +encodeQuery :: [(String, Either String FilePath)] -> String +encodeQuery [("", Left query)] = query -- Mostly for the sake of Gemini... +encodeQuery query = intercalate "&" $ M.mapMaybe encodePart query + where + encodePart (key, Left "") = Just $ escape key + encodePart (key, Left value) = Just (escape key ++ '=':escape value) + encodePart _ = Nothing + escape = escapeURIString isUnescapedInURIComponent -- | As per `fetchURL`, but also returns the redirected URI. fetchURL' :: Session -> [String] -> URI -> IO (URI, String, Either Text ByteString) -fetchURL' Session {redirectCount = 0, locale = locale'} _ uri = - return (uri, mimeERR, Left $ Txt.pack $ trans locale' ExcessiveRedirects) +fetchURL' sess@Session {redirectCount = 0 } _ uri = + return (uri, mimeERR, Left $ Txt.pack $ trans' sess ExcessiveRedirects) #ifdef WITH_PLUGIN_REWRITES fetchURL' session mimes uri @@ -247,14 +336,13 @@ #endif #ifdef WITH_PLUGIN_EXEC -fetchURL' session@Session { appName = appname, locale = l } mimes - uri@(URI "ext:" Nothing path query _) = do +fetchURL' session@Session { appName = appname } mimes uri@(URI "ext:" Nothing path query _) = do dir <- getXdgDirectory XdgData "nz.geek.adrian.hurl" sysdirs <- getXdgDirectoryList XdgDataDirs let dirs = concat [[dir' appname, dir'] | dir' <- dir : sysdirs] programs <- findExecutablesInDirectories dirs ("bin" path) case programs of - [] -> return (uri, mimeERR, Left $ Txt.pack $ trans l $ ReadFailed "404") + [] -> return (uri, mimeERR, Left $ Txt.pack $ trans' session $ ReadFailed "404") program:_ -> do let args = case query of { '?':rest -> split (== '&') rest; @@ -289,53 +377,69 @@ #ifdef WITH_HTTP_URI fetchURL' session accept uri | uriScheme uri `elem` ["http:", "https:"] = - fetchHTTPCached session accept uri id saveCookies + fetchHTTPCached session (cachingEnabled session) accept uri return saveCookies where saveCookies resp - | Just cookies <- retroactiveCookies session = putMVar cookies $ HTTP.responseCookieJar resp + | Just cookies <- retroactiveCookies session = + void $swapMVar cookies $HTTP.responseCookieJar resp | otherwise = return () #endif #ifdef WITH_GEMINI_URI -fetchURL' sess@Session {connCtxt = ctxt, locale = l} mimes uri@URI { +fetchURL' sess@Session { connCtxt = ctxt } 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 - -- NOTE: This case won't actually do anything until the caller (Rhapsode) implements forms. - ('1', _, label) -> return (uri, "application/xhtml+xml", Left $ Txt.concat [ - "
" - ]) + } = do + let params = TLS.defaultParamsClient host "gmni" + swapMVar (credentials' sess) (credentials sess) + 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 ()) + }, + TLS.clientHooks = def { + TLS.onCertificateRequest = deliverCredentials $ credentials' sess + } + }, + Conn.connectionUseSocks = Nothing + } + Conn.connectionPut conn $ C8.pack $ uriToString id uri "\r\n" + header <- Conn.connectionGetLine 1027 conn + case parseHeader $ C8.unpack header of ('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 } mimes $ relativeTo redirect' uri - -- TODO Implement client certificates, once I have a way for the user/caller to select one. - -- And once I figure out how to configure the TLS cryptography. - (_, _, err) -> return (uri, mimeERR, Left err) + (x, y, err) -> return (uri, mimeERR, Left $ Txt.pack $ + trans' sess $ GeminiError x y $ Txt.unpack $ + Txt.replace "<" "<" $ Txt.replace "&" "&" err) where parseHeader :: String -> (Char, Char, Text) parseHeader (major:minor:meta) = (major, minor, Txt.strip $ Txt.pack meta) - parseHeader _ = ('4', '1', Txt.pack $ trans l MalformedResponse) + parseHeader header = ('4', '1', Txt.pack $ trans' sess $ MalformedResponse header) 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 -fetchURL' Session {locale = l} (defaultMIME:_) uri@URI {uriScheme = "file:"} = do +fetchURL' sess (defaultMIME:_) uri@URI {uriScheme = "file:"} = do response <- B.readFile $ uriPath uri return (uri, defaultMIME, Right response) `catch` \e -> do return (uri, mimeERR, - Left $ Txt.pack $ trans l $ ReadFailed $ displayException (e :: IOException)) + Left $ Txt.pack $ trans' sess $ ReadFailed $ displayException (e :: IOException)) #endif #ifdef WITH_DATA_URI @@ -351,21 +455,21 @@ #endif #ifdef WITH_XDG -fetchURL' Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do +fetchURL' sess@Session { apps = a } _ uri@(URI {uriScheme = s}) = do app <- dispatchURIByMIME a uri ("x-scheme-handler/" ++ init s) - return (uri, htmlERR, Left $ Txt.pack $ trans l $ app) + return (uri, htmlERR, Left $ Txt.pack $ trans' sess $ app) #else -fetchURL' Session {locale = l} _ URI {uriScheme = scheme} = - return (uri, mimeERR, Left $ Txt.pack $ trans l $ UnsupportedScheme scheme) +fetchURL' sess _ URI {uriScheme = scheme} = + return (uri, mimeERR, Left $ Txt.pack $ trans' sess $ UnsupportedScheme scheme) #endif dispatchByMIME :: Session -> String -> URI -> IO (Maybe String) #if WITH_XDG -dispatchByMIME Session {locale = l, apps = a} mime uri = do +dispatchByMIME sess@Session { apps = a } mime uri = do err <- dispatchURIByMIME a uri mime return $ case err of UnsupportedMIME _ -> Nothing - _ -> Just $ trans l err + _ -> Just $ trans' sess err #else dispatchByMIME _ _ _ = return Nothing #endif @@ -395,14 +499,30 @@ #endif #ifdef WITH_HTTP_URI -fetchHTTPCached session accept@(defaultMIME:_) uri cbReq cbResp = do - cached <- if cachingEnabled session then readCacheHTTP uri else return (Nothing, Nothing) +fetchHTTPCached session @ Session { trans' = t} 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 + } + let manager = (if validateCertificates session + then managerHTTP else managerHTTPNoValidate) session + swapMVar (credentials' session) (credentials session) + + 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 request <- HTTP.requestFromURI uri cookieJar <- readMVar $ globalCookieJar session - let request' = cbReq $ request { + request'<- cbReq request { HTTP.cookieJar = Just $ cookieJar, HTTP.requestHeaders = [ ("Accept", C8.pack $ intercalate ", " accept), @@ -410,9 +530,21 @@ ] ++ fromMaybe [] cachingHeaders, HTTP.redirectCount = 0 } - response <- HTTP.httpLbs request $ managerHTTP session + response <- HTTP.httpLbs request' manager 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, [val | ("content-type", val) <- HTTP.responseHeaders response] @@ -425,7 +557,9 @@ Just location <- lookup "location" $ HTTP.responseHeaders response, Just uri' <- parseURIReference $ C8.unpack location -> return $ Left $ relativeTo uri' uri - (Status _ msg, "", _) -> return $ Right (Txt.pack mimeERR, B.fromStrict msg) + (Status code msg, "", _) -> return $ Right (Txt.pack mimeERR, + B.fromStrict $ C8.pack $ + trans' session $ HTTPStatus code $ C8.unpack msg) (_, body, (mimetype:_)) -> do cacheHTTP uri response forkIO cleanCacheHTTP -- Try to keep diskspace down... @@ -441,9 +575,22 @@ 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) -fetchHTTPCached session [] uri _ _ = - return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ UnsupportedMIME "") + `catch` \e -> do return (rawUri, mimeERR, Left $ Txt.pack $ transHttp t e) +fetchHTTPCached session _ [] uri _ _ = + return (uri, mimeERR, Left $ Txt.pack $ trans' session $ UnsupportedMIME "") +#endif + +#if WITH_HTTP_URI || WITH_GEMINI_URI +deliverCredentials credentialsMVar _ = do + credentials' <- readMVar credentialsMVar -- workaround for HTTP-Client-TLS + case credentials' of + Just (Left (public, private)) -> right <$> TLS.credentialLoadX509 public private + Just (Right (public, private)) -> + return $ right $ TLS.credentialLoadX509FromMemory public private + Nothing -> return Nothing + where + right (Left _) = Nothing + right (Right x) = Just x #endif -- Downloads utilities diff --git a/src/Network/URI/Locale.hs b/src/Network/URI/Locale.hs --- a/src/Network/URI/Locale.hs +++ b/src/Network/URI/Locale.hs @@ -1,11 +1,30 @@ -- | Internal module for retrieving languages to localize to. -module Network.URI.Locale(rfc2616Locale) where +-- Also provides decoupling layers between Network.URI.Messages & optional dependencies. +{-# LANGUAGE CPP #-} +module Network.URI.Locale(rfc2616Locale +#ifdef WITH_HTTP_URI +, transHttp +#endif +) where import System.Environment (lookupEnv) import Control.Monad (forM) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Char (toLower) +#ifdef WITH_HTTP_URI +import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..)) +import Control.Exception (displayException) +import Network.TLS (TLSException(..), TLSError(..), AlertDescription(..)) +import Control.Exception.Base (fromException) +import Network.HTTP.Types (Status(..)) + +import Network.URI.Messages +import qualified Data.ByteString.Char8 as C8 +import qualified Data.Text as Txt +import Text.Read (readMaybe) +#endif + --- This file is based on logic in GNOME's LibSoup & GLib. -- | Returns the languages to which responses should be localized. @@ -46,3 +65,76 @@ | (head':tail') <- split b as = (a:head') : tail' | otherwise = [a:as] split _ [] = [[]] + +-------- +---- Decoupling Layer +-------- +#ifdef WITH_HTTP_URI +transHttp trans' (InvalidUrlException url msg) = trans' $ InvalidUrl url msg +transHttp trans' (HttpExceptionRequest _ (TooManyRedirects _)) = trans' $ ExcessiveRedirects +transHttp trans' (HttpExceptionRequest _ ResponseTimeout) = trans' $ TimeoutResponse +transHttp trans' (HttpExceptionRequest _ ConnectionTimeout) = trans' $ TimeoutConnection +transHttp trans' (HttpExceptionRequest _ (ConnectionFailure err)) = + trans' $ FailedConnect $ displayException err +transHttp trans' (HttpExceptionRequest _ (StatusCodeException _ code)) = + trans' $ HTTPStatus (fromMaybe 500 $ readMaybe $ C8.unpack code) "" +transHttp trans' (HttpExceptionRequest _ OverlongHeaders) = + trans' $ HTTPStatus 431 "Overlong Headers" +transHttp trans' (HttpExceptionRequest _ (InvalidStatusLine why)) = + trans' $ MalformedResponse $ C8.unpack why +transHttp trans' (HttpExceptionRequest _ (InvalidHeader why)) = + trans' $ MalformedResponse $ C8.unpack why +transHttp trans' (HttpExceptionRequest _ (InvalidRequestHeader why)) = + trans' $ InvalidRequest $ C8.unpack why +transHttp trans' (HttpExceptionRequest _ (ProxyConnectException a b (Status code msg))) = + trans' $ ProxyError (C8.unpack a) b code $ C8.unpack msg +-- NOTE: Minor details are unlocalized for now... Can always come back to this! +transHttp trans' (HttpExceptionRequest _ NoResponseDataReceived) = + trans' $ MalformedResponse "Empty" +transHttp trans' (HttpExceptionRequest _ TlsNotSupported) = + trans' $ HandshakeMisc "Unsupported" +transHttp trans' (HttpExceptionRequest _ (WrongRequestBodyStreamSize a b)) = + trans' $ OtherException $ unlines ["Wrong request bodysize", show a, show b] +transHttp trans' (HttpExceptionRequest _ (ResponseBodyTooShort a b)) = + trans' $ MalformedResponse ("Too short " ++ show a ++ '<' : show b) +transHttp trans' (HttpExceptionRequest _ InvalidChunkHeaders) = + trans' $ MalformedResponse "Chunk headers" +transHttp trans' (HttpExceptionRequest _ IncompleteHeaders) = + trans' $ MalformedResponse "Incomplete headers" +transHttp trans' (HttpExceptionRequest _ (InvalidDestinationHost why)) = + trans' $ FailedConnect $ C8.unpack why +transHttp trans' (HttpExceptionRequest _ (HttpZlibException _)) = + trans' $ MalformedResponse "ZLib compression" +transHttp trans' (HttpExceptionRequest _ ConnectionClosed) = + trans' $ FailedConnect "already-closed" +transHttp trans' (HttpExceptionRequest _ (InvalidProxySettings why)) = + trans' $ FailedConnect ("proxy (" ++ Txt.unpack why ++ ")") +transHttp trans' (HttpExceptionRequest _ (InvalidProxyEnvironmentVariable key value)) = + trans' $ FailedConnect ("proxy (" ++ Txt.unpack key ++ '=' : Txt.unpack value ++ ")") +transHttp trans' (HttpExceptionRequest _ (InternalException e)) = + trans' $ case fromException e of + Just (Terminated _ why _) -> InsecureTerminated why + Just (HandshakeFailed (Error_Misc msg)) -> HandshakeMisc msg + Just (HandshakeFailed (Error_Protocol (_, _, CloseNotify))) -> HandshakeClosed + Just (HandshakeFailed (Error_Protocol (_, _, HandshakeFailure))) -> HandshakeError + Just (HandshakeFailed (Error_Protocol (_, _, BadCertificate))) -> InsecureCertificate "" + Just (HandshakeFailed (Error_Protocol (_, _, UnsupportedCertificate))) -> + InsecureCertificate $ trans' InsecureCertificateUnsupported + Just (HandshakeFailed (Error_Protocol (_, _, CertificateExpired))) -> + InsecureCertificate $ trans' InsecureCertificateExpired + Just (HandshakeFailed (Error_Protocol (_, _, CertificateRevoked))) -> + InsecureCertificate $ trans' InsecureCertificateRevoked + Just (HandshakeFailed (Error_Protocol (_, _, CertificateUnknown))) -> + InsecureCertificate $ trans' InsecureCertificateUnknown + Just (HandshakeFailed (Error_Protocol (_, _, UnknownCa))) -> + InsecureCertificate $ trans' InsecureCertificateUnknownCA + Just (HandshakeFailed (Error_Protocol (why, _, _))) -> HandshakeMisc why + Just (HandshakeFailed (Error_Certificate why)) -> InsecureCertificate why + Just (HandshakeFailed (Error_HandshakePolicy why)) -> HandshakePolicy why + Just (HandshakeFailed Error_EOF) -> HandshakeEOF + Just (HandshakeFailed (Error_Packet why)) -> HandshakePacketInvalid why + Just (HandshakeFailed (Error_Packet_unexpected a b)) -> HandshakePacketUnexpected a b + Just (HandshakeFailed (Error_Packet_Parsing why)) -> HandshakePacketUnparsed why + Just ConnectionNotEstablished -> InsecureUnestablished + Nothing -> OtherException $ displayException e +#endif diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs --- a/src/Network/URI/Messages.hs +++ b/src/Network/URI/Messages.hs @@ -13,39 +13,155 @@ import Data.List (stripPrefix) import Data.Maybe (fromMaybe) - -#if WITH_HTTP_URI -import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..)) -import Control.Exception (displayException) -#endif +import Control.Exception (Exception) trans _ (RawXML markup) = markup --- BEGIN LOCALIZATION -trans ("en":_) (UnsupportedScheme scheme) = "Unsupported protocol " ++ scheme -trans ("en":_) (UnsupportedMIME mime) = "Unsupported filetype " ++ mime -trans ("en":_) (RequiresInstall mime appsMarkup) = - "

Please install a compatible app to open " ++ linkType ++ " links

\n" ++ appsMarkup +("en":_) `trans` UnsupportedScheme scheme = "Unsupported protocol " ++ scheme +("en":_) `trans` UnsupportedMIME mime = "Unsupported filetype " ++ mime +("en":_) `trans` RequiresInstall mime appsMarkup = + "

Please install a compatible app to open " ++ linkType ++ + " links

\n" ++ appsMarkup where linkType = fromMaybe mime $ stripPrefix "x-scheme-handler/" mime -trans ("en":_) (OpenedWith app) = "Opened in " ++ app -trans ("en":_) (ReadFailed msg) = "Failed to read file: " ++ msg -trans ("en":_) MalformedResponse = "Invalid response!" -trans ("en":_) ExcessiveRedirects = "Too many redirects!" -#if WITH_HTTP_URI -trans ("en":_) (Http (InvalidUrlException url msg)) = "Invalid URL " ++ url ++ ": " ++ msg -trans ("en":_) (Http (HttpExceptionRequest _ (TooManyRedirects _))) = "Too many redirects!" -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!" -#endif +("en":_) `trans` OpenedWith app = "Opened in " ++ app +("en":_) `trans` ReadFailed msg = "Failed to read file: " ++ msg +("en":_) `trans` MalformedResponse why = "Invalid response! " ++ why +("en":_) `trans` ExcessiveRedirects = "Too many redirects!" +("en":_) `trans` GeminiError '1' '1' label = + "