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. *)
let materialize_generator gen limit =
let rec go gen pos acc count =
if count >= limit then (List.rev acc, true)
else
match gen (Some pos) with
| Generator.Done -> (List.rev acc, false)
| Generator.Error _ -> (List.rev acc, false)
| Generator.Value (t, next) ->
let mat = match t with
| Tuple.Materialized m -> Some m
| Tuple.NonMaterialized _ -> None
in
(match mat with
| None -> go next (pos + 1) acc count
| Some m -> go next (pos + 1) (m :: acc) (count + 1))
in
go gen 0 [] 0
let materialize_relation storage (rel : Relation.t) limit =
let gen = Algebra.Memory.to_generator storage rel in
materialize_generator gen 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)
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 ok_response db_hash msg =
js_obj [
("type", js_str "ok");
("message", js_str msg);
("db_hash", js_str (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 manip_err = function
| Manipulation.RelationNotFound s -> "RelationNotFound: " ^ s
| Manipulation.RelationAlreadyExists s -> "RelationAlreadyExists: " ^ s
| Manipulation.TupleNotFound h -> "TupleNotFound: " ^ h
| Manipulation.DuplicateTuple h -> "DuplicateTuple: " ^ h
| Manipulation.ConstraintViolation s -> "ConstraintViolation: " ^ s
| Manipulation.StorageError s -> "StorageError: " ^ s
(* TODO: language dispatch by trying parsers in sequence is a code smell —
a valid DRL expression that happens to also parse as DML would silently
be treated as DRL. The three sublanguages should share a common envelope,
e.g. a top-level tag distinguishing (Query ...) from (Exec ...). *)
let execute_command storage db_ref cmd =
let db = !db_ref in
let h = db.Management.Database.hash in
(* TODO: (schema) is a stopgap. Introspection should be expressible in
DRL itself via the catalog relations, not special-cased here. *)
let cmd = match String.trim cmd with
| "(schema)" -> {|(Base sakura:attribute)|}
| s -> s
in
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
| Error (Drl.Executor.Memory.RelationNotFound s) ->
error_response h ("RelationNotFound: " ^ s)
| Error (Drl.Executor.Memory.AlgebraError (Algebra.StorageError s)) ->
error_response h ("StorageError: " ^ s)
| Error (Drl.Executor.Memory.AlgebraError (Algebra.GeneratorError s)) ->
error_response h ("GeneratorError: " ^ s))
| Error _ ->
match Dml.Parser.of_string cmd with
| Ok stmt ->
(match Dml.Executor.Memory.execute storage db stmt with
| Ok new_db ->
db_ref := new_db;
ok_response new_db.Management.Database.hash "Database updated"
| Error (Dml.Executor.Memory.ManipulationError me) ->
error_response h (manip_err me)
| Error (Dml.Executor.Memory.RelationNotFound s) ->
error_response h ("RelationNotFound: " ^ s)
| Error (Dml.Executor.Memory.ParseError s) ->
error_response h ("ParseError: " ^ s))
| Error _ ->
match Dcl.Parser.of_string cmd with
| Ok stmt ->
(match Dcl.Executor.Memory.execute storage db stmt with
| Ok new_db ->
db_ref := new_db;
ok_response new_db.Management.Database.hash "Constraint registered"
| Error (Dcl.Executor.Memory.ManipulationError me) ->
error_response h (manip_err me)
| Error (Dcl.Executor.Memory.ConversionError s) ->
error_response h ("ConversionError: " ^ s))
| Error _ ->
error_response h "Parse error: not valid DRL, DML, or DCL"
(* TODO: registration failures are silently ignored; a broken prelude
relation leaves the catalog in a partially-seeded state with no
indication to the user. *)
let register_prelude_relations storage db =
let open Prelude.Standard in
List.fold_left
(fun db (rel : Relation.t) ->
match Manipulation.Memory.create_immutable_relation storage db
~name:rel.name
~schema:rel.schema
~generator:(Option.get rel.generator)
~membership_criteria:rel.membership_criteria
~cardinality:rel.cardinality
with
| Ok (new_db, _) -> new_db
| Error _ -> db)
db
[ less_than_natural
; less_than_or_equal_natural
; greater_than_natural
; greater_than_or_equal_natural
; equal_natural
; not_equal_natural
; plus_natural
; times_natural
; minus_natural
; divide_natural
]
(* TODO: single-threaded accept loop — one slow or hung client blocks all
others. Should use threads or non-blocking I/O. *)
let handle_client storage db_ref fd =
let ic = Unix.in_channel_of_descr fd in
let oc = Unix.out_channel_of_descr fd in
(try
while true do
let line = input_line ic in
let line = String.trim line in
if line <> "" then begin
let response = execute_command storage db_ref line in
output_string oc (response ^ "\n");
flush oc
end
done
with End_of_file | Unix.Unix_error _ -> ())
let () =
let port = default_port in
match Management.Physical.Memory.create () with
| Error _ -> failwith "Failed to create storage"
| Ok storage ->
match Manipulation.Memory.create_database storage ~name:"sakura" with
| Error _ -> failwith "Failed to create initial database"
| Ok db ->
let db = register_prelude_relations storage db in
let db_ref = ref db in
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.setsockopt sock Unix.SO_REUSEADDR true;
Unix.setsockopt sock Unix.SO_REUSEPORT true;
Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_loopback, port));
Unix.listen sock 5;
Printf.printf "Sakura server listening on 127.0.0.1:%d\n" port;
Printf.printf "Database hash: %s\n%!" (short_hash db.Management.Database.hash);
while true do
let (client_fd, _addr) = Unix.accept sock in
handle_client storage db_ref client_fd;
(try Unix.close client_fd with _ -> ())
done
