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

import Data.Aeson
import qualified Data.Aeson.KeyMap as KeyMap
import Network.Wai
import Servant
import Text.DocTemplates as DocTemplates
import Text.Pandoc
import Text.Pandoc.Writers.Shared (lookupMetaString)
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 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, unless, foldM)
import qualified Data.Set as Set
import Skylighting (defaultSyntaxMap)
import qualified Data.Map as M
import Text.Collate.Lang (Lang (..), parseLang)
import System.Console.GetOpt
import System.Environment (getProgName)
import qualified Control.Exception as E
import Text.Pandoc.Shared (safeStrRead, headerShift, filterIpynbOutput,
                           eastAsianLineBreakFilter)
import Text.Pandoc.App ( IpynbOutput (..), Opt(..), defaultOpts )
import Text.Pandoc.Builder (setMeta)
import Text.Pandoc.Format (parseFlavoredFormat, formatName)
import Text.Pandoc.SelfContained (makeSelfContained)
import System.Exit
import GHC.Generics (Generic)
import Network.Wai.Middleware.Cors ( cors,
           simpleCorsResourcePolicy, CorsResourcePolicy(corsRequestHeaders) )

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. IO a
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
pandocVersionText
        forall a. IO a
exitSuccess))
      String
"version info"

  ]

parseServerOptsFromArgs :: [String] -> IO ServerOpts
parseServerOptsFromArgs :: [String] -> IO ServerOpts
parseServerOptsFromArgs [String]
args = do
  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 => Base64 -> f () -> f ()
when (Base64 -> Base64
not (forall (t :: * -> *) a. Foldable t => t a -> Base64
null [String]
es) Base64 -> Base64 -> Base64
|| Base64 -> Base64
not (forall (t :: * -> *) a. Foldable t => t a -> Base64
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 => Base64 -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Base64
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 -> Base64
forall a. (a -> a -> Base64) -> (a -> a -> Base64) -> Eq a
/= :: Blob -> Blob -> Base64
$c/= :: Blob -> Blob -> Base64
== :: Blob -> Blob -> Base64
$c== :: Blob -> Blob -> Base64
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 Base64
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 Base64
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 Base64 -> 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"

instance ToJSON Params where
 toJSON :: Params -> Value
toJSON Params
params =
   case forall a. ToJSON a => a -> Value
toJSON (Params -> Opt
options Params
params) of
     (Object Object
o) -> Object -> Value
Object forall a b. (a -> b) -> a -> b
$
       forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"text" (forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Params -> Text
text Params
params)
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"files" (forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Params -> Maybe (Map String Blob)
files Params
params)
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"citeproc" (forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Params -> Maybe Base64
citeproc Params
params)
       forall a b. (a -> b) -> a -> b
$ Object
o
     Value
x -> Value
x

data Message =
  Message
  { Message -> Verbosity
verbosity :: Verbosity
  , Message -> Text
message   :: Text }
  deriving (forall x. Rep Message x -> Message
forall x. Message -> Rep Message x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Message x -> Message
$cfrom :: forall x. Message -> Rep Message x
Generic, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show)

instance ToJSON Message where
 toEncoding :: Message -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions

type Base64 = Bool

data Output = Succeeded Text Base64 [Message]
            | Failed Text
  deriving (forall x. Rep Output x -> Output
forall x. Output -> Rep Output x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Output x -> Output
$cfrom :: forall x. Output -> Rep Output x
Generic, Int -> Output -> ShowS
[Output] -> ShowS
Output -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Output] -> ShowS
$cshowList :: [Output] -> ShowS
show :: Output -> String
$cshow :: Output -> String
showsPrec :: Int -> Output -> ShowS
$cshowsPrec :: Int -> Output -> ShowS
Show)

instance ToJSON Output where
  toEncoding :: Output -> Encoding
toEncoding (Succeeded Text
o Base64
b [Message]
m) = Series -> Encoding
pairs
    ( Key
"output" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
o  forall a. Semigroup a => a -> a -> a
<>
      Key
"base64" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Base64
b  forall a. Semigroup a => a -> a -> a
<>
      Key
"messages" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Message]
m )
  toEncoding (Failed Text
errmsg) = Series -> Encoding
pairs
    ( Key
"error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
errmsg )

-- 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 '[OctetStream] BS.ByteString
  :<|>
  ReqBody '[JSON] Params :> Post '[PlainText] Text
  :<|>
  ReqBody '[JSON] Params :> Post '[JSON] Output
  :<|>
  "batch" :> ReqBody '[JSON] [Params] :> Post '[JSON] [Output]
  :<|>
  "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 = Middleware
