{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE TupleSections     #-}
{- |
   Module      : Text.Pandoc.SelfContained
   Copyright   : Copyright (C) 2011-2024 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 ( makeDataURI, makeSelfContained ) where
import qualified Codec.Compression.Zlib.Internal as Zlib
import Control.Applicative ((<|>))
import Data.ByteString (ByteString)
import Data.ByteString.Base64 (encode)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
import Data.Char (toLower)
import Crypto.Hash (hashWith, SHA1(SHA1))
import Network.URI (escapeURIString, isUnreserved)
import System.FilePath (takeDirectory, takeExtension, (</>))
import Text.HTML.TagSoup
import Text.Pandoc.Class.PandocMonad (PandocMonad (..), fetchItem,
                                      getInputFiles, report, setInputFiles)
import Text.Pandoc.Logging
import Text.Pandoc.Error (PandocError(..))
import Text.Pandoc.MIME (MimeType)
import Text.Pandoc.Shared (renderTags', trim, tshow, safeRead)
import Text.Pandoc.URI (isURI)
import Text.Pandoc.UTF8 (toString, toText, fromText)
import Text.Pandoc.Parsing (ParsecT, runParserT)
import qualified Text.Pandoc.Parsing as P
import Control.Monad.Except (throwError, catchError)
import Data.Either (lefts, rights)
import Data.Maybe (isNothing)
import qualified Data.Map as M
import Control.Monad.State

makeDataURI :: (MimeType, ByteString) -> T.Text
makeDataURI :: (Text, ByteString) -> Text
makeDataURI (Text
mime, ByteString
raw) =
  if Bool
textual
     then Text
"data:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mime' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack ((Char -> Bool) -> String -> String
escapeURIString Char -> Bool
isUnreserved (ByteString -> String
toString ByteString
raw))
     else Text
"data:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
mime' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";base64," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
toText (ByteString -> ByteString
encode ByteString
raw')
  where textual :: Bool
textual = Text
"text/" Text -> Text -> Bool
`T.isPrefixOf` Text
mime
        raw' :: ByteString
raw' = if Text
"+xml" Text -> Text -> Bool
`T.isSuffixOf` Text
mime
                  then (Char -> Bool) -> ByteString -> ByteString
B.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') ByteString
raw  -- strip off CRs
                  else ByteString
raw
        mime' :: Text
mime' = if Bool
textual Bool -> Bool -> Bool
&& Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
';') Text
mime)
                   then Text
mime Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";charset=utf-8"
                   else Text
mime  -- mime type already has charset

isSourceAttribute :: T.Text -> (T.Text, T.Text) -> Bool
isSourceAttribute :: Text -> (Text, Text) -> Bool
isSourceAttribute Text
tagname (Text
x,Text
_) =
  Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"src" Bool -> Bool -> Bool
||
  Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"data-src" Bool -> Bool -> Bool
||
  (Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"href" Bool -> Bool -> Bool
&& Text
tagname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"link") Bool -> Bool -> Bool
||
  Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"poster" Bool -> Bool -> Bool
||
  Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"data-background-image"

data ConvertState =
  ConvertState
  { ConvertState -> Map Text (Text, [(Text, Text)])
svgMap  :: M.Map T.Text (T.Text, [Attribute T.Text])
    -- map from hash to (id, svg attributes)
  , ConvertState -> Map (Text, Text) GetDataResult
fetchCache :: M.Map (MimeType, T.Text) GetDataResult
    -- cache of fetched resources, keyed on mime type hint and url
  } deriving (Int -> ConvertState -> String -> String
[ConvertState] -> String -> String
ConvertState -> String
(Int -> ConvertState -> String -> String)
-> (ConvertState -> String)
-> ([ConvertState] -> String -> String)
-> Show ConvertState
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ConvertState -> String -> String
showsPrec :: Int -> ConvertState -> String -> String
$cshow :: ConvertState -> String
show :: ConvertState -> String
$cshowList :: [ConvertState] -> String -> String
showList :: [ConvertState] -> String -> String
Show)

convertTags :: PandocMonad m =>
               [Tag T.Text] -> StateT ConvertState m [Tag T.Text]
convertTags :: forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [] = [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
convertTags (t :: Tag Text
t@TagOpen{}:[Tag Text]
ts)
  | Text -> Tag Text -> Text
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib Text
"data-external" Tag Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"1" = (Tag Text
tTag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:) ([Tag Text] -> [Tag Text])
-> StateT ConvertState m [Tag Text]
-> StateT ConvertState m [Tag Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [Tag Text]
ts
convertTags (t :: Tag Text
t@(TagOpen Text
"style" [(Text, Text)]
_):[Tag Text]
ts) =
  case (Tag Text -> Bool) -> [Tag Text] -> ([Tag Text], [Tag Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Tag Text -> Bool
forall str. Tag str -> Bool
isTagText [Tag Text]
ts of
    ([Tag Text]
xs,[Tag Text]
rest) -> do
      xs' <- (Tag Text -> StateT ConvertState m (Tag Text))
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\case
                    TagText Text
s -> Text -> Tag Text
forall str. str -> Tag str
TagText (Text -> Tag Text)
-> (ByteString -> Text) -> ByteString -> Tag Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
toText (ByteString -> Tag Text)
-> StateT ConvertState m ByteString
-> StateT ConvertState m (Tag Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ByteString -> StateT ConvertState m ByteString
forall (m :: * -> *).
PandocMonad m =>
String -> ByteString -> StateT ConvertState m ByteString
cssURLs String
"" (Text -> ByteString
fromText Text
s)
                    Tag Text
tag -> Tag Text -> StateT ConvertState m (Tag Text)
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return Tag Text
tag) [Tag Text]
xs
      ((t:xs') ++) <$> convertTags rest
convertTags (t :: Tag Text
t@(TagOpen Text
"script" [(Text, Text)]
as):tc :: Tag Text
tc@(TagClose Text
"script"):[Tag Text]
ts) =
  case Text -> Tag Text -> Text
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib Text
"src" Tag Text
t of
       Text
""  -> ([Tag Text
t, Tag Text
tc] [Tag Text] -> [Tag Text] -> [Tag Text]
forall a. [a] -> [a] -> [a]
++) ([Tag Text] -> [Tag Text])
-> StateT ConvertState m [Tag Text]
-> StateT ConvertState m [Tag Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [Tag Text]
ts
       Text
src -> do
           let typeAttr :: Text
typeAttr = Text -> Tag Text -> Text
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib Text
"type" Tag Text
t
           res <- Text -> Text -> StateT ConvertState m GetDataResult
forall (m :: * -> *).
PandocMonad m =>
Text -> Text -> StateT ConvertState m GetDataResult
getData Text
typeAttr Text
src
           rest <- convertTags ts
           case res of
                AlreadyDataURI Text
dataUri -> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"script"
                     ((Text
"src",Text
dataUri) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text
x,Text
y) | (Text
x,Text
y) <- [(Text, Text)]
as, Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"src"]) Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:
                     Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"script" Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
: [Tag Text]
rest
                Fetched (Text
mime, ByteString
bs)
                  | (Text
"text/javascript" Text -> Text -> Bool
`T.isPrefixOf` Text
mime Bool -> Bool -> Bool
||
                     Text
"application/javascript" Text -> Text -> Bool
`T.isPrefixOf` Text
mime Bool -> Bool -> Bool
||
                     Text
"application/x-javascript" Text -> Text -> Bool
`T.isPrefixOf` Text
mime) Bool -> Bool -> Bool
&&
                     Bool -> Bool
not (ByteString
"</script" ByteString -> ByteString -> Bool
`B.isInfixOf` (Char -> Char) -> ByteString -> ByteString
B.map Char -> Char
toLower ByteString
bs) ->
                     [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$
                       Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"script" [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
as
                                               , Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"type" Bool -> Bool -> Bool
||
                                                 Text
"data-" Text -> Text -> Bool
`T.isPrefixOf` Text
k]
                       Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
: Text -> Tag Text
forall str. str -> Tag str
TagText (ByteString -> Text
toText ByteString
bs)
                       Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
: Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"script"
                       Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
: [Tag Text]
rest
                  | Bool
otherwise ->
                       [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return  ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"script"
                         ((Text
"src",(Text, ByteString) -> Text
makeDataURI (Text
mime, ByteString
bs)) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:
                          [(Text
x,Text
y) | (Text
x,Text
y) <- [(Text, Text)]
as, Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"src"]) Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:
                        Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"script" Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
: [Tag Text]
rest
                CouldNotFetch PandocError
_ -> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$ Tag Text
tTag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:Tag Text
tcTag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:[Tag Text]
rest
convertTags (t :: Tag Text
t@(TagOpen Text
"link" [(Text, Text)]
as):[Tag Text]
ts) =
  case Text -> Tag Text -> Text
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib Text
"href" Tag Text
t of
       Text
""  -> (Tag Text
tTag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:) ([Tag Text] -> [Tag Text])
-> StateT ConvertState m [Tag Text]
-> StateT ConvertState m [Tag Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [Tag Text]
ts
       Text
src -> do
           res <- Text -> Text -> StateT ConvertState m GetDataResult
forall (m :: * -> *).
PandocMonad m =>
Text -> Text -> StateT ConvertState m GetDataResult
getData (Text -> Tag Text -> Text
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib Text
"type" Tag Text
t) Text
src
           case res of
                AlreadyDataURI Text
dataUri -> do
                  rest <- [Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [Tag Text]
ts
                  return $ TagOpen "link"
                     (("href",dataUri) : [(x,y) | (x,y) <- as, x /= "href"]) :
                     rest
                Fetched (Text
mime, ByteString
bs)
                  | (Text
"text/css" Text -> Text -> Bool
`T.isPrefixOf` Text
mime Bool -> Bool -> Bool
||
                      Text -> Tag Text -> Text
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib Text
"rel" Tag Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"stylesheet")
                    Bool -> Bool -> Bool
&& Text -> Bool
T.null (Text -> Tag Text -> Text
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib Text
"media" Tag Text
t)
                    Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString
"</" ByteString -> ByteString -> Bool
`B.isInfixOf` ByteString
bs) -> do
                      rest <- [Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$
                                 (Tag Text -> Bool) -> [Tag Text] -> [Tag Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Tag Text -> Tag Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"link") [Tag Text]
ts
                      return $
                       TagOpen "style" [("type", "text/css")] -- see #5725
                       : TagText (toText bs)
                       : TagClose "style"
                       : rest
                  | Bool
otherwise -> do
                      rest <- [Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [Tag Text]
ts
                      return $ TagOpen "link"
                       (("href",makeDataURI (mime, bs)) :
                         [(x,y) | (x,y) <- as, x /= "href"]) : rest
                CouldNotFetch PandocError
_ -> do
                      rest <- [Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [Tag Text]
ts
                      return $ t:rest
convertTags (t :: Tag Text
t@(TagOpen Text
tagname [(Text, Text)]
as):[Tag Text]
ts)
  | ((Text, Text) -> Bool) -> [(Text, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> (Text, Text) -> Bool
isSourceAttribute Text
tagname) [(Text, Text)]
as
     = do
       let inlineSvgs :: Bool
inlineSvgs = Text
tagname Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"img" Bool -> Bool -> Bool
&&
                        case Text -> [Text]
T.words (Text -> [Text]) -> Maybe Text -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"class" [(Text, Text)]
as of
                          Maybe [Text]
Nothing -> Bool
False
                          Just [Text]
cs -> Text
"inline-svg" Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
cs
       as' <- ((Text, Text)
 -> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text)))
-> [(Text, Text)]
-> StateT ConvertState m [Either (Text, [Tag Text]) (Text, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool
-> (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall {m :: * -> *}.
PandocMonad m =>
Bool
-> (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
processAttribute Bool
inlineSvgs) [(Text, Text)]
as
       let attrs = [Either (Text, [Tag Text]) (Text, Text)] -> [(Text, Text)]
forall a b. [Either a b] -> [b]
rights [Either (Text, [Tag Text]) (Text, Text)]
as'
       let svgContents = [Either (Text, [Tag Text]) (Text, Text)] -> [(Text, [Tag Text])]
forall a b. [Either a b] -> [a]
lefts [Either (Text, [Tag Text]) (Text, Text)]
as'
       rest <- convertTags ts
       case svgContents of
         [] -> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
tagname [(Text, Text)]
attrs Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
: [Tag Text]
rest
         ((Text
hash, [Tag Text]
tags) : [(Text, [Tag Text])]
_) -> do
             -- inlining the SVG loses the img element's alt text, so
             -- we add role and aria-label to the svg element:
             let svgImgAttrs :: [(Text, Text)]
svgImgAttrs = Text -> [(Text, Text)] -> [(Text, Text)]
addRole Text
"img" ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> [(Text, Text)]
addAriaLabel [(Text, Text)]
attrs
             -- drop "</img>" if present
             let rest' :: [Tag Text]
rest' = case [Tag Text]
rest of
                           TagClose Text
tn : [Tag Text]
xs | Text
tn Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
tagname ->  [Tag Text]
xs
                           [Tag Text]
_ -> [Tag Text]
rest
             svgmap <- (ConvertState -> Map Text (Text, [(Text, Text)]))
-> StateT ConvertState m (Map Text (Text, [(Text, Text)]))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConvertState -> Map Text (Text, [(Text, Text)])
svgMap
             case M.lookup hash svgmap of
               Just (Text
svgid, [(Text, Text)]
svgattrs) -> do
                 let attrs' :: [(Text, Text)]
attrs' = [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
combineSvgAttrs [(Text, Text)]
svgattrs
                                                  [(Text, Text)]
svgImgAttrs
                                     , Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"id"]
                 [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"svg" [(Text, Text)]
attrs' Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:
                          Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"use" [(Text
"href", Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
svgid),
                                         (Text
"width", Text
"100%"),
                                         (Text
"height", Text
"100%")] Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:
                          Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"use" Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:
                          Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"svg" Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:
                          [Tag Text]
rest'
               Maybe (Text, [(Text, Text)])
Nothing ->
                  case (Tag Text -> Bool) -> [Tag Text] -> [Tag Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Tag Text -> Bool) -> Tag Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Tag Text -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagOpenName Text
"svg") [Tag Text]
tags of
                    TagOpen Text
"svg" [(Text, Text)]
svgattrs : [Tag Text]
tags' -> do
                      let attrs' :: [(Text, Text)]
attrs' = [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
combineSvgAttrs [(Text, Text)]
svgattrs [(Text, Text)]
svgImgAttrs
                      let svgid :: Text
svgid = case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"id" [(Text, Text)]
attrs' of
                                     Just Text
id' -> Text
id'
                                     Maybe Text
Nothing -> Text
"svg_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hash
                      let attrs'' :: [(Text, Text)]
attrs'' = (Text
"id", Text
svgid) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:
                                    [(Text
k,Text
v) | (Text
k,Text
v) <- [(Text, Text)]
attrs', Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"id"]
                      (ConvertState -> ConvertState) -> StateT ConvertState m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ConvertState -> ConvertState) -> StateT ConvertState m ())
-> (ConvertState -> ConvertState) -> StateT ConvertState m ()
forall a b. (a -> b) -> a -> b
$ \ConvertState
st ->
                        ConvertState
st{ svgMap = M.insert hash (svgid, attrs'') (svgMap st) }
                      let fixUrl :: Text -> Text
fixUrl = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"url(#" (Text
"url(#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
svgid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_")
                      let addIdPrefix :: (a, Text) -> (a, Text)
addIdPrefix (a
"id", Text
x) = (a
"id", Text
svgid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x)
                          addIdPrefix (a
k, Text
x)
                           | a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"xlink:href" Bool -> Bool -> Bool
|| a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"href" =
                            case Text -> Maybe (Char, Text)
T.uncons Text
x of
                              Just (Char
'#', Text
x') -> (a
k, Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
svgid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
x')
                              Maybe (Char, Text)
_ -> (a
k, Text
x)
                          -- this clause handles things like
                          -- style="fill:url(#radialGradient46);stroke:none",
                          -- adding the svg id prefix to the anchor:
                          addIdPrefix (a
k, Text
x) = (a
k, Text -> Text
fixUrl Text
x)
                      let ensureUniqueId :: Tag Text -> Tag Text
ensureUniqueId (TagOpen Text
tname [(Text, Text)]
ats) =
                            Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
tname (((Text, Text) -> (Text, Text)) -> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (Text, Text)
forall {a}. (Eq a, IsString a) => (a, Text) -> (a, Text)
addIdPrefix [(Text, Text)]
ats)
                          ensureUniqueId Tag Text
x = Tag Text
x
                      [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"svg" [(Text, Text)]
attrs'' Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:
                                 (Tag Text -> Tag Text) -> [Tag Text] -> [Tag Text]
forall a b. (a -> b) -> [a] -> [b]
map Tag Text -> Tag Text
ensureUniqueId [Tag Text]
tags' [Tag Text] -> [Tag Text] -> [Tag Text]
forall a. [a] -> [a] -> [a]
++ [Tag Text]
rest'
                    [Tag Text]
_ -> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Tag Text] -> StateT ConvertState m [Tag Text])
-> [Tag Text] -> StateT ConvertState m [Tag Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
tagname [(Text, Text)]
attrs Tag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
: [Tag Text]
rest
  where processAttribute :: Bool
-> (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
processAttribute Bool
inlineSvgs (Text
x,Text
y) =
           if Text -> (Text, Text) -> Bool
isSourceAttribute Text
tagname (Text
x,Text
y)
              then do
                res <- Text -> Text -> StateT ConvertState m GetDataResult
forall (m :: * -> *).
PandocMonad m =>
Text -> Text -> StateT ConvertState m GetDataResult
getData (Text -> Tag Text -> Text
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
fromAttrib Text
"type" Tag Text
t) Text
y
                case res of
                  AlreadyDataURI Text
enc -> Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Text, [Tag Text]) (Text, Text)
 -> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text)))
-> Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Either (Text, [Tag Text]) (Text, Text)
forall a b. b -> Either a b
Right (Text
x, Text
enc)
                  Fetched (Text
"image/svg+xml", ByteString
bs) | Bool
inlineSvgs -> do
                    -- we filter CR in the hash to ensure that Windows
                    -- and non-Windows tests agree:
                    let hash :: Text
hash = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
20 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Digest SHA1 -> String
forall a. Show a => a -> String
show (Digest SHA1 -> String) -> Digest SHA1 -> String
forall a b. (a -> b) -> a -> b
$ SHA1 -> ByteString -> Digest SHA1
forall ba alg.
(ByteArrayAccess ba, HashAlgorithm alg) =>
alg -> ba -> Digest alg
hashWith SHA1
SHA1
                                             (ByteString -> Digest SHA1) -> ByteString -> Digest SHA1
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
B.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\r') ByteString
bs
                    Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Text, [Tag Text]) (Text, Text)
 -> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text)))
-> Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, [Tag Text]) -> Either (Text, [Tag Text]) (Text, Text)
forall a b. a -> Either a b
Left (Text
hash, Text -> [Tag Text]
getSvgTags (ByteString -> Text
toText ByteString
bs))
                  Fetched (Text
mt,ByteString
bs) -> Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Text, [Tag Text]) (Text, Text)
 -> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text)))
-> Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Either (Text, [Tag Text]) (Text, Text)
forall a b. b -> Either a b
Right (Text
x, (Text, ByteString) -> Text
makeDataURI (Text
mt,ByteString
bs))
                  CouldNotFetch PandocError
_ -> Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Text, [Tag Text]) (Text, Text)
 -> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text)))
-> Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Either (Text, [Tag Text]) (Text, Text)
forall a b. b -> Either a b
Right (Text
x, Text
y)
              else Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Text, [Tag Text]) (Text, Text)
 -> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text)))
-> Either (Text, [Tag Text]) (Text, Text)
-> StateT ConvertState m (Either (Text, [Tag Text]) (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Either (Text, [Tag Text]) (Text, Text)
forall a b. b -> Either a b
Right (Text
x,Text
y)

convertTags (Tag Text
t:[Tag Text]
ts) = (Tag Text
tTag Text -> [Tag Text] -> [Tag Text]
forall a. a -> [a] -> [a]
:) ([Tag Text] -> [Tag Text])
-> StateT ConvertState m [Tag Text]
-> StateT ConvertState m [Tag Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [Tag Text]
ts

addRole :: T.Text -> [(T.Text, T.Text)] -> [(T.Text, T.Text)]
addRole :: Text -> [(Text, Text)] -> [(Text, Text)]
addRole Text
role [(Text, Text)]
attrs =
  case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"role" [(Text, Text)]
attrs of
    Maybe Text
Nothing -> (Text
"role", Text
role) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
attrs
    Just Text
_ -> [(Text, Text)]
attrs

addAriaLabel :: [(T.Text, T.Text)] -> [(T.Text, T.Text)]
addAriaLabel :: [(Text, Text)] -> [(Text, Text)]
addAriaLabel [(Text, Text)]
attrs =
  case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"aria-label" [(Text, Text)]
attrs of
    Just Text
_ -> [(Text, Text)]
attrs
    Maybe Text
Nothing -> case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"alt" [(Text, Text)]
attrs of
                 Just Text
alt -> (Text
"aria-label", Text
alt) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
attrs
                 Maybe Text
Nothing -> [(Text, Text)]
attrs

-- we want to drop spaces, <?xml>, and comments before <svg>
-- and anything after </svg>:
getSvgTags :: T.Text -> [Tag T.Text]
getSvgTags :: Text -> [Tag Text]
getSvgTags Text
t =
  case (Tag Text -> Bool) -> [Tag Text] -> [Tag Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Tag Text -> Bool) -> Tag Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Tag Text -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagCloseName Text
"svg") ([Tag Text] -> [Tag Text])
-> ([Tag Text] -> [Tag Text]) -> [Tag Text] -> [Tag Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       (Tag Text -> Bool) -> [Tag Text] -> [Tag Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Tag Text -> Bool) -> Tag Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Tag Text -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagOpenName Text
"svg") ([Tag Text] -> [Tag Text]) -> [Tag Text] -> [Tag Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Tag Text]
forall str. StringLike str => str -> [Tag str]
parseTags Text
t of
    [] -> []
    [Tag Text]
xs -> [Tag Text]
xs [Tag Text] -> [Tag Text] -> [Tag Text]
forall a. [a] -> [a] -> [a]
++ [Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"svg"]

combineSvgAttrs :: [(T.Text, T.Text)] -> [(T.Text, T.Text)] -> [(T.Text, T.Text)]
combineSvgAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
combineSvgAttrs [(Text, Text)]
svgAttrs [(Text, Text)]
imgAttrs =
  case (Maybe (Double, Double, Double, Double)
mbViewBox, Maybe Int
mbHeight, Maybe Int
mbWidth) of
    (Maybe (Double, Double, Double, Double)
Nothing, Just Int
h, Just Int
w) -> -- calculate viewBox
      [(Text, Text)]
combinedAttrs [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ [(Text
"viewBox", [Text] -> Text
T.unwords [Text
"0", Text
"0", Int -> Text
forall a. Show a => a -> Text
tshow Int
w, Int -> Text
forall a. Show a => a -> Text
tshow Int
h])]
    (Just (Double
_minx,Double
_miny,Double
w,Double
h), Maybe Int
Nothing, Maybe Int
Nothing) ->
        [(Text, Text)]
combinedAttrs [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
        [ (Text
"width", Text -> Text
dropPointZero (Double -> Text
forall a. Show a => a -> Text
tshow Double
w)) |
            Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"width" [(Text, Text)]
combinedAttrs) ] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
        [ (Text
"height", Text -> Text
dropPointZero (Double -> Text
forall a. Show a => a -> Text
tshow Double
h)) |
            Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"height" [(Text, Text)]
combinedAttrs) ]
    (Maybe (Double, Double, Double, Double), Maybe Int, Maybe Int)
_ -> [(Text, Text)]
combinedAttrs
 where
  dropPointZero :: Text -> Text
dropPointZero Text
t = case Text -> Text -> Maybe Text
T.stripSuffix Text
".0" Text
t of
                       Maybe Text
Nothing -> Text
t
                       Just Text
t' -> Text
t'
  combinedAttrs :: [(Text, Text)]
combinedAttrs =
    [(Text
k, Text
v) | (Text
k, Text
v) <- [(Text, Text)]
imgAttrs
            , Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"class"] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
    [(Text
k, Text
v) | (Text
k, Text
v) <- [(Text, Text)]
svgAttrs
            , Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Text)]
imgAttrs)
            , Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"xmlns", Text
