diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,10 +1,16 @@ # Revision history for hurl -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. +## 2.0.0.0 -- 2021-01-07 +* Fix several real & potential crashes +* Expose APIs for querying localized labels for MIME types from the OS +* Expand search path for executable extensions +* Subsume Appstream feature flag into FreeDesktop, XML dependency is now nearly-required on Linux. ## 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. + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. 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.5.0.0 +version: 2.0.0.0 -- A short (one-line) description of the package. synopsis: Haskell URL resolver @@ -73,11 +73,6 @@ Default: True Manual: True -Flag appstream - Description: Failing to dispatch URIs and MIMEtypes as per `freedesktop`, consults the local AppStream database to suggest apps to install. Only has an effect if the `freedesktop` is also set. - Default: True - Manual: True - Flag rewriters Description: Support regexp-based URI rewriting/blocking plugins Default: True @@ -89,7 +84,7 @@ library -- Modules exported by the library. - exposed-modules: Network.URI.Charset, Network.URI.Fetch + exposed-modules: Network.URI.Charset, Network.URI.Fetch, Network.MIME.Info -- Modules included in this library but not exported. other-modules: Network.URI.Locale, Network.URI.Messages, Network.URI.Types @@ -100,11 +95,13 @@ -- Other library packages from which modules are imported. build-depends: base >=4.9 && <5, text >= 1.2 && <1.3, network-uri >=2.6 && <2.7, bytestring >= 0.10 && < 0.11, - async >= 2.1 && < 2.3, filepath, directory, + async >= 2.1 && < 2.3, filepath, directory >= 1.3.2, time >= 1.6 -- Directories containing source files. hs-source-dirs: src + + ghc-options: -fwarn-incomplete-patterns -fwarn-incomplete-uni-patterns -- Base language which the package is written in. default-language: Haskell2010 @@ -124,12 +121,10 @@ build-depends: base64-bytestring >=1.0 && <2.0 if flag(freedesktop) CPP-options: -DWITH_XDG - build-depends: process >= 1.2 && <2.0 - other-modules: Network.URI.XDG.Ini, Network.URI.XDG.MimeApps, Network.URI.XDG.DesktopEntry, Network.URI.XDG - if flag(freedesktop) && flag(appstream) - CPP-options: -DWITH_APPSTREAM - build-depends: xml-conduit >=1.8, zlib >= 0.6 && < 0.7, containers - other-modules: Network.URI.XDG.AppStream, Network.URI.XDG.AppStreamOutput + build-depends: process >= 1.2 && <2.0, xml-conduit >=1.8, zlib >= 0.6 && < 0.7, containers + other-modules: Network.URI.XDG.Ini, Network.URI.XDG.MimeApps, + Network.URI.XDG.DesktopEntry, Network.URI.XDG.MimeInfo, Network.URI.XDG, + Network.URI.XDG.AppStream, Network.URI.XDG.AppStreamOutput if flag(rewriters) CPP-options: -DWITH_PLUGIN_REWRITES build-depends: regex, regex-tdfa >= 1.2 && < 1.4 diff --git a/src/Network/MIME/Info.hs b/src/Network/MIME/Info.hs new file mode 100644 --- /dev/null +++ b/src/Network/MIME/Info.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +module Network.MIME.Info(mimeInfo, MIME, Application(..)) where + +#ifdef WITH_XDG +import Network.URI.XDG.MimeInfo (readMimeInfo) +#endif +import Network.URI.Locale (rfc2616Locale) +import Network.URI.Types (Application(..)) + +import qualified Data.Map as M +import Control.Concurrent.MVar (MVar, newMVar, readMVar, putMVar) +import System.IO.Unsafe (unsafePerformIO) +import Data.Char (toLower) + +type MIME = Application + +{-# NOINLINE mimeInfo #-} +mimeInfo :: String -> MIME +mimeInfo = unsafePerformIO $ do + (locales, _) <- rfc2616Locale + cache <- newMVar M.empty :: IO (MVar (M.Map String MIME)) + return $ \mime -> unsafePerformIO $ do + readMVar cache >>= inner mime locales cache + where + inner mime _ _ cache | Just val <- mime `M.lookup` cache = return val + inner mime locales cache' cache = do + ret <- readMimeInfo locales mime + putMVar cache' $ M.insert mime ret cache + return ret + +#ifndef WITH_XDG +readMimeInfo _ mime = return Application { + name = mime, + icon = URI "about:" Nothing "invalid" "" "", + description = "", + appId = mime + } +#endif 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 @@ -94,11 +94,13 @@ -- | Additional files to serve from about: URIs. aboutPages :: [(FilePath, ByteString)], -- | Log of timestamped/profiled URL requests - requestLog :: MVar [LogRecord], + requestLog :: Maybe (MVar [LogRecord]), -- | How many redirects to follow for Gemini or HTTP(S) requests redirectCount :: Int, -- | Whether to cache network responses, avoiding sending requests - cachingEnabled :: Bool + cachingEnabled :: Bool, + -- | App-specific config subdirectory to check + appName :: String } data LogRecord = LogRecord { @@ -140,7 +142,6 @@ #ifdef WITH_PLUGIN_REWRITES rewriters <- parseRewriters appname #endif - log <- newEmptyMVar return Session { #ifdef WITH_HTTP_URI @@ -157,9 +158,10 @@ #endif locale = ietfLocale, aboutPages = [], - requestLog = log, + requestLog = Nothing, redirectCount = 5, - cachingEnabled = True + cachingEnabled = True, + appName = appname } llookup key fallback map = fallback `fromMaybe` listToMaybe [v | (k, v) <- map, k == key] @@ -175,19 +177,18 @@ (_, mime, resp) <- fetchURL' sess mimes uri return (mime, resp) -fetchURLLogged sess mimes uri = do +fetchURLLogged log sess mimes uri = do begin' <- getCurrentTime res@(redirected', mimetype', response') <- fetchURL' sess mimes uri end' <- getCurrentTime - modifyMVar_ (requestLog sess) $ \log -> return ( - LogRecord uri mimes redirected' mimetype' response' begin' end' : log) + modifyMVar_ log $ \log' -> return ( + LogRecord uri mimes redirected' mimetype' response' begin' end' : log') return res -- | Concurrently fetch given URLs. fetchURLs :: Session -> [String] -> [URI] -> ((URI, String, Either Text ByteString) -> IO a) -> IO [(URI, a)] fetchURLs sess mimes uris cb = do - shouldntLog <- isEmptyMVar $ requestLog sess - let fetch = if shouldntLog then fetchURL' else fetchURLLogged + let fetch = case requestLog sess of {Nothing -> fetchURL'; Just log -> fetchURLLogged log} forConcurrently uris (\u -> fetch sess mimes u >>= cb) >>= return . L.zip uris -- | Internal MIMEtypes for error reporting @@ -205,24 +206,29 @@ | 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 +fetchURL' session@Session { appName = appname, locale = l } mimes + uri@(URI "ext:" Nothing path 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) + 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") + program:_ -> do + 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 "" -> [] @@ -283,10 +289,7 @@ 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) - ] + `catch` \e -> do return (uri, mimeERR, Left $ Txt.pack $ trans (locale session) $ Http e) #endif #ifdef WITH_GEMINI_URI @@ -421,15 +424,14 @@ } -- Logging API -enableLogging :: Session -> IO () +enableLogging :: Session -> IO Session enableLogging session = do - logInactive <- isEmptyMVar $ requestLog session - if logInactive then putMVar (requestLog session) [] else return () + log <- newMVar [] + return session { requestLog = Just log } retrieveLog :: Session -> IO [LogRecord] -retrieveLog session = do - logInactive <- isEmptyMVar $ requestLog session - if logInactive then return [] else takeMVar $ requestLog session +retrieveLog session@Session { requestLog = Just log } = swapMVar log [] +retrieveLog _ = return [] writeLog :: Handle -> Session -> IO () writeLog out session = do diff --git a/src/Network/URI/Locale.hs b/src/Network/URI/Locale.hs --- a/src/Network/URI/Locale.hs +++ b/src/Network/URI/Locale.hs @@ -44,4 +44,5 @@ split b (a:as) | a `elem` b = [] : split b as | (head':tail') <- split b as = (a:head') : tail' + | otherwise = [a:as] split _ [] = [[]] 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 @@ -10,7 +10,6 @@ import Data.List (stripPrefix) import Data.Maybe (catMaybes) -#if WITH_APPSTREAM import qualified Text.XML as XML import qualified Data.Map as M import Data.Text (Text) @@ -19,14 +18,11 @@ import Network.URI.XDG.AppStreamOutput import Control.Monad (forM) import Network.URI -#endif data XDGConfig = XDGConfig { -#if WITH_APPSTREAM components :: M.Map Text Component, componentsByMIME :: M.Map Text [Component], iconCache :: IconCache, -#endif handlers :: HandlersConfig, locales :: [String] } @@ -34,13 +30,9 @@ loadXDGConfig :: [String] -> IO XDGConfig loadXDGConfig locales = do handlers <- loadHandlers -#if WITH_APPSTREAM components <- loadDatabase locales icons <- scanIconCache return $ XDGConfig components (buildMIMEIndex components) icons handlers locales -#else - return $ XDGConfig handlers locales -#endif dispatchURIByMIME :: XDGConfig -> URI -> String -> IO Errors dispatchURIByMIME config uri mime = do @@ -50,7 +42,6 @@ Nothing -> reportUnsupported config mime uri reportUnsupported :: XDGConfig -> String -> URI -> IO Errors -#if WITH_APPSTREAM reportUnsupported XDGConfig { components = comps } "x-scheme-handler/appstream" URI { uriAuthority = Just (URIAuth { uriRegName = ident }) } | Just el <- xmlForID comps $ Txt.pack ident = return $ RawXML $ serializeXML el @@ -61,12 +52,6 @@ icons' <- testLocalIcons $ icons app return $ app {icons = icons'} return $ RequiresInstall mime $ outputApps apps' -#else -reportUnsupported _ mime _ - | Just scheme <- "x-scheme-handler/" `stripPrefix` mime = - return $ UnsupportedScheme (scheme ++ ":") - | otherwise = return $ UnsupportedMIME mime -#endif mapFirstM :: [a] -> (a -> IO (Maybe b)) -> IO (Maybe b) mapFirstM (x:xs) cb = do diff --git a/src/Network/URI/XDG/AppStream.hs b/src/Network/URI/XDG/AppStream.hs --- a/src/Network/URI/XDG/AppStream.hs +++ b/src/Network/URI/XDG/AppStream.hs @@ -91,7 +91,7 @@ "append" -> M.unionWith (++) comp base "replace" -> M.union comp base "remove-component" -> M.empty - "" -> comp + _ -> comp localizeComponent :: [String] -> Component -> Component localizeComponent locales comp = let locales' = map Txt.pack locales in diff --git a/src/Network/URI/XDG/MimeApps.hs b/src/Network/URI/XDG/MimeApps.hs --- a/src/Network/URI/XDG/MimeApps.hs +++ b/src/Network/URI/XDG/MimeApps.hs @@ -50,6 +50,7 @@ queryHandlers' group (config:configs) mime = queryHandlers'' group config mime ++ queryHandlers' group configs mime +queryHandlers' group [] mime = [] queryHandlers'' group config mime | Just apps <- iniLookup group mime config = filter (/= "") $ split ';' apps | otherwise = [] @@ -62,4 +63,5 @@ split b (a:as) | a == b = [] : split b as | (head':tail') <- split b as = (a:head') : tail' + | otherwise = [a:as] split _ [] = [[]] diff --git a/src/Network/URI/XDG/MimeInfo.hs b/src/Network/URI/XDG/MimeInfo.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/XDG/MimeInfo.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.URI.XDG.MimeInfo(readMimeInfo) where + +import Network.URI.Fetch (Application(..)) +import Network.URI + +import Text.XML as XML +import Data.Text (Text, append, unpack, pack) +import qualified Data.Map as M + +import System.Environment (lookupEnv) +import System.FilePath ((), (<.>)) +import System.Directory (doesFileExist) +import System.IO (hPrint, stderr) +import Control.Monad (forM) +import Control.Exception (catch) +import Data.Maybe (catMaybes, maybeToList, fromMaybe, mapMaybe) + +readMimeInfo :: [String] -> String -> IO Application +readMimeInfo locales mime = do + dirs <- lookupEnv "XDG_DATA_DIRS" + homedir <- lookupEnv "XDG_DATA_HOME" + let dirs' = fromMaybe' "~/.local/share/" homedir : + split ':' (fromMaybe' "/usr/local/share/:/usr/share/" dirs) + + files <- forM dirs' $ \dir -> do + let file = dir mime <.> "xml" + exists <- doesFileExist file + if exists then (Just <$> XML.readFile def file) `catch` handleBadXML else return Nothing + + return $ case catMaybes files of + file:_ -> readMimeInfo' locales mime $ documentRoot file + [] -> Application { + name = mime, + icon = URI "xdg-icon:" Nothing (replace '/' '-' mime genericIcon mime) "" "", + description = "", + appId = mime + } + +readMimeInfo' locales mime el = Application { + name = readEl "comment" Nothing mime, + icon = nullURI { + uriScheme = "xdg-icon:", + uriPath = readEl "icon" (Just "name") (replace '/' '-' mime) + readEl "generic-icon" (Just "name") (genericIcon mime) + }, + description = readEl "expanded-acronym" Nothing $ readEl "acronym" Nothing mime, + appId = mime + } + where + readEl key attr fallback + | (val:_) <- [v | l <- locales ++ [""], v <- maybeToList $ lookup key els] = unpack val + | otherwise = fallback + where els = readEl' (pack key) attr $ elementNodes el + readEl' key Nothing (NodeElement (Element name attrs childs):sibs) + | key == nameLocalName name = (lang attrs, nodesText childs) : readEl' key Nothing sibs + readEl' key attr'@(Just attr) (NodeElement (Element name attrs _):sibs) + | key == nameLocalName name, Just val <- Name key namespace Nothing `M.lookup` attrs = + (lang attrs, val) : readEl' key attr' sibs + readEl' key attr (_:sibs) = readEl' key attr sibs + readEl' _ _ [] = [] + + namespace = Just "http://www.freedesktop.org/standards/shared-mime-info" + lang = unpack . fromMaybe "" . M.lookup "{http://www.w3.org/XML/1998/namespace}lang" + +(+++) = append +nodesText :: [Node] -> Text +nodesText (NodeElement (Element _ attrs children):nodes) = nodesText children +++ nodesText nodes +nodesText (NodeContent text:nodes) = text +++ nodesText nodes +nodesText (_:nodes) = nodesText nodes +nodesText [] = "" + +genericIcon mime = let (group, _) = break (== '/') mime in group ++ "-x-generic" + +handleBadXML err@(InvalidXMLFile _ _) = hPrint stderr err >> return Nothing + +fromMaybe' a (Just "") = a +fromMaybe' _ (Just a) = a +fromMaybe' a Nothing = a + +split b (a:as) | a == b = [] : split b as + | (head':tail') <- split b as = (a:head') : tail' + | otherwise = [a:as] +split _ [] = [[]] + +replace old new (c:cs) | c == old = new:replace old new cs + | otherwise = c:replace old new cs +replace _ _ [] = []