send XML through sockets

7 files changed, 74 insertions, 24 deletions

diff --git a/bin/main.ml b/bin/main.ml
index 40429e3..db591ff 100644
--- a/bin/main.ml
+++ b/bin/main.ml
@@ -1,5 +1,9 @@
 let () =
   begin
-    (* let _ = Relational_engine.Relation.write_and_retrieve() in () *)
+    (* let response = *)
+      (* Relational_engine.Relation.write_and_retrieve() *)
+    (* in match response with *)
+       (* | Ok response -> print_endline response *)
+       (* | Error err -> print_endline err; *)
     Relational_engine.Server.start()
   end
diff --git a/deps/ppx_protocol_conv.nix b/deps/ppx_protocol_conv.nix
index c0a402e..6358215 100644
--- a/deps/ppx_protocol_conv.nix
+++ b/deps/ppx_protocol_conv.nix
@@ -11,12 +11,12 @@ ocamlPackages.buildDunePackage {
     owner = "andersfugmann";
     repo = "ppx_protocol_conv";
     rev = "master";
-    sha256 = "jJJ6FEn+AkMknqun0GkXh5DSXsJnFbdE7U8BQ7Dd/Fw=";
+    sha256 = "gFYg0251NOPPkc01BiSU3NEj3JWGKg1fu6UgQ67BBZM=";
   };
 
-  buildInputs = [];
+  buildInputs = [ocamlPackages.ppxlib ocamlPackages.ppx_sexp_conv ocamlPackages.sexplib ocamlPackages.alcotest ];
   
-  propagatedBuildInputs = [];
+  propagatedBuildInputs = [ ocamlPackages.ppxlib ocamlPackages.ppx_sexp_conv ocamlPackages.sexplib ocamlPackages.alcotest ];
 
   doCheck = true;
 
diff --git a/deps/ppx_protocol_conv_xml_light.nix b/deps/ppx_protocol_conv_xml_light.nix
new file mode 100644
index 0000000..51579f0
--- /dev/null
+++ b/deps/ppx_protocol_conv_xml_light.nix
@@ -0,0 +1,27 @@
+{ lib, ppx_protocol_conv, ocamlPackages, fetchFromGitHub, defaultVersion ? "5.2.1" }:
+ocamlPackages.buildDunePackage {
+  duneVersion = "3";
+  
+  pname = "ppx_protocol_conv_xml_light";
+  version = defaultVersion;
+
+  minimalOCamlVersion = "4.08";
+
+  src = fetchFromGitHub {
+    owner = "andersfugmann";
+    repo = "ppx_protocol_conv";
+    rev = "master";
+    sha256 = "gFYg0251NOPPkc01BiSU3NEj3JWGKg1fu6UgQ67BBZM=";
+  };
+
+  buildInputs = [ppx_protocol_conv ocamlPackages.xml-light ocamlPackages.ppx_sexp_conv ocamlPackages.sexplib ocamlPackages.alcotest ];
+  
+  propagatedBuildInputs = [ ocamlPackages.xml-light ocamlPackages.ppxlib ocamlPackages.ppx_sexp_conv ocamlPackages.sexplib ocamlPackages.alcotest ];
+
+  doCheck = true;
+
+  meta = {
+    license = lib.licenses.bsd3;
+    homepage = "https://github.com/andersfugmann/ppx_protocol_conv";
+  };
+}
diff --git a/flake.nix b/flake.nix
index 5bfcd74..58481f5 100644
--- a/flake.nix
+++ b/flake.nix
@@ -31,13 +31,21 @@
         ocamlPackages = legacyPackages.ocamlPackages;
         merklecpp = legacyPackages.callPackage ./deps/merklecpp.nix { };
         libressl = legacyPackages.callPackage ./deps/libressl.nix { };
