{-# 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)

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

data XDGConfig = XDGConfig {
    XDGConfig -> Map Text Component
components :: M.Map Text Component,
    XDGConfig -> Map Text [Component]
componentsByMIME :: M.Map Text [Component],
    XDGConfig -> IconCache
iconCache :: IconCache,
    XDGConfig -> HandlersConfig
handlers :: HandlersConfig,
    XDGConfig -> IconCache
locales :: [String]
}

loadXDGConfig :: [String] -> IO XDGConfig
loadXDGConfig :: IconCache -> IO XDGConfig
loadXDGConfig IconCache
locales = do
    HandlersConfig
handlers <- IO HandlersConfig
loadHandlers
    Map Text Component
components <- IconCache -> IO (Map Text Component)
loadDatabase IconCache
locales
    IconCache
icons <- IO IconCache
scanIconCache
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map Text Component
-> Map Text [Component]
-> IconCache
-> HandlersConfig
-> IconCache
-> XDGConfig
XDGConfig Map Text Component
components (Map Text Component -> Map Text [Component]
buildMIMEIndex Map Text Component
components) IconCache
icons HandlersConfig
handlers IconCache
locales

dispatchURIByMIME :: XDGConfig -> URI -> String -> IO Errors
dispatchURIByMIME :: XDGConfig -> URI -> String -> IO Errors
dispatchURIByMIME XDGConfig
config URI
uri String
mime = do
    Maybe String
app <- HandlersConfig -> String -> IconCache
queryHandlers (XDGConfig -> HandlersConfig
handlers XDGConfig
config) String
mime forall a b. [a] -> (a -> IO (Maybe b)) -> IO (Maybe b)
`mapFirstM` IconCache -> URI -> String -> IO (Maybe String)
launchApp (XDGConfig -> IconCache
locales XDGConfig
config) URI
uri
    case Maybe String
app of
        Just String
app -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Errors
OpenedWith String
app
        Maybe String
Nothing -> XDGConfig -> String -> URI -> IO Errors
reportUnsupported XDGConfig
config String
mime URI
uri

reportUnsupported :: XDGConfig -> String -> URI -> IO Errors
reportUnsupported :: XDGConfig -> String -> URI -> IO Errors
reportUnsupported XDGConfig { components :: XDGConfig -> Map Text Component
components = Map Text Component
comps } String
"x-scheme-handler/appstream" URI {
        uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just (URIAuth { uriRegName :: URIAuth -> String
uriRegName = String
ident })
    } | Just Element
el <- Map Text Component -> Text -> Maybe Element
xmlForID Map Text Component
comps forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
ident = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Errors
RawXML forall a b. (a -> b) -> a -> b
$ Element -> String
serializeXML Element
el
    | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Errors
UnsupportedScheme String
"appstream:" -- Could also do a 404...
reportUnsupported XDGConfig { iconCache :: XDGConfig -> IconCache
iconCache = IconCache
icondirs, componentsByMIME :: XDGConfig -> Map Text [Component]
componentsByMIME = Map Text [Component]
index } String
mime URI
_  = do
    let apps :: [App]
apps = IconCache -> Map Text [Component] -> Text -> [App]
appsForMIME IconCache
icondirs Map Text [Component]
index forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
mime
    [App]
apps' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [App]
apps forall a b. (a -> b) -> a -> b
$ \App
app -> do
        [Icon]
icons' <- [Icon] -> IO [Icon]
testLocalIcons forall a b. (a -> b) -> a -> b
$ App -> [Icon]
icons App
app
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ App
app {icons :: [Icon]
icons = [Icon]
icons'}
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> Errors
RequiresInstall String
mime forall a b. (a -> b) -> a -> b
$ [App] -> String
outputApps [App]
apps'

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

queryHandlers' :: XDGConfig -> [String] -> String -> IO [Application]
queryHandlers' :: XDGConfig -> IconCache -> String -> IO [Application]
queryHandlers' XDGConfig { handlers :: XDGConfig -> HandlersConfig
handlers = HandlersConfig
config } IconCache
locales String
mime =
    forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IconCache -> String -> IO (Maybe Application)
desktop2app IconCache
locales) (HandlersConfig -> String -> IconCache
queryHandlers HandlersConfig
config String
mime)