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
|
module Main (main) where
import Text.Pandoc hiding (handleError)
import XMLParse -- Our slightly modified copy of Text.XML.HaXml.Parse
import System.IO (hFlush, stdout)
import Text.XML.HaXml.Lex (xmlLex)
import Text.XML.HaXml.Posn (Posn ())
import Text.ParserCombinators.Poly.State (stGet)
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Text as T
import Data.List.Split (chop)
import qualified Network.XmlRpc.DTD_XMLRPC as XR
import Text.XML.HaXml.XmlContent (Document (..), toXml, fromXml)
import qualified Text.XML.HaXml.ByteStringPP as XPP
import Text.XML.HaXml.Escape (xmlEscape, stdXmlEscaper)
-- Modified version of XMLParse.document that doesn't wait for anything after
-- the top-level element
rpcMessage :: XParser (Document Posn)
rpcMessage = do
p <- prolog
e <- element
(_,ge) <- stGet
return $ Document p ge e []
escapeDoc :: Document i -> Document i
escapeDoc (Document p s e m) = Document p s (xmlEscape stdXmlEscaper e) m
rpcIn :: IO [Document Posn]
rpcIn = map (either error id) . chop (xmlParseWith rpcMessage) .
xmlLex "<stdin>" <$> getContents
rpcOut :: [Document ()] -> IO ()
rpcOut = mapM_ $ (<*) (hFlush stdout) . BSL8.putStr . XPP.document . escapeDoc
main :: IO ()
main = rpcOut . plugin =<< rpcIn
plugin :: [Document Posn] -> [Document ()]
plugin [] = []
plugin (i:is) = case parseRpcCall i of
Just ("import", _) -> (hookCall :) $ case is of
i':is' | isSuccessResponse i' -> importResponse : plugin is'
_ -> []
Just ("htmlize", args) -> rpcHtmlize args : plugin is
_ -> []
type RpcArgs = [(String, XR.Value_)]
parseRpcCall :: Document Posn -> Maybe (String, RpcArgs)
parseRpcCall doc = case fromXml doc of
Right (XR.MethodCall (XR.MethodName method) mArgs) ->
Just . (,) method $ case mArgs of
Just (XR.Params params) -> flattenParams params
Nothing -> []
_ -> Nothing
where
flattenParams [] = []
flattenParams ( XR.Param (XR.Value [XR.Value_AString (XR.AString key)])
: XR.Param (XR.Value [val])
: ps
) = (key, val) : flattenParams ps
flattenParams _ = error "args not in named-value format"
hookCall :: Document ()
hookCall = toXml False . XR.MethodCall (XR.MethodName "hook") . Just .
XR.Params . map stringParam $
[ "type", "htmlize"
, "id", "mdwn"
, "call", "htmlize"
]
where stringParam = XR.Param . XR.Value . (:[]) . XR.Value_AString .
XR.AString
isSuccessResponse :: Document Posn -> Bool
isSuccessResponse doc = case fromXml doc of
Right (XR.MethodResponseParams _) -> True
_ -> False
importResponse :: Document ()
importResponse = toXml False . XR.MethodResponseParams . XR.Params . (:[]) .
XR.Param . XR.Value . (:[]) . XR.Value_Nil $ XR.Nil ()
rpcHtmlize :: RpcArgs -> Document ()
rpcHtmlize args = toXml False . XR.MethodResponseParams . XR.Params . (:[]) .
XR.Param . XR.Value . (:[]) . XR.Value_AString . XR.AString $ htmlize mdwn
where Just (XR.Value_AString (XR.AString mdwn)) = lookup "content" args
htmlize :: String -> String
htmlize mdwn = either (error . show) id . runPure $ do
pdoc <- readMarkdown readOpts (T.pack mdwn)
T.unpack <$> writeHtml5String def pdoc
where readOpts = def {readerExtensions = pandocExtensions}
|
