7 files changed, 28 insertions(+), 179 deletions(-)

M rhapsode.cabal
M src/Input.hs
M src/Links.hs
D src/MimeInfo.hs
M src/Render.hs
M src/SpeechStyle.hs
M src/Types.hs

@@ 54,18 54,19 @@ library
   exposed-modules: CExports, Input, Links, Render, Types
   
   -- Modules included in this library.
-  other-modules:       SSML, SpeechStyle, MimeInfo
+  other-modules:       SSML, SpeechStyle
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
   
   -- Other library packages from which modules are imported.
-  build-depends:       base >=4.9 && <=4.12, directory, bytestring,
+  build-depends:       base >=4.9 && <=4.12, directory >= 1.3.2, bytestring,
         html-conduit, xml-conduit, text, containers, data-default-class,
         network-uri,
         stylist >= 2.4 && <3, css-syntax, xml-conduit-stylist >= 2.3 && <3, scientific,
-        async, hurl >= 1.5, filepath, temporary,
-        file-embed >= 0.0.9 && < 0.1, time, text-trie >= 0.2.5, parallel >= 1
+        async, hurl >= 2, filepath, temporary,
+        file-embed >= 0.0.9 && < 0.1, time,
+        text-trie >= 0.2.5, parallel >= 1, strict >= 0.4
   
   -- Directories containing source files.
   hs-source-dirs:      src

@@ 32,7 32,6 @@ import Data.FileEmbed
 
 -- For history
 import qualified Data.Trie.Text as Trie
-import Control.Concurrent.MVar
 
 -- For C API
 import Types


@@ 53,8 52,8 @@ fetchDocument http referer mime URI { uriScheme = "app:", uriPath = appID } = do
     return referer -- TODO play an error or success sound
 fetchDocument http referer mime uri = fetchURL' http mime uri >>= parseDocument' referer http
 
-parseDocument' ref sess resp@(_, mime, _) = do
-    page <- parseDocument ref sess resp >>= logHistory
+parseDocument' ref@Page {visitedURLs = hist} sess resp@(_, mime, _) = do
+    page <- parseDocument ref sess resp >>= logHistory hist
     apps' <- appsForMIME sess mime
     return $ attachHistory $ page { pageMIME = mime, apps = apps' }
   where


@@ 134,24 133,21 @@ pageForDoc uri doc = do
             if not hasAltStyle then authorStyle else
                 parse (conditionalStyles uri "document") <$> Txt.readFile path
 
-    hist <- newEmptyMVar
     return Page {Types.url = uri, html = doc, css = styles,
         -- These fields are all blank, to be filled in later by logHistory & parseDocument'
         pageTitle = "", pageMIME = "", apps = [],
-        backStack = [], forwardStack = [], visitedURLs = hist}
+        backStack = [], forwardStack = [], visitedURLs = Trie.empty}
 
-logHistory ret@Page {Types.url = url', html = doc, visitedURLs = hist} = do
+logHistory hist ret@Page {Types.url = url', html = doc} = do
     dir <- getXdgDirectory XdgData "rhapsode"
     createDirectoryIfMissing True dir
     now <- getCurrentTime
     let title = Txt.unpack $ getTitle $ XML.documentRoot doc
-    appendFile (dir </> "history.gmni") $ intercalate " " [
+    appendFile (dir </> "history.gmni") $ '\n' : intercalate " " [
         "=>", uriToStr' url', show now, title
       ]
 
-    modifyMVar_ hist $ return . Trie.insert (Txt.pack $ uriToStr' url') ()
-
-    return ret { pageTitle = title, visitedURLs = hist }
+    return ret { pageTitle = title, visitedURLs = Trie.insert (Txt.pack $ uriToStr' url') () hist}
   where
     getTitle (XML.Element "title" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs]
     getTitle (XML.Element "h1" _ childs) = Txt.concat [txt | XML.NodeContent txt <- childs]


@@ 264,9 260,12 @@ c_fetchURL c_session c_mimes c_referer c_uri = do
     doc <- fetchDocument session referer (words mimes) uri'
     newStablePtr doc
 
-foreign export ccall c_enableLogging :: StablePtr Session -> IO ()
+foreign export ccall c_enableLogging :: StablePtr Session -> IO (StablePtr Session)
 
-c_enableLogging c_session = deRefStablePtr c_session >>= enableLogging
+c_enableLogging c_session = do
+    ret <- deRefStablePtr c_session >>= enableLogging
+    freeStablePtr c_session
+    newStablePtr ret
 
 foreign export ccall c_writeLog :: CString -> StablePtr Session -> IO ()
 

@@ 3,13 3,13 @@ module Links(extractLinks, linkToText, Link(..), c_extractLinks) where
 
 import Text.XML
 import qualified Data.Map as M
+import Network.MIME.Info as MIME
 import Network.URI
 import Data.Text (Text, unpack, append, pack, replace, strip)
 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


@@ 24,7 24,6 @@ import System.IO (hPrint, stderr) -- For error reporting
 import Data.Trie.Text (Trie)
 import qualified Data.Trie.Text as Trie
 import Data.List (nub, intercalate)
-import Control.Concurrent.MVar (readMVar)
 import Control.Concurrent (forkIO)
 
 data Link = Link {


@@ 140,7 139,6 @@ readBookmarks = do
 -- Hopefully this'll help surfers rely less on YouTube, et al's hueristics.
 updateSuggestions :: Page -> IO ()
 updateSuggestions page = do
-    hist <- readMVar $ visitedURLs page
     let links = extractLinks $ html page
     let domain = maybe "" show $ uriAuthority $ url page
 


@@ 149,10 147,10 @@ updateSuggestions page = do
     exists <- doesFileExist path
     suggestions <- if not exists then return [] else do
         file <- Prelude.readFile path
-        return [line' | line <- lines file, line'@(_:uri':_) <- [words line], not (pack uri' `Trie.member` hist)]
+        return [line' | line <- lines file, line'@(_:uri':_) <- [words line], not (pack uri' `Trie.member` visitedURLs page)]
 
     let suggestions' = suggestions ++ nub [["=>", uri', domain] | link <- links,
-            let uri' = uriToString id (href link) "", not (pack uri' `Trie.member` hist)]
+            let uri' = uriToString id (href link) "", not (pack uri' `Trie.member` visitedURLs page)]
 
     createDirectoryIfMissing True dir
     Prelude.writeFile path $ unlines $ map unwords suggestions'