"xmlns:xlink", Text
"version", Text
"class"]] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
    [(Text, Text)]
mergedClasses
  parseViewBox :: Text -> Maybe (d, d, d, d)
parseViewBox Text
t =
    case (Text -> Maybe d) -> [Text] -> [Maybe d]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Maybe d
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead (Text -> Maybe d) -> (Text -> Text) -> Text -> Maybe d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
addZero) ([Text] -> [Maybe d]) -> [Text] -> [Maybe d]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.words Text
t of
      [Just d
llx, Just d
lly, Just d
urx, Just d
ury] -> (d, d, d, d) -> Maybe (d, d, d, d)
forall a. a -> Maybe a
Just (d
llx, d
lly, d
urx, d
ury)
      [Maybe d]
_ -> Maybe (d, d, d, d)
forall a. Maybe a
Nothing
  addZero :: Text -> Text
addZero Text
t =
    if Text
"-." Text -> Text -> Bool
`T.isPrefixOf` Text
t
       then Text
"-0." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop Int
2 Text
t -- safeRead fails on -.33, needs -0.33
       else Text
t
  (Maybe (Double, Double, Double, Double)
mbViewBox :: Maybe (Double, Double, Double, Double)) =
        Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"viewBox" [(Text, Text)]
svgAttrs Maybe Text
-> (Text -> Maybe (Double, Double, Double, Double))
-> Maybe (Double, Double, Double, Double)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe (Double, Double, Double, Double)
forall {d}. Read d => Text -> Maybe (d, d, d, d)
parseViewBox
  (Maybe Int
mbHeight :: Maybe Int) = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"height" [(Text, Text)]
combinedAttrs Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
  (Maybe Int
mbWidth :: Maybe Int) = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"width" [(Text, Text)]
combinedAttrs Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => Text -> m a
safeRead
  mergedClasses :: [(Text, Text)]
