git.iko.soy/typeable/pandoc
on 4eff607 help sign in
typeable/pandoc/src/Text/Pandoc/SelfContained.hs
178 lines 7.2 kB history raw
1{-# LANGUAGE OverloadedStrings #-}
2{-
3Copyright (C) 2011-2016 John MacFarlane <jgm@berkeley.edu>
5This program is free software; you can redistribute it and/or modify
6it under the terms of the GNU General Public License as published by
7the Free Software Foundation; either version 2 of the License, or
8(at your option) any later version.
10This program is distributed in the hope that it will be useful,
11but WITHOUT ANY WARRANTY; without even the implied warranty of
12MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13GNU General Public License for more details.
15You should have received a copy of the GNU General Public License
16along with this program; if not, write to the Free Software
17Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18-}
20{- |
21 Module : Text.Pandoc.SelfContained
22 Copyright : Copyright (C) 2011-2016 John MacFarlane
23 License : GNU GPL, version 2 or above
25 Maintainer : John MacFarlane <jgm@berkeley.edu>
26 Stability : alpha
27 Portability : portable
29Functions for converting an HTML file into one that can be viewed
30offline, by incorporating linked images, CSS, and scripts into
31the HTML using data URIs.
32-}
33module Text.Pandoc.SelfContained ( makeSelfContained ) where
34import Text.HTML.TagSoup
35import Network.URI (isURI, escapeURIString, URI(..), parseURI)
36import Data.ByteString.Base64
37import qualified Data.ByteString.Char8 as B
38import Data.ByteString (ByteString)
39import System.FilePath (takeExtension, takeDirectory, (</>))
40import Data.Char (toLower, isAscii, isAlphaNum)
41import Codec.Compression.GZip as Gzip
42import qualified Data.ByteString.Lazy as L
43import Text.Pandoc.Shared (renderTags', err, fetchItem', warn, trim)
44import Text.Pandoc.MediaBag (MediaBag)
45import Text.Pandoc.MIME (MimeType)
46import Text.Pandoc.UTF8 (toString)
47import Text.Pandoc.Options (WriterOptions(..))
48import Data.List (isPrefixOf)
49import Control.Applicative ((<|>))
50import Text.Parsec (runParserT, ParsecT)
51import qualified Text.Parsec as P
52import Control.Monad.Trans (lift)
54isOk :: Char -> Bool
55isOk c = isAscii c && isAlphaNum c
57makeDataURI :: String -> ByteString -> String
58makeDataURI mime raw =
59 if textual
60 then "data:" ++ mime' ++ "," ++ escapeURIString isOk (toString raw)
61 else "data:" ++ mime' ++ ";base64," ++ toString (encode raw)
62 where textual = "text/" `Data.List.isPrefixOf` mime
63 mime' = if textual && ';' `notElem` mime
64 then mime ++ ";charset=utf-8"
65 else mime -- mime type already has charset
67convertTag :: MediaBag -> Maybe String -> Tag String -> IO (Tag String)
68convertTag media sourceURL t@(TagOpen tagname as)
69 | tagname `elem`
70 ["img", "embed", "video", "input", "audio", "source", "track"] = do
71 as' <- mapM processAttribute as
72 return $ TagOpen tagname as'
73 where processAttribute (x,y) =
74 if x == "src" || x == "href" || x == "poster"
75 then do
76 enc <- getDataURI media sourceURL (fromAttrib "type" t) y
77 return (x, enc)
78 else return (x,y)
79convertTag media sourceURL t@(TagOpen "script" as) =
80 case fromAttrib "src" t of
81 [] -> return t
82 src -> do
83 enc <- getDataURI media sourceURL (fromAttrib "type" t) src
84 return $ TagOpen "script" (("src",enc) : [(x,y) | (x,y) <- as, x /= "src"])
85convertTag media sourceURL t@(TagOpen "link" as) =
86 case fromAttrib "href" t of
87 [] -> return t
88 src -> do
89 enc <- getDataURI media sourceURL (fromAttrib "type" t) src
90 return $ TagOpen "link" (("href",enc) : [(x,y) | (x,y) <- as, x /= "href"])
91convertTag _ _ t = return t
93cssURLs :: MediaBag -> Maybe String -> FilePath -> ByteString
94 -> IO ByteString
95cssURLs media sourceURL d orig = do
96 res <- runParserT (parseCSSUrls media sourceURL d) () "css" orig
97 case res of
98 Left e -> warn ("Could not parse CSS: " ++ show e) >> return orig
99 Right bs -> return bs
101parseCSSUrls :: MediaBag -> Maybe String -> FilePath
102 -> ParsecT ByteString () IO ByteString
103parseCSSUrls media sourceURL d = B.concat <$> P.many
104 (pCSSWhite <|> pCSSComment <|> pCSSUrl media sourceURL d <|> pCSSOther)
106-- Note: some whitespace in CSS is significant, so we can't collapse it!
107pCSSWhite :: ParsecT ByteString () IO ByteString
108pCSSWhite = B.singleton <$> P.space <* P.spaces
110pCSSComment :: ParsecT ByteString () IO ByteString
111pCSSComment = P.try $ do
112 P.string "/*"
113 P.manyTill P.anyChar (P.try (P.string "*/"))
114 return B.empty
116pCSSOther :: ParsecT ByteString () IO ByteString
117pCSSOther = do
118 (B.pack <$> P.many1 (P.noneOf "u/ \n\r\t")) <|>
119 (B.singleton <$> P.char 'u') <|>
120 (B.singleton <$> P.char '/')
122pCSSUrl :: MediaBag -> Maybe String -> FilePath
123 -> ParsecT ByteString () IO ByteString
124pCSSUrl media sourceURL d = P.try $ do
125 P.string "url("
126 P.spaces
127 quote <- P.option Nothing (Just <$> P.oneOf "\"'")
128 url <- P.manyTill P.anyChar (maybe (P.lookAhead (P.char ')')) P.char quote)
129 P.spaces
130 P.char ')'
131 let fallback = B.pack ("url(" ++ maybe "" (:[]) quote ++ trim url ++
132 maybe "" (:[]) quote ++ ")")
133 case trim url of
134 '#':_ -> return fallback
135 'd':'a':'t':'a':':':_ -> return fallback
136 u -> do let url' = if isURI u then u else d </> u
137 enc <- lift $ getDataURI media sourceURL "" url'
138 return (B.pack $ "url(" ++ enc ++ ")")
141getDataURI :: MediaBag -> Maybe String -> MimeType -> String
142 -> IO String
143getDataURI _ _ _ src@('d':'a':'t':'a':':':_) = return src -- already data: uri
144getDataURI media sourceURL mimetype src = do
145 let ext = map toLower $ takeExtension src
146 fetchResult <- fetchItem' media sourceURL src
147 (raw, respMime) <- case fetchResult of
148 Left msg -> err 67 $ "Could not fetch " ++ src ++
149 "\n" ++ show msg
150 Right x -> return x
151 let raw' = if ext == ".gz"
152 then B.concat $ L.toChunks $ Gzip.decompress $ L.fromChunks
153 $ [raw]
154 else raw
155 let mime = case (mimetype, respMime) of
156 ("",Nothing) -> error
157 $ "Could not determine mime type for `" ++ src ++ "'"
158 (x, Nothing) -> x
159 (_, Just x ) -> x
160 let cssSourceURL = case parseURI src of
161 Just u
162 | uriScheme u `elem` ["http:","https:"] ->
163 Just $ show u{ uriPath = "",
164 uriQuery = "",
165 uriFragment = "" }
166 _ -> Nothing
167 result <- if mime == "text/css"
168 then cssURLs media cssSourceURL (takeDirectory src) raw'
169 else return raw'
170 return $ makeDataURI mime result
172-- | Convert HTML into self-contained HTML, incorporating images,
173-- scripts, and CSS using data: URIs.
174makeSelfContained :: WriterOptions -> String -> IO String
175makeSelfContained opts inp = do
176 let tags = parseTags inp
177 out' <- mapM (convertTag (writerMediaBag opts) (writerSourceURL opts)) tags
178 return $ renderTags' out'