{-# LANGUAGE OverloadedStrings #-}
module MimeInfo(readMimeInfo, mimeInfoCached) where
import Types (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)
import qualified Data.Trie.Text as Trie
import Data.Trie.Text (Trie)
import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)
import System.IO.Unsafe (unsafePerformIO)
readMimeInfo :: [String] -> String -> IO Application
readMimeInfo locales mime = do
dirs <- lookupEnv "XDG_DATA_DIRS"
homedir <- lookupEnv "XDG_DATA_HOME"
let dirs' = fromMaybe' "~/.local/share/" homedir :
split ':' (fromMaybe' "/usr/local/share/:/usr/share/" dirs)
files <- forM dirs' $ \dir -> do
let file = dir </> mime <.> "xml"
exists <- doesFileExist file
if exists then (Just <$> XML.readFile def file) `catch` handleBadXML else return Nothing
return $ case catMaybes files of
file:_ -> readMimeInfo' locales mime $ documentRoot file
[] -> Application {
name = mime,
icon = URI "xdg-icon:" Nothing (replace '/' '-' mime </> genericIcon mime) "" "",
description = "",
appId = mime
}
readMimeInfo' locales mime el = Application {
name = readEl "comment" Nothing mime,
icon = nullURI {
uriScheme = "xdg-icon:",
uriPath = readEl "icon" (Just "name") (replace '/' '-' mime) </>
readEl "generic-icon" (Just "name") (genericIcon mime)
},
description = readEl "expanded-acronym" Nothing $ readEl "acronym" Nothing mime,
appId = mime
}
where
readEl key attr fallback
| (val:_) <- [v | l <- locales ++ [""], v <- maybeToList $ lookup key els] = unpack val
| otherwise = fallback
where els = readEl' (pack key) attr $ elementNodes el
readEl' key Nothing (NodeElement (Element name attrs childs):sibs)
| key == nameLocalName name = (lang attrs, nodesText childs) : readEl' key Nothing sibs
readEl' key attr'@(Just attr) (NodeElement (Element name attrs _):sibs)
| key == nameLocalName name, Just val <- Name key namespace Nothing `M.lookup` attrs =
(lang attrs, val) : readEl' key attr' sibs
readEl' key attr (_:sibs) = readEl' key attr sibs
readEl' _ _ [] = []
namespace = Just "http://www.freedesktop.org/standards/shared-mime-info"
lang = unpack . fromMaybe "" . M.lookup "{http://www.w3.org/XML/1998/namespace}lang"
(+++) = append
nodesText :: [Node] -> Text
nodesText (NodeElement (Element _ attrs children):nodes) = nodesText children +++ nodesText nodes
nodesText (NodeContent text:nodes) = text +++ nodesText nodes
nodesText (_:nodes) = nodesText nodes
nodesText [] = ""
genericIcon mime = let (group, _) = break (== '/') mime in group ++ "-x-generic"
handleBadXML err@(InvalidXMLFile _ _) = hPrint stderr err >> return Nothing
fromMaybe' a (Just "") = a
fromMaybe' _ (Just a) = a
fromMaybe' a Nothing = a
split b (a:as) | a == b = [] : split b as
| (head':tail') <- split b as = (a:head') : tail'
split _ [] = [[]]
replace old new (c:cs) | c == old = new:replace old new cs
| otherwise = c:replace old new cs
replace _ _ [] = []
--------
---- Pseudo-pure, caching API
--------
mimeInfoCached :: [String] -> IO (String -> Application)
mimeInfoCached locales = do
cache <- newMVar Trie.empty :: IO (MVar (Trie Application))
return $ \mime -> unsafePerformIO $ modifyMVar cache $ inner (pack mime)
where
inner mime cache | Just val <- mime `Trie.lookup` cache = return (cache, val)
inner mime cache = do
ret <- readMimeInfo locales $ unpack mime
return (Trie.insert mime ret cache, ret)