diff options
Diffstat (limited to '')
| -rw-r--r-- | bin/server.ml | 93 | ||||
| -rw-r--r-- | lib/attribute.ml | 7 | ||||
| -rw-r--r-- | lib/conventions.ml | 18 | ||||
| -rw-r--r-- | lib/tuple.ml | 17 | ||||
| -rw-r--r-- | todos.pl | 31 |
5 files changed, 95 insertions, 71 deletions
diff --git a/bin/server.ml b/bin/server.ml index b476631..7505b1c 100644 --- a/bin/server.ml +++ b/bin/server.ml @@ -3,50 +3,10 @@ open Relational_engine let default_port = 7777 let default_limit = 50 -(* TODO: move JSON serialisation into its own module; it's grown enough to - warrant separation and the server shouldn't own the wire format. *) - -let js_str s = - let buf = Buffer.create (String.length s + 2) in - Buffer.add_char buf '"'; - String.iter (function - | '"' -> Buffer.add_string buf {|\"|} - | '\\' -> Buffer.add_string buf {|\\|} - | '\n' -> Buffer.add_string buf {|\n|} - | '\r' -> Buffer.add_string buf {|\r|} - | '\t' -> Buffer.add_string buf {|\t|} - | c -> Buffer.add_char buf c) s; - Buffer.add_char buf '"'; - Buffer.contents buf - -let js_obj pairs = - "{" ^ - String.concat "," - (List.map (fun (k, v) -> js_str k ^ ":" ^ v) pairs) ^ - "}" - -let js_arr elems = "[" ^ String.concat "," elems ^ "]" -let js_bool b = if b then "true" else "false" -let js_int n = string_of_int n - (* TODO: AbstractValue carries no type tag of its own; we recover the OCaml runtime tag here via Obj introspection. This is fragile — it breaks the moment a domain stores a boxed integer or a custom block. The right fix is a typed value representation in Conventions. *) -let abstract_to_json (v : Conventions.AbstractValue.t) = - if Obj.is_int v then js_int (Obj.obj v : int) - else - let tag = Obj.tag v in - if tag = Obj.string_tag then js_str (Obj.obj v : string) - else if tag = Obj.double_tag then - let f = (Obj.obj v : float) in - if Float.is_nan f || Float.is_infinite f then "null" - else string_of_float f - else js_str "<opaque>" - -let tuple_to_json (t : Tuple.materialized) = - let pairs = Tuple.AttributeMap.bindings t.Tuple.attributes in - js_obj (List.map (fun (k, attr) -> (k, abstract_to_json attr.Attribute.value)) pairs) (* TODO: Generator.Error is silently treated as end-of-stream here, hiding real failures from the client. *) @@ -74,36 +34,43 @@ let materialize_relation storage (rel : Relation.t) limit = let short_hash (h : string) = String.sub h 0 (min 8 (String.length h)) -let relation_to_json storage (db_hash : string) (rel : Relation.t) limit = - let schema_json = - js_arr (List.map (fun (a, d) -> - js_obj [("attr", js_str a); ("domain", js_str d)] - ) rel.Relation.schema) +let tuple_to_sexp (t : Tuple.materialized) = + let open Sexplib.Sexp in + List (Tuple.AttributeMap.bindings t.Tuple.attributes + |> List.map (fun (k, attr) -> + List [Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value])) + +let relation_to_sexp storage (db_hash : string) (rel : Relation.t) limit = + let open Sexplib.Sexp in + let schema_sexp = + List (List.map (fun (a, d) -> List [Atom a; Atom d]) rel.Relation.schema) in let (tuples, truncated) = materialize_relation storage rel limit in - let rows_json = js_arr (List.map tuple_to_json tuples) in - js_obj [ - ("type", js_str "relation"); - ("name", js_str rel.Relation.name); - ("schema", schema_json); - ("rows", rows_json); - ("row_count", js_int (List.length tuples)); - ("truncated", js_bool truncated); - ("db_hash", js_str (short_hash db_hash)); + let rows_sexp = List (List.map tuple_to_sexp tuples) in + to_string @@ List [ + Atom "relation"; + List [Atom "name"; Atom rel.Relation.name]; + List [Atom "schema"; schema_sexp]; + List [Atom "rows"; rows_sexp]; + List [Atom "row_count"; Atom (string_of_int (List.length tuples))]; + List [Atom "truncated"; Atom (string_of_bool truncated)]; + List [Atom "db_hash"; Atom (short_hash db_hash)]; ] let ok_response db_hash msg = - js_obj [ - ("type", js_str "ok"); - ("message", js_str msg); - ("db_hash", js_str (short_hash db_hash)); + let open Sexplib.Sexp in + to_string @@ List [ + Atom "ok"; + List [Atom "message"; Atom msg]; + List [Atom "db_hash"; Atom (short_hash db_hash)]; ] let error_response db_hash msg = - js_obj [ - ("type", js_str "error"); - ("message", js_str msg); - ("db_hash", js_str (short_hash db_hash)); + let open Sexplib.Sexp in + to_string @@ List [ + Atom "error"; + List [Atom "message"; Atom msg]; + List [Atom "db_hash"; Atom (short_hash db_hash)]; ] let manip_err = function @@ -130,7 +97,7 @@ let execute_command storage db_ref cmd = match Drl.Parser.of_string cmd with | Ok query -> (match Drl.Executor.Memory.execute storage db query with - | Ok rel -> relation_to_json storage h rel default_limit + | Ok rel -> relation_to_sexp storage h rel default_limit | Error (Drl.Executor.Memory.RelationNotFound s) -> error_response h ("RelationNotFound: " ^ s) | Error (Drl.Executor.Memory.AlgebraError (Algebra.StorageError s)) -> diff --git a/lib/attribute.ml b/lib/attribute.ml index 27214b0..f3fc0b1 100644 --- a/lib/attribute.ml +++ b/lib/attribute.ml @@ -1,10 +1,11 @@ -type referenced = { value_hash : Conventions.Hash.t } +type referenced = { value_hash : Conventions.Hash.t } [@@deriving sexp_of] -type materialized = { value: Conventions.AbstractValue.t } +type materialized = { value: Conventions.AbstractValue.t } [@@deriving sexp_of] -type t = +type t = | Referenced of referenced | Materialized of materialized +[@@deriving sexp_of] let make_referenced ~value = let value_hash = Conventions.AbstractValue.hash value in diff --git a/lib/conventions.ml b/lib/conventions.ml index 0019447..60069b0 100644 --- a/lib/conventions.ml +++ b/lib/conventions.ml @@ -2,17 +2,35 @@ module Hash = struct type t = Interop.Sha256.t let hash_text text = Interop.Sha256.compute_hash (Bytes.of_string text) let compare = String.compare + let sexp_of_t = Sexplib.Std.sexp_of_string end module Name = struct type t = string + let sexp_of_t = Sexplib.Std.sexp_of_string end module Cardinality = struct type t = Finite of int | ConstrainedFinite | AlephZero | Continuum + let sexp_of_t = function + | Finite n -> Sexplib.Sexp.(List [Atom "Finite"; Atom (string_of_int n)]) + | ConstrainedFinite -> Sexplib.Sexp.Atom "ConstrainedFinite" + | AlephZero -> Sexplib.Sexp.Atom "AlephZero" + | Continuum -> Sexplib.Sexp.Atom "Continuum" end module AbstractValue = struct type t = Obj.t let hash (elem: t) = Interop.Sha256.compute_hash @@ Marshal.to_bytes elem [] + let sexp_of_t (v : t) = + let open Sexplib.Sexp in + if Obj.is_int v then Atom (string_of_int (Obj.obj v : int)) + else + let tag = Obj.tag v in + if tag = Obj.string_tag then Atom (Obj.obj v : string) + else if tag = Obj.double_tag then + let f = (Obj.obj v : float) in + if Float.is_nan f || Float.is_infinite f then Atom "nan" + else Atom (string_of_float f) + else Atom "<opaque>" end
\ No newline at end of file diff --git a/lib/tuple.ml b/lib/tuple.ml index 3c11fba..11fc508 100644 --- a/lib/tuple.ml +++ b/lib/tuple.ml @@ -1,18 +1,25 @@ -module AttributeMap = Map.Make(String) +module AttributeMap = struct + include Map.Make(String) + let sexp_of_t sexp_of_v m = + Sexplib.Sexp.List + (List.map (fun (k, v) -> Sexplib.Sexp.List [Sexplib.Sexp.Atom k; sexp_of_v v]) + (bindings m)) +end type non_materialized = { hash : Conventions.Hash.t; relation : Conventions.Name.t; attributes : Attribute.referenced AttributeMap.t; -} +} [@@deriving sexp_of] type materialized = { relation: Conventions.Name.t; - attributes: Attribute.materialized AttributeMap.t -} + attributes: Attribute.materialized AttributeMap.t; +} [@@deriving sexp_of] -type t = +type t = | Materialized of materialized | NonMaterialized of non_materialized +[@@deriving sexp_of] let make_materialized ~relation ~attributes = Materialized { relation; attributes } diff --git a/todos.pl b/todos.pl new file mode 100644 index 0000000..c1c6368 --- /dev/null +++ b/todos.pl @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use File::Find; + +my $root = $ARGV[0] // '.'; +my @files; + +find(sub { + $File::Find::prune = 1 if -d && /^(_build|\.git)$/; + push @files, $File::Find::name if /\.ml(i|l)?$/ && -f; +}, $root); + +my $count = 0; +for my $file (sort @files) { + open my $fh, '<', $file or die "Cannot open $file: $!"; + my $lineno = 0; + while (<$fh>) { + $lineno++; + if (/\bTODO\b[:\s]*(.*)/) { + my $msg = $1; + $msg =~ s/\s*\*\)\s*$//; # strip OCaml comment close + $msg =~ s/^\s+|\s+$//g; + printf "%-60s line %-4d %s\n", $file, $lineno, $msg; + $count++; + } + } + close $fh; +} + +print "\n$count TODO(s) found.\n"; |