-        ppx_protocol_conv = legacyPackages.callPackage ./deps/ppx_protocol_conv.nix { lib = legacyPackages.lib; fetchFromGitHub = legacyPackages.fetchFromGitHub; ocamlPackages = ocamlPackages; };
+        ppx_protocol_conv =
+          legacyPackages.callPackage ./deps/ppx_protocol_conv.nix {
+            lib = legacyPackages.lib;
+            fetchFromGitHub = legacyPackages.fetchFromGitHub;
+            ocamlPackages = ocamlPackages; };
+        ppx_protocol_conv_xml_light =
+          legacyPackages.callPackage ./deps/ppx_protocol_conv_xml_light.nix {
+            lib = legacyPackages.lib;
+            ppx_protocol_conv = ppx_protocol_conv;
+            fetchFromGitHub = legacyPackages.fetchFromGitHub;
+            ocamlPackages = ocamlPackages; };
         librelational_engine =
           legacyPackages.callPackage ./deps/relational_engine_lib.nix {
             libressl = libressl;
-            merklecpp = merklecpp;
-          };
-
+            merklecpp = merklecpp; };
         # Filtered sources (prevents unecessary rebuilds)
         sources = {
           ocaml = nix-filter.lib {
@@ -90,7 +98,9 @@
 
             nativeInputs = [ ];
 
-            buildInputs = [ppx_protocol_conv] ++ (with ocamlPackages; [
+            buildInputs = [ ppx_protocol_conv_xml_light
+                            ppx_protocol_conv ]
+            ++ (with ocamlPackages; [
               ctypes
               ctypes-foreign
               data-encoding
@@ -174,6 +184,7 @@
               ocamlPackages.lwt
               ocamlPackages.lwt-exit
               ppx_protocol_conv
+              ppx_protocol_conv_xml_light
             ];
           } ''
             echo "checking dune and ocaml formatting"
@@ -266,6 +277,7 @@
               ocamlPackages.lwt
               ocamlPackages.lwt-exit
               ppx_protocol_conv
+              ppx_protocol_conv_xml_light
             ];
 
 
diff --git a/lib/dune b/lib/dune
index b263205..ec9fd1f 100644
--- a/lib/dune
+++ b/lib/dune
@@ -1,7 +1,7 @@
 (library
  (name relational_engine)
- (libraries ctypes ctypes-foreign data-encoding lwt lwt.unix lwt-exit)
- (preprocess (pps ppx_deriving.show ppx_sexp_conv))
+ (libraries ctypes ctypes-foreign data-encoding lwt lwt.unix lwt-exit ppx_protocol_conv_xml_light)
+ (preprocess (pps ppx_deriving.show ppx_sexp_conv ppx_protocol_conv))
  ;; (c_library_flags -lssl -lcrypto -L %{env:LIBRESSL_LIB_PATH=})
  ;; (foreign_stubs
  ;;  (language cxx)
diff --git a/lib/relation.ml b/lib/relation.ml
index 1854875..5a896d4 100644
--- a/lib/relation.ml
+++ b/lib/relation.ml
@@ -1,14 +1,16 @@
-open Sexplib0
-open Sexplib0.Sexp_conv
+
 
 module Protocol = struct
-  type tuple = string list [@@deriving sexp]
+  open Protocol_conv_xml
+  open Sexplib0.Sexp_conv
+  type tuple =
+    string list [@@deriving sexp, protocol ~driver:(module Xml_light)]
   type relation =
     { attribute_name: string;
       attribute_type: string;
       tuples: tuple }
-      [@@deriving sexp]
-  type t = relation list [@@deriving sexp]
+      [@@deriving sexp, protocol ~driver:(module Xml_light)]
+  type t = relation list [@@deriving sexp, protocol ~driver:(module Xml_light)]
 end
 
 let write_and_retrieve() =
@@ -40,6 +42,9 @@ let write_and_retrieve() =
   let+ (_, Command.Read last_name) = Command.commit_and_perform (List.tl stream) locations command_read2 in
   (* List.iter (fun a -> print_endline a) (List.map Bytes.to_string first_name); *)
   (* List.iter (fun a -> print_endline a) (List.map Bytes.to_string last_name); *)
-  Ok (Sexp.to_string (Protocol.sexp_of_t [{attribute_name = "user/first-name"; attribute_type = "string"; tuples = List.map Bytes.to_string first_name};
-                                          {attribute_name = "user/last-name"; attribute_type = "string"; tuples = List.map Bytes.to_string last_name}]))
+  let relation_result: Protocol.relation list =
+    [{attribute_name = "user/first-name"; attribute_type = "string"; tuples = List.map Bytes.to_string first_name};
+     {attribute_name = "user/last-name"; attribute_type = "string"; tuples = List.map Bytes.to_string last_name}] in
+  Ok (Xml.to_string (Protocol.to_xml_light relation_result))
+    (* (Sexp.to_string (Protocol.sexp_of_t )) *)
     [@@warning "-8"] (* Suppress pattern match incomplete warnings *)
diff --git a/lib/server.ml b/lib/server.ml
index 6544f81..22bee73 100644
--- a/lib/server.ml
+++ b/lib/server.ml
@@ -17,16 +17,18 @@ let client_read sock maxlen =
   let rec _read sock acc =
     Lwt_unix.read sock str 0 maxlen
     >>= fun recvlen -> Lwt_io.write_line Lwt_io.stdout (Printf.sprintf "[LOG] Received %d bytes from client" recvlen)
-    >>= fun () -> if recvlen <= maxlen
-                  then Lwt.return (acc ^ (Bytes.to_string (Bytes.sub str 0 recvlen)))
-                  else _read sock (acc ^ (Bytes.to_string (Bytes.sub str 0 recvlen)))
-  in _read sock ""
+    >>= fun () -> let acc = (acc ^ (Bytes.to_string (Bytes.sub str 0 recvlen))) in
+                  if recvlen <= maxlen
+                  then Lwt.return acc
+                  else _read sock acc in
+  _read sock String.empty
+  >>= fun _ -> match Relation.write_and_retrieve() with | Ok results -> return results | Error err -> return err
 
 let rec socket_read sock =
+  (* (Int32.of_int (String.length results))) *)
   Lwt_unix.accept sock
   >>= fun (client, _) -> client_read client 512
-  >>= fun results -> Lwt_io.write_line Lwt_io.stdout results
-  >>= fun () -> return results
+  (* >>= fun results -> Lwt_unix.send client (Data_encoding.Binary.to_bytes_exn Data_encoding.Encoding.int32 5l) 0 1 [] *)
   >>= fun results -> Lwt_unix.send client (Bytes.of_string results) 0 (String.length results) []
   >>= fun _ -> Lwt_unix.wait_write client
   >>= fun () -> Lwt_unix.close client