@@ 10,7 10,7 @@ name: hurl
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 1.1.0.0
+version: 1.2.0.0
-- A short (one-line) description of the package.
synopsis: Haskell URL resolver
@@ 64,10 64,15 @@ Flag data
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 @@ library
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, async >= 2.1.0 && < 2.3.0, containers
+ other-modules: Network.URI.XDG.AppStream
@@ 0,0 1,181 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Network.URI.XDG.AppStream(loadDatabase, xmlForID) where -- , appsForMIME
+
+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.Concurrent.Async (forConcurrently)
+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)
+
+----
+-- 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 <- forConcurrently (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
+ forConcurrently 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)
+ )
+
+----
+-- 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 _ [] = []