From a3dc72fecc0c1ea5705e723c2bfe06d53d57c695 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sat, 18 Apr 2020 17:36:31 +1200 Subject: [PATCH] Refactor Rhapsode to use new HURL APIs and more leniantly handle MIMEtypes. --- bulletpoint.wav => about/bulletpoint.wav | Bin about/bulletpoint.wav.mime | 1 + link.wav => about/link.wav | Bin about/link.wav.mime | 1 + about/version | 15 +++++ about/version.mime | 1 + about/version.mime~ | 0 about/version~ | 0 rhapsode.cabal | 2 +- src/Input.hs | 80 ++++++++--------------- src/Render.hs | 29 ++++---- 11 files changed, 60 insertions(+), 69 deletions(-) rename bulletpoint.wav => about/bulletpoint.wav (100%) create mode 100644 about/bulletpoint.wav.mime rename link.wav => about/link.wav (100%) create mode 100644 about/link.wav.mime create mode 100644 about/version create mode 100644 about/version.mime create mode 100644 about/version.mime~ create mode 100644 about/version~ diff --git a/bulletpoint.wav b/about/bulletpoint.wav similarity index 100% rename from bulletpoint.wav rename to about/bulletpoint.wav diff --git a/about/bulletpoint.wav.mime b/about/bulletpoint.wav.mime new file mode 100644 index 0000000..ea44de0 --- /dev/null +++ b/about/bulletpoint.wav.mime @@ -0,0 +1 @@ +audio/vnd.wav diff --git a/link.wav b/about/link.wav similarity index 100% rename from link.wav rename to about/link.wav diff --git a/about/link.wav.mime b/about/link.wav.mime new file mode 100644 index 0000000..ea44de0 --- /dev/null +++ b/about/link.wav.mime @@ -0,0 +1 @@ +audio/vnd.wav diff --git a/about/version b/about/version new file mode 100644 index 0000000..230eea5 --- /dev/null +++ b/about/version @@ -0,0 +1,15 @@ + + + + + About Rhapsode + + +

Rhapsode version 1

+

2019–2020 © Adrian Cochrane, and others

+

Redistribution licensed under the + GNU GPLv3+. + Sound effects are + Public Domain.