mergedClasses = case (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"class" [(Text, Text)]
imgAttrs, Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"class" [(Text, Text)]
svgAttrs) of
                    (Just Text
c1, Just Text
c2) -> [(Text
"class", Text
c1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c2)]
                    (Maybe Text, Maybe Text)
_ -> []

cssURLs :: PandocMonad m
        => FilePath -> ByteString -> StateT ConvertState m ByteString
cssURLs :: forall (m :: * -> *).
PandocMonad m =>
String -> ByteString -> StateT ConvertState m ByteString
cssURLs String
d ByteString
orig = do
  res <- ParsecT ByteString () (StateT ConvertState m) ByteString
-> ()
-> String
-> ByteString
-> StateT ConvertState m (Either ParseError ByteString)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> String -> s -> m (Either ParseError a)
runParserT (String -> ParsecT ByteString () (StateT ConvertState m) ByteString
forall (m :: * -> *).
PandocMonad m =>
String -> ParsecT ByteString () (StateT ConvertState m) ByteString
parseCSSUrls String
d) () String
"css" ByteString
orig
  case res of
       Left ParseError
e    -> do
         LogMessage -> StateT ConvertState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT ConvertState m ())
-> LogMessage -> StateT ConvertState m ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
CouldNotParseCSS (Text -> LogMessage) -> Text -> LogMessage
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
e
         ByteString -> StateT ConvertState m ByteString
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
orig
       Right ByteString
