aboutsummaryrefslogtreecommitdiff
path: root/trypandoc/trypandoc.hs
blob: 2fcfe35e7663bfeb000c48bee406c78a39a0eae6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Network.Wai.Handler.CGI
import Network.Wai
import Control.Applicative ((<$>))
import Data.Maybe (mapMaybe, 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.Error (PandocError)
import Text.Pandoc.Shared (tabFilter)
import Data.Aeson
import qualified Data.Text as T
import Data.Text (Text)

main :: IO ()
main = run app

app :: Application
app req respond = do
  let query = queryToQueryText $ queryString req
  let getParam x = maybe (error $ T.unpack x ++ " paramater not set")
                       return $ lookup x query
  text <- getParam "text" >>= checkLength . fromMaybe T.empty
  fromFormat <- fromMaybe "" <$> getParam "from"
  toFormat <- fromMaybe "" <$> getParam "to"
  reader <- maybe (error $ "could not find reader for " ++ T.unpack fromFormat)              return
             $ lookup fromFormat fromFormats
  let writer = maybe (error $ "could not find writer for " ++ T.unpack toFormat) id
             $ lookup toFormat toFormats
  let result = case reader $ tabFilter 4 $ T.unpack text of
                    Right doc -> T.pack $ writer doc
                    Left  err -> error (show err)
  let output = encode $ object [ T.pack "html" .= result
                               , T.pack "name" .=
                                  if fromFormat == "markdown_strict"
                                     then T.pack "pandoc (strict)"
                                     else T.pack "pandoc"
                               , T.pack "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 "http://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML",
                   writerHighlight = True }

readerOpts :: ReaderOptions
readerOpts = def { readerParseRaw = True,
                   readerSmart = True }

fromFormats :: [(Text, String -> Either PandocError Pandoc)]
fromFormats = [
            ("native"       , readNative)
           ,("json"         , Text.Pandoc.readJSON readerOpts)
           ,("markdown"     , readMarkdown readerOpts)
           ,("markdown_strict" , readMarkdown readerOpts{
                    readerExtensions = strictExtensions,
                    readerSmart = False })
           ,("markdown_phpextra" , readMarkdown readerOpts{
                    readerExtensions = phpMarkdownExtraExtensions })
           ,("markdown_github" , readMarkdown readerOpts{
                    readerExtensions = githubMarkdownExtensions })
           ,("markdown_mmd",  readMarkdown readerOpts{
                    readerExtensions = multimarkdownExtensions })
           ,("rst"          , readRST readerOpts)
           ,("mediawiki"    , readMediaWiki readerOpts)
           ,("docbook"      , readDocBook readerOpts)
           ,("opml"         , readOPML readerOpts)
           ,("t2t"          , readTxt2TagsNoMacros readerOpts)
           ,("org"          , readOrg readerOpts)
           ,("textile"      , readTextile readerOpts) -- TODO : textile+lhs
           ,("html"         , readHtml readerOpts)
           ,("latex"        , readLaTeX readerOpts)
           ,("haddock"      , readHaddock readerOpts)
           ]

toFormats :: [(Text, Pandoc -> String)]
toFormats = mapMaybe (\(x,y) ->
                       case y of
                         PureStringWriter w -> Just (T.pack x, w writerOpts{
                             writerExtensions =
                               case x of
                                  "markdown_strict" -> strictExtensions
                                  "markdown_phpextra" -> phpMarkdownExtraExtensions
                                  "markdown_mmd" -> multimarkdownExtensions
                                  "markdown_github" -> githubMarkdownExtensions
                                  _ -> pandocExtensions
                                 })
                         _                  ->
                            case x of
                                 "rtf"     -> Just (T.pack x, writeRTF writerOpts)
                                 _         -> Nothing) writers