~alcinnz/hurl

hurl/src/Network/URI/XDG/MimeApps.hs -rw-r--r-- 2.3 KiB
41ee21d2 — Adrian Cochrane Broaden base dependency bounds, fix readStrict regression. 1 year, 4 months 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
module Network.URI.XDG.MimeApps(HandlersConfig, loadHandlers, queryHandlers, split, fromMaybe') where

import System.Environment (lookupEnv)
import Control.Monad (forM)
import Control.Exception (catch)
import System.FilePath
import Data.List (nub, (\\))
import System.Directory (getHomeDirectory)

import Network.URI.XDG.Ini

type HandlersConfig = [INI]

loadHandlers :: IO HandlersConfig
loadHandlers = do
    desktop <- lookupEnv "XDG_CURRENT_DESKTOP"
    dir0 <- mimeAppsDirs "XDG_CONFIG" ".config" "/etc/xdg"
    dir1 <- mimeAppsDirs "XDG_DATA" ".local/share" "/usr/local/share/:/usr/share/"
    let filepaths = mimeAppsFiles (dir0 ++ map (</> "applications") dir1) desktop
    files <- forM filepaths tryReadFile
    return $ map parseIni files

tryReadFile path = readFile path `catch` handler
  where
    handler :: IOError -> IO String
    handler e = return ""

mimeAppsDirs envPrefix defaultHome defaultDirs = do
    home <- lookupEnv (envPrefix ++ "_HOME")
    dirs <- lookupEnv (envPrefix ++ "_DIRS")
    cwd <- getHomeDirectory
    let home' = fromMaybe' (cwd </> defaultHome) home
    let dirs' = fromMaybe' defaultDirs dirs
    return (home' : filter (/= "") (split ':' 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 [] _ = []

---

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 [] mime = []
queryHandlers'' group config mime
    | Just apps <- iniLookup group mime config = filter (/= "") $ split ';' apps
    | otherwise = []

---

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'
        | otherwise = [a:as]
split _ [] = [[]]