{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE TypeOperators   #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Server
    ( app
    , ServerOpts(..)
    , Params(..)
    , Blob(..)
    , parseServerOpts
    ) where

import Data.Aeson
import Network.Wai
import Servant
import Text.DocTemplates as DocTemplates
import Text.Pandoc
import Text.Pandoc.Citeproc (processCitations)
import Text.Pandoc.Highlighting (lookupHighlightingStyle)
import qualified Text.Pandoc.UTF8 as UTF8
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Maybe (fromMaybe)
import Data.Char (isAlphaNum)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Base64 (decodeBase64, encodeBase64)
import Data.Default
import Control.Monad (when, foldM)
import qualified Data.Set as Set
import Skylighting (defaultSyntaxMap)
import qualified Data.Map as M
import System.Console.GetOpt
import System.Environment (getArgs, getProgName)
import qualified Control.Exception as E
import Text.Pandoc.Shared (safeStrRead, headerShift, filterIpynbOutput,
                           eastAsianLineBreakFilter, stripEmptyParagraphs)
import Text.Pandoc.App.Opt ( IpynbOutput (..), Opt(..), defaultOpts )
import Text.Pandoc.Builder (setMeta)
import Text.Pandoc.SelfContained (makeSelfContained)
import System.Exit

data ServerOpts =
  ServerOpts
    { ServerOpts -> Int
serverPort    :: Int
    , ServerOpts -> Int
serverTimeout :: Int }
  deriving (Int -> ServerOpts -> ShowS
[ServerOpts] -> ShowS
ServerOpts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerOpts] -> ShowS
$cshowList :: [ServerOpts] -> ShowS
show :: ServerOpts -> String
$cshow :: ServerOpts -> String
showsPrec :: Int -> ServerOpts -> ShowS
$cshowsPrec :: Int -> ServerOpts -> ShowS
Show)

defaultServerOpts :: ServerOpts
defaultServerOpts :: ServerOpts
defaultServerOpts = ServerOpts { serverPort :: Int
serverPort = Int
3030, serverTimeout :: Int
serverTimeout = Int
2 }

cliOptions :: [OptDescr (ServerOpts -> IO ServerOpts)]
cliOptions :: [OptDescr (ServerOpts -> IO ServerOpts)]
cliOptions =
  [ forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'p'] [String
"port"]
      (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s ServerOpts
opts -> case forall (m :: * -> *) a. (MonadPlus m, Read a) => String -> m a
safeStrRead String
s of
                            Just Int
i -> forall (m :: * -> *) a. Monad m => a -> m a
return ServerOpts
opts{ serverPort :: Int
serverPort = Int
i }
                            Maybe Int
Nothing ->
                              forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocOptionError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack
                                String
s forall a. Semigroup a => a -> a -> a
<> Text
" is not a number") String
"NUMBER")
      String
"port number"
  , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
't'] [String
"timeout"]
      (forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s ServerOpts
opts -> case forall (m :: * -> *) a. (MonadPlus m, Read a) => String -> m a
safeStrRead String
s of
                            Just Int
i -> forall (m :: * -> *) a. Monad m => a -> m a
return ServerOpts
opts{ serverTimeout :: Int
serverTimeout = Int
i }
                            Maybe Int
Nothing ->
                              forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocOptionError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack
                                String
s forall a. Semigroup a => a -> a -> a
<> Text
" is not a number") String
"NUMBER")
      String
"timeout (seconds)"

  , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'h'] [String
"help"]
      (forall a. a -> ArgDescr a
NoArg (\ServerOpts
_ -> do
        String
prg <- IO String
getProgName
        let header :: String
header = String
"Usage: " forall a. Semigroup a => a -> a -> a
<> String
prg forall a. Semigroup a => a -> a -> a
<> String
" [OPTION...]"
        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. String -> [OptDescr a] -> String
usageInfo String
header [OptDescr (ServerOpts -> IO ServerOpts)]
cliOptions
        forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess))
      String
