summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAdrian Cochrane <adrian@openwork.nz>2021-01-05 20:56:43 +1300
committerAdrian Cochrane <adrian@openwork.nz>2021-01-05 20:56:43 +1300
commit6d7fb3907be08d85c949a63a0da58302ba5e26d2 (patch)
tree9e1f830800aa56512d51ad4700999f0a9d125074
parente08dc01d58062b8794982e605d66e22886e28221 (diff)
downloadhurl-6d7fb3907be08d85c949a63a0da58302ba5e26d2.tar.gz
hurl-6d7fb3907be08d85c949a63a0da58302ba5e26d2.tar.bz2
hurl-6d7fb3907be08d85c949a63a0da58302ba5e26d2.zip
Upstream code for localizing filetype labels!
-rw-r--r--hurl.cabal5
-rw-r--r--src/Network/MIME/Info.hs38
-rw-r--r--src/Network/URI/XDG/MimeInfo.hs88
3 files changed, 129 insertions, 2 deletions
diff --git a/hurl.cabal b/hurl.cabal
index cb825fa..08789ff 100644
--- a/hurl.cabal
+++ b/hurl.cabal
@@ -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
diff --git a/src/Network/MIME/Info.hs b/src/Network/MIME/Info.hs
new file mode 100644
index 0000000..5ff9514
--- /dev/null
+++ b/src/Network/MIME/Info.hs
@@ -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
diff --git a/src/Network/URI/XDG/MimeInfo.hs b/src/Network/URI/XDG/MimeInfo.hs
new file mode 100644
index 0000000..0e7f399
--- /dev/null
+++ b/src/Network/URI/XDG/MimeInfo.hs
@@ -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 _ _ [] = []