+ + diff --git a/about/version.mime b/about/version.mime new file mode 100644 index 0000000..50eebc1 --- /dev/null +++ b/about/version.mime @@ -0,0 +1 @@ +application/xhtml+xml diff --git a/about/version.mime~ b/about/version.mime~ new file mode 100644 index 0000000..e69de29 diff --git a/about/version~ b/about/version~ new file mode 100644 index 0000000..e69de29 diff --git a/rhapsode.cabal b/rhapsode.cabal index d0f9deb..4a7c26a 100644 --- a/rhapsode.cabal +++ b/rhapsode.cabal @@ -64,7 +64,7 @@ library html-conduit, xml-conduit, text, containers, data-default-class, network-uri, stylist >= 1.1, css-syntax, xml-conduit-stylist, scientific, - async, hurl >= 1.2.0.0, filepath, temporary, + async, hurl >= 1.4.1.0, filepath, temporary, file-embed >= 0.0.9 && < 0.1 -- Directories containing source files. diff --git a/src/Input.hs b/src/Input.hs index dd10433..1feb41b 100644 --- a/src/Input.hs +++ b/src/Input.hs @@ -1,19 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} -module Input(fetchDocument, docForText, writeDownloadToFile) where +{-# LANGUAGE TemplateHaskell #-} +module Input(fetchDocument, docForText) where import Data.Text.Lazy (fromStrict) import qualified Data.Text as Txt import Data.Text.Encoding +import qualified Data.Text.Lazy as LTxt import qualified Data.ByteString.Lazy as B import qualified Text.HTML.DOM as HTML import qualified Text.XML as XML import Network.URI import Network.URI.Fetch +import Network.URI.Charset import qualified Data.Map as M import System.IO import System.IO.Temp import Data.Default.Class +import System.Directory +import Data.FileEmbed -- For C API import Types @@ -22,57 +27,25 @@ import Data.Maybe (fromMaybe) import Foreign.StablePtr import Foreign.C.String --- FIXME segfaults when exposed to C. ---fetchURLs session refererDoc refererURL srcs = forConcurrently srcs $ \(mime, url) -> do --- let u = relativeTo url refererURL --- let charsets' = map Txt.unpack charsets --- resp <- fetchURL session mime u --- (a, b) <- case resp of --- ("text/css", bytes) -> let --- cssParser = CSS.parseForURL (conditionalStyles u "document") u --- in return (refererDoc, cssParser $ applyCSScharset charsets' bytes) --- _ -> parseDocument session resp >>= \doc -> return (doc, H2C.html2css doc refererURL) --- return (u, a, b) +fetchDocument http mime uri = fetchURL' http mime uri >>= parseDocument http +parseDocument sess (uri, "html/x-error\t", resp) = parseDocument sess (uri, "text/html", resp) +parseDocument _ (_, "text/html", Left text) = return $ HTML.parseLT $ fromStrict text +parseDocument _ (_, "text/html", Right bytes) = return $ HTML.parseLBS bytes ---applyCSScharset (charset:charsets) (Right bytes) --- | cssCharset (CSSTok.tokenize text) == Txt.pack charset = text --- | otherwise = applyCSScharset charsets $ Right bytes --- where --- text = convertCharset charset $ B.toStrict bytes ---applyCSScharset _ (Right bytes) = convertCharset "utf-8" $ B.toStrict bytes ---applyCSScharset _ (Left text) = text ---cssCharset toks | (CSSTok.AtKeyword "charset":toks') <- skipCSSspace toks, --- (CSSTok.String charset:_) <- skipCSSspace toks' = charset --- | otherwise = "" ---skipCSSspace (CSSTok.Whitespace:toks) = skipCSSspace toks ---skipCSSspace toks = toks - -fetchDocument http mime uri = fetchURL http mime uri >>= parseDocument http -parseDocument _ ("text/html", Left text) = return $ HTML.parseLT $ fromStrict text -parseDocument _ ("text/html", Right bytes) = return $ HTML.parseLBS bytes -parseDocument _ ("text/plain", Left text) = return $ docForText text -parseDocument _ ("text/plain", Right bytes) = return $ docForText $ decodeUtf8 $ B.toStrict bytes -parseDocument _ ("application/xhtml+xml", Left text) | Right doc <- XML.parseText def $ fromStrict text = return doc - | otherwise = return $ docForText "Unreadable webpage!" -parseDocument _ ("application/xhtml+xml", Right bytes) | Right doc <- XML.parseLBS def bytes = return doc - | otherwise = return $ docForText "Unreadable webpage!" -parseDocument session (mime, download) = do - localURI <- writeDownloadToFile download - result <- dispatchByMIME session mime localURI - -- I'm not sure when I can delete this file. - case result of - Just text -> return $ docForText $ Txt.pack text - Nothing -> parseDocument session ("application/xhtml+xml", download) - -writeDownloadToFile (Left text) = do - path <- writeSystemTempFile "rhapsode-download" $ Txt.unpack text - return $ URI "file:" (Just $ URIAuth "" "" "") path "" "" - -writeDownloadToFile (Right bytes) = do - temp <- getCanonicalTemporaryDirectory - (path, handle) <- openBinaryTempFile temp "rhapsode-download" - B.hPut handle bytes - return $ URI "file:" (Just $ URIAuth "" "" "") path "" "" +parseDocument _ (_, _, Left text) + | Right doc <- XML.parseText def $ fromStrict text = return doc + | otherwise = return $ docForText text +parseDocument _ (_, _, Right bytes) | Right doc <- XML.parseLBS def bytes = return doc +parseDocument _ (_, 't':'e':'x':'t':'/':_, Right bytes) = + -- charset wasn't specified, so assume utf-8. + return $ docForText $ convertCharset "utf-8" $ B.toStrict bytes +parseDocument sess resp@(_, mime, _) = do + dir <- getCurrentDirectory -- TODO find Downloads directory. + ret <- saveDownload nullURI { + uriScheme = "file:", + uriAuthority = Just (URIAuth "" "" "") + } dir resp >>= dispatchByMIME sess mime + return $ HTML.parseLT $ LTxt.pack $ fromMaybe "Unsupported filetype" ret docForText txt = XML.Document { XML.documentPrologue = XML.Prologue [] Nothing [], @@ -90,7 +63,10 @@ docForText txt = XML.Document { foreign export ccall c_newSession :: IO (StablePtr Session) foreign export ccall c_freeSession :: StablePtr Session -> IO () -c_newSession = newSession >>= newStablePtr +c_newSession = do + sess <- newSession + newStablePtr $ sess {aboutPages = map lazify $(embedDir "about")} + where lazify (a, b) = (a, B.fromStrict b) c_freeSession = freeStablePtr diff --git a/src/Render.hs b/src/Render.hs index b93dbe0..a6298d8 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -24,11 +24,11 @@ import Network.URI.Charset import Data.List (nub, elem) import Control.Concurrent.Async (forConcurrently) import System.IO.Temp +import Control.Exception (catch) -- Internal Rhapsode Subcomponents import StyleTree import SSML -import Input (writeDownloadToFile) -- C API import Types @@ -121,21 +121,18 @@ instance CSS.StyleSheet StyleAssets where ) downloadAssets session mimes (StyleAssets _ assets) = do - -- FIXME delete these temp files. - localUris <- forConcurrently assets (\uri -> - fetchURL' session mimes uri >>= saveAsset mimes) - return $ zip assets [uri {uriScheme = "", uriAuthority = Nothing} | uri <- localUris] - --- variant of HURL fetchURL which includes about:link.wav & about:bullet-point.wav -fetchURL' _ _ (URI "about:" Nothing "link.wav" _ _) = - return ("audio/vnd.wav", Right $ B.fromStrict $(embedFile "link.wav")) -fetchURL' _ _ (URI "about:" Nothing "bulletpoint.wav" _ _) = - return ("audio/vnd.wav", Right $ B.fromStrict $(embedFile "bulletpoint.wav")) -fetchURL' s m u = fetchURL s m u - -saveAsset mimes (mime, download) - | mime `notElem` mimes = return nullURI - | otherwise = writeDownloadToFile download + dir <- Dir.getXdgDirectory Dir.XdgCache "rhapsode" + Dir.removeDirectoryRecursive dir `catch` ignoreError -- Clear cache. + Dir.createDirectoryIfMissing True dir + + fetchURLs session mimes assets $ filterMIMEs mimes $ saveDownload nullURI dir + where + ignoreError :: IOError -> IO () + ignoreError _ = return () + +filterMIMEs mimes cb download@(_, mime, _) + | mime `elem` mimes = cb download + | otherwise = return nullURI rewritePropertyVal rewrites (CSSTok.Url text:vals) | Just uri <- parseURIReference $ Txt.unpack text, Just rewrite <- uri `M.lookup` rewrites = -- 2.30.2