"help message"

  , forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'v'] [String
"version"]
      (forall a. a -> ArgDescr a
NoArg (\ServerOpts
_ -> do
        String
prg <- IO String
getProgName
        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
prg forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
pandocVersion
        forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess))
      String
"version info"

  ]

parseServerOpts :: IO ServerOpts
parseServerOpts :: IO ServerOpts
parseServerOpts = do
  [String]
args <- IO [String]
getArgs
  let handleUnknownOpt :: a -> a
handleUnknownOpt a
x = a
"Unknown option: " forall a. Semigroup a => a -> a -> a
<> a
x
  case forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' forall a. ArgOrder a
Permute [OptDescr (ServerOpts -> IO ServerOpts)]
cliOptions [String]
args of
    ([ServerOpts -> IO ServerOpts]
os, [String]
ns, [String]
unrecognizedOpts, [String]
es) -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
es) Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unrecognizedOpts)) forall a b. (a -> b) -> a -> b
$
        forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocOptionError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
es forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (Semigroup a, IsString a) => a -> a
handleUnknownOpt [String]
unrecognizedOpts) forall a. [a] -> [a] -> [a]
++
          (String
"Try --help for more information.")
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ns)) forall a b. (a -> b) -> a -> b
$
        forall e a. Exception e => e -> IO a
E.throwIO forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocOptionError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$
                     String
"Unknown arguments: " forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
ns
      forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) ServerOpts
defaultServerOpts [ServerOpts -> IO ServerOpts]
os

newtype Blob = Blob BL.ByteString
  deriving (Int -> Blob -> ShowS
[Blob] -> ShowS
Blob -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Blob] -> ShowS
$cshowList :: [Blob] -> ShowS
show :: Blob -> String
$cshow :: Blob -> String
showsPrec :: Int -> Blob -> ShowS
$cshowsPrec :: Int -> Blob -> ShowS
Show, Blob -> Blob -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Blob -> Blob -> Bool
$c/= :: Blob -> Blob -> Bool
== :: Blob -> Blob -> Bool
$c== :: Blob -> Blob -> Bool
Eq)

instance ToJSON Blob where
  toJSON :: Blob -> Value
toJSON (Blob ByteString
bs) = forall a. ToJSON a => a -> Value
toJSON (ByteString -> Text
encodeBase64 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
bs)

instance FromJSON Blob where
 parseJSON :: Value -> Parser Blob
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Blob" forall a b. (a -> b) -> a -> b
$ \Text
t -> do
   let inp :: ByteString
inp = Text -> ByteString
UTF8.fromText Text
t
   case ByteString -> Either Text ByteString
decodeBase64 ByteString
inp of
        Right ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Blob
Blob forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
bs
        Left Text
_ -> -- treat as regular text
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Blob
Blob forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
inp

-- This is the data to be supplied by the JSON payload
-- of requests.  Maybe values may be omitted and will be
-- given default values.
data Params = Params
  { Params -> Opt
options               :: Opt
  , Params -> Text
text                  :: Text
  , Params -> Maybe (Map String Blob)
files                 :: Maybe (M.Map FilePath Blob)
  , Params -> Maybe Bool
citeproc              :: Maybe Bool
  } deriving (Int -> Params -> ShowS
[Params] -> ShowS
Params -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Params] -> ShowS
$cshowList :: [Params] -> ShowS
show :: Params -> String
$cshow :: Params -> String
showsPrec :: Int -> Params -> ShowS
$cshowsPrec :: Int -> Params -> ShowS
Show)

instance Default Params where
  def :: Params
def = Params
    { options :: Opt
options = Opt
defaultOpts
    , text :: Text
text = forall a. Monoid a => a
mempty
    , files :: Maybe (Map String Blob)
files = forall a. Maybe a
Nothing
    , citeproc :: Maybe Bool
citeproc = forall a. Maybe a
Nothing
    }

