Rename pandoc-cgi -> pandoc-server.

2 files changed, 158 insertions, 0 deletions

diff --git a/server/Main.hs b/server/Main.hs
new file mode 100644
index 000000000..4266519c7
--- /dev/null
+++ b/server/Main.hs
@@ -0,0 +1,42 @@
+module Main where
+
+import PandocServer (app)
+import qualified Network.Wai.Handler.CGI as CGI
+import qualified Network.Wai.Handler.Warp as Warp
+import Network.Wai.Middleware.Timeout (timeout)
+import System.Environment (getProgName)
+import Options.Applicative
+
+data Opts = Opts
+  { optPort :: Warp.Port,
+    optTimeout :: Int }  -- in seconds
+
+options :: Parser Opts
+options = Opts
+  <$> option auto
+         ( long "port"
+         <> value 3030
+         <> metavar "PORT"
+         <> help "Port to serve on" )
+  <*> option auto
+         ( long "timeout"
+         <> value 2
+         <> metavar "SECONDS"
+         <> help "Seconds timeout" )
+
+main :: IO ()
+main = do
+  progname <- getProgName
+  let optspec = info (options <**> helper)
+       ( fullDesc
+       <> progDesc "Run a pandoc server"
+       <> header "pandoc-server - text conversion server" )
+  opts <- execParser optspec
+
+  let port = optPort opts
+  let app' = timeout (optTimeout opts) app
+  if progname == "pandoc-server.cgi"
+     then -- operate as a CGI script
+       CGI.run app'
+     else -- operate as a persistent server
+       Warp.run port app'
diff --git a/server/PandocServer.hs b/server/PandocServer.hs
new file mode 100644
index 000000000..5b02c4ea3
--- /dev/null
+++ b/server/PandocServer.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE DataKinds       #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators   #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module PandocServer
+    ( app
+    , Params(..)
+    ) where
+
+import Data.Aeson
+import Data.Aeson.TH
+import Network.Wai
+import Servant
+import Text.Pandoc
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TLE
+import Data.Maybe (fromMaybe)
+import Data.Char (isAlphaNum)
+
+-- 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
+  { text           :: Text
+  , from           :: Maybe Text
+  , to             :: Maybe Text
+  , wrapText       :: Maybe WrapOption
+  , columns        :: Maybe Int
+  , standalone     :: Maybe Bool
+  , template       :: Maybe Text
+  } deriving (Show)
+
+-- Automatically derive code to convert to/from JSON.
+$(deriveJSON defaultOptions ''Params)
+
+-- This is the API.  The "/convert" endpoint takes a request body
+-- consisting of a JSON-encoded Params structure and responds to
+-- Get requests with either plain text or JSON, depending on the
+-- Accept header.
+type API =
+  ReqBody '[JSON] Params :> Post '[PlainText, JSON] Text
+  :<|>
+  ReqBody '[JSON] [Params] :> Post '[JSON] [Text]
+  :<|>
+  "babelmark" :> ReqBody '[JSON] Params :> Get '[JSON] Value
+  :<|>
+  "version" :> Get '[PlainText, JSON] Text
+
+app :: Application
+app = serve api server
+
+api :: Proxy API
+api = Proxy
+
+server :: Server API
+server = convert
+    :<|> mapM convert
+    :<|> babelmark  -- for babelmark which expects {"html": "", "version": ""}
+    :<|> pure pandocVersion
+ where
+  babelmark params = do
+    res <- convert params
+    return $ toJSON $ object [ "html" .= res, "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.
+  convert params = handleErr $ runPure (convert' params)
+
+  convert' :: PandocMonad m => Params -> m Text
+  convert' params = do
+    let readerFormat = fromMaybe "markdown" $ from params
+    let writerFormat = fromMaybe "html" $ to params
+    (readerSpec, readerExts) <- getReader readerFormat
+    (writerSpec, writerExts) <- getWriter writerFormat
+    let isStandalone = fromMaybe False (standalone params)
+    let toformat = T.toLower $ T.takeWhile isAlphaNum $ writerFormat
+    mbTemplate <- if isStandalone
+                     then case template params of
+                            Nothing -> Just <$>
+                              compileDefaultTemplate toformat
+                            Just t  -> Just <$>
+                              compileCustomTemplate toformat t
+                     else return Nothing
+    -- We don't yet handle binary formats:
+    reader <- case readerSpec of
+                TextReader r -> return r
+                _ -> throwError $ PandocAppError $
+                       readerFormat <> " is not a text reader"
+    writer <- case writerSpec of
+                TextWriter w -> return w
+                _ -> throwError $ PandocAppError $
+                       readerFormat <> " is not a text reader"
+    reader def{ readerExtensions = readerExts
+              , readerStandalone = isStandalone }
+           (text params) >>=
+      writer def{ writerExtensions = writerExts
+                , writerWrapText = fromMaybe WrapAuto (wrapText params)
+                , writerColumns = fromMaybe 72 (columns params)
+                , writerTemplate = mbTemplate }
+
+  handleErr (Right t) = return t
+  handleErr (Left err) = throwError $
+    err500 { errBody = TLE.encodeUtf8 $ TL.fromStrict $ renderError err }
+
+  compileCustomTemplate toformat t = do
+    res <- runWithPartials $ compileTemplate ("custom." <> T.unpack toformat) t
+    case res of
+      Left e -> throwError $ PandocTemplateError (T.pack e)
+      Right tpl -> return tpl