wip

ocaml/database/db_cache_types.ml

@@ -689,13 +689,14 @@ let remove_row tblname objref db =
      )
   |> Database.increment
 
+open Sexplib0.Sexp_conv
 type where_record = {
     table: string  (** table from which ... *)
   ; return: string  (** we'd like to return this field... *)
   ; where_field: string  (** where this other field... *)
   ; where_value: string  (** contains this value *)
 }
-[@@deriving rpc]
+[@@deriving rpc, sexp_of]
 
 type structured_op_t = AddSet | RemoveSet | AddMap | RemoveMap | AddMapLegacy
-[@@deriving rpc]
+[@@deriving rpc, sexp_of]

ocaml/database/db_cache_types.mli

@@ -201,13 +201,14 @@ type where_record = {
   ; return: string  (** we'd like to return this field... *)
   ; where_field: string  (** where this other field... *)
   ; where_value: string  (** contains this value *)
-}
+} [@@deriving sexp_of]
 
 val where_record_of_rpc : Rpc.t -> where_record
 
 val rpc_of_where_record : where_record -> Rpc.t
 
 type structured_op_t = AddSet | RemoveSet | AddMap | RemoveMap | AddMapLegacy
+[@@deriving sexp_of]
 
 val structured_op_t_of_rpc : Rpc.t -> structured_op_t
 

ocaml/database/db_exn.ml

@@ -11,29 +11,40 @@
  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  * GNU Lesser General Public License for more details.
  *)
+open Sexplib0.Sexp_conv
 
 (** class * field * uuid * key *)
 exception Duplicate_key of string * string * string * string
+[@@deriving sexp]
 
 (** message * class * key *)
 exception DBCache_NotFound of string * string * string
+[@@deriving sexp]
 
 (** class * field * key *)
 exception Uniqueness_constraint_violation of string * string * string
+[@@deriving sexp]
 
 (** class * field * value *)
 exception Integrity_violation of string * string * string
+[@@deriving sexp]
 
 (** class * _ * uuid *)
 exception Read_missing_uuid of string * string * string
+[@@deriving sexp]
 
 (** class * _ * uuid *)
 exception Too_many_values of string * string * string
+[@@deriving sexp]
 
 exception Remote_db_server_returned_unknown_exception
+[@@deriving sexp]
 
 exception Remote_db_server_returned_bad_message
+[@@deriving sexp]
 
 exception Empty_key_in_map
+[@@deriving sexp]
 
 exception Invalid_value
+[@@deriving sexp]

ocaml/database/db_filter_types.ml

@@ -12,7 +12,8 @@
  * GNU Lesser General Public License for more details.
  *)
 
-type _val = Field of string | Literal of string [@@deriving rpc]
+open Sexplib0.Sexp_conv
+type _val = Field of string | Literal of string [@@deriving rpc, sexp_of]
 
 (** Represent a predicate: table row -> bool *)
 type expr =
@@ -22,4 +23,4 @@ type expr =
   | Eq of _val * _val
   | And of expr * expr
   | Or of expr * expr
-[@@deriving rpc]
+[@@deriving rpc, sexp_of]

ocaml/database/db_interface.ml

@@ -23,14 +23,15 @@ module type RPC = sig
   (** [rpc request] transmits [request] and receives a response *)
 end
 
-type table = string
+open Sexplib0.Sexp_conv
+type table = string [@@deriving sexp]
 
-type field_name = string
+type field_name = string [@@deriving sexp]
 
 
-type row_ref = string
+type row_ref = string [@@deriving sexp]
 
-type uuid = string
+type uuid = string [@@deriving sexp]
 
 
 (** The client interface to the database *)
@@ -100,7 +101,7 @@ module type DB_ACCESS = sig
   (** [db_get_by_name_label tbl label] returns the list of object references
       		associated with [label] *)
 
-  val delete_row : Db_ref.t -> row_ref -> table -> unit
+  val delete_row : Db_ref.t -> table -> row_ref -> unit
   (** [delete_row context tbl ref] deletes row [ref] from table [tbl] *)
 
   val process_structured_field :

