~alcinnz/hurl

ref: a7c88c86ffb0620b2557bb6aa4a35c2749bfaf22 hurl/src/Network/URI/XDG.hs -rw-r--r-- 2.5 KiB
a7c88c86 — Adrian Cochrane Expose redirected URIs to caller. 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
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.URI.XDG(XDGConfig, loadXDGConfig, dispatchURIByMIME) where

import Network.URI (URI(..))
import Network.URI.Messages (Errors(..))
import Network.URI.XDG.DesktopEntry
import Network.URI.XDG.MimeApps
import Data.List (stripPrefix)

#if WITH_APPSTREAM
import qualified Text.XML as XML
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as Txt
import Network.URI.XDG.AppStream
import Network.URI.XDG.AppStreamOutput
import Control.Monad (forM)
import Network.URI
#endif

data XDGConfig = XDGConfig {
#if WITH_APPSTREAM
    components :: M.Map Text Component,
    componentsByMIME :: M.Map Text [Component],
    iconCache :: IconCache,
#endif
    handlers :: HandlersConfig,
    locales :: [String]
}

loadXDGConfig :: [String] -> IO XDGConfig
loadXDGConfig locales = do
    handlers <- loadHandlers
#if WITH_APPSTREAM
    components <- loadDatabase locales
    icons <- scanIconCache
    return $ XDGConfig components (buildMIMEIndex components) icons handlers locales
#else
    return $ XDGConfig handlers locales
#endif

dispatchURIByMIME :: XDGConfig -> URI -> String -> IO Errors
dispatchURIByMIME config uri mime = do
    app <- queryHandlers (handlers config) mime `mapFirstM` launchApp (locales config) uri
    case app of
        Just app -> return $ OpenedWith app
        Nothing -> reportUnsupported config mime uri

reportUnsupported :: XDGConfig -> String -> URI -> IO Errors
#if WITH_APPSTREAM
reportUnsupported XDGConfig { components = comps } "x-scheme-handler/appstream" URI {
        uriAuthority = Just (URIAuth { uriRegName = ident })
    } | Just el <- xmlForID comps $ Txt.pack ident = return $ RawXML $ serializeXML el
    | otherwise = return $ UnsupportedScheme "appstream:" -- Could also do a 404...
reportUnsupported XDGConfig { iconCache = icondirs, componentsByMIME = index } mime _  = do
    let apps = appsForMIME icondirs index $ Txt.pack mime
    apps' <- forM apps $ \app -> do
        icons' <- testLocalIcons $ icons app
        return $ app {icons = icons'}
    return $ RequiresInstall mime $ outputApps apps'
#else
reportUnsupported _ mime _
    | Just scheme <- "x-scheme-handler/" `stripPrefix` mime =
        return $ UnsupportedScheme (scheme ++ ":")
    | otherwise = return $ UnsupportedMIME mime
#endif

mapFirstM :: [a] -> (a -> IO (Maybe b)) -> IO (Maybe b)
mapFirstM (x:xs) cb = do
    item <- cb x
    case item of
        Just _ -> return item
        Nothing -> mapFirstM xs cb
mapFirstM [] _ = return Nothing