{-# 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 qualified Data.ByteString.Base64 as Base64 (decodeLenient, encode)
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
(Int -> ServerOpts -> ShowS)
-> (ServerOpts -> String)
-> ([ServerOpts] -> ShowS)
-> Show ServerOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerOpts -> ShowS
showsPrec :: Int -> ServerOpts -> ShowS
$cshow :: ServerOpts -> String
show :: ServerOpts -> String
$cshowList :: [ServerOpts] -> ShowS
showList :: [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 =
  [ String
-> [String]
-> ArgDescr (ServerOpts -> IO ServerOpts)
-> String
-> OptDescr (ServerOpts -> IO ServerOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'p'] [String
"port"]
      ((String -> ServerOpts -> IO ServerOpts)
-> String -> ArgDescr (ServerOpts -> IO ServerOpts)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s ServerOpts
opts -> case String -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => String -> m a
safeStrRead String
s of
                            Just Int
i -> ServerOpts -> IO ServerOpts
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerOpts
opts{ serverPort = i }
                            Maybe Int
Nothing ->
                              PandocError -> IO ServerOpts
forall e a. Exception e => e -> IO a
E.throwIO (PandocError -> IO ServerOpts) -> PandocError -> IO ServerOpts
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocOptionError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack
                                String
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a number") String
"NUMBER")
      String
"port number"
  , String
-> [String]
-> ArgDescr (ServerOpts -> IO ServerOpts)
-> String
-> OptDescr (ServerOpts -> IO ServerOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
't'] [String
"timeout"]
      ((String -> ServerOpts -> IO ServerOpts)
-> String -> ArgDescr (ServerOpts -> IO ServerOpts)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s ServerOpts
opts -> case String -> Maybe Int
forall (m :: * -> *) a. (MonadPlus m, Read a) => String -> m a
safeStrRead String
s of
                            Just Int
i -> ServerOpts -> IO ServerOpts
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerOpts
opts{ serverTimeout = i }
                            Maybe Int
Nothing ->
                              PandocError -> IO ServerOpts
forall e a. Exception e => e -> IO a
E.throwIO (PandocError -> IO ServerOpts) -> PandocError -> IO ServerOpts
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocOptionError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack
                                String
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not a number") String
"NUMBER")
      String
"timeout (seconds)"

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

  , String
-> [String]
-> ArgDescr (ServerOpts -> IO ServerOpts)
-> String
-> OptDescr (ServerOpts -> IO ServerOpts)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'v'] [String
"version"]
      ((ServerOpts -> IO ServerOpts)
-> ArgDescr (ServerOpts -> IO ServerOpts)
forall a. a -> ArgDescr a
NoArg (\ServerOpts
_ -> do
        String
prg <- IO String
getProgName
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
pandocVersionText
        IO ServerOpts
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: " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x
  case ArgOrder (ServerOpts -> IO ServerOpts)
-> [OptDescr (ServerOpts -> IO ServerOpts)]
-> [String]
-> ([ServerOpts -> IO ServerOpts], [String], [String], [String])
forall a.
ArgOrder a
-> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' ArgOrder (ServerOpts -> IO ServerOpts)
forall a. ArgOrder a
Permute [OptDescr (ServerOpts -> IO ServerOpts)]
cliOptions [String]
args of
    ([ServerOpts -> IO ServerOpts]
os, [String]
ns, [String]
unrecognizedOpts, [String]
es) -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
es) Bool -> Bool -> Bool
|| Bool -> Bool
not ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unrecognizedOpts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        PandocError -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (PandocError -> IO ()) -> PandocError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocOptionError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
          [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
es String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
forall {a}. (Semigroup a, IsString a) => a -> a
handleUnknownOpt [String]
unrecognizedOpts) String -> ShowS
forall a. [a] -> [a] -> [a]
++
          (String
"Try --help for more information.")
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        PandocError -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (PandocError -> IO ()) -> PandocError -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocOptionError (Text -> PandocError) -> Text -> PandocError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                     String
"Unknown arguments: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
ns
      (ServerOpts -> (ServerOpts -> IO ServerOpts) -> IO ServerOpts)
-> ServerOpts -> [ServerOpts -> IO ServerOpts] -> IO ServerOpts
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (((ServerOpts -> IO ServerOpts) -> ServerOpts -> IO ServerOpts)
-> ServerOpts -> (ServerOpts -> IO ServerOpts) -> IO ServerOpts
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ServerOpts -> IO ServerOpts) -> ServerOpts -> IO ServerOpts
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
(Int -> Blob -> ShowS)
-> (Blob -> String) -> ([Blob] -> ShowS) -> Show Blob
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Blob -> ShowS
showsPrec :: Int -> Blob -> ShowS
$cshow :: Blob -> String
show :: Blob -> String
$cshowList :: [Blob] -> ShowS
showList :: [Blob] -> ShowS
Show, Blob -> Blob -> Bool
(Blob -> Blob -> Bool) -> (Blob -> Blob -> Bool) -> Eq Blob
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Blob -> Blob -> Bool
== :: Blob -> Blob -> Bool
$c/= :: Blob -> Blob -> Bool
/= :: Blob -> Blob -> Bool
Eq)

instance ToJSON Blob where
  toJSON :: Blob -> Value
toJSON (Blob ByteString
bs) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (ByteString -> Text
UTF8.toText (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict ByteString
bs)

instance FromJSON Blob where
 parseJSON :: Value -> Parser Blob
parseJSON = String -> (Text -> Parser Blob) -> Value -> Parser Blob
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Blob" ((Text -> Parser Blob) -> Value -> Parser Blob)
-> (Text -> Parser Blob) -> Value -> Parser Blob
forall a b. (a -> b) -> a -> b
$
   Blob -> Parser Blob
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Blob -> Parser Blob) -> (Text -> Blob) -> Text -> Parser Blob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Blob
Blob (ByteString -> Blob) -> (Text -> ByteString) -> Text -> Blob
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
UTF8.fromText

-- 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
(Int -> Params -> ShowS)
-> (Params -> String) -> ([Params] -> ShowS) -> Show Params
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Params -> ShowS
showsPrec :: Int -> Params -> ShowS
$cshow :: Params -> String
show :: Params -> String
$cshowList :: [Params] -> ShowS
showList :: [Params] -> ShowS
Show)

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

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

instance ToJSON Params where
 toJSON :: Params -> Value
toJSON Params
params =
   case Opt -> Value
forall a. ToJSON a => a -> Value
toJSON (Params -> Opt
options Params
params) of
     (Object Object
o) -> Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$
       Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"text" (Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Params -> Text
text Params
params)
       (Object -> Object) -> (Object -> Object) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"files" (Maybe (Map String Blob) -> Value
forall a. ToJSON a => a -> Value
toJSON (Maybe (Map String Blob) -> Value)
-> Maybe (Map String Blob) -> Value
forall a b. (a -> b) -> a -> b
$ Params -> Maybe (Map String Blob)
files Params
params)
       (Object -> Object) -> (Object -> Object) -> Object -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"citeproc" (Maybe Bool -> Value
forall a. ToJSON a => a -> Value
toJSON (Maybe Bool -> Value) -> Maybe Bool -> Value
forall a b. (a -> b) -> a -> b
$ Params -> Maybe Bool
citeproc Params
params)
       (Object -> Object) -> Object -> Object
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. Message -> Rep Message x)
-> (forall x. Rep Message x -> Message) -> Generic Message
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
$cfrom :: forall x. Message -> Rep Message x
from :: forall x. Message -> Rep Message x
$cto :: forall x. Rep Message x -> Message
to :: forall x. Rep Message x -> Message
Generic, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Message -> ShowS
showsPrec :: Int -> Message -> ShowS
$cshow :: Message -> String
show :: Message -> String
$cshowList :: [Message] -> ShowS
showList :: [Message] -> ShowS
Show)

