WiP: switch to Xmlm for output

This requires changing the `type xml` type to match what Xmlm expects,
to avoid having to convert to another variant.

Author: edwintorok

ocaml/libs/http-lib/dune

@@ -1,109 +1,103 @@
 (library
-  (name http_lib)
-  (public_name http-lib)
-  (modes best)
-  (wrapped false)
-  (modules (:standard \ http_svr http_proxy server_io http_test radix_tree_test test_client test_server))
-  (preprocess (per_module ((pps ppx_deriving_rpc) Http)))
-  (libraries
-    astring
-    base64
-    fmt
-    ipaddr
-    mtime
-    mtime.clock.os
-    rpclib.core
-    rpclib.json
-    rpclib.xml
-    safe_resources
-    sha
-    stunnel
-    threads.posix
-    uuid
-    uri
-    xapi-backtrace
-    xapi-consts.xapi_version
-    xapi-idl.updates
-    xapi-log
-    clock
-    xapi-stdext-pervasives
-    xapi-stdext-threads
-    xapi-stdext-unix
-    xml-light2
-  )
-)
+ (name http_lib)
+ (public_name http-lib)
+ (modes best)
+ (wrapped false)
+ (modules
+  (:standard
+   \
+   http_svr
+   http_proxy
+   server_io
+   http_test
+   radix_tree_test
+   test_client
+   test_server))
+ (preprocess
+  (per_module
+   ((pps ppx_deriving_rpc)
+    Http)))
+ (libraries
+  astring
+  base64
+  fmt
+  ipaddr
+  mtime
+  mtime.clock.os
+  rpclib.core
+  rpclib.json
+  rpclib.xml
+  xmlm
+  safe_resources
+  sha
+  stunnel
+  threads.posix
+  uuid
+  uri
+  xapi-backtrace
+  xapi-consts.xapi_version
+  xapi-idl.updates
+  xapi-log
+  clock
+  xapi-stdext-pervasives
+  xapi-stdext-threads
+  xapi-stdext-unix
+  xml-light2))
 
 (library
-  (name httpsvr)
-  (wrapped false)
-  (modes best)
-  (modules http_svr http_proxy server_io)
-  (libraries
-    astring
-    http_lib
-    ipaddr
-    polly
-    tgroup
-    threads.posix
-    tracing
-    tracing_propagator
-    uri
-    xapi-log
-    xapi-stdext-pervasives
-    xapi-stdext-threads
-    xapi-stdext-unix
-  )
-)
+ (name httpsvr)
+ (wrapped false)
+ (modes best)
+ (modules http_svr http_proxy server_io)
+ (libraries
+  astring
+  http_lib
+  ipaddr
+  polly
+  tgroup
+  threads.posix
+  tracing
+  tracing_propagator
+  uri
+  xapi-log
+  xapi-stdext-pervasives
+  xapi-stdext-threads
+  xapi-stdext-unix))
 
 (tests
-  (names http_test radix_tree_test)
-  (package http-lib)
-  (modes (best exe))
-  (modules http_test radix_tree_test)
-  (libraries
-    alcotest
-
-    fmt
-    http_lib
-  )
-)
+ (names http_test radix_tree_test)
+ (package http-lib)
+ (modes
+  (best exe))
+ (modules http_test radix_tree_test)
+ (libraries alcotest fmt http_lib))
 
 (executable
-  (modes exe)
-  (name test_client)
-  (modules test_client)
-  (libraries
-
-    http_lib
-    safe-resources
-    stunnel
-    threads.posix
-    xapi-backtrace
-    xapi-log
-    xapi-stdext-pervasives
-    xapi-stdext-unix
-  )
-)
+ (modes exe)
+ (name test_client)
+ (modules test_client)
+ (libraries
+  http_lib
+  safe-resources
+  stunnel
+  threads.posix
+  xapi-backtrace
+  xapi-log
+  xapi-stdext-pervasives
+  xapi-stdext-unix))
 
 (executable
-  (modes exe)
-  (name test_server)
-  (modules test_server)
-  (libraries
-
-    http_lib
-    httpsvr
-    safe-resources
-    threads.posix
-    xapi-stdext-threads
-    xapi-stdext-unix
-  )
-)
+ (modes exe)
+ (name test_server)
+ (modules test_server)
+ (libraries
+  http_lib
+  httpsvr
+  safe-resources
+  threads.posix
+  xapi-stdext-threads
+  xapi-stdext-unix))
 
 (cram
-  (package xapi)
-  (deps
-    test_client.exe
-    test_server.exe
-  )
-)
+ (package xapi)
+ (deps test_client.exe test_server.exe))

