From da4f67a27b662c70dd6b16b23ea591ecaddfd2e5 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 17 Jan 2020 13:49:42 +1300
Subject: [PATCH] Draft logic for looking apps to dispatch MIMEtypes & URI
 schemes to on XDG platforms

---
 src/Network/URI/XDG/MimeApps.hs | 54 +++++++++++++++++++++++++++++++++
 1 file changed, 54 insertions(+)
 create mode 100644 src/Network/URI/XDG/MimeApps.hs

diff --git a/src/Network/URI/XDG/MimeApps.hs b/src/Network/URI/XDG/MimeApps.hs
new file mode 100644
index 0000000..dae94e8
--- /dev/null
+++ b/src/Network/URI/XDG/MimeApps.hs
@@ -0,0 +1,54 @@
+module Network.URI.XDG.MimeApps(HandlersConfig, loadHandlers, queryHandlers) where
+
+import System.Environment (lookupEnv)
+import Control.Monad (forM)
+import System.FilePath
+import Data.List (nub, (\\))
+
+import Network.URI.XDG.Ini
+
+type HandlersConfig = [INI]
+
+loadHandlers :: IO HandlersConfig
+loadHandlers = do
+    desktop <- lookupEnv "XDG_CURRENT_DESKTOP"
+    dir0 <- mimeAppsDirs "XDG_CONFIG"
+    dir1 <- mimeAppsDirs "XDG_DATA"
+    let filepaths = mimeAppsFiles (dir0 ++ map (</> "applications") dir1) desktop
+    files <- forM filepaths readFile
+    return $ map parseIni files
+
+mimeAppsDirs envPrefix = do
+    home <- lookupEnv (envPrefix ++ "_HOME")
+    dirs <- lookupEnv (envPrefix ++ "_DIRS")
+    let dirs' = (case dirs of
+            Just x -> filter (/= "") $ split ':' x
+            Nothing -> [])
+    return $ case home of
+        Just home' -> home' : dirs'
+        Nothing -> dirs'
+
+mimeAppsFiles (dir:dirs) (Just desktop) = (dir </> desktop ++ "-mimeapps.list") :
+    (dir </> "mimeapps.list") : (mimeAppsFiles dirs $ Just desktop)
+mimeAppsFiles (dir:dirs) Nothing = (dir </> "mimeapps.list") : mimeAppsFiles dirs Nothing
+mimeAppsFiles [] _ = []
+
+split b (a:as) | a == b = [] : split b as
+        | (head':tail') <- split b as = (a:head') : tail'
+split _ [] = [[]]
+
+---
+
+queryHandlers :: HandlersConfig -> String -> [String]
+-- TODO Expand MIMEtypes in reference to the local MIMEtypes database.
+queryHandlers config mime = nub (
+        queryHandlers' "default applications" config mime ++
+        (queryHandlers' "added associations" config mime \\
+        queryHandlers' "removed associations" config mime)
+    )
+
+queryHandlers' group (config:configs) mime =
+    queryHandlers'' group config mime ++ queryHandlers' group configs mime
+queryHandlers'' group config mime
+    | Just apps <- iniLookup group mime config = filter (/= "") $ split ';' apps
+    | otherwise = []
-- 
2.30.2