bs  -> ByteString -> StateT ConvertState m ByteString
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

parseCSSUrls :: PandocMonad m
             => FilePath
             -> ParsecT ByteString () (StateT ConvertState m) ByteString
parseCSSUrls :: forall (m :: * -> *).
PandocMonad m =>
String -> ParsecT ByteString () (StateT ConvertState m) ByteString
parseCSSUrls String
d = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> ParsecT ByteString () (StateT ConvertState m) [ByteString]
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) [ByteString]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many
  (ParsecT ByteString () (StateT ConvertState m) ByteString
forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m ByteString
pCSSWhite ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a.
ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT ByteString () (StateT ConvertState m) ByteString
forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m ByteString
pCSSComment ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a.
ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT ByteString () (StateT ConvertState m) ByteString
forall (m :: * -> *).
PandocMonad m =>
String -> ParsecT ByteString () (StateT ConvertState m) ByteString
pCSSImport String
d ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a.
ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> ParsecT ByteString () (StateT ConvertState m) ByteString
forall (m :: * -> *).
PandocMonad m =>
String -> ParsecT ByteString () (StateT ConvertState m) ByteString
pCSSUrl String
d ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a.
ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT ByteString () (StateT ConvertState m) ByteString
forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m ByteString
pCSSOther)

pCSSImport :: PandocMonad m
           => FilePath
           -> ParsecT ByteString () (StateT ConvertState m) ByteString
pCSSImport :: forall (m :: * -> *).
PandocMonad m =>
String -> ParsecT ByteString () (StateT ConvertState m) ByteString
pCSSImport String
d = ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT ByteString () (StateT ConvertState m) ByteString
 -> ParsecT ByteString () (StateT ConvertState m) ByteString)
-> ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a b. (a -> b) -> a -> b
$ do
  String -> ParsecT ByteString () (StateT ConvertState m) String
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m String
P.string String
"@import"
  ParsecT ByteString () (StateT ConvertState m) ()
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s u m ()
P.spaces
  res <- (ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m (Text, ByteString)
pQuoted ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
-> ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
-> ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
forall a.
ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
-> ParsecT ByteString () (StateT ConvertState m) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m (Text, ByteString)
pUrl) ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
-> ((Text, ByteString)
    -> ParsecT
         ByteString
         ()
         (StateT ConvertState m)
         (Either ByteString (Text, ByteString)))
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a b.
ParsecT ByteString () (StateT ConvertState m) a
-> (a -> ParsecT ByteString () (StateT ConvertState m) b)
-> ParsecT ByteString () (StateT ConvertState m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall (m :: * -> *).
PandocMonad m =>
String
-> (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
handleCSSUrl String
d
  P.spaces
  P.char ';'
  case res of
       Left ByteString
b       -> ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
 -> ParsecT ByteString () (StateT ConvertState m) ByteString)
-> ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
"@import " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
b ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> String -> ByteString
B.pack String
";"
       Right (Text
_, ByteString
b) -> ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b

-- Note: some whitespace in CSS is significant, so we can't collapse it!
pCSSWhite :: PandocMonad m => ParsecT ByteString () m ByteString
pCSSWhite :: forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m ByteString
pCSSWhite = Char -> ByteString
B.singleton (Char -> ByteString)
-> ParsecT ByteString () m Char
-> ParsecT ByteString () m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s u m Char
P.space ParsecT ByteString () m ByteString
-> ParsecT ByteString () m () -> ParsecT ByteString () m ByteString
forall a b.
ParsecT ByteString () m a
-> ParsecT ByteString () m b -> ParsecT ByteString () m a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT ByteString () m ()
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s u m ()
P.spaces

pCSSComment :: PandocMonad m => ParsecT ByteString () m ByteString
pCSSComment :: forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m ByteString
pCSSComment = ParsecT ByteString () m ByteString
-> ParsecT ByteString () m ByteString
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT ByteString () m ByteString
 -> ParsecT ByteString () m ByteString)
-> ParsecT ByteString () m ByteString
-> ParsecT ByteString () m ByteString
forall a b. (a -> b) -> a -> b
$ do
  String -> ParsecT ByteString () m String
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m String
P.string String
"/*"
  ParsecT ByteString () m Char
-> ParsecT ByteString () m String -> ParsecT ByteString () m String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
P.manyTill ParsecT ByteString () m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s u m Char
P.anyChar (ParsecT ByteString () m String -> ParsecT ByteString () m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (String -> ParsecT ByteString () m String
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m String
P.string String
"*/"))
  ByteString -> ParsecT ByteString () m ByteString