ocaml/database/db_rpc_client_v3.ml

@@ -0,0 +1,146 @@
+(*
+ * Copyright (C) 2010 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** client-side for remote database access protocol v2 *)
+
+open Db_rpc_common_v3
+open Db_exn
+
+module D = Debug.Make (struct let name = __MODULE__ end)
+
+module Make =
+functor
+  (RPC : Db_interface.RPC)
+  ->
+  struct
+    type field = Schema.Value.t
+
+    open Db_interface
+
+    type regular_fields = (field_name * field) list
+
+    type associated_fields = (field_name * row_ref list) list
+
+    (** dictionary of regular fields x dictionary of associated set_ref values *)
+    type db_record = regular_fields * associated_fields
+
+    let initialise = RPC.initialise
+
+    let rpc x =
+      let reply = RPC.rpc (Wire.to_string x) in
+      match reply |> Wire.parse_string with
+      | Ok r ->
+          r
+      | Error (pos, str) ->
+          D.error "%s: failed to parse RPC reply at position %d: %s" __LOC__ pos
+            str ;
+          D.debug "The RPC that we failed to parse was: %S" str ;
+          raise Remote_db_server_returned_bad_message
+
+    let process (x : Request.t) response_of_sexp =
+      x |> Request.sexp_of_t |> rpc |> response_of_sexp
+
+    let get_table_from_ref _ x =
+      let (Response.Get_table_from_ref y) =
+        process (Request.Get_table_from_ref x)
+          Response.get_table_from_ref_of_sexp
+      in
+      y
+
+    let is_valid_ref _ x =
+      let (Response.Is_valid_ref y) =
+        process (Request.Is_valid_ref x) Response.is_valid_ref_of_sexp
+      in
+      y
+
+    let read_refs _ x =
+      let (Response.Read_refs y) =
+        process (Request.Read_refs x) Response.read_refs_of_sexp
+      in
+      y
+
+    let read_field_where _ x =
+      let (Response.Read_field_where y) =
+        process (Request.Read_field_where x) Response.read_field_where_of_sexp
+      in
+      y
+
+    let db_get_by_uuid _ t u =
+      let (Response.Db_get_by_uuid y) =
+        process (Request.Db_get_by_uuid (t, u)) Response.db_get_by_uuid_of_sexp
+      in
+      y
+
+    let db_get_by_name_label _ t l =
+      let (Response.Db_get_by_name_label y) =
+        process
+          (Request.Db_get_by_name_label (t, l))
+          Response.db_get_by_name_label_of_sexp
+      in
+      y
+
+    let create_row _ x y z =
+      let (Response.Create_row y) =
+        process (Request.Create_row (x, y, z)) Response.create_row_of_sexp
+      in
+      y
+
+    let delete_row _ x y =
+      let (Response.Delete_row y) =
+        process (Request.Delete_row (x, y)) Response.delete_row_of_sexp
+      in
+      y
+
+    let write_field _ a b c d =
+      let (Response.Write_field y) =
+        process (Request.Write_field (a, b, c, d)) Response.write_field_of_sexp
+      in
+      y
+
+    let read_field _ x y z =
+      let (Response.Read_field y) =
+        process (Request.Read_field (x, y, z)) Response.read_field_of_sexp
+      in
+      y
+
+    let find_refs_with_filter _ s e =
+      let (Response.Find_refs_with_filter y) =
+        process
+          (Request.Find_refs_with_filter (s, e))
+          Response.find_refs_with_filter_of_sexp
+      in
+      y
+
+    let read_record _ x y =
+      let (Response.Read_record (x, y)) =
+        process (Request.Read_record (x, y)) Response.read_record_of_sexp
+      in
+      (x, y)
+
+    let read_records_where _ x e =
+      let (Response.Read_records_where y) =
+        process
+          (Request.Read_records_where (x, e))
+          Response.read_records_where_of_sexp
+      in
+      y
+
+    let process_structured_field _ a b c d e =
+      let (Response.Process_structured_field y) =
+        process
+          (Request.Process_structured_field (a, b, c, d, e))
+          Response.process_structured_field_of_sexp
+      in
+      y
+  end

