diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. 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: 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 diff --git a/src/Network/URI/Cache.hs b/src/Network/URI/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Cache.hs @@ -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 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,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 diff --git a/src/Network/URI/PlugIns/Rewriters.hs b/src/Network/URI/PlugIns/Rewriters.hs --- a/src/Network/URI/PlugIns/Rewriters.hs +++ b/src/Network/URI/PlugIns/Rewriters.hs @@ -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 diff --git a/src/Network/URI/Types.hs b/src/Network/URI/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Types.hs @@ -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 +} diff --git a/src/Network/URI/XDG.hs b/src/Network/URI/XDG.hs --- a/src/Network/URI/XDG.hs +++ b/src/Network/URI/XDG.hs @@ -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) diff --git a/src/Network/URI/XDG/DesktopEntry.hs b/src/Network/URI/XDG/DesktopEntry.hs --- a/src/Network/URI/XDG/DesktopEntry.hs +++ b/src/Network/URI/XDG/DesktopEntry.hs @@ -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