corsWithContentType forall a b. (a -> b) -> a -> b
$ forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy API
api Server API
server

-- | Allow Content-Type header with values other then allowed by simpleCors.
corsWithContentType :: Middleware
corsWithContentType :: Middleware
corsWithContentType = (Request -> Maybe CorsResourcePolicy) -> Middleware
cors (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just CorsResourcePolicy
policy)
    where
      policy :: CorsResourcePolicy
policy = CorsResourcePolicy
simpleCorsResourcePolicy
        { corsRequestHeaders :: [HeaderName]
corsRequestHeaders = [HeaderName
"Content-Type"] }

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 ByteString
convertBytes
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}. MonadError ServerError m => Params -> m Text
convertText
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}. Monad m => Params -> m Output
convertJSON
    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 :: * -> *}. Monad m => Params -> m Output
convertJSON
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}.
MonadError ServerError m =>
Text -> Maybe Text -> Maybe Text -> Base64 -> 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
pandocVersionText
 where
  babelmark :: Text -> Maybe Text -> Maybe Text -> Base64 -> m Value
babelmark Text
text' Maybe Text
from' Maybe Text
to' Base64
standalone' = do
    Text
res <- forall {m :: * -> *}. MonadError ServerError m => Params -> m Text
convertText 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 :: Base64
optStandalone = Base64
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
.= Version
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.
  convertText :: Params -> m Text
convertText 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 -> PandocPure a)
-> (ByteString -> PandocPure a) -> Params -> PandocPure a
convert' forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> PandocPure a)
-> (ByteString -> PandocPure a) -> Params -> PandocPure a
convert' (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
UTF8.fromText) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict) Params
params)

  convertJSON :: Params -> m Output
convertJSON Params
params = forall {m :: * -> *}.
Monad m =>
Either PandocError Output -> m Output
handleErrJSON forall a b. (a -> b) -> a -> b
$
    forall a. PandocPure a -> Either PandocError a
runPure
      (forall a.
(Text -> PandocPure a)
-> (ByteString -> PandocPure a) -> Params -> PandocPure a
convert'
        (\Text
t -> Text -> Base64 -> [Message] -> Output
Succeeded Text
t Base64
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LogMessage -> Message
toMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => m [LogMessage]
getLog)
        (\ByteString
bs -> Text -> Base64 -> [Message] -> Output
Succeeded (ByteString -> Text
encodeBase64 (ByteString -> ByteString
BL.toStrict ByteString
bs)) Base64
True
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map LogMessage -> Message
toMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). PandocMonad m => m [LogMessage]
getLog)
        Params
params)

  toMessage :: LogMessage -> Message
toMessage LogMessage
m = Message { verbosity :: Verbosity
verbosity = LogMessage -> Verbosity
messageVerbosity LogMessage
m
                        , message :: Text
message = LogMessage -> Text
showLogMessage LogMessage
m }

  convert' :: (Text -> PandocPure a)
           -> (BL.ByteString -> PandocPure a)
           -> Params -> PandocPure a
  convert' :: forall a.
(Text -> PandocPure a)
-> (ByteString -> PandocPure a) -> Params -> PandocPure a
convert' Text -> PandocPure a
textHandler ByteString -> PandocPure 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
    FlavoredFormat
readerFormat <- forall (m :: * -> *). PandocMonad m => Text -> m FlavoredFormat
parseFlavoredFormat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Maybe a -> a
fromMaybe Text
"markdown" forall a b. (a -> b) -> a -> b
$ Opt -> Maybe Text
optFrom Opt
opts
    FlavoredFormat
writerFormat <- forall (m :: * -> *). PandocMonad m => Text -> m FlavoredFormat
parseFlavoredFormat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =>
FlavoredFormat -> m (Reader m, Extensions)
getReader FlavoredFormat
readerFormat
    (Writer PandocPure
writerSpec, Extensions
writerExts) <- forall (m :: * -> *).
PandocMonad m =>
FlavoredFormat -> m (Writer m, Extensions)
getWriter FlavoredFormat
writerFormat

    let isStandalone :: Base64
isStandalone = Opt -> Base64
optStandalone Opt
opts
    let toformat :: Text
