hurl 2.1.1.0 → 2.2.0.0
raw patch · 8 files changed
+748/−121 lines, 8 filesdep +connectiondep +cookiedep +data-default-classdep −HsOpenSSLdep −http-client-openssldep −io-streamsdep ~bytestringdep ~directorydep ~network-urinew-component:exe:hurl-postPVP ok
version bump matches the API change (PVP)
Dependencies added: connection, cookie, data-default-class, http-client-tls, publicsuffixlist, tls
Dependencies removed: HsOpenSSL, http-client-openssl, io-streams, openssl-streams
Dependency ranges changed: bytestring, directory, network-uri, time
API changes (from Hackage documentation)
+ Network.URI.Fetch: submitURL' :: Session -> [String] -> URI -> ByteString -> ByteString -> [(String, Either String FilePath)] -> IO (URI, String, Either Text ByteString)
Files
- ChangeLog.md +6/−3
- Main2.hs +30/−0
- hurl.cabal +20/−5
- src/Network/URI/Cache.hs +99/−10
- src/Network/URI/CookiesDB.hs +135/−0
- src/Network/URI/Fetch.hs +221/−74
- src/Network/URI/Locale.hs +94/−2
- src/Network/URI/Messages.hs +143/−27
ChangeLog.md view
@@ -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.
+ Main2.hs view
@@ -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 "")
hurl.cabal view
@@ -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
src/Network/URI/Cache.hs view
@@ -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
+ src/Network/URI/CookiesDB.hs view
@@ -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"
src/Network/URI/Fetch.hs view
@@ -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 [- "<form><label>",- Txt.replace "<" "<" $ Txt.replace "&" "&" label,- "<input /></label></form>"- ])+ } = 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
src/Network/URI/Locale.hs view
@@ -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
src/Network/URI/Messages.hs view
@@ -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) =- "<h1>Please install a compatible app to open <code>" ++ linkType ++ "</code> links</h1>\n" ++ appsMarkup+("en":_) `trans` UnsupportedScheme scheme = "Unsupported protocol " ++ scheme+("en":_) `trans` UnsupportedMIME mime = "Unsupported filetype " ++ mime+("en":_) `trans` RequiresInstall mime appsMarkup =+ "<h1>Please install a compatible app to open <code>" ++ linkType +++ "</code> links</h1>\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 =+ "<form><label>" ++ label ++ "<input type=password></form>" +("en":_) `trans` GeminiError '1' _ label = "<form><label>" ++ label ++ "<input></form>"+("en":_) `trans` GeminiError '4' '1' _ = "Site unavailable!"+("en":_) `trans` GeminiError '4' '2' _ = "Program error!"+("en":_) `trans` GeminiError '4' '3' _ = "Proxy error!"+("en":_) `trans` GeminiError '4' '4' timeout =+ "Site busy! Please reload after at least " ++ timeout ++ " seconds"+("en":_) `trans` GeminiError '5' '1' _ = "Page not found! Try the <a href='/'>homepage</a>."+("en":_) `trans` GeminiError '5' '2' _ = "Page deleted! Try the <a href='/'>homepage</a>."+("en":_) `trans` GeminiError '5' '3' _ = "Contacted wrong server!"+("en":_) `trans` GeminiError '5' '9' _ = "Malformed request, my bad!"+("en":_) `trans` GeminiError '6' '1' _ = "<form><label>Authentication required" +++ "<-argo-authenticate error='Unauthorized account!'></-argo-authenticate></form>"+("en":_) `trans` GeminiError '6' '2' _ = "<form><label>Authentication required" +++ "<-argo-authenticate error='Invalid account!'></-argo-authenticate></form>"+("en":_) `trans` GeminiError '6' _ _ = "<form><label>Authentication required" +++ "<-argo-authenticate></-argo-authenticate></form>"+("en":_) `trans` GeminiError _ _ error = error+("en":_) `trans` HTTPStatus 400 _ = "I sent a bad request, according to this site."+("en":_) `trans` HTTPStatus 401 _ = "Authentication required!" -- FIXME: Support HTTP Basic Auth.+("en":_) `trans` HTTPStatus 402 _ = "Payment required!"+("en":_) `trans` HTTPStatus 403 _ = "Access denied!"+("en":_) `trans` HTTPStatus 404 _ = "Page not found! Try the <a href='/'>homepage</a>."+("en":_) `trans` HTTPStatus 405 _ = "Bad webform for this destination webaddress! " +++ "<em>Method not allowed</em>."+("en":_) `trans` HTTPStatus 406 _ = "No representation available for given criteria!"+("en":_) `trans` HTTPStatus 407 _ = "Authentication into proxyserver required!"+("en":_) `trans` HTTPStatus 408 _ = "The site took too long to connect! <em>(HTTP 408)</em>"+("en":_) `trans` HTTPStatus 409 _ = "Request is based on outdated state!"+("en":_) `trans` HTTPStatus 410 _ = "Page deleted! Try the <a href='/'>homepage</a>."+("en":_) `trans` HTTPStatus 411 _ = "I sent a bad request, according to this site." +++ "<em>(Missing <code>Content-Length</code> header)</em>"+("en":_) `trans` HTTPStatus 412 _ = "Webpage doesn't meet our preconditions."+("en":_) `trans` HTTPStatus 413 _ = "Payload too large, please upload a smaller file!"+("en":_) `trans` HTTPStatus 414 _ = "Web address is too long for the site!"+("en":_) `trans` HTTPStatus 415 _ = "No representation available for supported filetypes!"+("en":_) `trans` HTTPStatus 416 _ = "Invalid byte-range of requested resource!"+("en":_) `trans` HTTPStatus 417 _ = "Site cannot satisfy our stated expectations!"+("en":_) `trans` HTTPStatus 418 _ = unlines [+ "<p>I'm a little teapot<br/>",+ "Short and stout<br/>",+ "Here is my handle<br/>",+ "And here is my spout.</p>>",+ "<p>When I get all steamed up<br/>",+ "Hear me shout<br/>",+ "<q>Tip me over<br/>",+ "And pour me out!</q></p>"+ ]+("en":_) `trans` HTTPStatus 421 _ = "Contacted wrong server!"+("en":_) `trans` HTTPStatus 422 _ = "Invalid <strong>WebDAV</strong> request!"+("en":_) `trans` HTTPStatus 423 _ = "<strong>WebDAV</strong> resource is locked!"+("en":_) `trans` HTTPStatus 424 _ = "Failed due to previous failure!"+("en":_) `trans` HTTPStatus 425 _ = "Site requires stronger security on our request!"+("en":_) `trans` HTTPStatus 426 _ = "Site requires newer networking-protocols!"+("en":_) `trans` HTTPStatus 428 _ = "Site requires additional protection to avoid loosing changes!"+("en":_) `trans` HTTPStatus 429 _ = "We sent this site too many requests for it to cope with!"+("en":_) `trans` HTTPStatus 431 _ = "I sent more auxiliary data than this site can cope with!"+("en":_) `trans` HTTPStatus 451 _ = "Requested page cannot legally be provided!"++("en":_) `trans` HTTPStatus 500 _ = "The site experienced an error generating this webpage. " +++ "<em>The webmasters have probably already been automatically notified.</em>"+("en":_) `trans` HTTPStatus 501 _ =+ "Bad webform for this destination webaddress! <em>Method not implemented</em>."+("en":_) `trans` HTTPStatus 502 _ = "Proxyserver got a malformed response!"+("en":_) `trans` HTTPStatus 503 _ = "The site is not available right now!"+("en":_) `trans` HTTPStatus 504 _ = "The site took too long to respond! <em>(Behind proxy)</em>"+("en":_) `trans` HTTPStatus 505 _ = "The site does not speak the language as me! " +++ "<em>(Unsupported HTTP version)</em>"+("en":_) `trans` HTTPStatus 506 _ = "The site is misconfigured!"+("en":_) `trans` HTTPStatus 507 _ = "Insufficient <strong>WebDAV</strong> storage!"+("en":_) `trans` HTTPStatus 508 _ = "<strong>WebDAV</strong> loop detected!"+("en":_) `trans` HTTPStatus 510 _ = "Further request extensions required!"+("en":_) `trans` HTTPStatus 511 _ = "Authentication into network required!"+("en":_) `trans` HTTPStatus _ error = error -- Fallback+("en":_) `trans` OtherException error = "Internal Exception <pre><code>" ++ error ++ "</code></pre>"+("en":_) `trans` InvalidUrl url message =+ "Invalid web address <code>" ++ url ++ "</code>: <em>" ++ message ++ "</em>"+("en":_) `trans` ProxyError msg code code' msg' = unlines [+ "<h1>Proxy failed to forward request!<h1>",+ "<p>" ++ show code ++ " " ++ msg ++ "</p>",+ "<p>" ++ show code' ++ " " ++ msg' ++ "</p>"+ ]+("en":_) `trans` InvalidRequest why =+ "Attempted to send invalid auxiliary data: <em>" ++ why ++ "</em>"+("en":_) `trans` InsecureUnestablished =+ "Attempted to send or recieve data before establishing secure connection!"+("en":_) `trans` InsecureCertificate why = unlines [+ "<h1>The site failed to prove it is who it says it is!</h1>",+ "<p>" ++ why ++ "</p>",+ "<p><a href=action:history/back>Leave Insecure Site</a> | ",+ "<a href=action:novalidate>Accept Imposter Risk & Continue</a></p>"+ ]+("en":_) `trans` InsecureTerminated why = "Secure session disconnected! <em>" ++ why ++ "</em>"+trans ("en":_) InsecureCertificateUnknownCA = "The authority vouching for it is unknown to me!"+trans ("en":_) InsecureCertificateUnknown =+ "The cryptographic certificate it has sent us to prove its identity instead " +++ "belongs to someone else!"+trans ("en":_) InsecureCertificateRevoked =+ "The cryptographic certificate it has sent us to prove its identity has been revoked!"+trans ("en":_) InsecureCertificateExpired =+ "The cryptographic certificate it has sent us to prove its identity has expired!"+trans ("en":_) InsecureCertificateUnsupported =+ "It has sent us a cryptographic certificate to prove its identity I failed to make sense of."+("en":_) `trans` HandshakePacketUnparsed why = "Invalid security packet: <em>" ++ why ++ "</em>"+("en":_) `trans` HandshakePacketUnexpected a b = unlines [+ "<p>Invalid security packet: <em>" ++ a ++ "</em></p>",+ "<p>" ++ b ++ "</p>"+ ]+("en":_) `trans` HandshakePacketInvalid why = "Invalid security packet: <em>" ++ why ++ "</em>"+trans ("en":_) HandshakeEOF = "Secure session disconnected!"+("en":_) `trans` HandshakePolicy why = "Invalid handshake policy: <em>" ++ why ++ "</em>"+("en":_) `trans` HandshakeMisc why =+ "Failed to establish secure connection! <em>" ++ why ++ "</em>"+trans ("en":_) HandshakeError = "Failed to negotiate security parameters!"+trans ("en":_) HandshakeClosed = "Secure session disconnected!"+("en":_) `trans` FailedConnect why = "Failed to open connection to the site: <em>" ++ why ++ "</em>"+trans ("en":_) TimeoutConnection = "The site took too long to connect!"+trans ("en":_) TimeoutResponse = "The site took too long to respond!" --- END LOCALIZATION trans (_:locales) err = trans locales err-trans [] err = trans ["en"] err+trans [] err = show err data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String- | OpenedWith String | ReadFailed String | RawXML String | MalformedResponse- | ExcessiveRedirects-#if WITH_HTTP_URI- | Http HttpException-#endif+ | OpenedWith String | ReadFailed String | RawXML String | MalformedResponse String+ | ExcessiveRedirects | HTTPStatus Int String | GeminiError Char Char String+ | OtherException String | InvalidUrl String String | ProxyError String Int Int String+ | InvalidRequest String+ | InsecureUnestablished | InsecureCertificate String | InsecureTerminated String+ | InsecureCertificateUnknownCA | InsecureCertificateUnknown | InsecureCertificateRevoked+ | InsecureCertificateExpired | InsecureCertificateUnsupported+ | HandshakePacketUnparsed String | HandshakePacketUnexpected String String+ | HandshakePacketInvalid String+ | HandshakeEOF | HandshakePolicy String | HandshakeMisc String | HandshakeError | HandshakeClosed+ | FailedConnect String | TimeoutConnection | TimeoutResponse deriving (Show)++instance Exception Errors