{-# LANGUAGE OverloadedStrings #-}
module Network.URI.XDG.MimeInfo(readMimeInfo) where

import Network.URI.Fetch (Application(..))
import Network.URI

import Text.XML as XML
import Data.Text (Text, append, unpack, pack)
import qualified Data.Map as M

import System.Environment (lookupEnv)
import System.FilePath ((</>), (<.>))
import System.Directory (doesFileExist)
import System.IO (hPrint, stderr)
import Control.Monad (forM)
import Control.Exception (catch)
import Data.Maybe (catMaybes, maybeToList, fromMaybe, mapMaybe)

import System.Directory (getHomeDirectory)

readMimeInfo :: [String] -> String -> IO Application
readMimeInfo :: [String] -> String -> IO Application
readMimeInfo [String]
locales String
mime = do
    Maybe String
dirs <- String -> IO (Maybe String)
lookupEnv String
"XDG_DATA_DIRS"
    Maybe String
homedir <- String -> IO (Maybe String)
lookupEnv String
"XDG_DATA_HOME"
    String
cwd <- IO String
getHomeDirectory
    let dirs' :: [String]
dirs' = forall {p}. (Eq p, IsString p) => p -> Maybe p -> p
fromMaybe' (String
cwd String -> String -> String
</> String
".local/share/") Maybe String
homedir forall a. a -> [a] -> [a]
:
            forall {a}. Eq a => a -> [a] -> [[a]]
split Char
':' (forall {p}. (Eq p, IsString p) => p -> Maybe p -> p
fromMaybe' String
"/usr/local/share/:/usr/share/" Maybe String
dirs)

    [Maybe Document]
files <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
dirs' forall a b. (a -> b) -> a -> b
$ \String
dir -> do
        let file :: String
file = String
dir String -> String -> String
</> String
"mime" String -> String -> String
</> String
mime String -> String -> String
<.> String
"xml"
        Bool
exists <- String -> IO Bool
doesFileExist String
file
        if Bool