toformat = FlavoredFormat -> Text
formatName FlavoredFormat
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 Base64
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 -> Base64) -> [a] -> [a]
filter (Base64 -> Base64
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Base64
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 :: Base64
readerStandalone = Base64
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 :: Base64
readerStripComments = Opt -> Base64
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 :: Base64
writerTableOfContents = Opt -> Base64
optTableOfContents Opt
opts
             , writerIncremental :: Base64
writerIncremental = Opt -> Base64
optIncremental Opt
opts
             , writerHTMLMathMethod :: HTMLMathMethod
writerHTMLMathMethod = Opt -> HTMLMathMethod
optHTMLMathMethod Opt
opts
             , writerNumberSections :: Base64
writerNumberSections = Opt -> Base64
optNumberSections Opt
opts
             , writerNumberOffset :: [Int]
writerNumberOffset = Opt -> [Int]
optNumberOffset Opt
opts
             , writerSectionDivs :: Base64
writerSectionDivs = Opt -> Base64
optSectionDivs Opt
opts
             , writerReferenceLinks :: Base64
writerReferenceLinks = Opt -> Base64
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 :: Base64
writerHtmlQTags = Opt -> Base64
optHtmlQTags Opt
opts
             , writerSlideLevel :: Maybe Int
writerSlideLevel = Opt -> Maybe Int
optSlideLevel Opt
opts
             , writerTopLevelDivision :: TopLevelDivision
writerTopLevelDivision = Opt -> TopLevelDivision
optTopLevelDivision Opt
opts
             , writerListings :: Base64
writerListings = Opt -> Base64
optListings Opt
opts
             , writerHighlightStyle :: Maybe Style
writerHighlightStyle = Maybe Style
hlStyle
             , writerSetextHeaders :: Base64
writerSetextHeaders = Opt -> Base64
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
             , writerSplitLevel :: Int
writerSplitLevel = Opt -> Int
optSplitLevel 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 :: Base64
writerPreferAscii = Opt -> Base64
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 d :: Pandoc
d@(Pandoc Meta
meta [Block]
_) = do
          case Text -> Meta -> Text
lookupMetaString Text
"lang" Meta
meta of
              Text
""      -> forall (m :: * -> *). PandocMonad m => Lang -> m ()
setTranslations forall a b. (a -> b) -> a -> b
$
                            Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang Text
"en" forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just Text
"US") [] [] []
              Text
l       -> case Text -> Either String Lang
parseLang Text
l of
                              Left String
_   -> forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
InvalidLang Text
l
                              Right Lang
l' -> forall (m :: * -> *). PandocMonad m => Lang -> m ()
setTranslations Lang
l'
          case Writer PandocPure
writerSpec of
                TextWriter WriterOptions -> Pandoc -> PandocPure Text
w ->
                  WriterOptions -> Pandoc -> PandocPure Text
w WriterOptions
writeropts Pandoc
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    (if Opt -> Base64
optEmbedResources Opt
opts Base64 -> Base64 -> Base64
&& Maybe Text -> Base64
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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    Text -> PandocPure a
textHandler
                ByteStringWriter WriterOptions -> Pandoc -> PandocPure ByteString
w ->
                  WriterOptions -> Pandoc -> PandocPure ByteString
w WriterOptions
writeropts Pandoc
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> PandocPure a
bsHandler

    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
.
                   (if Extension -> Extensions -> Base64
extensionEnabled Extension
Ext_east_asian_line_breaks
                          Extensions
readerExts Base64 -> Base64 -> Base64
&&
                       Base64 -> Base64
not (Extension -> Extensions -> Base64
extensionEnabled Extension
Ext_east_asian_line_breaks
                              Extensions
writerExts Base64 -> Base64 -> Base64
&&
                            Opt -> WrapOption
optWrap Opt
opts forall a. Eq a => a -> a -> Base64
== 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 -> Base64
htmlFormat (Opt -> Maybe Text
optTo Opt
opts) -> Text -> Format
Format Text
"html"
                              | Base64
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 Base64
citeproc Params
params of
          Just Base64
True -> forall (m :: * -> *). PandocMonad m => Pandoc -> m Pandoc
processCitations
          Maybe Base64
_ -> 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 -> Base64
htmlFormat Maybe Text
Nothing = Base64
True
  htmlFormat (Just Text
f) =
    forall (t :: * -> *) a.
Foldable t =>
(a -> Base64) -> t a -> Base64
any (Text -> Text -> Base64
`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 }

  handleErrJSON :: Either PandocError Output -> m Output
handleErrJSON (Right Output
o) = forall (m :: * -> *) a. Monad m => a -> m a
return Output
o
  handleErrJSON (Left PandocError
err) =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Output
Failed (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