hurl 1.4.2.1 → 1.5.0.0

raw patch · 8 files changed

+331/−41 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• hurl.cabal +3/−2
• src/Network/URI/Cache.hs +149/−0
• src/Network/URI/Fetch.hs +110/−24
• src/Network/URI/PlugIns/Rewriters.hs +7/−4
• src/Network/URI/Types.hs +10/−0
• src/Network/URI/XDG.hs +7/−1
• src/Network/URI/XDG/DesktopEntry.hs +40/−10

@@ -3,3 +3,8 @@ ## 0.1.0.0  -- YYYY-mm-dd  * First version. Released on an unsuspecting world.++## 1.5.0.0 -- 2020-12-24+* Add HTTP caching+* Add `ext:` URI scheme as a plugin system.+* Expose APIs list all apps for a given MIMEtype & open a URL in one.

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.4.2.1+version:             1.5.0.0  -- A short (one-line) description of the package. synopsis:            Haskell URL resolver@@ -92,7 +92,7 @@   exposed-modules:     Network.URI.Charset, Network.URI.Fetch      -- Modules included in this library but not exported.-  other-modules:       Network.URI.Locale, Network.URI.Messages+  other-modules:       Network.URI.Locale, Network.URI.Messages, Network.URI.Types      -- LANGUAGE extensions used by modules in this package.   -- other-extensions:    @@ -113,6 +113,7 @@     CPP-options:   -DWITH_HTTP_URI     build-depends: http-client, http-types >= 0.12 && <0.13,                    http-client-openssl, HsOpenSSL+    other-modules: Network.URI.Cache   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

