From 6d7fb3907be08d85c949a63a0da58302ba5e26d2 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Tue, 5 Jan 2021 20:56:43 +1300 Subject: [PATCH] Upstream code for localizing filetype labels! --- hurl.cabal | 5 +- src/Network/MIME/Info.hs | 38 ++++++++++++++ src/Network/URI/XDG/MimeInfo.hs | 88 +++++++++++++++++++++++++++++++++ 3 files changed, 129 insertions(+), 2 deletions(-) create mode 100644 src/Network/MIME/Info.hs create mode 100644 src/Network/URI/XDG/MimeInfo.hs 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 _ _ [] = [] -- 2.30.2