@@ 1,146 0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module MimeInfo(readMimeInfo, mimeInfoCached) 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)
-
-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
-    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'
-split _ [] = [[]]
-
-replace old new (c:cs) | c == old = new:replace old new cs
-    | otherwise = c:replace old new cs
-replace _ _ [] = []
-
---------
----- Pseudo-pure, caching API
---------
-
-{-# 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) locales
-  where
-    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

@@ 38,7 38,6 @@ import           Control.Exception (catch)
 --- For psuedoclasses
 import qualified Data.Trie.Text as Trie
 import qualified Data.CSS.Syntax.Selector as CSSSel
-import Control.Concurrent.MVar (readMVar)
 
 -- Internal Rhapsode Subcomponents
 import SpeechStyle


@@ 166,9 165,8 @@ foreign export ccall c_renderDoc :: StablePtr Session -> StablePtr Page -> Bool 
 c_renderDoc c_session c_page rewriteURLs = do
     session <- deRefStablePtr c_session
     page <- deRefStablePtr c_page
-    hist <- readMVar $ visitedURLs page
     css' <- retreiveStyles session $ css page
-    let pseudoFilter = rhapsodePseudoFilter (Types.url page) hist
+    let pseudoFilter = rhapsodePseudoFilter (Types.url page) $ visitedURLs page
     qCSS <- if rewriteURLs then do
         assets <- downloadAssets session [
                 "audio/vnd.wav"

@@ 9,8 9,7 @@ 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(..))
+import Network.MIME.Info as MIME
 
 data Unit' = Unit' Text Float
 data SpeechStyle = SpeechStyle {


@@ 199,7 198,7 @@ parseStrings (Function "-rhaps-percentage":String num:String denom:RightParen:to
     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
+    append (pack $ MIME.name $ mimeInfo $ unpack mime) <$> parseStrings toks
 parseStrings [] = Just ""
 parseStrings _ = Nothing
 

@@ 14,10 14,10 @@ import Network.URI.Fetch (Application(..))
 import Data.Trie.Text (Trie)
 import qualified Data.Text as Txt
 import qualified Data.Trie.Text as Trie
-import Control.Concurrent.MVar
 import System.Directory
 import System.FilePath ((</>))
 import Control.Parallel (par)
+import qualified System.IO.Strict as Strict
 
 import Foreign.Ptr
 import Foreign.StablePtr


@@ 34,22 34,22 @@ data Page = Page {
     backStack :: [(String, URI)],
     forwardStack :: [(String, URI)],
     -- Probably don't need an MVar here, but let's be safe!
-    visitedURLs :: MVar (Trie ())
+    visitedURLs :: Trie ()
 }
 
 foreign export ccall c_initialReferer :: IO (StablePtr Page)
 
-loadVisited :: IO (MVar (Trie ()))
+loadVisited :: IO (Trie ())
 loadVisited = do
     dir <- getXdgDirectory XdgData "rhapsode"
     let path = dir </> "history.gmni"
     exists <- doesFileExist path
 
     if exists then do
-        file <- Prelude.readFile path
+        file <- Strict.readFile path -- Can't leave this file locked when I'll shortly append to it!
         let hist = Trie.fromList [(Txt.pack uri, ()) | _:uri:_ <- map words $ lines file]
-        hist `par` newMVar hist
-    else newMVar Trie.empty
+        hist `par` return hist
+    else return Trie.empty
 
 c_initialReferer = do
     cwd <- getCurrentDirectory