summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authoralcinnz <>2020-03-25 23:25:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-03-25 23:25:00 (GMT)
commitab66b13c1b897297810f3a8a858b57e2d5338bf0 (patch)
treecc7280dadc72c6c2f385da2ae04e52d7ea066e71
parent6aedca38339961619de33fe86f5e7cf5b843b79d (diff)
version 1.3.0.0HEAD1.3.0.0master
-rw-r--r--hurl.cabal13
-rw-r--r--src/Network/URI/Fetch.hs29
-rw-r--r--src/Network/URI/Locale.hs13
-rw-r--r--src/Network/URI/Messages.hs11
-rw-r--r--src/Network/URI/XDG.hs67
-rw-r--r--src/Network/URI/XDG/AppStream.hs259
-rw-r--r--src/Network/URI/XDG/AppStreamOutput.hs51
7 files changed, 414 insertions, 29 deletions
diff --git a/hurl.cabal b/hurl.cabal
index 15edac6..80a3cf9 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.2.0.0
+version: 1.3.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, containers
+ other-modules: Network.URI.XDG.AppStream, Network.URI.XDG.AppStreamOutput
diff --git a/src/Network/URI/Fetch.hs b/src/Network/URI/Fetch.hs
index 7727fb1..51e7420 100644
--- a/src/Network/URI/Fetch.hs
+++ b/src/Network/URI/Fetch.hs
@@ -37,7 +37,7 @@ data Session = Session {
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 @@ data Session = Session {
-- 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 @@ newSession = do
#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 @@ fetchURL _ (defaultMIME:_) uri@URI {uriScheme = "data:"} =
#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
diff --git a/src/Network/URI/Locale.hs b/src/Network/URI/Locale.hs
index d78df0e..ee9dc50 100644
--- a/src/Network/URI/Locale.hs
+++ b/src/Network/URI/Locale.hs
@@ -11,11 +11,12 @@ import Data.Char (toLower)
-- | 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' (c:cs) = toLower c : toRFC2616Lang' cs
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 _ [] = [[]]
diff --git a/src/Network/URI/Messages.hs b/src/Network/URI/Messages.hs
index d5fd2fb..d146b25 100644
--- a/src/Network/URI/Messages.hs
+++ b/src/Network/URI/Messages.hs
@@ -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 ("en":_) (Http (HttpExceptionRequest _ _)) = "The site doesn't appear to s
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
diff --git a/src/Network/URI/XDG.hs b/src/Network/URI/XDG.hs
index ffe8656..c5da184 100644
--- a/src/Network/URI/XDG.hs
+++ b/src/Network/URI/XDG.hs
@@ -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
diff --git a/src/Network/URI/XDG/AppStream.hs b/src/Network/URI/XDG/AppStream.hs
new file mode 100644
index 0000000..eda68f1
--- /dev/null
+++ b/src/Network/URI/XDG/AppStream.hs
@@ -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 _ [] = []
diff --git a/src/Network/URI/XDG/AppStreamOutput.hs b/src/Network/URI/XDG/AppStreamOutput.hs
new file mode 100644
index 0000000..31faf85
--- /dev/null
+++ b/src/Network/URI/XDG/AppStreamOutput.hs
@@ -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 = "?"