-- Automatically derive code to convert to/from JSON.
instance FromJSON Params where
 parseJSON :: Value -> Parser Params
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Params" forall a b. (a -> b) -> a -> b
$ \Object
o ->
   Opt -> Text -> Maybe (Map String Blob) -> Maybe Bool -> Params
Params
     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"text"
     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"files"
     forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"citeproc"


-- This is the API.  The "/convert" endpoint takes a request body
-- consisting of a JSON-encoded Params structure and responds to
-- Get requests with either plain text or JSON, depending on the
-- Accept header.
type API =
  ReqBody '[JSON] Params :> Post '[PlainText, JSON] Text
  :<|>
  ReqBody '[JSON] Params :> Post '[OctetStream] BS.ByteString
  :<|>
  "batch" :> ReqBody '[JSON] [Params] :> Post '[JSON] [Text]
  :<|>
  "babelmark" :> QueryParam' '[Required] "text" Text :> QueryParam "from" Text :> QueryParam "to" Text :> QueryFlag "standalone" :> Get '[JSON] Value
  :<|>
  "version" :> Get '[PlainText, JSON] Text

app :: Application
app :: Application
app = forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy API
api Server API
server

api :: Proxy API
api :: Proxy API
api = forall {k} (t :: k). Proxy t
Proxy

server :: Server API
server :: Server API
server = forall {m :: * -> *}. MonadError ServerError m => Params -> m Text
convert
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}.
MonadError ServerError m =>
Params -> m ByteString
convertBytes
    forall a b. a -> b -> a :<|> b
:<|> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. MonadError ServerError m => Params -> m Text
convert
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}.
MonadError ServerError m =>
Text -> Maybe Text -> Maybe Text -> Bool -> m Value
babelmark  -- for babelmark which expects {"html": "", "version": ""}
    forall a b. a -> b -> a :<|> b
:<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
pandocVersion
 where
  babelmark :: Text -> Maybe Text -> Maybe Text -> Bool -> m Value
babelmark Text
text' Maybe Text
from' Maybe Text
to' Bool
standalone' = do
    Text