@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.URI.Cache(shouldCacheHTTP, cacheHTTP, readCacheHTTP, cleanCacheHTTP) where+import Network.HTTP.Client+import Network.HTTP.Types.Status+import Network.HTTP.Types.Header++-- For escaping filepaths, since I already have this dependency+import Network.URI (escapeURIString, isUnescapedInURIComponent, URI, uriToString)+import Data.Time.Clock+import Data.Time.Format++import Data.ByteString as Strict+import Data.ByteString.Char8 as C+import Data.ByteString.Lazy as Lazy+import System.IO as IO+import System.FilePath+import System.Directory+import qualified Data.Text as Txt++import Data.Maybe+import Data.Char (isSpace)+import Data.List as L+import Control.Monad (forM, void, when)+import Text.Read (readMaybe)++strip = C.dropWhile isSpace -- FIXME Upgrade bytestring dependency for a real strip function.++httpCacheDirective :: Response b -> Strict.ByteString -> Maybe Strict.ByteString+httpCacheDirective response key | Just header <- lookup hCacheControl $ responseHeaders response =+        let directives = Prelude.map strip $ C.split ',' header+        in if key `Prelude.elem` directives+            then Just ""+            else listToMaybe $ mapMaybe (C.stripPrefix $ C.snoc key '=') directives+    | otherwise = Nothing++shouldCacheHTTP :: Response b -> Bool+-- IETF RFC7234 Section 3+shouldCacheHTTP response = -- Assume GET+    statusCode (responseStatus response) `Prelude.elem` [200, 201, 404] && -- Supported response code+        isNothing (httpCacheDirective response "no-store") -- Honor no-store+        -- This is a private cache, don't check for Cache-Control: private+        -- Also, I'll cache anything for supported response codes, regardless of explicit expiry times.++uriToString' uri = uriToString id uri ""+parseHTTPTime :: String -> Maybe UTCTime+parseHTTPTime str | ',' `L.elem` str = parseTimeM True defaultTimeLocale rfc822DateFormat str+parseHTTPTime str = parseTimeM True defaultTimeLocale "%_d %b %Y %H:%M:%S %Z" str+secondsFromNow i = do+    now <- getCurrentTime+    -- This ugliness required because regex depends on outdated version of time.+    return $ addUTCTime (fromRational $ toRational $ secondsToDiffTime i) now++computeExpires :: Response a -> IO UTCTime+computeExpires resp+  | Just header <- lookup hExpires $ responseHeaders resp,+        Just time <- parseHTTPTime $ C.unpack header = return time+  | Just pragma <- httpCacheDirective resp "max-age",+        Just seconds <- readMaybe $ C.unpack pragma = secondsFromNow seconds+  | otherwise = secondsFromNow (60*60*24) -- One day++cacheHTTP :: URI -> Response Lazy.ByteString -> IO ()+cacheHTTP uri resp | shouldCacheHTTP resp = do+    expires <- computeExpires resp+    let headers = responseHeaders resp+    writeKV (uriToString' uri) (+        [("expires", show expires)] ++ getHeader "content-type" "mime" +++            getHeader "ETag" "etag" ++ getHeader "Last-Modified" "modified",+        responseBody resp)+  where+    getHeader header key | Just value <- lookup header $ responseHeaders resp = [(key, C.unpack value)]+        | otherwise = []+cacheHTTP _ _ = return ()++readCacheHTTP :: URI -> IO (Maybe (Txt.Text, Lazy.ByteString), Maybe ResponseHeaders)+readCacheHTTP uri = do+    cached <- readKV $ uriToString' uri+    case cached of+        Just (headers, body) | Just expiry <- readMaybe =<< lookup "expires" headers -> do+            let mime = fromMaybe "application/octet-stream" $ lookup "mime" headers+            now <- getCurrentTime++            -- Headers for a validation request & whether should be sent.+            let headers' = if expiry <= now then Nothing else Just (+                    [("If-Modified-Since", C.pack val) | ("modified", val) <- headers,+                        isJust $ parseHTTPTime val] +++                    [("If-None-Match", C.pack val) | ("etag", val) <- headers])+            -- Cache entry has expired, delete.+            when (isJust headers') $ deleteKV $ uriToString' uri++            return (Just (Txt.pack mime, body), headers')++        _ -> return (Nothing, Just [])++cleanCacheHTTP = void $ do+    now <- getCurrentTime+    let tombstone = now++    dir <- getXdgDirectory XdgCache "nz.geek.adrian.hurl"+    dirExists <- doesDirectoryExist (dir </> "http")+    files <- if dirExists then listDirectory (dir </> "http") else return []+    forM files $ \file -> do+        exists <- doesFileExist file+        when exists $ IO.withFile file ReadMode $ \h -> do+            (headers, _) <- parseHeaders h+            let hasHeader h = isJust $ lookup h headers+                validatable = hasHeader "modified" || hasHeader "etag"+                expires = fromMaybe tombstone (readMaybe =<< lookup "expires" headers)+            when (now >= expires && not validatable) $ removeFile file++------+--- Key-value storage+------++readKV :: String -> IO (Maybe ([(String, String)], Lazy.ByteString))+writeKV :: String -> ([(String, String)], Lazy.ByteString) -> IO ()+deleteKV :: String -> IO ()+openKV :: String -> IO.IOMode -> (Handle -> IO r) -> IO (Maybe r)+pathKV :: String -> IO FilePath++pathKV key = do+    dir <- getXdgDirectory XdgCache "nz.geek.adrian.hurl"+    createDirectoryIfMissing True (dir </> "http")+    return (dir </> "http" </> escapeURIString isUnescapedInURIComponent key)++openKV key mode act = do+    path <- pathKV key+    exists <- doesFileExist path+    if exists then Just <$> IO.withFile path mode act else return Nothing++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)+strip' = L.dropWhile isSpace . L.dropWhileEnd isSpace++writeKV key (headers, body) = void $ openKV key WriteMode $ \h -> do+    forM headers $ \(key, value) -> do+        IO.hPutStrLn h (key++' ':value)+    IO.hPutStrLn h ""+    Lazy.hPut h body++deleteKV key = pathKV key >>= removeFile

@@ -2,12 +2,15 @@ {-# 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), newSession,+module Network.URI.Fetch(Session(locale, aboutPages, redirectCount, cachingEnabled), newSession,     fetchURL, fetchURL', fetchURLs, mimeERR, htmlERR,-    dispatchByMIME, saveDownload, downloadToURI,+    dispatchByMIME, appsForMIME, Application(..), dispatchByApp,+    saveDownload, downloadToURI,     -- logging API     LogRecord(..), enableLogging, retrieveLog, writeLog) where +import Network.URI.Types+ import qualified Data.Text as Txt import           Data.Text (Text) import           Network.URI@@ -21,8 +24,12 @@ import           Control.Concurrent.Async (forConcurrently)  -- for about: URIs & port parsing, all standard lib-import Data.Maybe (fromMaybe, listToMaybe)+import Data.Maybe (fromMaybe, listToMaybe, isJust)+import Data.Either (isLeft) import Text.Read (readMaybe)+-- for executable extensions, all standard lib+import Data.Char (isSpace)+import System.Exit (ExitCode(..))  -- for saveDownload import System.Directory@@ -41,6 +48,9 @@ import qualified OpenSSL.Session as TLS import           Network.HTTP.Types import           Data.List (intercalate)+import           Control.Concurrent (forkIO)++import           Network.URI.Cache #endif  #ifdef WITH_RAW_CONNECTIONS@@ -86,7 +96,9 @@     -- | Log of timestamped/profiled URL requests     requestLog :: MVar [LogRecord],     -- | How many redirects to follow for Gemini or HTTP(S) requests-    redirectCount :: Int+    redirectCount :: Int,+    -- | Whether to cache network responses, avoiding sending requests+    cachingEnabled :: Bool }  data LogRecord = LogRecord {@@ -146,7 +158,8 @@         locale = ietfLocale,         aboutPages = [],         requestLog = log,-        redirectCount = 5+        redirectCount = 5,+        cachingEnabled = True     }  llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key]@@ -192,6 +205,32 @@     | Just uri' <- applyRewriter (rewriter session) uri = fetchURL' session mimes uri' #endif +fetchURL' session mimes uri@(URI {uriScheme = "ext:", uriAuthority = Nothing,+        uriPath = path, uriQuery = query}) = do+    dir <- getXdgDirectory XdgData "nz.geek.adrian.hurl"+    let program = dir </> "bin" </> path+    let args = case query of {+        '?':rest -> split (== '&') rest;+        _ -> []+    }+    (exitcode, stdout, stderr) <- readProcessWithExitCode program args ""+    let response = if isSuccess exitcode then stdout else stderr+    let (header, body) = breakOn '\n' response+    case strip header of+        'm':'i':'m':'e':mimetype -> return (uri, strip mimetype, Left $ Txt.pack body)+        'u':'r':'l':header' | Just uri' <- parseURIReference $ strip header' ->+            fetchURL' (session {redirectCount = redirectCount session - 1}) mimes $+                relativeTo uri' uri+        _ | isSuccess exitcode -> return (uri, "text/html", Left $ Txt.pack response)+        _ -> return (uri, mimeERR, Left $ Txt.pack response)+  where+    split p s = case dropWhile p s of+        "" -> []+        s' -> let (w, s'') = break p s' in w : split p s''+    strip = dropWhile isSpace . dropWhileEnd isSpace+    isSuccess ExitSuccess = True+    isSuccess _ = False+ fetchURL' session mimes uri@(URI {uriScheme = "about:", uriPath = ""}) =     fetchURL' session mimes $ uri {uriPath = "version"} fetchURL' Session {aboutPages = pages} _ url@URI {uriScheme = "about:", uriPath = path} =@@ -202,23 +241,48 @@  #ifdef WITH_HTTP_URI fetchURL' session accept@(defaultMIME:_) uri | uriScheme uri `elem` ["http:", "https:"] = do-    request <- HTTP.requestFromURI uri-    response <- HTTP.httpLbs request {-            HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form.-            HTTP.requestHeaders = [-                ("Accept", C8.pack $ intercalate ", " accept),-                ("Accept-Language", C8.pack $ intercalate ", " $ locale session)-            ],-            HTTP.redirectCount = redirectCount session-        } $ managerHTTP session-    return $ case (-            HTTP.responseBody response,-            [val | ("content-type", val) <- HTTP.responseHeaders response]-      ) of-        ("", _) -> (uri, mimeERR, Right $ B.fromStrict $ statusMessage $ HTTP.responseStatus response)-        (response, (mimetype:_)) -> let mime = Txt.toLower $ convertCharset "utf-8" mimetype-            in resolveCharset' uri (L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime) response-        (response, []) -> (uri, defaultMIME, Right response)+    cached <- if cachingEnabled session 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+            response <- HTTP.httpLbs request {+                    HTTP.cookieJar = Nothing, -- Will only be supported by Rhapsode when submitting a form.+                    HTTP.requestHeaders = [+                        ("Accept", C8.pack $ intercalate ", " accept),+                        ("Accept-Language", C8.pack $ intercalate ", " $ locale session)+                    ] ++ fromMaybe [] cachingHeaders,+                    HTTP.redirectCount = 0+                } $ managerHTTP session+            case (+                    HTTP.responseStatus response,+                    HTTP.responseBody response,+                    [val | ("content-type", val) <- HTTP.responseHeaders response]+              ) of+                (Status 304 _, _, _) | Just cached'@(_, body) <- cached -> do+                    cacheHTTP uri $ response { HTTP.responseBody = body }+                    return $ Right cached'+                -- Manually handle redirects so the caller & HTTP cache gets the correct URI.+                (Status code _, _, _) | code > 300 && code < 400,+                        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)+                (_, body, (mimetype:_)) -> do+                    cacheHTTP uri response+                    forkIO cleanCacheHTTP -- Try to keep diskspace down...++                    let mime = Txt.toLower $ convertCharset "utf-8" mimetype+                    return $ Right (mime, body)+                (_, response, []) -> return $ Right (Txt.pack defaultMIME, response)++    case response of+        Left redirect ->+            let session' = session { redirectCount = redirectCount session - 1 }+            in fetchURL' session' accept redirect+        Right (mime, body) ->+            let mime' = L.map (Txt.unpack . Txt.strip) $ Txt.splitOn ";" mime+            in return $ resolveCharset' uri mime' body   `catches` [     Handler $ \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e),     Handler $ \(ErrorCall msg) -> do return (uri, mimeERR, Left $ Txt.pack msg)@@ -299,6 +363,30 @@ dispatchByMIME _ _ _ = return Nothing #endif +appsForMIME :: Session -> String -> IO [Application]+#if WITH_XDG+appsForMIME Session { apps = a, locale = l } = queryHandlers' a l+#else+appsForMIME _ _ = []+#endif++dispatchByApp :: Session -> Application -> String -> URI -> IO Bool+#if WITH_XDG+dispatchByApp session@Session { locale = l } Application { appId = app} mime uri = do+    try1 <- launchApp' l uri app -- First try handing off the URL, feedreaders need this!+    case try1 of+        Left app -> return True+        Right False -> return False+        Right True -> do+            -- Download as temp file to open locally, the app requires it...+            temp <- canonicalizePath =<< getTemporaryDirectory+            resp <- fetchURL' session [mime] uri+            uri' <- saveDownload (URI "file:" Nothing "" "" "") temp resp+            isLeft <$> launchApp' l uri' app+#else+dispatchByApp _ _ _ _ = return False+#endif+ -- Downloads utilities -- | write download to a file in the given directory. saveDownload :: URI -> FilePath -> (URI, String, Either Text ByteString) -> IO URI@@ -362,8 +450,6 @@  -- Utils -#ifdef WITH_DATA_URI breakOn c (a:as) | c == a = ([], as)     | otherwise = let (x, y) = breakOn c as in (a:x, y) breakOn _ [] = ([], [])-#endif

@@ -38,10 +38,13 @@     loadRewriters dir = do         files <- Dir.listDirectory dir         raw <- forConcurrently files $ \file -> do-            rewriter <- parseRewriter file-            return $ case rewriter of-                Select x -> x-                Pipe x -> x+            exists <- doesFileExist file+            if exists then do+                rewriter <- parseRewriter file+                return $ case rewriter of+                    Select x -> x+                    Pipe x -> x+            else return []         return $ concat raw  applyRewriter :: Rewriter -> URI -> Maybe URI

@@ -0,0 +1,10 @@+module Network.URI.Types(Application(..)) where++import Network.URI++data Application = Application {+    name :: String,+    icon :: URI,+    description :: String,+    appId :: String -- internal+}

@@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-module Network.URI.XDG(XDGConfig, loadXDGConfig, dispatchURIByMIME) where+module Network.URI.XDG(XDGConfig, loadXDGConfig, dispatchURIByMIME, queryHandlers', launchApp') where  import Network.URI (URI(..))+import Network.URI.Types import Network.URI.Messages (Errors(..)) import Network.URI.XDG.DesktopEntry import Network.URI.XDG.MimeApps import Data.List (stripPrefix)+import Data.Maybe (catMaybes)  #if WITH_APPSTREAM import qualified Text.XML as XML@@ -73,3 +75,7 @@         Just _ -> return item         Nothing -> mapFirstM xs cb mapFirstM [] _ = return Nothing++queryHandlers' :: XDGConfig -> [String] -> String -> IO [Application]+queryHandlers' XDGConfig { handlers = config } locales mime =+    catMaybes <$> mapM (desktop2app locales) (queryHandlers config mime)

@@ -1,6 +1,7 @@-module Network.URI.XDG.DesktopEntry(launchApp) where+module Network.URI.XDG.DesktopEntry(launchApp, launchApp', desktop2app) where -import Data.Maybe (fromMaybe, catMaybes)+import Data.Maybe (fromMaybe, catMaybes, isJust)+import Data.List (isInfixOf) import Control.Exception (catch) import System.Environment (lookupEnv) import Control.Monad (forM)@@ -12,20 +13,29 @@  import Network.URI.XDG.Ini import Network.URI.XDG.MimeApps (split, fromMaybe')+import Network.URI.Types (Application(..)) -launchApp :: [String] -- ^ The locale to use+launchApp' :: [String] -- ^ The locale to use              -> URI -- ^ The URI to have it open.              -> String -- ^ The .desktop ID-             -> IO (Maybe String) -- ^ The localized name of the application-launchApp locales uri desktopID = do+             -> IO (Either String Bool) -- ^ The localized name of the application or whether it expects a local path.+launchApp' locales uri desktopID = do     app <- readDesktopID desktopID     let grp = "desktop entry"     let name = fromMaybe desktopID $ iniLookupLocalized locales grp "name" app     case (iniLookup grp "type" app, iniLookup grp "exec" app) of+        (Just "Application", Just exec) | uriScheme uri /= "file:" && (isInfixOf "%f" exec || isInfixOf "%F" exec) ->+            return $ Right True         (Just "Application", Just exec) ->             catch (execApp uri exec name app) execFailed-        _ -> return Nothing+        _ -> return $ Right False +launchApp :: [String] -- ^ The locale to use+             -> URI -- ^ The URI to have it open.+             -> String -- ^ The .desktop ID+             -> IO (Maybe String) -- ^ The localized name of the application+launchApp a b c = leftToMaybe <$> launchApp' a b c+ readDesktopID desktopID = do     dirs <- lookupEnv "XDG_DATA_DIRS"     let dirs' = split ':' $ fromMaybe' "/usr/local/share/:/usr/share/" dirs@@ -65,10 +75,30 @@ esc' (c:cs) = c : esc' cs esc' [] = "'" -execApp :: URI -> String -> String -> INI -> IO (Maybe String)+execApp :: URI -> String -> String -> INI -> IO (Either String a) execApp uri exec name app = do     spawnCommand $ macros uri exec (app, name)-    return $ Just name+    return $ Left name -execFailed :: IOError -> IO (Maybe String)-execFailed _ = return Nothing+execFailed :: IOError -> IO (Either a Bool)+execFailed _ = return $ Right False++desktop2app :: [String] -> String -> IO (Maybe Application)+desktop2app locales desktopId = do+    app <- readDesktopID desktopId+    let grp = "desktop entry"+    let localized key = iniLookupLocalized locales grp key app+    let isApp = iniLookup grp "type" app == Just "Application" && isJust (iniLookup grp "exec" app)+    return $ if isApp then Just $ Application {+        name = fromMaybe desktopId $ localized "name",+        description = fromMaybe "" $ localized "comment",+        icon = case localized "icon" of+            Just icon -> URI "xdg-icon:" Nothing icon "" ""+            Nothing -> URI "about:" Nothing "blank" "" "",+        appId = desktopId+    } else Nothing++--- Utils++leftToMaybe (Left a) = Just a+leftToMaybe (Right _) = Nothing