{-# 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
    XDGConfig -> Map Text Component
components :: M.Map Text Component,
    XDGConfig -> Map Text [Component]
componentsByMIME :: M.Map Text [Component],
    XDGConfig -> IconCache
iconCache :: IconCache,
#endif
    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
#if WITH_APPSTREAM
    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
#else
    return $ XDGConfig handlers locales
#endif

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
#if WITH_APPSTREAM
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'
#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 :: [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