pandoc/src/Text/Pandoc/SelfContained.hs

{-# LANGUAGE OverloadedStrings #-}
{-
Copyright (C) 2011 John MacFarlane <jgm@berkeley.edu>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{- |
   Module      : Text.Pandoc.SelfContained
   Copyright   : Copyright (C) 2011 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Functions for converting an HTML file into one that can be viewed
offline, by incorporating linked images, CSS, and scripts into
the HTML using data URIs.
-}
module Text.Pandoc.SelfContained ( makeSelfContained ) where
import Text.HTML.TagSoup
import Network.URI (isURI, escapeURIString)
import Data.ByteString.Base64
import qualified Data.ByteString.Char8 as B
import Data.ByteString (ByteString)
import System.FilePath (takeExtension, dropExtension, takeDirectory, (</>))
import Data.Char (toLower, isAscii, isAlphaNum)
import Codec.Compression.GZip as Gzip
import qualified Data.ByteString.Lazy as L
import Text.Pandoc.Shared (renderTags', openURL, readDataFile, err)
import Text.Pandoc.UTF8 (toString,  fromString)
import Text.Pandoc.MIME (getMimeType)
import System.Directory (doesFileExist)

isOk :: Char -> Bool
isOk c = isAscii c && isAlphaNum c

convertTag :: Maybe FilePath -> Tag String -> IO (Tag String)
convertTag userdata t@(TagOpen tagname as)
  | tagname `elem` ["img", "embed", "video", "input", "audio", "source"] =
       case fromAttrib "src" t of
         []   -> return t
         src  -> do
           (raw, mime) <- getRaw userdata (fromAttrib "type" t) src
           let enc = "data:" ++ mime ++ ";base64," ++ toString (encode raw)
           return $ TagOpen tagname
                    (("src",enc) : [(x,y) | (x,y) <- as, x /= "src"])
convertTag userdata t@(TagOpen "script" as) =
  case fromAttrib "src" t of
       []     -> return t
       src    -> do
           (raw, mime) <- getRaw userdata (fromAttrib "type" t) src
           let enc = "data:" ++ mime ++ "," ++ escapeURIString isOk (toString raw)
           return $ TagOpen "script" (("src",enc) : [(x,y) | (x,y) <- as, x /= "src"])
convertTag userdata t@(TagOpen "link" as) =
  case fromAttrib "href" t of
       []  -> return t
       src -> do
           (raw, mime) <- getRaw userdata (fromAttrib "type" t) src
           let enc = "data:" ++ mime ++ "," ++ escapeURIString isOk (toString raw)
           return $ TagOpen "link" (("href",enc) : [(x,y) | (x,y) <- as, x /= "href"])
convertTag _ t = return t

-- NOTE: This is really crude, it doesn't respect CSS comments.
cssURLs :: Maybe FilePath -> FilePath -> ByteString -> IO ByteString
cssURLs userdata d orig =
  case B.breakSubstring "url(" orig of
       (x,y) | B.null y  -> return orig
             | otherwise -> do
                  let (u,v) = B.breakSubstring ")" $ B.drop 4 y
                  let url = toString
                          $ case B.take 1 u of
                                 "\"" -> B.takeWhile (/='"') $ B.drop 1 u
                                 "'"  -> B.takeWhile (/='\'') $ B.drop 1 u
                                 _    -> u
                  let url' = if isURI url
                                then url
                                else d </> url
                  (raw, mime) <- getRaw userdata "" url'
                  rest <- cssURLs userdata d v
                  let enc = "data:" `B.append` fromString mime `B.append`
                               ";base64," `B.append` (encode raw)
                  return $ x `B.append` "url(" `B.append` enc `B.append` rest

getItem :: Maybe FilePath -> String -> IO (ByteString, Maybe String)
getItem userdata f =
  if isURI f
     then openURL f >>= either handleErr return
     else do
       -- strip off trailing query or fragment part, if relative URL.
       -- this is needed for things like cmunrm.eot?#iefix,
       -- which is used to get old versions of IE to work with web fonts.
       let f' = takeWhile (\c -> c /= '?' && c /= '#') f
       let mime = case takeExtension f' of
                       ".gz" -> getMimeType $ dropExtension f'
                       x     -> getMimeType x
       exists <- doesFileExist f'
       cont <- if exists then B.readFile f' else readDataFile userdata f'
       return (cont, mime)
  where handleErr e = err 61 $ "Failed to retrieve " ++ f ++ "\n" ++ show e

getRaw :: Maybe FilePath -> String -> String -> IO (ByteString, String)
getRaw userdata mimetype src = do
  let ext = map toLower $ takeExtension src
  (raw, respMime) <- getItem userdata src
  let raw' = if ext == ".gz"
                then B.concat $ L.toChunks $ Gzip.decompress $ L.fromChunks
                      $ [raw]
                else raw
  let mime = case (mimetype, respMime) of
                  ("",Nothing) -> error
                         $ "Could not determine mime type for `" ++ src ++ "'"
                  (x, Nothing) -> x
                  (_, Just x ) -> x
  result <- if mime == "text/css"
               then cssURLs userdata (takeDirectory src) raw'
               else return raw'
  return (result, mime)

-- | Convert HTML into self-contained HTML, incorporating images,
-- scripts, and CSS using data: URIs.  Items specified using absolute
-- URLs will be downloaded; those specified using relative URLs will
-- be sought first relative to the working directory, then relative
-- to the user data directory (if the first parameter is 'Just'
-- a directory), and finally relative to pandoc's default data
-- directory.
makeSelfContained :: Maybe FilePath -> String -> IO String
makeSelfContained userdata inp = do
  let tags = parseTags inp
  out' <- mapM (convertTag userdata) tags
  return $ renderTags' out'