ocaml/database/db_rpc_common_v3.ml

@@ -0,0 +1,102 @@
+(*
+ * Copyright (C) 2010 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** Marshall/unmarshall functions and types for db remote access protocol v3 *)
+
+open Sexplib0.Sexp_conv
+open Db_interface
+
+module Wire = Csexp.Make(Sexplib0.Sexp)
+
+module Request = struct
+  type t =
+    | Get_table_from_ref of row_ref
+    | Is_valid_ref of row_ref
+    | Read_refs of table
+    | Find_refs_with_filter of table * Db_filter_types.expr
+    | Read_field_where of Db_cache_types.where_record
+    | Db_get_by_uuid of table * uuid
+    | Db_get_by_name_label of table * string
+    | Create_row of table * (string * Schema.Value.t) list * row_ref
+    | Delete_row of table * row_ref
+    | Write_field of table * row_ref * field_name * Schema.Value.t
+    | Read_field of string * table * row_ref
+    | Read_record of table * row_ref
+    | Read_records_where of table * Db_filter_types.expr
+    | Process_structured_field of
+        (string * string)
+        * table
+        * field_name
+        * row_ref
+        * Db_cache_types.structured_op_t
+  [@@deriving sexp_of]
+
+  (* Make sure the slave only ever uses the idempotent version *)
+  let sexp_of_t t =
+    let t' =
+      match t with
+      | Process_structured_field (a, b, c, d, Db_cache_types.AddMapLegacy) ->
+          Process_structured_field (a, b, c, d, Db_cache_types.AddMap)
+      | x ->
+          x
+    in
+    sexp_of_t t'
+end
+
+module Response = struct
+  (* TODO:wrap exceptions as variants... *)
+  type 'a t = ('a, exn) result [@@deriving of_sexp]
+
+  type get_table_from_ref = Get_table_from_ref of table option
+  [@@deriving of_sexp]
+
+  type is_valid_ref = Is_valid_ref of bool [@@deriving of_sexp]
+
+  type read_refs = Read_refs of row_ref list [@@deriving of_sexp]
+
+  type find_refs_with_filter = Find_refs_with_filter of row_ref list
+  [@@deriving of_sexp]
+
+  type read_field_where = Read_field_where of Schema.Value.t list
+  [@@deriving of_sexp]
+
+  type db_get_by_uuid = Db_get_by_uuid of row_ref [@@deriving of_sexp]
+
+  type db_get_by_name_label = Db_get_by_name_label of row_ref list
+  [@@deriving of_sexp]
+
+  type create_row = Create_row of unit [@@deriving of_sexp]
+
+  type delete_row = Delete_row of unit [@@deriving of_sexp]
+
+  type write_field = Write_field of unit [@@deriving of_sexp]
+
+  type read_field = Read_field of Schema.Value.t [@@deriving of_sexp]
+
+  type read_record =
+    | Read_record of
+        (field_name * Schema.Value.t) list * (field_name * row_ref list) list
+  [@@deriving of_sexp]
+
+  type read_records_where =
+    | Read_records_where of
+        ( row_ref
+        * ((field_name * Schema.Value.t) list * (field_name * row_ref list) list)
+        )
+        list
+  [@@deriving of_sexp]
+
+  type process_structured_field = Process_structured_field of unit
+  [@@deriving of_sexp]
+end

ocaml/database/dune

@@ -27,6 +27,7 @@
       test_schemas unit_test_marshall unit_test_sql))
   (libraries
     forkexec
+    csexp
     gzip
     rpclib.core
     rpclib.json
@@ -49,7 +50,7 @@
     xmlm
   )
   (wrapped false)
-  (preprocess (pps ppx_deriving_rpc))
+  (preprocess (pps ppx_deriving_rpc ppx_sexp_conv))
 )
 
 (executable