exists then (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseSettings -> String -> IO Document
XML.readFile forall a. Default a => a
def String
file) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` forall {a}. XMLException -> IO (Maybe a)
handleBadXML else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a. [Maybe a] -> [a]
catMaybes [Maybe Document]
files of
        Document
file:[Document]
_ -> [String] -> String -> Element -> Application
readMimeInfo' [String]
locales String
mime forall a b. (a -> b) -> a -> b
$ Document -> Element
documentRoot Document
file
        [] -> Application {
            name :: String
name = String
mime,
            icon :: URI
icon = String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
"xdg-icon:" forall a. Maybe a
Nothing (forall {t}. Eq t => t -> t -> [t] -> [t]
replace Char
'/' Char
'-' String
mime String -> String -> String
</> String -> String
genericIcon String
mime) String
"" String
"",
            description :: String
description = String
"",
            appId :: String
appId = String
mime
          }

readMimeInfo' :: [String] -> String -> Element -> Application
readMimeInfo' [String]
locales String
mime Element
el = Application {
        name :: String
name = forall {a}. String -> Maybe a -> String -> String
readEl String
"comment" forall a. Maybe a
Nothing String
mime,
        icon :: URI
icon = URI
nullURI {
            uriScheme :: String
uriScheme = String
"xdg-icon:",
            uriPath :: String
uriPath = forall {a}. String -> Maybe a -> String -> String
readEl String
"icon" (forall a. a -> Maybe a
Just String
"name") (forall {t}. Eq t => t -> t -> [t] -> [t]
replace Char
'/' Char
'-' String
mime) String -> String -> String
</>
                forall {a}. String -> Maybe a -> String -> String
readEl String
"generic-icon" (forall a. a -> Maybe a
Just String
"name") (String -> String
genericIcon String
mime)
        },
        description :: String
description = forall {a}. String -> Maybe a -> String -> String
readEl String
"expanded-acronym" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall {a}. String -> Maybe a -> String -> String
readEl String
"acronym" forall a. Maybe a
Nothing String
mime,
        appId :: String
appId = String
mime
    }
  where
    readEl :: String -> Maybe a -> String -> String
readEl String
key Maybe a
attr String
fallback
        | (Text
val:[Text]
_) <- [Text
v | String
l <- [String]
locales forall a. [a] -> [a] -> [a]
++ [String
""], Text
v <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
l [(String, Text)]
els] = Text -> String
unpack Text
val
        | Bool
otherwise = String
fallback
      where els :: [(String, Text)]
els = forall {a}. Text -> Maybe a -> [Node] -> [(String, Text)]
readEl' (String -> Text
pack String
key) Maybe a
attr forall a b. (a -> b) -> a -> b
$ Element -> [Node]
elementNodes Element
el
    readEl' :: Text -> Maybe a -> [Node] -> [(String, Text)]
readEl' Text
key Maybe a
Nothing (NodeElement (Element Name
name Map Name Text
attrs [Node]
childs):[Node]
sibs)
        | Text
key forall a. Eq a => a -> a -> Bool
== Name -> Text
nameLocalName Name
name = (Map Name Text -> String
lang Map Name Text
attrs, [Node] -> Text
nodesText [Node]
childs) forall a. a -> [a] -> [a]
: Text -> Maybe a -> [Node] -> [(String, Text)]
readEl' Text
key forall a. Maybe a
Nothing [Node]
sibs
    readEl' Text
key attr' :: Maybe a
attr'@(Just a
attr) (NodeElement (Element Name
name Map Name Text
attrs [Node]
_):[Node]
sibs)
        | Text
key forall a. Eq a => a -> a -> Bool
== Name -> Text
nameLocalName Name
name, Just Text
val <- Text -> Maybe Text -> Maybe Text -> Name
Name Text
key Maybe Text
namespace forall a. Maybe a
Nothing forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map Name Text
attrs =
            (Map Name Text -> String
lang Map Name Text
attrs, Text
val) forall a. a -> [a] -> [a]
: Text -> Maybe a -> [Node] -> [(String, Text)]
readEl' Text
key Maybe a
attr' [Node]
sibs
    readEl' Text
key Maybe a
attr (Node
_:[Node]
sibs) = Text -> Maybe a -> [Node] -> [(String, Text)]
readEl' Text
key Maybe a
attr [Node]
sibs
    readEl' Text
_ Maybe a
_ [] = []

    namespace :: Maybe Text
namespace = forall a. a -> Maybe a
Just Text
"http://www.freedesktop.org/standards/shared-mime-info"
    lang :: Map Name Text -> String
lang = Text -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe Text
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
"{http://www.w3.org/XML/1998/namespace}lang"

+++ :: Text -> Text -> Text
(+++) = Text -> Text -> Text
append
nodesText :: [Node] -> Text
nodesText :: [Node] -> Text
nodesText (NodeElement (Element Name
_ Map Name Text
attrs [Node]
children):[Node]
nodes) = [Node] -> Text
nodesText [Node]
children Text -> Text -> Text
+++ [Node] -> Text
nodesText [Node]
nodes
nodesText (NodeContent Text
text:[Node]
nodes) = Text
text Text -> Text -> Text
+++ [Node] -> Text
nodesText [Node]
nodes
nodesText (Node
_:[Node]
nodes) = [Node] -> Text
nodesText [Node]
nodes
nodesText [] = Text
""

genericIcon :: String -> String
genericIcon String
mime = let (String
group, String
_) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') String
mime in  String
group forall a. [a] -> [a] -> [a]
++ String
"-x-generic"

handleBadXML :: XMLException -> IO (Maybe a)
handleBadXML err :: XMLException
err@(InvalidXMLFile String
_ SomeException
_) = forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr XMLException
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

fromMaybe' :: p -> Maybe p -> p
fromMaybe' p
a (Just p
"") = p
a
fromMaybe' p
_ (Just p
a) = p
a
fromMaybe' p
a Maybe p
Nothing = p
a

split :: a -> [a] -> [[a]]
split a
b (a
a:[a]
as) | a
a forall a. Eq a => a -> a -> Bool
== a
b = [] forall a. a -> [a] -> [a]
: a -> [a] -> [[a]]
split a
b [a]
as
        | ([a]
head':[[a]]
tail') <- a -> [a] -> [[a]]
split a
b [a]
as = (a
aforall a. a -> [a] -> [a]
:[a]
head') forall a. a -> [a] -> [a]
: [[a]]
tail'
        | Bool
otherwise = [a
aforall a. a -> [a] -> [a]
:[a]
as]
split a
_ [] = [[]]

replace :: t -> t -> [t] -> [t]
replace t
old t
new (t
c:[t]
cs) | t
c forall a. Eq a => a -> a -> Bool
== t
old = t
newforall a. a -> [a] -> [a]
:t -> t -> [t] -> [t]
replace t
old t
new [t]
cs
    | Bool
otherwise = t
cforall a. a -> [a] -> [a]
:t -> t -> [t] -> [t]
replace t
old t
new [t]
cs
replace t
_ t
_ [] = []