From 32909aaaf7dbcd3d9ce96d381f60f39dd4e9fc6d Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 7 Jan 2021 19:58:30 +1300 Subject: [PATCH] Various (attempted) crash fixes. --- rhapsode.cabal | 9 +-- src/Input.hs | 23 ++++--- src/Links.hs | 8 +-- src/MimeInfo.hs | 146 --------------------------------------------- src/Render.hs | 4 +- src/SpeechStyle.hs | 5 +- src/Types.hs | 12 ++-- 7 files changed, 28 insertions(+), 179 deletions(-) delete mode 100644 src/MimeInfo.hs diff --git a/rhapsode.cabal b/rhapsode.cabal index b5601f3..92a53d6 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -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 diff --git a/src/Input.hs b/src/Input.hs index 2cae0b1..1cd6a73 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -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 () diff --git a/src/Links.hs b/src/Links.hs index 2f19c61..89e6288 100644 --- a/src/Links.hs +++ b/src/Links.hs @@ -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' diff --git a/src/MimeInfo.hs b/src/MimeInfo.hs deleted file mode 100644 index 67f1a7f..0000000 --- a/src/MimeInfo.hs +++ /dev/null @@ -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 diff --git a/src/Render.hs b/src/Render.hs index 3c31794..a1a5b32 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -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" diff --git a/src/SpeechStyle.hs b/src/SpeechStyle.hs index e4af1ff..c608d52 100644 --- a/src/SpeechStyle.hs +++ b/src/SpeechStyle.hs @@ -9,8 +9,7 @@ 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(..)) +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 diff --git a/src/Types.hs b/src/Types.hs index fab1a3e..1f82b43 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 -- 2.30.2