From e042770f34bd674410ba723b236a79c14310f3ac Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 2 Jan 2021 16:13:09 +1300 Subject: [PATCH] Integrate Shared MIME Info implementation to better label rel=alternate links --- rhapsode.cabal | 2 +- src/Links.hs | 7 ++++++ src/MimeInfo.hs | 54 ++++++++++++++++++++++++++++++++++++++++------ src/SpeechStyle.hs | 4 ++++ useragent.css | 4 +++- 5 files changed, 62 insertions(+), 9 deletions(-) diff --git a/rhapsode.cabal b/rhapsode.cabal index 2375ee6..b5601f3 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -54,7 +54,7 @@ library exposed-modules: CExports, Input, Links, Render, Types -- Modules included in this library. - other-modules: SSML, SpeechStyle + other-modules: SSML, SpeechStyle, MimeInfo -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/Links.hs b/src/Links.hs index b49aa8c..2f19c61 100644 --- a/src/Links.hs +++ b/src/Links.hs @@ -9,6 +9,7 @@ import qualified Data.Text.Foreign as FTxt import Data.Maybe import Types +import MimeInfo import Foreign.StablePtr import Foreign.C.String import Foreign.Marshal.Array @@ -59,6 +60,12 @@ extractEl path el@(Element (Name "details" _ _) _ childs) = extractEl _ (Element "{https://specifications.freedesktop.org/metainfo/1.0}url" attrs childs) | Just label <- "{https://specifications.freedesktop.org/metainfo/1.0}type" `M.lookup` attrs, Just url <- parseAbsoluteURI $ unpack $ nodesText childs "" = [Link label "" url] +extractEl _ el@(Element _ attrs []) + | Just "alternae" <- "rel" `M.lookup` attrs', Just typ <- "type" `M.lookup` attrs', + Just val <- "href" `M.lookup` attrs', Just uri <- parseURIReference $ unpack val = + let Application name _ title _ = mimeInfoCached $ unpack typ + in [Link (pack name) (pack title) uri] + where attrs' = M.mapKeys nameLocalName attrs extractEl path el@(Element _ _ children) = extractElAttr el "href" ++ extractElAttr el "longdesc" ++ diff --git a/src/MimeInfo.hs b/src/MimeInfo.hs index aba3af1..67f1a7f 100644 --- a/src/MimeInfo.hs +++ b/src/MimeInfo.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module MimeInfo(readMimeInfo, mimeInfoCached) where -import Types (Application(..)) +import Network.URI.Fetch (Application(..)) import Network.URI import Text.XML as XML @@ -14,12 +14,13 @@ import System.Directory (doesFileExist) import System.IO (hPrint, stderr) import Control.Monad (forM) import Control.Exception (catch) -import Data.Maybe (catMaybes, maybeToList, fromMaybe) +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 @@ -95,12 +96,51 @@ replace _ _ [] = [] ---- Pseudo-pure, caching API -------- -mimeInfoCached :: [String] -> IO (String -> Application) -mimeInfoCached locales = do +{-# 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) + return $ \mime -> unsafePerformIO $ modifyMVar cache $ inner (pack mime) locales where - inner mime cache | Just val <- mime `Trie.lookup` cache = return (cache, val) - inner mime cache = do + 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 diff --git a/src/SpeechStyle.hs b/src/SpeechStyle.hs index 8efdf57..e4af1ff 100644 --- a/src/SpeechStyle.hs +++ b/src/SpeechStyle.hs @@ -9,6 +9,8 @@ import Data.Scientific (toRealFloat) import Data.Maybe (isJust, catMaybes, fromMaybe) import Text.Read (readMaybe) -- to parse into a more international textual representation. +import MimeInfo (mimeInfoCached) -- to correct label of rel=alternate links. +import Network.URI.Fetch as App (Application(..)) data Unit' = Unit' Text Float data SpeechStyle = SpeechStyle { @@ -196,6 +198,8 @@ parseStrings (Function "-rhaps-percentage":String num:String denom:RightParen:to frac = round (readNum num / readNum denom * 100) readNum :: Text -> Float readNum = fromMaybe (0.0) . readMaybe . unpack +parseStrings (Function "-rhaps-filetype":String mime:RightParen:toks) = + append (pack $ App.name $ mimeInfoCached $ unpack mime) <$> parseStrings toks parseStrings [] = Just "" parseStrings _ = Nothing diff --git a/useragent.css b/useragent.css index 3036a76..e00c842 100644 --- a/useragent.css +++ b/useragent.css @@ -54,7 +54,9 @@ p, pre, samp, blockquote {pause: strong; -rhaps-marker: -rhaps-paragraph} pre, address, samp {speak-as: literal-punctuation} pre, samp, code {voice: neutral 2; white-space: pre;} :link {cue-after: url(about:link.wav) !important; voice-pitch: low} -link[rel] {content: attr(rel)} link[title] {content: attr(title)} /* [title] overrides [rel] */ +link[rel] {content: attr(rel)} +link[rel=alternate][type] {content: -rhaps-filetype(attr(type))} +link[title] {content: attr(title)} /* [title] overrides [rel] */ :visited {cue-after: url(about:link.wav) -0.1db !important} img {content: "Image " attr(src)} img:lang(hu):not([alt]) {content: "kép " attr(src)} -- 2.30.2