packages feed

hurl 1.2.0.0 → 1.3.0.0

raw patch · 7 files changed

+414/−29 lines, 7 filesdep +containersdep +xml-conduitdep +zlib

Dependencies added: containers, xml-conduit, zlib

Files

hurl.cabal view
@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             1.2.0.0+version:             1.3.0.0  -- A short (one-line) description of the package. synopsis:            Haskell URL resolver@@ -64,10 +64,15 @@   Manual:      True  Flag freedesktop-  Description: Dispatches unsupported URIs to external apps on FreeDesktop.Org-compatible desktops. Works on most non-mainstream/non-proprietary desktops.+  Description: Dispatches unsupported URIs and MIMEtypes to external apps on FreeDesktop.Org-compatible desktops. Works on most non-mainstream/non-proprietary desktops.   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+ source-repository head     type: git     location: https://git.nzoss.org.nz/alcinnz/hurl.git@@ -105,3 +110,7 @@     CPP-options:   -DWITH_XDG     build-depends: filepath, directory, 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 && < 1.9, zlib >= 0.6 && < 0.7, containers+    other-modules: Network.URI.XDG.AppStream, Network.URI.XDG.AppStreamOutput
src/Network/URI/Fetch.hs view
@@ -37,7 +37,7 @@     managerHTTP :: HTTP.Manager, #endif #ifdef WITH_XDG-    apps :: HandlersConfig,+    apps :: XDGConfig, #endif     -- | The languages (RFC2616-encoded) to which responses should be localized.     locale :: [String]@@ -47,12 +47,12 @@ -- if HTTP is enabled. newSession :: IO Session newSession = do-    locale' <- rfc2616Locale+    (ietfLocale, unixLocale) <- rfc2616Locale #ifdef WITH_HTTP_URI     managerHTTP' <- HTTP.newManager TLS.tlsManagerSettings #endif #ifdef WITH_XDG-    apps' <- loadHandlers+    apps' <- loadXDGConfig unixLocale #endif      return Session {@@ -62,7 +62,7 @@ #ifdef WITH_XDG         apps = apps', #endif-        locale = locale'+        locale = ietfLocale     }  -- | Retrieves a URL-identified resource & it's MIMEtype, possibly decoding it's text.@@ -117,22 +117,21 @@ #endif  #ifdef WITH_XDG-fetchURL Session {locale = l, apps = a} _ uri@(URI {uriScheme = s})-    | canDispatchMIME a ("x-scheme-handler/" ++ init s) = do-        app <- dispatchURIByMIME l a uri ("x-scheme-handler/" ++ init s)-        return (-            "text/plain",-            Left $ Txt.pack $ trans l $ case app of-                Just name -> OpenedWith name-                Nothing -> UnsupportedScheme s)-#endif-+fetchURL Session {locale = l, apps = a} _ uri@(URI {uriScheme = s}) = do+        app <- dispatchURIByMIME a uri ("x-scheme-handler/" ++ init s)+        return ("text/html", Left $ Txt.pack $ trans l $ app)+#else fetchURL Session {locale = l} _ URI {uriScheme = scheme} =     return ("text/plain", Left $ Txt.pack $ trans l $ UnsupportedScheme scheme)+#endif  dispatchByMIME :: Session -> String -> URI -> IO (Maybe String) #if WITH_XDG-dispatchByMIME Session {locale = l, apps = a} mime uri = dispatchURIByMIME l a uri mime+dispatchByMIME Session {locale = l, apps = a} mime uri = do+    err <- dispatchURIByMIME a uri mime+    return $ case err of+        UnsupportedMIME _ -> Nothing+        _ -> Just $ trans l err #else dispatchByMIME _ _ _ = return Nothing #endif
src/Network/URI/Locale.hs view
@@ -11,11 +11,12 @@ -- | Returns the languages to which responses should be localized. -- Retrieved from Gettext configuration & reformatted for use in the -- HTTP Accept-Language request header.-rfc2616Locale :: IO [String]+rfc2616Locale :: IO ([String], [String]) rfc2616Locale = do     locales <- forM ["LANGUAGE", "LC_ALL", "LC_MESSAGES", "LANG"] lookupEnv-    let locales' = mapMaybe toRFC2616Lang $ split ':' $ firstJust locales "en_US"-    return (locales' ++ [l | l <- extractLangs locales', l `notElem` locales'])+    let posix = split ":" $ firstJust locales "en_US"+    let ietf = mapMaybe toRFC2616Lang posix+    return (explode ietf, explode posix)  toRFC2616Lang "C" = Nothing toRFC2616Lang ('C':'.':_) = Nothing@@ -31,14 +32,16 @@ toRFC2616Lang' [] = []  -- Makes sure to include the raw languages, and not just localized variants.-extractLangs (locale:locales) | (lang:_) <- split '-' locale = lang : extractLangs locales+extractLangs (locale:locales) | (lang:_) <- split "-_.@" locale = lang : extractLangs locales extractLangs (_:locales) = extractLangs locales extractLangs [] = [] +explode locales = locales ++ [l | l <- extractLangs locales, l `notElem` locales]+ firstJust (Just a:_) _ | a /= "" = a firstJust (_:maybes) fallback = firstJust maybes fallback firstJust [] fallback = fallback -split b (a:as) | a == b = [] : split b as+split b (a:as) | a `elem` b = [] : split b as         | (head':tail') <- split b as = (a:head') : tail' split _ [] = [[]]
src/Network/URI/Messages.hs view
@@ -11,13 +11,21 @@ -- Translations between #if WITH_HTTP_URI & #endif are specific to HTTP error handling. module Network.URI.Messages (trans, Errors(..)) where +import Data.List (stripPrefix)+import Data.Maybe (fromMaybe)+ #if WITH_HTTP_URI import Network.HTTP.Client (HttpException(..), HttpExceptionContent(..)) import Control.Exception (displayException) #endif +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+  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 #if WITH_HTTP_URI@@ -33,7 +41,8 @@ trans (_:locales) err = trans locales err trans [] err = trans ["en"] err -data Errors = UnsupportedScheme String | OpenedWith String | ReadFailed String+data Errors = UnsupportedScheme String | UnsupportedMIME String | RequiresInstall String String+    | OpenedWith String | ReadFailed String | RawXML String #if WITH_HTTP_URI     | Http HttpException #endif
src/Network/URI/XDG.hs view
@@ -1,15 +1,70 @@-module Network.URI.XDG(HandlersConfig, loadHandlers, canDispatchMIME, dispatchURIByMIME) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.URI.XDG(XDGConfig, loadXDGConfig, dispatchURIByMIME) where  import Network.URI (URI(..))+import Network.URI.Messages (Errors(..)) import Network.URI.XDG.DesktopEntry import Network.URI.XDG.MimeApps+import Data.List (stripPrefix) -canDispatchMIME :: HandlersConfig -> String -> Bool-canDispatchMIME config mime = not $ null $ queryHandlers config mime+#if WITH_APPSTREAM+import qualified Text.XML as XML+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as Txt+import Network.URI.XDG.AppStream+import Network.URI.XDG.AppStreamOutput+import Control.Monad (forM)+import Network.URI+#endif -dispatchURIByMIME :: [String] -> HandlersConfig -> URI -> String -> IO (Maybe String)-dispatchURIByMIME locales config uri mime =-    queryHandlers config mime `mapFirstM` launchApp locales uri+data XDGConfig = XDGConfig {+#if WITH_APPSTREAM+    components :: M.Map Text Component,+    componentsByMIME :: M.Map Text [Component],+    iconCache :: IconCache,+#endif+    handlers :: HandlersConfig,+    locales :: [String]+}++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+    app <- queryHandlers (handlers config) mime `mapFirstM` launchApp (locales config) uri+    case app of+        Just app -> return $ OpenedWith app+        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+    | otherwise = return $ UnsupportedScheme "appstream:" -- Could also do a 404...+reportUnsupported XDGConfig { iconCache = icondirs, componentsByMIME = index } mime _  = do+    let apps = appsForMIME icondirs index $ Txt.pack mime+    apps' <- forM apps $ \app -> do+        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
+ src/Network/URI/XDG/AppStream.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.URI.XDG.AppStream(+    Component, loadDatabase, xmlForID, buildMIMEIndex,+    App(..), Icon(..), IconCache, scanIconCache, appsForMIME+) where++import qualified Data.Map as M+import qualified Text.XML as XML+import Codec.Compression.GZip (decompress)+import qualified Data.ByteString.Lazy as LBS+import System.Directory+import System.FilePath ((</>), takeBaseName)+import Control.Exception (catch)+import Control.Monad (forM)+import Data.List (isSuffixOf, sortOn, elemIndex)+import Data.Maybe (catMaybes, mapMaybe, fromMaybe)+import System.Process (callProcess)+import Data.Text (Text)+import qualified Data.Text as Txt+import Text.Read (readMaybe)+import Data.Char (isDigit)++----+-- Load in the XML files+----+type Component = M.Map Text [XML.Element]+cachedir = ".cache/nz.geek.adrian.hurl/appstream/"++loadDatabase :: [String] -> IO (M.Map Text Component)+loadDatabase locales = do+    -- Handle YAML files for Debian-derivatives+    sharePaths' <- yaml2xml "/usr/share/app-info/yaml/" "share" `catch` handleListError+    cachePaths' <- yaml2xml "/var/cache/app-info/yaml/" "cache" `catch` handleListError++    -- Read in the XML files.+    sharePaths <- listDirectory "/usr/share/app-info/xml/" `catch` handleListError+    cachePaths <- listDirectory "/var/cache/app-info/xml/" `catch` handleListError+    xmls <- forM (sharePaths ++ sharePaths' ++ cachePaths ++ cachePaths') $ \path -> do+        text <- LBS.readFile path+        let decompressor = if ".gz" `isSuffixOf` path then decompress else id+        return $ rightToMaybe $ XML.parseLBS XML.def $ decompressor text++    -- Index components by ID and their subelements by name+    let components = concat $ map getComponents $ catMaybes xmls+    let componentsByID = list2map [(getText "id" comp, comp) | comp <- components]+    let mergeComponents' = filterMergeAttrs . localizeComponent locales . mergeComponents+    let componentByID = M.filter M.null $ M.map mergeComponents' componentsByID+    return componentByID++yaml2xml :: FilePath -> String -> IO [FilePath]+yaml2xml source destSubDir = do+    home <- getHomeDirectory+    let destDir = home </> cachedir </> destSubDir ++ ".xml.gz"++    paths <- listDirectory source+    forM paths $ \path -> do+        let dest = destDir </> takeBaseName path+        destExists <- doesPathExist dest++        srcTime <- getModificationTime path+        destTime <- if destExists then getModificationTime path else return srcTime+        if srcTime >= destTime+            then callProcess "appstreamcli" ["convert", "--format=xml", path, dest]+            else return ()++    listDirectory destDir++getComponents :: XML.Document -> [Component]+getComponents XML.Document {+        XML.documentRoot = XML.Element {+            XML.elementNodes = nodes+        }+    } = mapMaybe getComponent nodes+getComponent :: XML.Node -> Maybe Component+getComponent (XML.NodeElement XML.Element {+        XML.elementName = XML.Name "component" _ _,+        XML.elementAttributes = attrs,+        XML.elementNodes = nodes+    }) = Just $ list2map (+        [(key, txt2el name val) | (name@(XML.Name key _ _), val) <- M.toList attrs] +++        [(key, node) | XML.NodeElement node@(XML.Element (XML.Name key _ _) _ _) <- nodes]+    )+  where txt2el name txt = XML.Element name M.empty [XML.NodeContent txt]+getComponent _ = Nothing++mergeComponents :: [Component] -> Component+mergeComponents comps = mergeComponents' $ reverse $ sortOn (getInt "priority") comps+mergeComponents' [] = M.empty+mergeComponents' (comp:comps) = let base = mergeComponents' comps in+    case getText "merge" comp of+        "append" -> M.unionWith (++) comp base+        "replace" -> M.union comp base+        "remove-component" -> M.empty+        "" -> comp++localizeComponent :: [String] -> Component -> Component+localizeComponent locales comp = let locales' = map Txt.pack locales in+    let locale = bestXMLLocale locales' $ comp2xml comp in+    M.filter null $ M.map (mapMaybe $ filterElByLocale locale) comp++filterMergeAttrs :: Component -> Component+filterMergeAttrs comp = "priority" `M.delete` M.delete "merge" comp++----+-- Lookup by ID+----++xmlForID :: M.Map Text Component -> Text -> Maybe XML.Element+xmlForID comps id = comp2xml <$> M.lookup id comps++elementOrder :: [Text]+elementOrder = [+        "id", "pkgname", "source_pkgname", "name",+        "project_license", "summary", "description",+        "url", "project_group", "icon",+        "mimetypes", "categories", "keywords",+        "screenshots",+        "compulsory_for_desktop", "provides",+        "developer_name", "launchable", "releases",+        "languages", "bundle", "suggests",+        "content_rating", "agreement"+    ]++comp2xml :: Component -> XML.Element+comp2xml comp = XML.Element "component" M.empty $ map XML.NodeElement $ comp2els comp+comp2els :: Component -> [XML.Element]+comp2els comp = concat (+        map (\k -> M.findWithDefault [] k comp) elementOrder +++        (map snd $ M.toList $ M.filterWithKey (\k v -> k `notElem` elementOrder) comp)+    )++----+-- Lookup by MIME+----++buildMIMEIndex :: M.Map Text Component -> M.Map Text [Component]+buildMIMEIndex comps = list2map [(mime, comp) | (_, comp) <- M.toList comps, mime <- getMIMEs comp]++getMIMEs :: Component -> [Text]+getMIMEs comp = let nodes = concat $ map (XML.elementNodes) $ getEls "mimetypes" comp+    in filter Txt.null $ map node2txt nodes++--++data App = App {+    ident :: Text,+    name :: Text,+    summary :: Text,+    icons :: [Icon]+}+data Icon = Icon {+    source :: Text,+    width :: Maybe Int,+    height :: Maybe Int,+    url :: Text+}++appsForMIME :: IconCache -> M.Map Text [Component] -> Text -> [App]+appsForMIME iconcache comps mime = mapMaybe (comp2app iconcache) $ M.findWithDefault [] mime comps++comp2app :: IconCache -> Component -> Maybe App+comp2app iconcache comp+    | getText "type" comp == "desktop-application" = Just $ App {+        ident = getText "id" comp,+        name = getText "name" comp,+        summary = getText "summary" comp,+        icons = sortOn rankIcon $ concat $ map (el2icon iconcache) $ getEls "icon" comp+    }+    | otherwise = Nothing+  where rankIcon icon = source icon `elemIndex` ["stock", "cached", "local", "remote"]++el2icon :: IconCache -> XML.Element -> [Icon]+el2icon iconcache el@(XML.Element _ attrs _)+    | Just "cached" <- "type" `M.lookup` attrs =+        [Icon "cached" size size $ Txt.append "file://" $ Txt.pack path+        | (size, path) <- lookupCachedIcons iconcache $ el2txt el]+el2icon _ el@(XML.Element _ attrs _) = [Icon {+        source = M.findWithDefault "" "type" attrs,+        width = parseIntAttr "width",+        height = parseIntAttr "height",+        url = iconURL el+    }]+  where parseIntAttr attr = M.lookup attr attrs >>= readMaybe . Txt.unpack++iconURL el@(XML.Element _ attrs _) = case "type" `M.lookup` attrs of+    Just "stock" -> "icon:" `Txt.append` val -- URI scheme NOT implemented+    Just "cached" -> "file:///{usr/share,var/cache}/app-info/icons/*/*/" `Txt.append` val -- FIXME, resolve & provide multiple options.+    Just "local" -> "file://" `Txt.append` val+    Just "remote" -> val+    _ -> "about:blank"+  where val = el2txt el++-- AppStream icon cache+type IconCache = [FilePath]+scanIconCache :: IO IconCache+scanIconCache = do+    sharePaths <- listDirectory "/usr/share/app-info/icons/" `catch` handleListError+    varPaths <- listDirectory "/usr/share/app-info/icons/"+    paths <- forM (sharePaths ++ varPaths) (\x -> listDirectory x `catch` handleListError)+    return (concat paths ++ sharePaths ++ varPaths)++lookupCachedIcons :: IconCache -> Text -> [(Maybe Int, FilePath)]+lookupCachedIcons iconcache icon = [(size $ takeBaseName dir, dir </> Txt.unpack icon) | dir <- iconcache]+    where size dirname = readMaybe $ takeWhile isDigit dirname++----+-- Supporting utilities+----+handleListError :: IOError -> IO [a]+handleListError _ = return []++-- It's not worth importing Data.Either.Combinators for this.+rightToMaybe :: Either l r -> Maybe r+rightToMaybe (Left _) = Nothing+rightToMaybe (Right x) = Just x++list2map :: Ord a => [(a, b)] -> M.Map a [b]+list2map = foldr insertEntry M.empty+    where insertEntry (key, value) = M.insertWith (++) key [value]++-- XML Utils++el2txt :: XML.Element -> Text+el2txt el = Txt.concat $ map node2txt $ XML.elementNodes el+node2txt :: XML.Node -> Text+node2txt (XML.NodeElement el) = el2txt el+node2txt (XML.NodeContent txt) = txt+node2txt _ = ""++getEls :: Text -> Component -> [XML.Element]+getEls key comp = M.findWithDefault [emptyEl] key comp+getEl :: Text -> Component -> XML.Element+getEl key comp | ret:_ <- getEls key comp = ret+    | otherwise = emptyEl+getText :: Text -> Component -> Text+getText key comp = el2txt $ getEl key comp+getInt :: Text -> Component -> Integer+getInt key comp = fromMaybe 0 $ readMaybe $ Txt.unpack $ getText key comp+emptyEl :: XML.Element+emptyEl = XML.Element "placeholder" M.empty []++bestXMLLocale :: [Text] -> XML.Element -> Text+bestXMLLocale locales (XML.Element _ attrs nodes)+    | Just locale <- "xml:lang" `M.lookup` attrs = locale+    | locale:_ <- sortOn rankLocale [bestXMLLocale locales el+            | XML.NodeElement el <- nodes] = locale+    | otherwise = ""+  where rankLocale locale = locale `elemIndex` locales++filterElByLocale :: Text -> XML.Element -> Maybe XML.Element+filterElByLocale locale el@(XML.Element _ attrs nodes)+    | Just locale' <- "xml:lang" `M.lookup` attrs, locale' /= locale = Nothing+    | otherwise = Just $ el {XML.elementNodes = filterNodesByLocale locale nodes}+filterNodesByLocale :: Text -> [XML.Node] -> [XML.Node]+filterNodesByLocale locale (XML.NodeElement el:nodes)+    | Just el' <- filterElByLocale locale el = XML.NodeElement el' : filterNodesByLocale locale nodes+    | otherwise = filterNodesByLocale locale nodes+filterNodesByLocale locale (node:nodes) = node : filterNodesByLocale locale nodes+filterNodesByLocale _ [] = []
+ src/Network/URI/XDG/AppStreamOutput.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.URI.XDG.AppStreamOutput(serializeXML, outputApps, testLocalIcons) where++import qualified Text.XML as XML+import qualified Data.Map as M+import Data.Text (Text, append, pack)+import qualified Data.Text as Txt+import Data.Text.Lazy (unpack)+import Network.URI.XDG.AppStream++import Data.List (stripPrefix)+import Control.Monad (forM)+import System.Directory (doesFileExist)+import Data.Maybe (catMaybes)++outputApps apps = serializeXML $ el "p" $ map outputApp apps+outputApp (App ident' name' summary' icons') =+    el' "a" [("href", "appstream://" `append` ident'), ("title", summary')] [+        el "picture" [+            el' (if i == 0 then "img" else "source") [+                ("src", url'),+                ("alt", name' `append` " logo " `append` int2txt width' `append` "x" `append` int2txt height'),+                ("sizes", int2txt width' `append` "w")] []+            | (i, Icon _ width' height' url') <- zip [0..] icons'+        ],+        XML.Element "caption" M.empty [XML.NodeContent name']]++testLocalIcons icons = do+    icons' <- forM icons $ \icon -> case "file://" `stripPrefix` Txt.unpack (url icon) of+        Just path -> do+            exists <- doesFileExist path+            return $ if exists then Just icon else Nothing+        Nothing -> return $ Just icon+    return $ catMaybes icons'++-- Generic XML/Text utilities+serializeXML el = unpack $ XML.renderText XML.def XML.Document {+        XML.documentPrologue = XML.Prologue [] Nothing [],+        XML.documentRoot = el,+        XML.documentEpilogue = []+    }++el' name attrs children = XML.Element {+        XML.elementName = XML.Name name Nothing Nothing,+        XML.elementAttributes = M.fromList attrs,+        XML.elementNodes = map XML.NodeElement children+    }+el name children = el' name [] children++int2txt (Just n) = pack $ show n+int2txt Nothing = "?"