instance ToJSON Message where
 toEncoding :: Message -> Encoding
toEncoding = Options -> Message -> Encoding
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. Output -> Rep Output x)
-> (forall x. Rep Output x -> Output) -> Generic Output
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
$cfrom :: forall x. Output -> Rep Output x
from :: forall x. Output -> Rep Output x
$cto :: forall x. Rep Output x -> Output
to :: forall x. Rep Output x -> Output
Generic, Int -> Output -> ShowS
[Output] -> ShowS
Output -> String
(Int -> Output -> ShowS)
-> (Output -> String) -> ([Output] -> ShowS) -> Show Output
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Output -> ShowS
showsPrec :: Int -> Output -> ShowS
$cshow :: Output -> String
show :: Output -> String
$cshowList :: [Output] -> ShowS
showList :: [Output] -> ShowS
Show)

instance ToJSON Output where
  toEncoding :: Output -> Encoding
toEncoding (Succeeded Text
o Bool
b [Message]
m) = Series -> Encoding
pairs
    ( Key
"output" Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
o  Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<>
      Key
"base64" Key -> Bool -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
b  Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<>
      Key
"messages" Key -> [Message] -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Message]
m )
  toEncoding (Failed Text
errmsg) = Series -> Encoding
pairs
    ( Key
"error" Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e 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 Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Proxy API -> Server API -> Application
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 (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. a -> b -> a
const (Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy)
-> Maybe CorsResourcePolicy -> Request -> Maybe CorsResourcePolicy
forall a b. (a -> b) -> a -> b
$ CorsResourcePolicy -> Maybe CorsResourcePolicy
forall a. a -> Maybe a
Just CorsResourcePolicy
policy)
    where
      policy :: CorsResourcePolicy
policy = CorsResourcePolicy
simpleCorsResourcePolicy
        { corsRequestHeaders = ["Content-Type"] }

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

server :: Server API
server :: Server API
server = Params -> Handler ByteString
forall {m :: * -> *}.
MonadError ServerError m =>
Params -> m ByteString
convertBytes
    (Params -> Handler ByteString)
-> ((Params -> Handler Text)
    :<|> ((Params -> Handler Output)
          :<|> (([Params] -> Handler [Output])
                :<|> ((Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
                      :<|> Handler Text))))
-> (Params -> Handler ByteString)
   :<|> ((Params -> Handler Text)
         :<|> ((Params -> Handler Output)
               :<|> (([Params] -> Handler [Output])
                     :<|> ((Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
                           :<|> Handler Text))))
forall a b. a -> b -> a :<|> b
:<|> Params -> Handler Text
forall {m :: * -> *}. MonadError ServerError m => Params -> m Text
convertText
    (Params -> Handler Text)
-> ((Params -> Handler Output)
    :<|> (([Params] -> Handler [Output])
          :<|> ((Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
                :<|> Handler Text)))
-> (Params -> Handler Text)
   :<|> ((Params -> Handler Output)
         :<|> (([Params] -> Handler [Output])
               :<|> ((Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
                     :<|> Handler Text)))
forall a b. a -> b -> a :<|> b
:<|> Params -> Handler Output
forall {m :: * -> *}. Monad m => Params -> m Output
convertJSON
    (Params -> Handler Output)
-> (([Params] -> Handler [Output])
    :<|> ((Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
          :<|> Handler Text))
-> (Params -> Handler Output)
   :<|> (([Params] -> Handler [Output])
         :<|> ((Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
               :<|> Handler Text))
forall a b. a -> b -> a :<|> b
:<|> (Params -> Handler Output) -> [Params] -> Handler [Output]
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 Params -> Handler Output
forall {m :: * -> *}. Monad m => Params -> m Output
convertJSON
    ([Params] -> Handler [Output])
-> ((Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
    :<|> Handler Text)
-> ([Params] -> Handler [Output])
   :<|> ((Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
         :<|> Handler Text)
forall a b. a -> b -> a :<|> b
:<|> Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value
forall {m :: * -> *}.
MonadError ServerError m =>
Text -> Maybe Text -> Maybe Text -> Bool -> m Value
babelmark  -- for babelmark which expects {"html": "", "version": ""}
    (Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
-> Handler Text
-> (Text -> Maybe Text -> Maybe Text -> Bool -> Handler Value)
   :<|> Handler Text
forall a b. a -> b -> a :<|> b
:<|> Text -> Handler Text
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
pandocVersionText
 where
  babelmark :: Text -> Maybe Text -> Maybe Text -> Bool -> m Value
babelmark Text
text' Maybe Text
from' Maybe Text
to' Bool
standalone' = do
    Text
res <- Params -> m Text
forall {m :: * -> *}. MonadError ServerError m => Params -> m Text
convertText Params
forall a. Default a => a
def{
                        text = text',
                        options = defaultOpts{
                          optFrom = from',
                          optTo = to',
                          optStandalone = standalone' }
                      }
    Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Value -> Value
forall a. ToJSON a => a -> Value
toJSON (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [ Key
"html" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
res, Key
"version" Key -> Version -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e 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 = Either PandocError Text -> m Text
forall {m :: * -> *} {a}.
MonadError ServerError m =>
Either PandocError a -> m a
handleErr (Either PandocError Text -> m Text)
-> Either PandocError Text -> m Text
forall a b. (a -> b) -> a -> b
$
    PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure ((Text -> PandocPure Text)
-> (ByteString -> PandocPure Text) -> Params -> PandocPure Text
forall a.
(Text -> PandocPure a)
-> (ByteString -> PandocPure a) -> Params -> PandocPure a
convert' Text -> PandocPure Text
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> PandocPure Text
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> PandocPure Text)
-> (ByteString -> Text) -> ByteString -> PandocPure Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
UTF8.toText (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                               ByteString -> ByteString
Base64.encode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict) Params
params)

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

  convertJSON :: Params -> m Output
convertJSON Params
params = Either PandocError Output -> m Output
forall {m :: * -> *}.
Monad m =>
Either PandocError Output -> m Output
handleErrJSON (Either PandocError Output -> m Output)
-> Either PandocError Output -> m Output
forall a b. (a -> b) -> a -> b
$
    PandocPure Output -> Either PandocError Output
forall a. PandocPure a -> Either PandocError a
runPure
      ((Text -> PandocPure Output)
-> (ByteString -> PandocPure Output) -> Params -> PandocPure Output
forall a.
(Text -> PandocPure a)
-> (ByteString -> PandocPure a) -> Params -> PandocPure a
convert'
        (\Text
t -> Text -> Bool -> [Message] -> Output
Succeeded Text
t Bool
False ([Message] -> Output)
-> ([LogMessage] -> [Message]) -> [LogMessage] -> Output
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogMessage -> Message) -> [LogMessage] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map LogMessage -> Message
toMessage ([LogMessage] -> Output)
-> PandocPure [LogMessage] -> PandocPure Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PandocPure [LogMessage]
forall (m :: * -> *). PandocMonad m => m [LogMessage]
getLog)
        (\ByteString
bs -> Text -> Bool -> [Message] -> Output
Succeeded (ByteString -> Text
UTF8.toText (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Base64.encode (ByteString -> ByteString
BL.toStrict ByteString
bs)) Bool
True
                 ([Message] -> Output)
-> ([LogMessage] -> [Message]) -> [LogMessage] -> Output
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogMessage -> Message) -> [LogMessage] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map LogMessage -> Message
toMessage ([LogMessage] -> Output)
-> PandocPure [LogMessage] -> PandocPure Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PandocPure [LogMessage]
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 <- PandocPure UTCTime
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 -> () -> PandocPure ()
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just Map String Blob
fs -> do
        let filetree :: FileTree
filetree = (String -> Blob -> FileTree -> FileTree)
-> FileTree -> Map String Blob -> FileTree
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey String -> Blob -> FileTree -> FileTree
addFile FileTree
forall a. Monoid a => a
mempty Map String Blob
fs
        (PureState -> PureState) -> PandocPure ()
modifyPureState ((PureState -> PureState) -> PandocPure ())
-> (PureState -> PureState) -> PandocPure ()
forall a b. (a -> b) -> a -> b
$ \PureState
st -> PureState
st{ stFiles = filetree }

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

    let isStandalone :: Bool
isStandalone = Opt -> Bool
optStandalone Opt
opts
    let toformat :: Text
toformat = FlavoredFormat -> Text
formatName FlavoredFormat
writerFormat
    Maybe Style
hlStyle <- (Text -> PandocPure Style)
-> Maybe Text -> PandocPure (Maybe Style)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (String -> PandocPure Style
forall (m :: * -> *). PandocMonad m => String -> m Style
lookupHighlightingStyle (String -> PandocPure Style)
-> (Text -> String) -> Text -> PandocPure Style
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)
                  (Maybe Text -> PandocPure (Maybe Style))
-> Maybe Text -> PandocPure (Maybe Style)
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 -> Template Text -> Maybe (Template Text)
forall a. a -> Maybe a
Just (Template Text -> Maybe (Template Text))
-> PandocPure (Template Text) -> PandocPure (Maybe (Template Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                              Text -> PandocPure (Template Text)
forall (m :: * -> *). PandocMonad m => Text -> m (Template Text)
compileDefaultTemplate Text
toformat
                            Just String
t  -> Template Text -> Maybe (Template Text)
forall a. a -> Maybe a
Just (Template Text -> Maybe (Template Text))
-> PandocPure (Template Text) -> PandocPure (Maybe (Template Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                              Text -> String -> PandocPure (Template Text)
forall {m :: * -> *} {a}.
(PandocMonad m, HasChars a, ToText a, FromText a) =>
Text -> String -> m (Template a)
compileCustomTemplate Text
toformat String
t
                     else Maybe (Template Text) -> PandocPure (Maybe (Template Text))
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Template Text)
forall a. Maybe a
Nothing

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

    let readeropts :: ReaderOptions
readeropts = ReaderOptions
forall a. Default a => a
def{ readerExtensions = readerExts
                        , readerStandalone = isStandalone
                        , readerTabStop = optTabStop opts
                        , readerIndentedCodeClasses =
                            optIndentedCodeClasses opts
                        , readerAbbreviations = abbrevs
                        , readerDefaultImageExtension =
                            optDefaultImageExtension opts
                        , readerTrackChanges = optTrackChanges opts
                        , readerStripComments = optStripComments opts
                        }

    let writeropts :: WriterOptions
writeropts =
          WriterOptions
forall a. Default a => a
def{ writerExtensions = writerExts
             , writerTabStop = optTabStop opts
             , writerWrapText = optWrap opts
             , writerColumns = optColumns opts
             , writerTemplate = mbTemplate
             , writerSyntaxMap = defaultSyntaxMap
             , writerVariables = optVariables opts
             , writerTableOfContents = optTableOfContents opts
             , writerIncremental = optIncremental opts
             , writerHTMLMathMethod = optHTMLMathMethod opts
             , writerNumberSections = optNumberSections opts
             , writerNumberOffset = optNumberOffset opts
             , writerSectionDivs = optSectionDivs opts
             , writerReferenceLinks = optReferenceLinks opts
             , writerDpi = optDpi opts
             , writerEmailObfuscation = optEmailObfuscation opts
             , writerIdentifierPrefix = optIdentifierPrefix opts
             , writerCiteMethod = optCiteMethod opts
             , writerHtmlQTags = optHtmlQTags opts
             , writerSlideLevel = optSlideLevel opts
             , writerTopLevelDivision = optTopLevelDivision opts
             , writerListings = optListings opts
             , writerHighlightStyle = hlStyle
             , writerSetextHeaders = optSetextHeaders opts
             , writerEpubSubdirectory = T.pack $ optEpubSubdirectory opts
             , writerEpubMetadata = T.pack <$> optEpubMetadata opts
             , writerEpubFonts = optEpubFonts opts
             , writerSplitLevel = optSplitLevel opts
             , writerTOCDepth = optTOCDepth opts
             , writerReferenceDoc = optReferenceDoc opts
             , writerReferenceLocation = optReferenceLocation opts
             , writerPreferAscii = optAscii opts
             }

    let reader :: Text -> PandocPure Pandoc
reader = case Reader PandocPure
readerSpec of
                TextReader forall a. ToSources a => ReaderOptions -> a -> PandocPure Pandoc
r -> ReaderOptions -> Text -> PandocPure Pandoc
forall a. ToSources a => ReaderOptions -> a -> PandocPure Pandoc
r ReaderOptions
readeropts
                ByteStringReader ReaderOptions -> ByteString -> PandocPure Pandoc
r ->
                  ReaderOptions -> ByteString -> PandocPure Pandoc
r ReaderOptions
readeropts (ByteString -> PandocPure Pandoc)
-> (Text -> ByteString) -> Text -> PandocPure Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.decodeLenient
                    (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
UTF8.fromText

    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
""      -> Lang -> PandocPure ()
forall (m :: * -> *). PandocMonad m => Lang -> m ()
setTranslations (Lang -> PandocPure ()) -> Lang -> PandocPure ()
forall a b. (a -> b) -> a -> b
$
                            Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang Text
"en" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"US") [] [] []
              Text
l       -> case Text -> Either String Lang
parseLang Text
l of
                              Left String
_   -> LogMessage -> PandocPure ()
forall (m :: * -> *). PandocMonad m => LogMessage -> m ()
report (LogMessage -> PandocPure ()) -> LogMessage -> PandocPure ()
forall a b. (a -> b) -> a -> b
$ Text -> LogMessage
InvalidLang Text
l
                              Right Lang
l' -> Lang -> PandocPure ()
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 PandocPure Text -> (Text -> PandocPure Text) -> PandocPure Text
forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
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 Text -> PandocPure Text
forall (m :: * -> *). PandocMonad m => Text -> m Text
makeSelfContained
                        else Text -> PandocPure Text
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return) PandocPure Text -> (Text -> PandocPure a) -> PandocPure a
forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
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 PandocPure ByteString
-> (ByteString -> PandocPure a) -> PandocPure a
forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
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             -> Pandoc -> Pandoc
forall a. a -> a
id
                        Int
x             -> Int -> Pandoc -> Pandoc
headerShift Int
x) (Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
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 WrapOption -> WrapOption -> Bool
forall a. Eq a => a -> a -> Bool
== WrapOption
WrapPreserve)
                       then Pandoc -> Pandoc
eastAsianLineBreakFilter
                       else Pandoc -> Pandoc
forall a. a -> a
id) (Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   (case Opt -> IpynbOutput
optIpynbOutput Opt
opts of
                     IpynbOutput
IpynbOutputAll  -> Pandoc -> Pandoc
forall a. a -> a
id
                     IpynbOutput
IpynbOutputNone -> Maybe Format -> Pandoc -> Pandoc
filterIpynbOutput Maybe Format
forall a. Maybe a
Nothing
                     IpynbOutput
IpynbOutputBest -> Maybe Format -> Pandoc -> Pandoc
filterIpynbOutput (Format -> Maybe Format
forall a. a -> Maybe a
Just (Format -> Maybe Format) -> Format -> Maybe Format
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
                   [] -> Meta -> Meta
forall a. a -> a
id
                   [String]
fs -> Text -> MetaValue -> Meta -> Meta
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
forall b. ToMetaValue b => Text -> b -> Meta -> Meta
setMeta Text
"bibliography" ([MetaValue] -> MetaValue
MetaList
                            ((String -> MetaValue) -> [String] -> [MetaValue]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> MetaValue
MetaString (Text -> MetaValue) -> (String -> Text) -> String -> MetaValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) [String]
fs))) (Meta -> Meta) -> (Meta -> Meta) -> Meta -> Meta
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 (Meta -> Meta)
-> (String -> Meta -> Meta) -> Maybe String -> Meta -> Meta
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Meta -> Meta
forall a. a -> a
id (Text -> MetaValue -> Meta -> Meta
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
forall b. ToMetaValue b => Text -> b -> Meta -> Meta
setMeta Text
"csl" (MetaValue -> Meta -> Meta)
-> (String -> MetaValue) -> String -> Meta -> Meta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MetaValue
MetaString (Text -> MetaValue) -> (String -> Text) -> String -> MetaValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
                   (Opt -> Maybe String
optCSL Opt
opts) (Meta -> Meta) -> (Meta -> Meta) -> Meta -> Meta
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                 (Meta -> Meta)
-> (String -> Meta -> Meta) -> Maybe String -> Meta -> Meta
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Meta -> Meta
forall a. a -> a
id (Text -> MetaValue -> Meta -> Meta
forall a b. (HasMeta a, ToMetaValue b) => Text -> b -> a -> a
forall b. ToMetaValue b => Text -> b -> Meta -> Meta
setMeta Text
"citation-abbreviations" (MetaValue -> Meta -> Meta)
-> (String -> MetaValue) -> String -> Meta -> Meta
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MetaValue
MetaString (Text -> MetaValue) -> (String -> Text) -> String -> MetaValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                              String -> Text
T.pack)
                   (Opt -> Maybe String
optCitationAbbreviations Opt
opts) (Meta -> Meta) -> Meta -> Meta
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 Meta -> Meta -> Meta
forall a. Semigroup a => a -> a -> a
<> Meta
m') [Block]
bs

    Text -> PandocPure Pandoc
reader (Params -> Text
text Params
params) PandocPure Pandoc
-> (Pandoc -> PandocPure Pandoc) -> PandocPure Pandoc
forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      Pandoc -> PandocPure Pandoc
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> PandocPure Pandoc)
-> (Pandoc -> Pandoc) -> Pandoc -> PandocPure Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pandoc -> Pandoc
transforms (Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meta -> Pandoc -> Pandoc
addMetadata Meta
meta PandocPure Pandoc
-> (Pandoc -> PandocPure Pandoc) -> PandocPure Pandoc
forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (case Params -> Maybe Bool
citeproc Params
params of
          Just Bool
True -> Pandoc -> PandocPure Pandoc
forall (m :: * -> *). PandocMonad m => Pandoc -> m Pandoc
processCitations
          Maybe Bool
_ -> Pandoc -> PandocPure Pandoc
forall a. a -> PandocPure a
forall (m :: * -> *) a. Monad m => a -> m a
return) PandocPure Pandoc -> (Pandoc -> PandocPure a) -> PandocPure a
forall a b. PandocPure a -> (a -> PandocPure b) -> PandocPure b
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) =
    (Text -> Bool) -> [Text] -> Bool
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) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
t
  handleErr (Left PandocError
err) = ServerError -> m a
forall a. ServerError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> m a) -> ServerError -> m a
forall a b. (a -> b) -> a -> b
$
    ServerError
err500 { errBody = TLE.encodeUtf8 $ TL.fromStrict $ renderError err }

  handleErrJSON :: Either PandocError Output -> m Output
handleErrJSON (Right Output
o) = Output -> m Output
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Output
o
  handleErrJSON (Left PandocError
err) =
    Output -> m Output
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Output -> m Output) -> Output -> m Output
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 <- WithPartials m (Either String (Template a))
-> m (Either String (Template a))
forall (m :: * -> *) a. WithPartials m a -> m a
runWithPartials (WithPartials m (Either String (Template a))
 -> m (Either String (Template a)))
-> WithPartials m (Either String (Template a))
-> m (Either String (Template a))
forall a b. (a -> b) -> a -> b
$ String -> Text -> WithPartials m (Either String (Template a))
forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
String -> Text -> m (Either String (Template a))
compileTemplate (String
"custom." String -> ShowS
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 -> PandocError -> m (Template a)
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m (Template a)) -> PandocError -> m (Template a)
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocTemplateError (String -> Text
T.pack String
e)
      Right Template a
tpl -> Template a -> m (Template a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Template a
tpl