{-# 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' = String -> Maybe String -> String
forall p. (Eq p, IsString p) => p -> Maybe p -> p
fromMaybe' (String
cwd String -> String -> String
</> String
".local/share/") Maybe String
homedir String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
            Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
split Char
':' (String -> Maybe String -> String
forall p. (Eq p, IsString p) => p -> Maybe p -> p
fromMaybe' String
"/usr/local/share/:/usr/share/" Maybe String
dirs)

    [Maybe Document]
files <- [String] -> (String -> IO (Maybe Document)) -> IO [Maybe Document]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
dirs' ((String -> IO (Maybe Document)) -> IO [Maybe Document])
-> (String -> IO (Maybe Document)) -> IO [Maybe Document]
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 (Document -> Maybe Document
forall a. a -> Maybe a
Just (Document -> Maybe Document) -> IO Document -> IO (Maybe Document)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseSettings -> String -> IO Document
XML.readFile ParseSettings
forall a. Default a => a
def String
file) IO (Maybe Document)
-> (XMLException -> IO (Maybe Document)) -> IO (Maybe Document)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` XMLException -> IO (Maybe Document)
forall a. XMLException -> IO (Maybe a)
handleBadXML else Maybe Document -> IO (Maybe Document)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Document
forall a. Maybe a
Nothing

    Application -> IO Application
forall (m :: * -> *) a. Monad m => a -> m a
return (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ case [Maybe Document] -> [Document]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Document]
files of
        Document
file:[Document]
_ -> [String] -> String -> Element -> Application
readMimeInfo' [String]
locales String
mime (Element -> Application) -> Element -> Application
forall a b. (a -> b) -> a -> b
$ Document -> Element
documentRoot Document
file
        [] -> Application :: String -> URI -> String -> String -> Application
Application {
            name :: String
name = String
mime,
            icon :: URI
icon = String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
"xdg-icon:" Maybe URIAuth
forall a. Maybe a
Nothing (Char -> Char -> String -> String
forall a. Eq a => a -> a -> [a] -> [a]
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 :: String -> URI -> String -> String -> Application
Application {
        name :: String
name = String -> Maybe Any -> String -> String
forall a. String -> Maybe a -> String -> String
readEl String
"comment" Maybe Any
forall a. Maybe a
Nothing String
mime,
        icon :: URI
icon = URI
nullURI {
            uriScheme :: String
uriScheme = String
"xdg-icon:",
            uriPath :: String
uriPath = String -> Maybe String -> String -> String
forall a. String -> Maybe a -> String -> String
readEl String
"icon" (String -> Maybe String
forall a. a -> Maybe a
Just String
"name") (Char -> Char -> String -> String
forall a. Eq a => a -> a -> [a] -> [a]
replace Char
'/' Char
'-' String
mime) String -> String -> String
</>
                String -> Maybe String -> String -> String
forall a. String -> Maybe a -> String -> String
readEl String
"generic-icon" (String -> Maybe String
forall a. a -> Maybe a
Just String
"name") (String -> String
genericIcon String
mime)
        },
        description :: String
description = String -> Maybe Any -> String -> String
forall a. String -> Maybe a -> String -> String
readEl String
"expanded-acronym" Maybe Any
forall a. Maybe a
Nothing (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> Maybe Any -> String -> String
forall a. String -> Maybe a -> String -> String
readEl String
"acronym" Maybe Any
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
""], Text
v <- Maybe Text -> [Text]
forall a. Maybe a -> [a]
maybeToList (Maybe Text -> [Text]) -> Maybe Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> [(String, Text)] -> Maybe Text
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 = Text -> Maybe a -> [Node] -> [(String, Text)]
forall a. Text -> Maybe a -> [Node] -> [(String, Text)]
readEl' (String -> Text
pack String
key) Maybe a
attr ([Node] -> [(String, Text)]) -> [Node] -> [(String, Text)]
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 Text -> Text -> Bool
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) (String, Text) -> [(String, Text)] -> [(String, Text)]
forall a. a -> [a] -> [a]
: Text -> Maybe a -> [Node] -> [(String, Text)]
readEl' Text
key Maybe a
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 Text -> Text -> Bool
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 Maybe Text
forall a. Maybe a
Nothing Name -> Map Name Text -> Maybe Text
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) (String, Text) -> [(String, Text)] -> [(String, Text)]
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 = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://www.freedesktop.org/standards/shared-mime-info"
    lang :: Map Name Text -> String
lang = Text -> String
unpack (Text -> String)
-> (Map Name Text -> Text) -> Map Name Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text)
-> (Map Name Text -> Maybe Text) -> Map Name Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Map Name Text -> Maybe Text
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
_) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') String
mime in  String
group String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-x-generic"

handleBadXML :: XMLException -> IO (Maybe a)
handleBadXML err :: XMLException
err@(InvalidXMLFile String
_ SomeException
_) = Handle -> XMLException -> IO ()
forall a. Show a => Handle -> a -> IO ()
hPrint Handle
stderr XMLException
err IO () -> IO (Maybe a) -> IO (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b = [] [a] -> [[a]] -> [[a]]
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
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
head') [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
tail'
        | Bool
otherwise = [a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as]
split a
_ [] = [[]]

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