3 files changed, 129 insertions(+), 2 deletions(-)

M hurl.cabal
A src/Network/MIME/Info.hs
A src/Network/URI/XDG/MimeInfo.hs

@@ 92,7 92,7 @@ library
   exposed-modules:     Network.URI.Charset, Network.URI.Fetch
   
   -- Modules included in this library but not exported.
-  other-modules:       Network.URI.Locale, Network.URI.Messages, Network.URI.Types
+  other-modules:       Network.URI.Locale, Network.URI.Messages, Network.URI.Types, Network.MIME.Info
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    


@@ 127,7 127,8 @@ library
   if flag(freedesktop)
     CPP-options:   -DWITH_XDG
     build-depends: process >= 1.2 && <2.0
-    other-modules: Network.URI.XDG.Ini, Network.URI.XDG.MimeApps, Network.URI.XDG.DesktopEntry, Network.URI.XDG
+    other-modules: Network.URI.XDG.Ini, Network.URI.XDG.MimeApps,
+        Network.URI.XDG.DesktopEntry, Network.URI.XDG.MimeInfo, Network.URI.XDG
   if flag(freedesktop) && flag(appstream)
     CPP-options:   -DWITH_APPSTREAM
     build-depends: xml-conduit >=1.8, zlib >= 0.6 && < 0.7, containers

@@ 0,0 1,38 @@
+{-# LANGUAGE CPP #-}
+module Network.MIME.Info(mimeInfo, MIME(..)) where
+
+#ifdef WITH_XDG
+import Network.URI.XDG.MimeInfo (readMimeInfo)
+#endif
+import Network.URI.Locale (rfc2616Locale)
+import Network.URI.Types (Application(..))
+
+import qualified Data.Map as M
+import Control.Concurrent.MVar (MVar, newMVar, readMVar, putMVar)
+import System.IO.Unsafe (unsafePerformIO)
+import Data.Char (toLower)
+
+type MIME = Application
+
+{-# NOINLINE mimeInfo #-}
+mimeInfo :: String -> MIME
+mimeInfo = unsafePerformIO $ do
+    (locales, _) <- rfc2616Locale
+    cache <- newMVar M.empty :: IO (MVar (M.Map String MIME))
+    return $ \mime -> unsafePerformIO $ do
+        readMVar cache >>= inner mime locales cache
+  where
+    inner mime _ _ cache | Just val <- mime `M.lookup` cache = return val
+    inner mime locales cache' cache = do
+        ret <- readMimeInfo locales mime
+        putMVar cache' $ M.insert mime ret cache
+        return ret
+
+#ifndef WITH_XDG
+readMimeInfo _ mime = return Application {
+        name = mime,
+        icon = URI "about:" Nothing "invalid" "" "",
+        description = "",
+        appId = mime
+    }
+#endif

@@ 0,0 1,88 @@
+{-# 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)
+
+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'
+        | otherwise = [a:as]
+split _ [] = [[]]
+
+replace old new (c:cs) | c == old = new:replace old new cs
+    | otherwise = c:replace old new cs
+replace _ _ [] = []