hurl 1.5.0.0 → 2.0.0.0

raw patch · 9 files changed

+187/−70 lines, 9 filesdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: directory

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−3
• hurl.cabal +9/−14
• src/Network/MIME/Info.hs +38/−0
• src/Network/URI/Fetch.hs +39/−37
• src/Network/URI/Locale.hs +1/−0
• src/Network/URI/XDG.hs +0/−15
• src/Network/URI/XDG/AppStream.hs +1/−1
• src/Network/URI/XDG/MimeApps.hs +2/−0
• src/Network/URI/XDG/MimeInfo.hs +88/−0

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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 _ [] = [[]]

@@ -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

@@ -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

@@ -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 _ [] = [[]]

@@ -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 _ _ [] = []