diff options
| -rw-r--r-- | .github/workflows/ci.yml | 2 | ||||
| -rw-r--r-- | cabal.project | 6 | ||||
| -rw-r--r-- | linux/make_artifacts.sh | 6 | ||||
| -rw-r--r-- | pandoc-cgi/Main.hs | 8 | ||||
| -rw-r--r-- | pandoc-cgi/PandocCGI.hs | 106 | ||||
| -rw-r--r-- | pandoc.cabal | 20 | ||||
| -rw-r--r-- | trypandoc/Makefile | 2 | ||||
| -rw-r--r-- | trypandoc/trypandoc.hs | 76 |
8 files changed, 138 insertions, 88 deletions
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ec6eb55be..e8036248d 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -56,7 +56,7 @@ jobs: testopts: '--test-option=--hide-successes --test-option=--ansi-tricks=false' - ghc: '8.10.7' cabal: '3.2' - cabalopts: '-ftrypandoc' + cabalopts: '-fpandoc-cgi' testopts: '--test-option=--hide-successes --test-option=--ansi-tricks=false' - ghc: '9.0.2' cabal: '3.4' diff --git a/cabal.project b/cabal.project index 7e9293916..65cf0b392 100644 --- a/cabal.project +++ b/cabal.project @@ -7,3 +7,9 @@ source-repository-package type: git location: https://github.com/tarleb/gridtables tag: 76198add9b404124b3a2fdf137399256a91d337b + + +source-repository-package + type: git + location: https://github.com/jgm/pandoc-server + tag: fb4a86f725c5e61eff63227a39df591262bccf67 diff --git a/linux/make_artifacts.sh b/linux/make_artifacts.sh index e016185ff..d611a2768 100644 --- a/linux/make_artifacts.sh +++ b/linux/make_artifacts.sh @@ -27,10 +27,12 @@ ghc --version cabal v2-update cabal v2-clean -cabal v2-configure --enable-tests -f-export-dynamic -fembed_data_files --enable-executable-static --ghc-options '-j4 +RTS -A256m -RTS -split-sections -optc-Os -optl=-pthread' pandoc +cabal v2-configure --enable-tests -fpandoc-cgi -f-export-dynamic -fembed_data_files --enable-executable-static --ghc-options '-j4 +RTS -A256m -RTS -split-sections -optc-Os -optl=-pthread' pandoc cabal v2-build -j4 cabal v2-test -j4 -for f in $(find dist-newstyle -name 'pandoc' -type f -perm /400); do cp $f /artifacts/; done +cabal v2-install --bindir=$ARTIFACTS +for f in $(find dist-newstyle -name 'pandoc' -type f -perm /400); do cp $f $ARTIFACTS/; done +for f in $(find dist-newstyle -name 'pandoc-cgi' -type f -perm /400); do cp $f /$ARTIFACTS/; done # make deb diff --git a/pandoc-cgi/Main.hs b/pandoc-cgi/Main.hs new file mode 100644 index 000000000..d83edd2a3 --- /dev/null +++ b/pandoc-cgi/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import PandocCGI (app) +import Network.Wai.Handler.CGI (run) +import Network.Wai.Middleware.Timeout (timeout) + +main :: IO () +main = run $ timeout 2 app diff --git a/pandoc-cgi/PandocCGI.hs b/pandoc-cgi/PandocCGI.hs new file mode 100644 index 000000000..73825311b --- /dev/null +++ b/pandoc-cgi/PandocCGI.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module PandocCGI + ( 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 = + "convert" :> ReqBody '[JSON] Params :> Post '[PlainText, JSON] Text + :<|> + "convert-batch" :> ReqBody '[JSON] [Params] :> Post '[JSON] [Text] + +app :: Application +app = serve api server + +api :: Proxy API +api = Proxy + +server :: Server API +server = convert + :<|> mapM convert + where + -- 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 diff --git a/pandoc.cabal b/pandoc.cabal index 15407f605..44ec59510 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -428,8 +428,8 @@ flag lua53 Description: Embed Lua 5.3 instead of 5.4. Default: False -flag trypandoc - Description: Build trypandoc cgi executable. +flag pandoc-cgi + Description: Build pandoc-cgi executable. Default: False flag nightly @@ -789,16 +789,20 @@ executable pandoc buildable: True other-modules: Paths_pandoc -executable trypandoc +executable pandoc-cgi import: common-executable - main-is: trypandoc.hs - hs-source-dirs: trypandoc - if flag(trypandoc) - build-depends: aeson, - http-types, + main-is: Main.hs + other-modules: PandocCGI + hs-source-dirs: pandoc-cgi + if flag(pandoc-cgi) + build-depends: base, + pandoc, + aeson, text, + servant-server, wai >= 0.3, wai-extra >= 3.0.24 + buildable: True else buildable: False diff --git a/trypandoc/Makefile b/trypandoc/Makefile index cedf37721..c2e364767 100644 --- a/trypandoc/Makefile +++ b/trypandoc/Makefile @@ -1,7 +1,7 @@ CGIBIN=/home/website/cgi-bin TRYPANDOC=/home/website/pandoc.org/try/ CGI=${CGIBIN}/trypandoc -BIN=/home/jgm/.cabal/bin/trypandoc +BIN=/home/jgm/.cabal/bin/pandoc-cgi install: ${CGI} ${TRYPANDOC}/index.html diff --git a/trypandoc/trypandoc.hs b/trypandoc/trypandoc.hs deleted file mode 100644 index ad4ece5ed..000000000 --- a/trypandoc/trypandoc.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{- | - Module : Main - Copyright : © 2014-2022 John MacFarlane <[email protected]> - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane <[email protected]> - Stability : alpha - Portability : portable - -Provides a webservice which allows to try pandoc in the browser. --} -module Main where -import Network.Wai.Handler.CGI -import Network.Wai.Middleware.Timeout (timeout) -import Network.Wai -import Data.Maybe (fromMaybe) -import Network.HTTP.Types.Status (status200) -import Network.HTTP.Types.Header (hContentType) -import Network.HTTP.Types.URI (queryToQueryText) -import Text.Pandoc -import Text.Pandoc.Highlighting (pygments) -import Text.Pandoc.Shared (tabFilter) -import Data.Aeson -import qualified Data.Text as T -import Data.Text (Text) - -main :: IO () -main = run $ timeout 2 app - -app :: Application -app req respond = do - let query = queryToQueryText $ queryString req - let getParam x = maybe (error $ T.unpack x ++ " parameter not set") - return $ lookup x query - text <- getParam "text" >>= checkLength . fromMaybe T.empty - fromFormat <- fromMaybe "" <$> getParam "from" - toFormat <- fromMaybe "" <$> getParam "to" - standalone <- (==) "1" . fromMaybe "" <$> getParam "standalone" - compiledTemplate <- runIO . compileDefaultTemplate $ toFormat - let template = if standalone then either (const Nothing) Just compiledTemplate else Nothing - let reader = case runPure $ getReader fromFormat of - Right (TextReader r, es) -> r readerOpts{ - readerExtensions = es } - _ -> error $ "could not find reader for " - ++ T.unpack fromFormat - let writer = case runPure $ getWriter toFormat of - Right (TextWriter w, es) -> w writerOpts{ - writerExtensions = es, writerTemplate = template } - _ -> error $ "could not find writer for " ++ - T.unpack toFormat - let result = case runPure $ reader (tabFilter 4 text) >>= writer of - Right s -> s - Left err -> error (show err) - let output = encode $ object [ "html" .= result - , "name" .= - if fromFormat == "markdown_strict" - then T.pack "pandoc (strict)" - else T.pack "pandoc" - , "version" .= pandocVersion] - respond $ responseLBS status200 [(hContentType,"text/json; charset=UTF-8")] output - -checkLength :: Text -> IO Text -checkLength t = - if T.length t > 10000 - then error "exceeds length limit of 10,000 characters" - else return t - -writerOpts :: WriterOptions -writerOpts = def { writerReferenceLinks = True, - writerEmailObfuscation = NoObfuscation, - writerHTMLMathMethod = MathJax defaultMathJaxURL, - writerHighlightStyle = Just pygments } - -readerOpts :: ReaderOptions -readerOpts = def |