~alcinnz/hurl

ref: f7a8c1d76fa7ee17b7a81db535639ca2be1b77e5 hurl/src/Network/URI/XDG/AppStream.hs -rw-r--r-- 9.8 KiB
f7a8c1d7 — Adrian Cochrane Improve data: URI handling, provide utility to convert other URIs to data: URIs. 4 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
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 _ [] = []