From 0f67342eba8391071f76a89ea5d875bb1f79379d Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 1 Jan 2021 20:23:03 +1300
Subject: [PATCH] Draft code for querying the FreeDesktop.Org MimeInfo XML
 database.

---
 src/Links.hs    |   8 +++-
 src/MimeInfo.hs | 106 ++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 113 insertions(+), 1 deletion(-)
 create mode 100644 src/MimeInfo.hs

diff --git a/src/Links.hs b/src/Links.hs
index e197f84..623fd2a 100644
--- a/src/Links.hs
+++ b/src/Links.hs
@@ -52,7 +52,13 @@ extractMisc [] = []
 extractEl path el@(Element (Name "details" _ _) _ childs) =
     [Link (nodesText summary' $ nodesText childs "") "+" nullURI {
         uriFragment = '#':'.':intercalate "." (map show $ reverse path)
-    } | NodeElement summary@(Element (Name "summary" _ _) _ summary') <- childs]
+    } | NodeElement summary@(Element (Name "summary" _ _) _ summary') <- childs] ++
+    extractNodes (0:path) childs
+-- Special case for showing Appstream metadata of compatible apps.
+-- Fallback for incompatible package manager UIs.
+extractEl (Element "{https://specifications.freedesktop.org/metainfo/1.0}url" attrs childs)
+    | Just label <- attrs `M.lookup `"{https://specifications.freedesktop.org/metainfo/1.0}type",
+      Just url <- parseAbsoluteURI $ nodesText childs "" = [Link label "" url]
 extractEl path el@(Element _ _ children) =
     extractElAttr el "href" ++
     extractElAttr el "longdesc" ++
diff --git a/src/MimeInfo.hs b/src/MimeInfo.hs
new file mode 100644
index 0000000..aba3af1
--- /dev/null
+++ b/src/MimeInfo.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE OverloadedStrings #-}
+module MimeInfo(readMimeInfo, mimeInfoCached) where
+
+import Types (Application(..))
+import Network.URI
+
+import Text.XML as XML
+import Data.Text (Text, append, unpack, pack)
+import qualified Data.Map as M
+
+import System.Environment (lookupEnv)
+import System.FilePath ((</>), (<.>))
+import System.Directory (doesFileExist)
+import System.IO (hPrint, stderr)
+import Control.Monad (forM)
+import Control.Exception (catch)
+import Data.Maybe (catMaybes, maybeToList, fromMaybe)
+
+import qualified Data.Trie.Text as Trie
+import Data.Trie.Text (Trie)
+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)
+import System.IO.Unsafe (unsafePerformIO)
+
+readMimeInfo :: [String] -> String -> IO Application
+readMimeInfo locales mime = do
+    dirs <- lookupEnv "XDG_DATA_DIRS"
+    homedir <- lookupEnv "XDG_DATA_HOME"
+    let dirs' = fromMaybe' "~/.local/share/" homedir :
+            split ':' (fromMaybe' "/usr/local/share/:/usr/share/" dirs)
+
+    files <- forM dirs' $ \dir -> do
+        let file = dir </> mime <.> "xml"
+        exists <- doesFileExist file
+        if exists then (Just <$> XML.readFile def file) `catch` handleBadXML else return Nothing
+
+    return $ case catMaybes files of
+        file:_ -> readMimeInfo' locales mime $ documentRoot file
+        [] -> Application {
+            name = mime,
+            icon = URI "xdg-icon:" Nothing (replace '/' '-' mime </> genericIcon mime) "" "",
+            description = "",
+            appId = mime
+          }
+
+readMimeInfo' locales mime el = Application {
+        name = readEl "comment" Nothing mime,
+        icon = nullURI {
+            uriScheme = "xdg-icon:",
+            uriPath = readEl "icon" (Just "name") (replace '/' '-' mime) </>
+                readEl "generic-icon" (Just "name") (genericIcon mime)
+        },
+        description = readEl "expanded-acronym" Nothing $ readEl "acronym" Nothing mime,
+        appId = mime
+    }
+  where
+    readEl key attr fallback
+        | (val:_) <- [v | l <- locales ++ [""], v <- maybeToList $ lookup key els] = unpack val
+        | otherwise = fallback
+      where els = readEl' (pack key) attr $ elementNodes el
+    readEl' key Nothing (NodeElement (Element name attrs childs):sibs)
+        | key == nameLocalName name = (lang attrs, nodesText childs) : readEl' key Nothing sibs
+    readEl' key attr'@(Just attr) (NodeElement (Element name attrs _):sibs)
+        | key == nameLocalName name, Just val <- Name key namespace Nothing `M.lookup` attrs =
+            (lang attrs, val) : readEl' key attr' sibs
+    readEl' key attr (_:sibs) = readEl' key attr sibs
+    readEl' _ _ [] = []
+
+    namespace = Just "http://www.freedesktop.org/standards/shared-mime-info"
+    lang = unpack . fromMaybe "" . M.lookup "{http://www.w3.org/XML/1998/namespace}lang"
+
+(+++) = append
+nodesText :: [Node] -> Text
+nodesText (NodeElement (Element _ attrs children):nodes) = nodesText children +++ nodesText nodes
+nodesText (NodeContent text:nodes) = text +++ nodesText nodes
+nodesText (_:nodes) = nodesText nodes
+nodesText [] = ""
+
+genericIcon mime = let (group, _) = break (== '/') mime in  group ++ "-x-generic"
+
+handleBadXML err@(InvalidXMLFile _ _) = hPrint stderr err >> return Nothing
+
+fromMaybe' a (Just "") = a
+fromMaybe' _ (Just a) = a
+fromMaybe' a Nothing = a
+
+split b (a:as) | a == b = [] : split b as
+        | (head':tail') <- split b as = (a:head') : tail'
+split _ [] = [[]]
+
+replace old new (c:cs) | c == old = new:replace old new cs
+    | otherwise = c:replace old new cs
+replace _ _ [] = []
+
+--------
+---- Pseudo-pure, caching API
+--------
+
+mimeInfoCached :: [String] -> IO (String -> Application)
+mimeInfoCached locales = do
+    cache <- newMVar Trie.empty :: IO (MVar (Trie Application))
+    return $ \mime -> unsafePerformIO $ modifyMVar cache $ inner (pack mime)
+  where
+    inner mime cache | Just val <- mime `Trie.lookup` cache = return (cache, val)
+    inner mime cache = do
+        ret <- readMimeInfo locales $ unpack mime
+        return (Trie.insert mime ret cache, ret)
-- 
2.30.2