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

@@ 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:    

@@ 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" ++

@@ 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

@@ 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
 

@@ 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)}