{-# 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
    XDGConfig -> IO XDGConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (XDGConfig -> IO XDGConfig) -> XDGConfig -> IO XDGConfig
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 IconCache -> (String -> IO (Maybe String)) -> IO (Maybe String)
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 -> Errors -> IO Errors
forall (m :: * -> *) a. Monad m => a -> m a
return (Errors -> IO Errors) -> Errors -> IO Errors
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 (Text -> Maybe Element) -> Text -> Maybe Element
forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
ident = Errors -> IO Errors
forall (m :: * -> *) a. Monad m => a -> m a
return (Errors -> IO Errors) -> Errors -> IO Errors
forall a b. (a -> b) -> a -> b
$ String -> Errors
RawXML (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ Element -> String
serializeXML Element
el
    | Bool
otherwise = Errors -> IO Errors
forall (m :: * -> *) a. Monad m => a -> m a
return (Errors -> IO Errors) -> Errors -> IO Errors
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 (Text -> [App]) -> Text -> [App]
forall a b. (a -> b) -> a -> b
$ String -> Text
Txt.pack String
mime
    [App]
apps' <- [App] -> (App -> IO App) -> IO [App]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [App]
apps ((App -> IO App) -> IO [App]) -> (App -> IO App) -> IO [App]
forall a b. (a -> b) -> a -> b
$ \App
app -> do
        [Icon]
icons' <- [Icon] -> IO [Icon]
testLocalIcons ([Icon] -> IO [Icon]) -> [Icon] -> IO [Icon]
forall a b. (a -> b) -> a -> b
$ App -> [Icon]
icons App
app
        App -> IO App
forall (m :: * -> *) a. Monad m => a -> m a
return (App -> IO App) -> App -> IO App
forall a b. (a -> b) -> a -> b
$ App
app {icons :: [Icon]
icons = [Icon]
icons'}
    Errors -> IO Errors
forall (m :: * -> *) a. Monad m => a -> m a
return (Errors -> IO Errors) -> Errors -> IO Errors
forall a b. (a -> b) -> a -> b
$ String -> String -> Errors
RequiresInstall String
mime (String -> Errors) -> String -> Errors
forall a b. (a -> b) -> a -> b
$ [App] -> String
outputApps [App]
apps'

mapFirstM :: [a] -> (a -> IO (Maybe b)) -> IO (Maybe b)
mapFirstM :: [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
_ -> Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
item
        Maybe b
Nothing -> [a] -> (a -> IO (Maybe b)) -> IO (Maybe b)
forall a b. [a] -> (a -> IO (Maybe b)) -> IO (Maybe b)
mapFirstM [a]
xs a -> IO (Maybe b)
cb
mapFirstM [] a -> IO (Maybe b)
_ = Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
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 =
    [Maybe Application] -> [Application]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Application] -> [Application])
-> IO [Maybe Application] -> IO [Application]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe Application))
-> IconCache -> IO [Maybe Application]
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)