R bulletpoint.wav => about/bulletpoint.wav +0 -0
A about/bulletpoint.wav.mime => about/bulletpoint.wav.mime +1 -0
@@ 0,0 1,1 @@
+audio/vnd.wav
R link.wav => about/link.wav +0 -0
A about/link.wav.mime => about/link.wav.mime +1 -0
@@ 0,0 1,1 @@
+audio/vnd.wav
A about/version => about/version +15 -0
@@ 0,0 1,15 @@
+<?xml version="1.0" encoding="utf-8"?>
+<html>
+<head>
+ <meta charset="utf-8" />
+ <title>About Rhapsode</title>
+</head>
+<body>
+ <h1><a href="https://rhapsode.adrian.geek.nz/" title="Homepage">Rhapsode</a> version 1</h1>
+ <p>2019–2020 © <a href="https://adrian.geek.nz/" title="Author">Adrian Cochrane</a>, and others</p>
+ <p>Redistribution licensed under the
+ <a href="https://www.gnu.org/licenses/gpl-3.0-standalone.html" title="License">GNU GPLv3+</a>.
+ Sound effects are
+ <a href="https://www.copyrightlaws.com/what-is-the-public-domain/" title="Sound effects">Public Domain</a>.</p>
+</body>
+</html>
A about/version.mime => about/version.mime +1 -0
@@ 0,0 1,1 @@
+application/xhtml+xml
A about/version.mime~ => about/version.mime~ +0 -0
A about/version~ => about/version~ +0 -0
M rhapsode.cabal => rhapsode.cabal +1 -1
@@ 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.
M src/Input.hs => src/Input.hs +28 -52
@@ 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
M src/Render.hs => src/Render.hs +13 -16
@@ 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 =