forall a. a -> ParsecT ByteString () m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty

pCSSOther :: PandocMonad m => ParsecT ByteString () m ByteString
pCSSOther :: forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m ByteString
pCSSOther =
  (String -> ByteString
B.pack (String -> ByteString)
-> ParsecT ByteString () m String
-> ParsecT ByteString () m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT ByteString () m Char -> ParsecT ByteString () m String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many1 (String -> ParsecT ByteString () m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m Char
P.noneOf String
"u/ \n\r\t")) ParsecT ByteString () m ByteString
-> ParsecT ByteString () m ByteString
-> ParsecT ByteString () m ByteString
forall a.
ParsecT ByteString () m a
-> ParsecT ByteString () m a -> ParsecT ByteString () m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (Char -> ByteString
B.singleton (Char -> ByteString)
-> ParsecT ByteString () m Char
-> ParsecT ByteString () m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT ByteString () m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
Char -> ParsecT s u m Char
P.char Char
'u') ParsecT ByteString () m ByteString
-> ParsecT ByteString () m ByteString
-> ParsecT ByteString () m ByteString
forall a.
ParsecT ByteString () m a
-> ParsecT ByteString () m a -> ParsecT ByteString () m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (Char -> ByteString
B.singleton (Char -> ByteString)
-> ParsecT ByteString () m Char
-> ParsecT ByteString () m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT ByteString () m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
Char -> ParsecT s u m Char
P.char Char
'/')

pCSSUrl :: PandocMonad m
        => FilePath
        -> ParsecT ByteString () (StateT ConvertState m) ByteString
pCSSUrl :: forall (m :: * -> *).
PandocMonad m =>
String -> ParsecT ByteString () (StateT ConvertState m) ByteString
pCSSUrl String
d = ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT ByteString () (StateT ConvertState m) ByteString
 -> ParsecT ByteString () (StateT ConvertState m) ByteString)
-> ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a b. (a -> b) -> a -> b
$ do
  res <- ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m (Text, ByteString)
