summaryrefslogtreecommitdiff
path: root/app
diff options
context:
space:
mode:
authorDaniel Gnoutcheff <gnoutchd@softwarefreedom.org>2021-09-13 13:52:44 -0400
committerDaniel Gnoutcheff <gnoutchd@softwarefreedom.org>2021-09-13 13:52:44 -0400
commit49203ec1cddf607f2f468ff4d1b230f9f236ccb5 (patch)
tree042495b5ba9f69bdd860d7040edf2c1f49cf1763 /app
parenta794e6a57630bcf969109f5660dd97db27cceaa4 (diff)
Rewrite to fix escaping
Diffstat (limited to 'app')
-rw-r--r--app/Main.hs137
1 files changed, 74 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}