{-# LANGUAGE OverloadedStrings #-}
module MimeInfo(readMimeInfo, mimeInfoCached) 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 qualified Data.Trie.Text as Trie
import Data.Trie.Text (Trie)
import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)
import System.IO.Unsafe (unsafePerformIO)
import Data.Char (toLower)
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
--------
{-# NOINLINE mimeInfoCached #-}
mimeInfoCached :: String -> Application
mimeInfoCached = unsafePerformIO $ do
(locales, _) <- rfc2616Locale
cache <- newMVar Trie.empty :: IO (MVar (Trie Application))
return $ \mime -> unsafePerformIO $ modifyMVar cache $ inner (pack mime) locales
where
inner mime _ cache | Just val <- mime `Trie.lookup` cache = return (cache, val)
inner mime locales cache = do
ret <- readMimeInfo locales $ unpack mime
return (Trie.insert mime ret cache, ret)
--------
---- Locales
--------
rfc2616Locale :: IO ([String], [String])
rfc2616Locale = do
locales <- forM ["LANGUAGE", "LC_ALL", "LC_MESSAGES", "LANG"] lookupEnv
let posix = split ':' $ firstJust locales "en_US"
let ietf = mapMaybe toRFC2616Lang posix
return (explode ietf, explode posix)
toRFC2616Lang "C" = Nothing
toRFC2616Lang ('C':'.':_) = Nothing
toRFC2616Lang ('C':'@':_) = Nothing
toRFC2616Lang lang = case toRFC2616Lang' lang of
"" -> Nothing
lang' -> Just lang'
toRFC2616Lang' ('_':cs) = '-' : toRFC2616Lang' cs
toRFC2616Lang' ('.':_) = []
toRFC2616Lang' ('@':_) = []
toRFC2616Lang' (c:cs) = toLower c : toRFC2616Lang' cs
toRFC2616Lang' [] = []
-- Makes sure to include the raw languages, and not just localized variants.
extractLangs :: [String] -> [String]
extractLangs (locale:locales) | (lang:_) <- split '-' locale = lang : extractLangs locales
extractLangs (_:locales) = extractLangs locales
extractLangs [] = []
explode :: [String] -> [String]
explode locales = locales ++ [l | l <- extractLangs locales, l `notElem` locales]
firstJust (Just a:_) _ | a /= "" = a
firstJust (_:maybes) fallback = firstJust maybes fallback
firstJust [] fallback = fallback