~alcinnz/rhapsode

e042770f34bd674410ba723b236a79c14310f3ac — Adrian Cochrane 3 years ago 5d89018
Integrate Shared MIME Info implementation to better label rel=alternate links
5 files changed, 62 insertions(+), 9 deletions(-)

M rhapsode.cabal
M src/Links.hs
M src/MimeInfo.hs
M src/SpeechStyle.hs
M useragent.css
M rhapsode.cabal => rhapsode.cabal +1 -1
@@ 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:    

M src/Links.hs => src/Links.hs +7 -0
@@ 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" ++

M src/MimeInfo.hs => src/MimeInfo.hs +47 -7
@@ 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

M src/SpeechStyle.hs => src/SpeechStyle.hs +4 -0
@@ 9,6 9,8 @@ import Data.Scientific (toRealFloat)
import Data.Maybe (isJust, catMaybes, fromMaybe)

import Text.Read (readMaybe) -- to parse <progress> 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


M useragent.css => useragent.css +3 -1
@@ 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)}