res <- forall {m :: * -> *}. MonadError ServerError m => Params -> m Text
convert forall a. Default a => a
def{ text :: Text
text = Text
text',
                        options :: Opt
options = Opt
defaultOpts{
                          optFrom :: Maybe Text
optFrom = Maybe Text
from',
                          optTo :: Maybe Text
optTo = Maybe Text
to',
                          optStandalone :: Bool
optStandalone = Bool
standalone' }
                      }
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"html" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
res, Key
"version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
pandocVersion ]

  -- We use runPure for the pandoc conversions, which ensures that
  -- they will do no IO.  This makes the server safe to use.  However,
  -- it will mean that features requiring IO, like RST includes, will not work.
  -- Changing this to
  --    handleErr =<< liftIO (runIO (convert' params))
  -- will allow the IO operations.
  convert :: Params -> m Text
convert Params
params = forall {m :: * -> *} {a}.
MonadError ServerError m =>
Either PandocError a -> m a
handleErr forall a b. (a -> b) -> a -> b
$
    forall a. PandocPure a -> Either PandocError a
runPure (forall a.
(Text -> a) -> (ByteString -> a) -> Params -> PandocPure a
convert' forall a. a -> a
id (ByteString -> Text
encodeBase64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict) Params
params)

  convertBytes :: Params -> m ByteString
convertBytes Params
params = forall {m :: * -> *} {a}.
MonadError ServerError m =>
Either PandocError a -> m a
handleErr forall a b. (a -> b) -> a -> b
$
    forall a. PandocPure a -> Either PandocError a
runPure (forall a.
(Text -> a) -> (ByteString -> a) -> Params -> PandocPure a
convert' Text -> ByteString
UTF8.fromText ByteString -> ByteString
BL.toStrict Params
params)

  convert' :: (Text -> a) -> (BL.ByteString -> a) -> Params -> PandocPure a
  convert' :: forall a.
(Text -> a) -> (ByteString -> a) -> Params -> PandocPure a
convert' Text -> a
textHandler ByteString -> a
bsHandler Params
params = do
    UTCTime
curtime <- forall (m :: * -> *). PandocMonad m => m UTCTime
getCurrentTime
    -- put files params in ersatz file system
    let addFile :: FilePath -> Blob -> FileTree -> FileTree
        addFile :: String -> Blob -> FileTree -> FileTree
addFile String
fp (Blob ByteString
lbs) =
          String -> FileInfo -> FileTree -> FileTree
insertInFileTree String
fp FileInfo{ infoFileMTime :: UTCTime
infoFileMTime = UTCTime
curtime
                                      , infoFileContents :: ByteString
infoFileContents = ByteString -> ByteString
BL.toStrict ByteString
lbs }
    case Params -> Maybe (Map String Blob)
files Params
params of
      Maybe (Map String Blob)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just Map String Blob
fs -> do
        let filetree :: FileTree
filetree = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey String -> Blob -> FileTree -> FileTree
addFile forall a. Monoid a => a
mempty Map String Blob
fs
        (PureState -> PureState) -> PandocPure ()
modifyPureState forall a b. (a -> b) -> a -> b
$ \PureState
st -> PureState
st{ stFiles :: FileTree
stFiles = FileTree
filetree }

    let opts :: Opt
opts = Params -> Opt
options Params
params
    let readerFormat :: Text
readerFormat = forall a. a -> Maybe a -> a
fromMaybe Text
"markdown" forall a b. (a -> b) -> a -> b
$ Opt -> Maybe Text
optFrom Opt
opts
    let writerFormat :: Text
writerFormat = forall a. a -> Maybe a -> a
fromMaybe Text
"html" forall a b. (a -> b) -> a -> b
$ Opt -> Maybe Text
optTo Opt
opts
    (Reader PandocPure
readerSpec, Extensions
readerExts) <- forall (m :: * -> *).
PandocMonad m =>
Text -> m (Reader m, Extensions)
getReader Text
readerFormat
    (Writer PandocPure
writerSpec, Extensions
writerExts) <- forall (m :: * -> *).
PandocMonad m =>
Text -> m (Writer m, Extensions)
getWriter Text
writerFormat

    let isStandalone :: Bool
isStandalone = Opt -> Bool
optStandalone Opt
opts
    let toformat :: Text
toformat = Text -> Text
T.toLower forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.takeWhile Char -> Bool
isAlphaNum forall a b. (a -> b) -> a -> b
$ Text
writerFormat
    Maybe Style
hlStyle <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *). PandocMonad m => String -> m Style
lookupHighlightingStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
                  forall a b. (a -> b) -> a -> b
$ Opt -> Maybe Text
optHighlightStyle Opt
opts

    Maybe (Template Text)
mbTemplate <- if Bool
isStandalone
                     then case Opt -> Maybe String
optTemplate Opt
opts of
                            Maybe String
Nothing -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                              forall (m :: * -> *). PandocMonad m => Text -> m (Template Text)
compileDefaultTemplate Text
toformat
                            Just String
t  -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                              forall {m :: * -> *} {a}.
(PandocMonad m, HasChars a, ToText a, FromText a) =>
Text -> String -> m (Template a)
compileCustomTemplate Text
toformat String
t
                     else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    Set Text
abbrevs <- forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
UTF8.toText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                 case Opt -> Maybe String
optAbbreviations Opt
opts of
                      Maybe String
Nothing -> forall (m :: * -> *). PandocMonad m => String -> m ByteString
readDataFile String
"abbreviations"
                      Just String
f  -> forall (m :: * -> *). PandocMonad m => String -> m ByteString
readFileStrict String
f

    let readeropts :: ReaderOptions
readeropts = forall a. Default a => a
def{ readerExtensions :: Extensions
readerExtensions = Extensions
readerExts
                        , readerStandalone :: Bool
readerStandalone = Bool
isStandalone
                        , readerTabStop :: Int
readerTabStop = Opt -> Int
optTabStop Opt
opts
                        , readerIndentedCodeClasses :: [Text]
readerIndentedCodeClasses =
                            Opt -> [Text]
optIndentedCodeClasses Opt
opts
                        , readerAbbreviations :: Set Text
readerAbbreviations = Set Text
abbrevs
                        , readerDefaultImageExtension :: Text
readerDefaultImageExtension =
                            Opt -> Text
optDefaultImageExtension Opt
opts
                        , readerTrackChanges :: TrackChanges
readerTrackChanges = Opt -> TrackChanges
optTrackChanges Opt
opts
                        , readerStripComments :: Bool
readerStripComments = Opt -> Bool
optStripComments Opt
opts
                        }
    let writeropts :: WriterOptions
writeropts =
          forall a. Default a => a
def{ writerExtensions :: Extensions
writerExtensions = Extensions
writerExts
             , writerTabStop :: Int
writerTabStop = Opt -> Int
optTabStop Opt
opts
             , writerWrapText :: WrapOption
writerWrapText = Opt -> WrapOption
optWrap Opt
opts
             , writerColumns :: Int
writerColumns = Opt -> Int
optColumns Opt
opts
             , writerTemplate :: Maybe (Template Text)
writerTemplate = Maybe (Template Text)
mbTemplate
             , writerSyntaxMap :: SyntaxMap
writerSyntaxMap = SyntaxMap
defaultSyntaxMap
             , writerVariables :: Context Text
writerVariables = Opt -> Context Text
optVariables Opt
opts
             , writerTableOfContents :: Bool
writerTableOfContents = Opt -> Bool
optTableOfContents Opt
opts
             , writerIncremental :: Bool
writerIncremental = Opt -> Bool
optIncremental Opt
opts
             , writerHTMLMathMethod :: HTMLMathMethod
writerHTMLMathMethod = Opt -> HTMLMathMethod
optHTMLMathMethod Opt
opts
             , writerNumberSections :: Bool
writerNumberSections = Opt -> Bool
optNumberSections Opt
opts
             , writerNumberOffset :: [Int]
writerNumberOffset = Opt -> [Int]
optNumberOffset Opt
opts
             , writerSectionDivs :: Bool
writerSectionDivs = Opt -> Bool
optSectionDivs Opt
opts
             , writerReferenceLinks :: Bool
writerReferenceLinks = Opt -> Bool
optReferenceLinks Opt
opts
             , writerDpi :: Int
writerDpi = Opt -> Int
optDpi Opt
opts
             , writerEmailObfuscation :: ObfuscationMethod
writerEmailObfuscation = Opt -> ObfuscationMethod
optEmailObfuscation Opt
opts
             , writerIdentifierPrefix :: Text
writerIdentifierPrefix = Opt -> Text
optIdentifierPrefix Opt
opts
             , writerCiteMethod :: CiteMethod
writerCiteMethod = Opt -> CiteMethod
optCiteMethod Opt
opts
             , writerHtmlQTags :: Bool
writerHtmlQTags = Opt -> Bool
optHtmlQTags Opt
opts
             , writerSlideLevel :: Maybe Int
writerSlideLevel = Opt -> Maybe Int
optSlideLevel Opt
opts
             , writerTopLevelDivision :: TopLevelDivision
writerTopLevelDivision = Opt -> TopLevelDivision
optTopLevelDivision Opt
opts
             , writerListings :: Bool
writerListings = Opt -> Bool
optListings Opt
opts
             , writerHighlightStyle :: Maybe Style
writerHighlightStyle = Maybe Style
hlStyle
             , writerSetextHeaders :: Bool
writerSetextHeaders = Opt -> Bool
optSetextHeaders Opt
opts
             , writerEpubSubdirectory :: Text
writerEpubSubdirectory = String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Opt -> String
optEpubSubdirectory Opt
opts
             , writerEpubMetadata :: Maybe Text
writerEpubMetadata = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Opt -> Maybe String
optEpubMetadata Opt
opts
             , writerEpubFonts :: [String]
writerEpubFonts = Opt -> [String]
optEpubFonts Opt
opts
             , writerEpubChapterLevel :: Int
writerEpubChapterLevel = Opt -> Int
optEpubChapterLevel Opt
opts
             , writerTOCDepth :: Int
writerTOCDepth = Opt -> Int
optTOCDepth Opt
opts
             , writerReferenceDoc :: Maybe String
writerReferenceDoc = Opt -> Maybe String
optReferenceDoc Opt
opts
             , writerReferenceLocation :: ReferenceLocation
writerReferenceLocation = Opt -> ReferenceLocation
optReferenceLocation Opt
opts
             , writerPreferAscii :: Bool
writerPreferAscii = Opt -> Bool
optAscii Opt
opts
             }
    let reader :: Text -> PandocPure Pandoc
reader = case Reader PandocPure
readerSpec of
                TextReader forall a. ToSources a => ReaderOptions -> a -> PandocPure Pandoc
r -> forall a. ToSources a => ReaderOptions -> a -> PandocPure Pandoc
r ReaderOptions
readeropts
                ByteStringReader ReaderOptions -> ByteString -> PandocPure Pandoc
r -> \Text
t -> do
                  let eitherbs :: Either Text ByteString
eitherbs = ByteString -> Either Text ByteString
decodeBase64 forall a b. (a -> b) -> a -> b
$ Text -> ByteString
UTF8.fromText Text
t
                  case Either Text ByteString
eitherbs of
                    Left Text
errt -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocSomeError Text
errt
                    Right ByteString
bs -> ReaderOptions -> ByteString -> PandocPure Pandoc
r ReaderOptions
readeropts forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
bs
    let writer :: Pandoc -> PandocPure a
writer = case Writer PandocPure
writerSpec of
                TextWriter WriterOptions -> Pandoc -> PandocPure Text
w ->
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> a
textHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  (\Pandoc
d -> WriterOptions -> Pandoc -> PandocPure Text
w WriterOptions
writeropts Pandoc
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                         if Opt -> Bool
optEmbedResources Opt
opts Bool -> Bool -> Bool
&& Maybe Text -> Bool
htmlFormat (Opt -> Maybe Text
optTo Opt
opts)
                            then forall (m :: * -> *). PandocMonad m => Text -> m Text
makeSelfContained
                            else forall (m :: * -> *) a. Monad m => a -> m a
return)
                ByteStringWriter WriterOptions -> Pandoc -> PandocPure ByteString
w -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> a
bsHandler forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterOptions -> Pandoc -> PandocPure ByteString
w WriterOptions
writeropts

    let transforms :: Pandoc -> Pandoc
        transforms :: Pandoc -> Pandoc
transforms = (case Opt -> Int
optShiftHeadingLevelBy Opt
opts of
                        Int
0             -> forall a. a -> a
id
                        Int
x             -> Int -> Pandoc -> Pandoc
headerShift Int
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   (case Opt -> Bool
optStripEmptyParagraphs Opt
opts of
                        Bool
True          -> Pandoc -> Pandoc
stripEmptyParagraphs
                        Bool
False         -> forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   (if Extension -> Extensions -> Bool
extensionEnabled Extension
Ext_east_asian_line_breaks
                          Extensions
readerExts Bool -> Bool -> Bool
&&
                       Bool -> Bool
not (Extension -> Extensions -> Bool
extensionEnabled Extension
Ext_east_asian_line_breaks
                              Extensions
writerExts Bool -> Bool -> Bool
&&
                            Opt -> WrapOption
optWrap Opt
opts forall a. Eq a => a -> a -> Bool
== WrapOption
WrapPreserve)
                       then Pandoc -> Pandoc
eastAsianLineBreakFilter
                       else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   (case Opt -> IpynbOutput
optIpynbOutput Opt
opts of
                     IpynbOutput
IpynbOutputAll  -> forall a. a -> a
id
                     IpynbOutput
IpynbOutputNone -> Maybe Format -> Pandoc -> Pandoc
filterIpynbOutput forall a. Maybe a
Nothing
                     IpynbOutput
IpynbOutputBest -> Maybe Format -> Pandoc -> Pandoc
filterIpynbOutput (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
                       case Opt -> Maybe Text
optTo Opt
opts of
                            Just Text
"latex"  -> Text -> Format
Format Text
"latex"
                            Just Text
"beamer" -> Text -> Format
Format Text
"latex"
                            Maybe Text
Nothing       -> Text -> Format
Format Text
"html"
                            Just Text
f
                              | Maybe Text -> Bool
htmlFormat (Opt -> Maybe Text
optTo Opt
opts) -> Text -> Format
Format Text
"html"
                              | Bool
otherwise -> Text -> Format
Format Text
f))

    let meta :: Meta
meta =   (case Opt -> [String]
optBibliography Opt
opts of
                   [] -> forall a. a -> a
id
                   [String]
fs -> forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta Text
"bibliography" ([MetaValue] -> MetaValue
MetaList
                            (forall a b. (a -> b) -> [a] -> [b]
map (Text -> MetaValue
MetaString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [String]
fs))) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta Text
"csl" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MetaValue
MetaString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
                   (Opt -> Maybe String
optCSL Opt
opts) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
setMeta Text
"citation-abbreviations" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MetaValue
MetaString forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                              String -> Text
T.pack)
                   (Opt -> Maybe String
optCitationAbbreviations Opt
opts) forall a b. (a -> b) -> a -> b
$
                 Opt -> Meta
optMetadata Opt
opts

    let addMetadata :: Meta -> Pandoc -> Pandoc
addMetadata Meta
m' (Pandoc Meta
m [Block]
bs) = Meta -> [Block] -> Pandoc
Pandoc (Meta
m forall a. Semigroup a => a -> a -> a
<> Meta
m') [Block]
bs

    Text -> PandocPure Pandoc
reader (Params -> Text
text Params
params) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> Pandoc
transforms forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> Pandoc -> Pandoc
addMetadata Meta
meta forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (case Params -> Maybe Bool
citeproc Params
params of
          Just Bool
True -> forall (m :: * -> *). PandocMonad m => Pandoc -> m Pandoc
processCitations
          Maybe Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      Pandoc -> PandocPure a
writer

  htmlFormat :: Maybe Text -> Bool
  htmlFormat :: Maybe Text -> Bool
htmlFormat Maybe Text
Nothing = Bool
True
  htmlFormat (Just Text
f) =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
f)
      [Text
"html",Text
"html4",Text
"html5",Text
"s5",Text
"slidy", Text
"slideous",Text
"dzslides",Text
"revealjs"]

  handleErr :: Either PandocError a -> m a
handleErr (Right a
t) = forall (m :: * -> *) a. Monad m => a -> m a
return a
t
  handleErr (Left PandocError
err) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
    ServerError
err500 { errBody :: ByteString
errBody = Text -> ByteString
TLE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.fromStrict forall a b. (a -> b) -> a -> b
$ PandocError -> Text
renderError PandocError
err }

  compileCustomTemplate :: Text -> String -> m (Template a)
compileCustomTemplate Text
toformat String
t = do
    Either String (Template a)
res <- forall (m :: * -> *) a. WithPartials m a -> m a
runWithPartials forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
String -> Text -> m (Either String (Template a))
compileTemplate (String
"custom." forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
toformat)
               (String -> Text
T.pack String
t)
    case Either String (Template a)
res of
      Left String
e -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocTemplateError (String -> Text
T.pack String
e)
      Right Template a
tpl -> forall (m :: * -> *) a. Monad m => a -> m a
return Template a
tpl