pUrl ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
-> ((Text, ByteString)
    -> ParsecT
         ByteString
         ()
         (StateT ConvertState m)
         (Either ByteString (Text, ByteString)))
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a b.
ParsecT ByteString () (StateT ConvertState m) a
-> (a -> ParsecT ByteString () (StateT ConvertState m) b)
-> ParsecT ByteString () (StateT ConvertState m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String
-> (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall (m :: * -> *).
PandocMonad m =>
String
-> (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
handleCSSUrl String
d
  case res of
       Left ByteString
b -> ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
b
       Right (Text
mt,ByteString
b) -> do
         let enc :: Text
enc = (Text, ByteString) -> Text
makeDataURI (Text
mt, ByteString
b)
         ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
 -> ParsecT ByteString () (StateT ConvertState m) ByteString)
-> ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
fromText (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
"url(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
enc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

pQuoted :: PandocMonad m
        => ParsecT ByteString () m (T.Text, ByteString)
pQuoted :: forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m (Text, ByteString)
pQuoted = ParsecT ByteString () m (Text, ByteString)
-> ParsecT ByteString () m (Text, ByteString)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT ByteString () m (Text, ByteString)
 -> ParsecT ByteString () m (Text, ByteString))
-> ParsecT ByteString () m (Text, ByteString)
-> ParsecT ByteString () m (Text, ByteString)
forall a b. (a -> b) -> a -> b
$ do
  quote <- String -> ParsecT ByteString () m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m Char
P.oneOf String
"\"'"
  url <- T.pack <$> P.manyTill P.anyChar (P.char quote)
  let fallback = Text -> ByteString
fromText (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
quote Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
trim Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
quote
  return (url, fallback)

pUrl :: PandocMonad m
     => ParsecT ByteString () m (T.Text, ByteString)
pUrl :: forall (m :: * -> *).
PandocMonad m =>
ParsecT ByteString () m (Text, ByteString)
pUrl = ParsecT ByteString () m (Text, ByteString)
-> ParsecT ByteString () m (Text, ByteString)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT ByteString () m (Text, ByteString)
 -> ParsecT ByteString () m (Text, ByteString))
-> ParsecT ByteString () m (Text, ByteString)
-> ParsecT ByteString () m (Text, ByteString)
forall a b. (a -> b) -> a -> b
$ do
  String -> ParsecT ByteString () m String
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m String
P.string String
"url("
  ParsecT ByteString () m ()
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s u m ()
P.spaces
  quote <- Maybe Char
-> ParsecT ByteString () m (Maybe Char)
-> ParsecT ByteString () m (Maybe Char)
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option Maybe Char
forall a. Maybe a
Nothing (Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> Maybe Char)
-> ParsecT ByteString () m Char
-> ParsecT ByteString () m (Maybe Char)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ParsecT ByteString () m Char
forall (m :: * -> *) s u.
(Monad m, Stream s m Char, UpdateSourcePos s Char) =>
String -> ParsecT s u m Char
P.oneOf String
"\"'")
  url <- T.pack <$> P.manyTill P.anyChar (maybe (P.lookAhead (P.char ')')) P.char quote)
  P.spaces
  P.char ')'
  let fallback = Text -> ByteString
fromText (Text
"url(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (Char -> Text) -> Maybe Char -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Char -> Text
T.singleton Maybe Char
quote Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
trim Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                            Text -> (Char -> Text) -> Maybe Char -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Char -> Text
T.singleton Maybe Char
quote Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
  return (url, fallback)

handleCSSUrl :: PandocMonad m
             => FilePath -> (T.Text, ByteString)
             -> ParsecT ByteString () (StateT ConvertState m)
                  (Either ByteString (MimeType, ByteString))
handleCSSUrl :: forall (m :: * -> *).
PandocMonad m =>
String
-> (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
handleCSSUrl String
d (Text
url, ByteString
fallback) =
  case (Char -> Bool) -> String -> String
escapeURIString (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'|') (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
trim Text
url) of
      Char
'#':String
_ -> Either ByteString (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString (Text, ByteString)
 -> ParsecT
      ByteString
      ()
      (StateT ConvertState m)
      (Either ByteString (Text, ByteString)))
-> Either ByteString (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString (Text, ByteString)
forall a b. a -> Either a b
Left ByteString
fallback
      Char
'd':Char
'a':Char
't':Char
'a':Char
':':String
_ -> Either ByteString (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString (Text, ByteString)
 -> ParsecT
      ByteString
      ()
      (StateT ConvertState m)
      (Either ByteString (Text, ByteString)))
-> Either ByteString (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString (Text, ByteString)
forall a b. a -> Either a b
Left ByteString
fallback
      String
u ->  do let url' :: Text
url' = if Text -> Bool
isURI (String -> Text
T.pack String
u) then String -> Text
T.pack String
u else String -> Text
T.pack (String
d String -> String -> String
</> String
u)
               res <- StateT ConvertState m GetDataResult
-> ParsecT ByteString () (StateT ConvertState m) GetDataResult
forall (m :: * -> *) a. Monad m => m a -> ParsecT ByteString () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ConvertState m GetDataResult
 -> ParsecT ByteString () (StateT ConvertState m) GetDataResult)
-> StateT ConvertState m GetDataResult
-> ParsecT ByteString () (StateT ConvertState m) GetDataResult
forall a b. (a -> b) -> a -> b
$ Text -> Text -> StateT ConvertState m GetDataResult
forall (m :: * -> *).
PandocMonad m =>
Text -> Text -> StateT ConvertState m GetDataResult
getData Text
"" Text
url'
               case res of
                    AlreadyDataURI Text
uri -> Either ByteString (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString (Text, ByteString)
 -> ParsecT
      ByteString
      ()
      (StateT ConvertState m)
      (Either ByteString (Text, ByteString)))
-> Either ByteString (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString (Text, ByteString)
forall a b. a -> Either a b
Left (Text -> ByteString
fromText (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
"url(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uri Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
                    Fetched (Text
mt', ByteString
raw) -> do
                      -- note that the downloaded CSS may
                      -- itself contain url(...).
                      (mt, b) <- if Text
"text/css" Text -> Text -> Bool
`T.isPrefixOf` Text
mt'
                                    -- see #5725: in HTML5, content type
                                    -- isn't allowed on style type attribute
                                    then (Text
"text/css",) (ByteString -> (Text, ByteString))
-> ParsecT ByteString () (StateT ConvertState m) ByteString
-> ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT ConvertState m ByteString
-> ParsecT ByteString () (StateT ConvertState m) ByteString
forall (m :: * -> *) a. Monad m => m a -> ParsecT ByteString () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> ByteString -> StateT ConvertState m ByteString
forall (m :: * -> *).
PandocMonad m =>
String -> ByteString -> StateT ConvertState m ByteString
cssURLs String
d ByteString
raw)
                                    else (Text, ByteString)
-> ParsecT ByteString () (StateT ConvertState m) (Text, ByteString)
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
mt', ByteString
raw)
                      return $ Right (mt, b)
                    CouldNotFetch PandocError
_ -> Either ByteString (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a. a -> ParsecT ByteString () (StateT ConvertState m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString (Text, ByteString)
 -> ParsecT
      ByteString
      ()
      (StateT ConvertState m)
      (Either ByteString (Text, ByteString)))
-> Either ByteString (Text, ByteString)
-> ParsecT
     ByteString
     ()
     (StateT ConvertState m)
     (Either ByteString (Text, ByteString))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString (Text, ByteString)
forall a b. a -> Either a b
Left ByteString
fallback

data GetDataResult =
    AlreadyDataURI T.Text
  | CouldNotFetch PandocError
  | Fetched (MimeType, ByteString)
  deriving (Int -> GetDataResult -> String -> String
[GetDataResult] -> String -> String
GetDataResult -> String
(Int -> GetDataResult -> String -> String)
-> (GetDataResult -> String)
-> ([GetDataResult] -> String -> String)
-> Show GetDataResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GetDataResult -> String -> String
showsPrec :: Int -> GetDataResult -> String -> String
$cshow :: GetDataResult -> String
show :: GetDataResult -> String
$cshowList :: [GetDataResult] -> String -> String
showList :: [GetDataResult] -> String -> String
Show)

-- | Decompress gzipped data, catching decompression errors instead
-- of throwing an imprecise exception from pure code.
decompressGzip :: ByteString -> Either T.Text ByteString
decompressGzip :: ByteString -> Either Text ByteString
decompressGzip ByteString
bs =
  [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> Either Text [ByteString] -> Either Text ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (ByteString
 -> Either Text [ByteString] -> Either Text [ByteString])
-> (ByteString -> Either Text [ByteString])
-> (DecompressError -> Either Text [ByteString])
-> (forall s. DecompressStream (ST s))
-> ByteString
-> Either Text [ByteString]
forall a.
(ByteString -> a -> a)
-> (ByteString -> a)
-> (DecompressError -> a)
-> (forall s. DecompressStream (ST s))
-> ByteString
-> a
Zlib.foldDecompressStreamWithInput
      (\ByteString
chunk Either Text [ByteString]
rest -> (ByteString
chunk ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:) ([ByteString] -> [ByteString])
-> Either Text [ByteString] -> Either Text [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text [ByteString]
rest)
      (Either Text [ByteString] -> ByteString -> Either Text [ByteString]
forall a b. a -> b -> a
const ([ByteString] -> Either Text [ByteString]
forall a b. b -> Either a b
Right []))
      (Text -> Either Text [ByteString]
forall a b. a -> Either a b
Left (Text -> Either Text [ByteString])
-> (DecompressError -> Text)
-> DecompressError
-> Either Text [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (DecompressError -> String) -> DecompressError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecompressError -> String
forall a. Show a => a -> String
show)
      (Format -> DecompressParams -> DecompressStream (ST s)
forall s. Format -> DecompressParams -> DecompressStream (ST s)
Zlib.decompressST Format
Zlib.gzipFormat DecompressParams
Zlib.defaultDecompressParams)
      (ByteString -> ByteString
L.fromStrict ByteString
bs)

getData :: PandocMonad m
        => MimeType -> T.Text
        -> StateT ConvertState m GetDataResult
getData :: forall (m :: * -> *).
PandocMonad m =>
Text -> Text -> StateT ConvertState m GetDataResult
getData Text
mimetype Text
src
  | Text
"data:" Text -> Text -> Bool
`T.isPrefixOf` Text
src = GetDataResult -> StateT ConvertState m GetDataResult
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GetDataResult -> StateT ConvertState m GetDataResult)
-> GetDataResult -> StateT ConvertState m GetDataResult
forall a b. (a -> b) -> a -> b
$ Text -> GetDataResult
AlreadyDataURI Text
src -- already data: uri
  | Bool
otherwise = do
      cache <- (ConvertState -> Map (Text, Text) GetDataResult)
-> StateT ConvertState m (Map (Text, Text) GetDataResult)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ConvertState -> Map (Text, Text) GetDataResult
fetchCache
      case M.lookup (mimetype, src) cache of
        Just GetDataResult
res -> GetDataResult -> StateT ConvertState m GetDataResult
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return GetDataResult
res
        Maybe GetDataResult
Nothing -> do
          res <- StateT ConvertState m GetDataResult
-> (PandocError -> StateT ConvertState m GetDataResult)
-> StateT ConvertState m GetDataResult
forall a.
StateT ConvertState m a
-> (PandocError -> StateT ConvertState m a)
-> StateT ConvertState m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError StateT ConvertState m GetDataResult
fetcher PandocError -> StateT ConvertState m GetDataResult
forall {m :: * -> *}.
PandocMonad m =>
PandocError -> StateT ConvertState m GetDataResult
handler
          modify $ \ConvertState
st ->
            ConvertState
st{ fetchCache = M.insert (mimetype, src) res (fetchCache st) }
          return res
 where
   fetcher :: StateT ConvertState m GetDataResult
fetcher = do
      let ext :: Text
ext = Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
takeExtension (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
src
      (raw, respMime) <- Text -> StateT ConvertState m (ByteString, Maybe Text)
forall (m :: * -> *).
PandocMonad m =>
Text -> m (ByteString, Maybe Text)
fetchItem Text
src
      if ext `elem` [".gz", ".svgz"]
         then case decompressGzip raw of
                Right ByteString
raw' -> ByteString -> Maybe Text -> StateT ConvertState m GetDataResult
forall {m :: * -> *}.
PandocMonad m =>
ByteString -> Maybe Text -> StateT ConvertState m GetDataResult
processFetched ByteString
raw' Maybe Text
respMime
                Left Text
err -> do
                  let msg :: Text
msg = Text
"could not decompress: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
                  LogMessage -> StateT ConvertState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT ConvertState m ())
-> LogMessage -> StateT ConvertState m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LogMessage
CouldNotFetchResource Text
src Text
msg
                  GetDataResult -> StateT ConvertState m GetDataResult
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GetDataResult -> StateT ConvertState m GetDataResult)
-> GetDataResult -> StateT ConvertState m GetDataResult
forall a b. (a -> b) -> a -> b
$ PandocError -> GetDataResult
CouldNotFetch (PandocError -> GetDataResult) -> PandocError -> GetDataResult
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError Text
msg
         else processFetched raw respMime
   processFetched :: ByteString -> Maybe Text -> StateT ConvertState m GetDataResult
processFetched ByteString
raw' Maybe Text
respMime = do
      let mime :: Text
mime = case (Text
mimetype, Maybe Text
respMime) of
                  (Text
"",Maybe Text
Nothing) -> Text
"application/octet-stream"
                  (Text
x, Maybe Text
Nothing) -> Text
x
                  (Text
_, Just Text
x ) -> Text
x
      result <- if Text
"text/css" Text -> Text -> Bool
`T.isPrefixOf` Text
mime
                then do
                  oldInputs <- StateT ConvertState m [String]
forall (m :: * -> *). PandocMonad m => m [String]
getInputFiles
                  setInputFiles [T.unpack src]
                  res <- cssURLs (takeDirectory $ T.unpack src) raw'
                  setInputFiles oldInputs
                  return res
               else ByteString -> StateT ConvertState m ByteString
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
raw'
      return $ Fetched (mime, result)
   handler :: PandocError -> StateT ConvertState m GetDataResult
handler PandocError
e
      -- If fetch failed and we have a fragment and/or query,
      -- try the fetch again without these, since the resource
      -- may be local (see #1477, #11021)
     | (Char -> Bool) -> Text -> Bool
T.any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'#') Text
src Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
isURI Text
src)
       = Text -> Text -> StateT ConvertState m GetDataResult
forall (m :: * -> *).
PandocMonad m =>
Text -> Text -> StateT ConvertState m GetDataResult
getData Text
mimetype (Text -> Text
removeQueryAndFragment Text
src)
     | Bool
otherwise
       = case PandocError
e of
          PandocResourceNotFound Text
r -> do
            LogMessage -> StateT ConvertState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT ConvertState m ())
-> LogMessage -> StateT ConvertState m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LogMessage
CouldNotFetchResource Text
r Text
""
            GetDataResult -> StateT ConvertState m GetDataResult
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GetDataResult -> StateT ConvertState m GetDataResult)
-> GetDataResult -> StateT ConvertState m GetDataResult
forall a b. (a -> b) -> a -> b
$ PandocError -> GetDataResult
CouldNotFetch PandocError
e
          PandocHttpError Text
u Text
er -> do
            LogMessage -> StateT ConvertState m ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> StateT ConvertState m ())
-> LogMessage -> StateT ConvertState m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LogMessage
CouldNotFetchResource Text
u Text
er
            GetDataResult -> StateT ConvertState m GetDataResult
forall a. a -> StateT ConvertState m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GetDataResult -> StateT ConvertState m GetDataResult)
-> GetDataResult -> StateT ConvertState m GetDataResult
forall a b. (a -> b) -> a -> b
$ PandocError -> GetDataResult
CouldNotFetch PandocError
e
          PandocError
_ -> PandocError -> StateT ConvertState m GetDataResult
forall a. PandocError -> StateT ConvertState m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PandocError
e
   removeQueryAndFragment :: Text -> Text
removeQueryAndFragment = (Char -> Bool) -> Text -> Text
T.takeWhile (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?')

-- | Convert HTML into self-contained HTML, incorporating images,
-- scripts, and CSS using data: URIs.
makeSelfContained :: PandocMonad m => T.Text -> m T.Text
makeSelfContained :: forall (m :: * -> *). PandocMonad m => Text -> m Text
makeSelfContained Text
inp = do
  let tags :: [Tag Text]
tags = Text -> [Tag Text]
forall str. StringLike str => str -> [Tag str]
parseTags Text
inp
  let convertState :: ConvertState
convertState = ConvertState { svgMap :: Map Text (Text, [(Text, Text)])
svgMap = Map Text (Text, [(Text, Text)])
forall a. Monoid a => a
mempty,
                                    fetchCache :: Map (Text, Text) GetDataResult
fetchCache = Map (Text, Text) GetDataResult
forall a. Monoid a => a
mempty }
  out' <- StateT ConvertState m [Tag Text] -> ConvertState -> m [Tag Text]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ([Tag Text] -> StateT ConvertState m [Tag Text]
forall (m :: * -> *).
PandocMonad m =>
[Tag Text] -> StateT ConvertState m [Tag Text]
convertTags [Tag Text]
tags) ConvertState
convertState
  return $ renderTags' out'