Rewrite to fix escaping

3 files changed, 76 insertions, 63 deletions

diff --git a/app/Main.hs b/app/Main.hs
index e61fe1d..2205f77 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,58 +1,19 @@
 module Main (main) where
 
 import Text.Pandoc hiding (handleError)
-import Network.XmlRpc.Internals
 import XMLParse -- Our slightly modified copy of Text.XML.HaXml.Parse
 
-import Data.IORef (IORef (), newIORef, readIORef, writeIORef)
 import System.IO (hSetBuffering, stdout, BufferMode (LineBuffering))
-import Text.XML.HaXml.XmlContent (fromXml)
-import Text.XML.HaXml.Lex (Token (), xmlLex)
-import Text.XML.HaXml.Types (Document (..))
+import Text.XML.HaXml.Lex (xmlLex)
 import Text.XML.HaXml.Posn (Posn ())
 import Text.ParserCombinators.Poly.State (stGet)
-import Control.Monad.Except (liftEither)
-import Control.Monad (void)
 import qualified Data.ByteString.Lazy.Char8 as BSL8
 import qualified Data.Text as T
-
-type Stream = IORef [Token]
-type Callback = MethodCall -> IO MethodResponse
-
-main :: IO ()
-main = do
-  hSetBuffering stdout LineBuffering
-  handleCalls =<< newIORef =<< xmlLex "<stdin>" <$> getContents
-
-handleCalls :: Stream -> IO ()
-handleCalls stream = do
-  let callback = callbackWith stream
-  mCall <- readCall stream
-  case mCall of
-    Nothing -> return ()
-    Just call -> do
-      BSL8.putStrLn . renderResponse =<< case call of
-        MethodCall "import" [] -> handleImportCall callback
-        MethodCall "htmlize" args -> handleHtmlizeCall args
-        _ -> return (Fault 0 "Unknown method")
-      handleCalls stream
-
-readCall :: Stream -> IO (Maybe MethodCall)
-readCall streamR = do
-  stream <- readIORef streamR
-  case stream of
-    [] -> return Nothing
-    _ -> Just <$> do
-      let (xml, stream') = xmlParseWith rpcMessage stream
-      writeIORef streamR stream'
-      handleError fail $ fromXRMethodCall =<< liftEither (fromXml =<< xml)
-
-callbackWith :: Stream -> Callback
-callbackWith streamR call = do
-  BSL8.putStrLn $ renderCall call
-  (xml, stream') <- xmlParseWith rpcMessage <$> readIORef streamR
-  writeIORef streamR stream'
-  handleError fail $ fromXRMethodResponse =<< liftEither (fromXml =<< xml)
+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
@@ -63,23 +24,73 @@ rpcMessage = do
   (_,ge) <- stGet
   return $ Document p ge e []
 
-handleImportCall :: Callback -> IO MethodResponse
-handleImportCall callback = do
-  void $ callback $ MethodCall "hook" 
-    [ ValueString "type", ValueString "htmlize"
-    , ValueString "id",   ValueString "mdwn"
-    , ValueString "call", ValueString "htmlize"]
-  return $ Return ValueNil
+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_ $ BSL8.putStrLn . XPP.document . escapeDoc
+
+main :: IO ()
+main = do
+  hSetBuffering stdout LineBuffering
+  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 ()
 
-namedVals :: [Value] -> [(String, Value)]
-namedVals ((ValueString key):val:xs) = (key, val) : namedVals xs
-namedVals [] = []
-namedVals _ = error "arguments not in IkiWiki named-value form"
+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
 
-handleHtmlizeCall :: [Value] -> IO MethodResponse
-handleHtmlizeCall args = 
-  either (fail . show) return . runPure $ do
-    pdoc <- readMarkdown readOpts (T.pack mdwn)
-    Return . ValueString . T.unpack <$> writeHtml5String def pdoc
-  where Just (ValueString mdwn) = lookup "content" (namedVals args)
-        readOpts = def {readerExtensions = pandocExtensions}
+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}
diff --git a/fast-pandoc.cabal b/fast-pandoc.cabal
index ce5e5b6..8cd253a 100644
--- a/fast-pandoc.cabal
+++ b/fast-pandoc.cabal
@@ -35,5 +35,6 @@ executable fast-pandoc
     , mtl
     , pandoc
     , polyparse
+    , split
     , text
   default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
index 6c8791d..64e09d2 100644
--- a/package.yaml
+++ b/package.yaml
@@ -29,6 +29,7 @@ dependencies:
 - HaXml
 - polyparse
 - filepath
+- split
 
 executables:
   fast-pandoc: