{-# 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 _ [] = []