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
76
77
78
79
80
81
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.URI.XDG(XDGConfig, loadXDGConfig, dispatchURIByMIME, queryHandlers', launchApp') where
import Network.URI (URI(..))
import Network.URI.Types
import Network.URI.Messages (Errors(..))
import Network.URI.XDG.DesktopEntry
import Network.URI.XDG.MimeApps
import Data.List (stripPrefix)
import Data.Maybe (catMaybes)
#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
queryHandlers' :: XDGConfig -> [String] -> String -> IO [Application]
queryHandlers' XDGConfig { handlers = config } locales mime =
catMaybes <$> mapM (desktop2app locales) (queryHandlers config mime)