git.iko.soy/typeable/pandoc
on 34412cf help sign in
typeable/pandoc/src/Text/Pandoc/SelfContained.hs
231 lines 9.5 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 Codec.Compression.GZip as Gzip
35import Control.Applicative ((<|>))
36import Control.Monad.Except (throwError)
37import Control.Monad.Trans (lift)
38import Data.ByteString (ByteString)
39import Data.ByteString.Base64
40import qualified Data.ByteString.Char8 as B
41import qualified Data.ByteString.Lazy as L
42import Data.Char (isAlphaNum, isAscii, toLower)
43import Data.List (isPrefixOf)
44import Network.URI (URI (..), escapeURIString, isURI, parseURI)
45import System.FilePath (takeDirectory, takeExtension, (</>))
46import Text.HTML.TagSoup
47import Text.Pandoc.Class (PandocMonad (..), fetchItem, report)
48import Text.Pandoc.Error
49import Text.Pandoc.Logging
50import Text.Pandoc.MIME (MimeType)
51import Text.Pandoc.Options (WriterOptions (..))
52import Text.Pandoc.Shared (renderTags', trim)
53import Text.Pandoc.UTF8 (toString)
54import Text.Parsec (ParsecT, runParserT)
55import qualified Text.Parsec as P
57isOk :: Char -> Bool
58isOk c = isAscii c && isAlphaNum c
60makeDataURI :: (MimeType, ByteString) -> String
61makeDataURI (mime, raw) =
62 if textual
63 then "data:" ++ mime' ++ "," ++ escapeURIString isOk (toString raw)
64 else "data:" ++ mime' ++ ";base64," ++ toString (encode raw)
65 where textual = "text/" `Data.List.isPrefixOf` mime
66 mime' = if textual && ';' `notElem` mime
67 then mime ++ ";charset=utf-8"
68 else mime -- mime type already has charset
70convertTags :: PandocMonad m => Maybe String -> [Tag String] -> m [Tag String]
71convertTags _ [] = return []
72convertTags sourceURL (t@TagOpen{}:ts)
73 | fromAttrib "data-external" t == "1" = (t:) <$> convertTags sourceURL ts
74convertTags sourceURL (t@(TagOpen tagname as):ts)
75 | tagname `elem`
76 ["img", "embed", "video", "input", "audio", "source", "track"] = do
77 as' <- mapM processAttribute as
78 rest <- convertTags sourceURL ts
79 return $ TagOpen tagname as' : rest
80 where processAttribute (x,y) =
81 if x == "src" || x == "data-src" || x == "href" || x == "poster"
82 then do
83 enc <- getDataURI sourceURL (fromAttrib "type" t) y
84 return (x, enc)
85 else return (x,y)
86convertTags sourceURL (t@(TagOpen "script" as):TagClose "script":ts) =
87 case fromAttrib "src" t of
88 [] -> (t:) <$> convertTags sourceURL ts
89 src -> do
90 let typeAttr = fromAttrib "type" t
91 res <- getData sourceURL typeAttr src
92 rest <- convertTags sourceURL ts
93 case res of
94 Left dataUri -> return $ TagOpen "script"
95 (("src",dataUri) : [(x,y) | (x,y) <- as, x /= "src"]) :
96 TagClose "script" : rest
97 Right (mime, bs)
98 | (mime == "text/javascript" ||
99 mime == "application/javascript" ||
100 mime == "application/x-javascript") &&
101 not ("</script" `B.isInfixOf` bs) ->
102 return $
103 TagOpen "script" [("type", typeAttr)|not (null typeAttr)]
104 : TagText (toString bs)
105 : TagClose "script"
106 : rest
107 | otherwise ->
108 return $ TagOpen "script"
109 (("src",makeDataURI (mime, bs)) :
110 [(x,y) | (x,y) <- as, x /= "src"]) :
111 TagClose "script" : rest
112convertTags sourceURL (t@(TagOpen "link" as):ts) =
113 case fromAttrib "href" t of
114 [] -> (t:) <$> convertTags sourceURL ts
115 src -> do
116 res <- getData sourceURL (fromAttrib "type" t) src
117 case res of
118 Left dataUri -> do
119 rest <- convertTags sourceURL ts
120 return $ TagOpen "link"
121 (("href",dataUri) : [(x,y) | (x,y) <- as, x /= "href"]) :
122 rest
123 Right (mime, bs)
124 | mime == "text/css" && not ("</" `B.isInfixOf` bs) -> do
125 rest <- convertTags sourceURL $
126 dropWhile (==TagClose "link") ts
127 return $
128 TagOpen "style" [("type", "text/css")]
129 : TagText (toString bs)
130 : TagClose "style"
131 : rest
132 | otherwise -> do
133 rest <- convertTags sourceURL ts
134 return $ TagOpen "link"
135 (("href",makeDataURI (mime, bs)) :
136 [(x,y) | (x,y) <- as, x /= "href"]) : rest
137convertTags sourceURL (t:ts) = (t:) <$> convertTags sourceURL ts
139cssURLs :: PandocMonad m
140 => Maybe String -> FilePath -> ByteString -> m ByteString
141cssURLs sourceURL d orig = do
142 res <- runParserT (parseCSSUrls sourceURL d) () "css" orig
143 case res of
144 Left e -> do
145 report $ CouldNotParseCSS (show e)
146 return orig
147 Right bs -> return bs
149parseCSSUrls :: PandocMonad m
150 => Maybe String -> FilePath -> ParsecT ByteString () m ByteString
151parseCSSUrls sourceURL d = B.concat <$> P.many
152 (pCSSWhite <|> pCSSComment <|> pCSSUrl sourceURL d <|> pCSSOther)
154-- Note: some whitespace in CSS is significant, so we can't collapse it!
155pCSSWhite :: PandocMonad m => ParsecT ByteString () m ByteString
156pCSSWhite = B.singleton <$> P.space <* P.spaces
158pCSSComment :: PandocMonad m => ParsecT ByteString () m ByteString
159pCSSComment = P.try $ do
160 P.string "/*"
161 P.manyTill P.anyChar (P.try (P.string "*/"))
162 return B.empty
164pCSSOther :: PandocMonad m => ParsecT ByteString () m ByteString
165pCSSOther = do
166 (B.pack <$> P.many1 (P.noneOf "u/ \n\r\t")) <|>
167 (B.singleton <$> P.char 'u') <|>
168 (B.singleton <$> P.char '/')
170pCSSUrl :: PandocMonad m
171 => Maybe String -> FilePath -> ParsecT ByteString () m ByteString
172pCSSUrl sourceURL d = P.try $ do
173 P.string "url("
174 P.spaces
175 quote <- P.option Nothing (Just <$> P.oneOf "\"'")
176 url <- P.manyTill P.anyChar (maybe (P.lookAhead (P.char ')')) P.char quote)
177 P.spaces
178 P.char ')'
179 let fallback = B.pack ("url(" ++ maybe "" (:[]) quote ++ trim url ++
180 maybe "" (:[]) quote ++ ")")
181 case trim url of
182 '#':_ -> return fallback
183 'd':'a':'t':'a':':':_ -> return fallback
184 u -> do let url' = if isURI u then u else d </> u
185 enc <- lift $ getDataURI sourceURL "" url'
186 return (B.pack $ "url(" ++ enc ++ ")")
188getDataURI :: PandocMonad m => Maybe String -> MimeType -> String -> m String
189getDataURI sourceURL mimetype src = do
190 res <- getData sourceURL mimetype src
191 case res of
192 Left uri -> return uri
193 Right x -> return $ makeDataURI x
195getData :: PandocMonad m
196 => Maybe String -> MimeType -> String
197 -> m (Either String (MimeType, ByteString))
198getData _ _ src@('d':'a':'t':'a':':':_) = return $ Left src-- already data: uri
199getData sourceURL mimetype src = do
200 let ext = map toLower $ takeExtension src
201 (raw, respMime) <- fetchItem sourceURL src
202 let raw' = if ext == ".gz"
203 then B.concat $ L.toChunks $ Gzip.decompress $ L.fromChunks
204 $ [raw]
205 else raw
206 mime <- case (mimetype, respMime) of
207 ("",Nothing) -> throwError $ PandocSomeError
208 $ "Could not determine mime type for `" ++ src ++ "'"
209 (x, Nothing) -> return x
210 (_, Just x ) -> return x
211 let cssSourceURL = case parseURI src of
212 Just u
213 | uriScheme u `elem` ["http:","https:"] ->
214 Just $ show u{ uriPath = "",
215 uriQuery = "",
216 uriFragment = "" }
217 _ -> Nothing
218 result <- if mime == "text/css"
219 then cssURLs cssSourceURL (takeDirectory src) raw'
220 else return raw'
221 return $ Right (mime, result)
225-- | Convert HTML into self-contained HTML, incorporating images,
226-- scripts, and CSS using data: URIs.
227makeSelfContained :: PandocMonad m => WriterOptions -> String -> m String
228makeSelfContained opts inp = do
229 let tags = parseTags inp
230 out' <- convertTags (writerSourceURL opts) tags
231 return $ renderTags' out'