{-# 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
_ ->
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
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
}
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 )
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
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
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 ]
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
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