From 7239e77a1a2e8cacf2e04e88eaf5da99137d4a22 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 24 Mar 2020 18:23:32 +1300
Subject: [PATCH] Support looking up icons by MIMEtype.

---
 src/Network/URI/XDG/AppStream.hs | 80 +++++++++++++++++++++++++++++++-
 1 file changed, 79 insertions(+), 1 deletion(-)

diff --git a/src/Network/URI/XDG/AppStream.hs b/src/Network/URI/XDG/AppStream.hs
index 0d1029e..e019207 100644
--- a/src/Network/URI/XDG/AppStream.hs
+++ b/src/Network/URI/XDG/AppStream.hs
@@ -1,5 +1,8 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Network.URI.XDG.AppStream(loadDatabase, xmlForID) where -- , appsForMIME
+module Network.URI.XDG.AppStream(
+    loadDatabase, xmlForID, buildMIMEIndex,
+    App(..), Icon(..), appsForMIME
+) where
 
 import qualified Data.Map as M
 import qualified Text.XML as XML
@@ -15,6 +18,7 @@ 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
@@ -125,6 +129,80 @@ comp2els comp = concat (
         (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 <- forConcurrently (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
 ----
-- 
2.30.2