From 6370ab8a13697df679fb756e7906a4a6a400337e Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 22 Mar 2020 20:08:19 +1300 Subject: [PATCH] Draft AppStream loading code. --- hurl.cabal | 13 ++- src/Network/URI/XDG/AppStream.hs | 181 +++++++++++++++++++++++++++++++ 2 files changed, 192 insertions(+), 2 deletions(-) create mode 100644 src/Network/URI/XDG/AppStream.hs diff --git a/hurl.cabal b/hurl.cabal index 867bb13..06b185f 100644 --- a/hurl.cabal +++ b/hurl.cabal @@ -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 diff --git a/src/Network/URI/XDG/AppStream.hs b/src/Network/URI/XDG/AppStream.hs new file mode 100644 index 0000000..0d1029e --- /dev/null +++ b/src/Network/URI/XDG/AppStream.hs @@ -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 _ [] = [] -- 2.30.2