ocaml/libs/http-lib/xMLRPC.ml

@@ -23,10 +23,10 @@ let rtte name xml =
 
 type xmlrpc = Xml.xml
 
-let pretty_print = function
-  | Xml.Element (tag, _, _) ->
+let pretty_print : xmlrpc -> string = function
+  | `El (((_uri, tag), _), _) ->
       "Element=" ^ String.escaped tag
-  | Xml.PCData d ->
+  | `Data d ->
       "PCData=" ^ String.escaped d
 
 type response =
@@ -53,9 +53,9 @@ module FromString = struct
 end
 
 module To = struct
-  let pcdata string = Xml.PCData string
+  let pcdata string = `Data string
 
-  let box tag vs = Xml.Element (tag, [], vs)
+  let box tag vs = `El ((("", tag), []), vs)
 
   let value v = box "value" [v]
 
@@ -136,14 +136,14 @@ end
 module From = struct
   let id x = x
 
-  let pcdata f = function
-    | Xml.PCData string ->
+  let pcdata f : Xml.xml -> _ = function
+    | `Data string ->
         f string
     | xml ->
         rtte "pcdata" xml
 
-  let unbox ok f = function
-    | Xml.Element (s, [], data) when List.mem s ok ->
+  let unbox ok f : Xml.xml -> _ = function
+    | `El (((_, s), []), data) when List.mem s ok ->
         f data
     | xml ->
         rtte
@@ -177,7 +177,7 @@ module From = struct
   let name f xml =
     unbox ["name"]
       (function
-        | [Xml.PCData str] ->
+        | [`Data str] ->
             f str
         | [] ->
             debug "encountered <name/> within a <structure>" ;
@@ -194,7 +194,7 @@ module From = struct
 
   let array f = value (singleton ["array"] (unbox ["data"] (List.map f)))
 
-  let boolean = value (singleton ["boolean"] (( <> ) (Xml.PCData "0")))
+  let boolean = value (singleton ["boolean"] (( <> ) (`Data "0")))
 
   let datetime x =
     Clock.Date.of_iso8601 (value (singleton ["dateTime.iso8601"] (pcdata id)) x)
@@ -209,11 +209,11 @@ module From = struct
       (unbox ["params"] (List.map (singleton ["param"] id)))
       xml
 
-  let string = function
-    | Xml.Element ("value", [], [Xml.PCData s]) ->
+  let string : Xml.xml -> string = function
+    | `El ((("", "value"), []), [`Data s]) ->
         s
-    | Xml.Element ("value", [], [Xml.Element ("string", [], [])])
-    | Xml.Element ("value", [], []) ->
+    | `El ((("", "value"), []), [`El ((("", "string"), []), [])])
+    | `El ((("", "value"), []), []) ->
         ""
     | xml ->
         value (singleton ["string"] (pcdata id)) xml
@@ -233,7 +233,7 @@ module From = struct
       | "Failure" -> (
         match array id (List.assoc "ErrorDescription" bindings) with
         | [] ->
-            rtte "Empty array of error strings" (Xml.PCData "")
+            rtte "Empty array of error strings" (`Data "")
         | code :: strings ->
             Failure (string code, List.map string strings)
       )
@@ -250,14 +250,14 @@ module From = struct
   let methodResponse xml =
     singleton ["methodResponse"]
       (function
-        | Xml.Element ("params", _, _) as xml -> (
+        | `El ((("", "params"), _), _) as xml -> (
           match success xml with
           | [xml] ->
               status xml
           | _ ->
               rtte "Expected single return value (struct status)" xml
         )
-        | Xml.Element ("fault", _, _) as xml ->
+        | `El ((("", "fault"), _), _) as xml ->
             Fault (fault id xml)
         | xml ->
             rtte "response" xml