AppStream.hs

{-# 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
    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 "/var/cache/app-info/icons/" `catch` handleListError
    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 _ [] = []