diff options
Diffstat (limited to 'bin/server.ml')
| -rw-r--r-- | bin/server.ml | 254 |
1 files changed, 254 insertions, 0 deletions
diff --git a/bin/server.ml b/bin/server.ml new file mode 100644 index 0000000..a7b5fa3 --- /dev/null +++ b/bin/server.ml @@ -0,0 +1,254 @@ +open Relational_engine + +let default_port = 7777 +let default_limit = 50 + +(* ============================================================================ + Minimal JSON serialisation — no external deps + ============================================================================ *) + +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 + +(* ============================================================================ + Value serialisation + ============================================================================ *) + +(** Convert an AbstractValue (Obj.t) to a JSON fragment. + Uses Obj tag inspection to recover Int / String / Float. *) +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) + +(* ============================================================================ + Relation materialisation + ============================================================================ *) + +(** Iterate a generator up to [limit] tuples; returns (rows, truncated). *) +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 + +(** Materialise either a stored or generator-backed relation. *) +let materialize_relation storage (rel : Relation.t) limit = + let gen = Algebra.Memory.to_generator storage rel in + materialize_generator gen limit + +(* ============================================================================ + JSON response builders + ============================================================================ *) + +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)); + ] + +(* ============================================================================ + Error formatting + ============================================================================ *) + +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 + +(* ============================================================================ + Command execution + ============================================================================ *) + +let execute_command storage db_ref cmd = + let db = !db_ref in + let h = db.Management.Database.hash in + (* 0. Special commands *) + let cmd = match String.trim cmd with + | "(schema)" -> {|(Base sakura:attribute)|} + | s -> s + in + (* 1. Try DRL *) + 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 _ -> + (* 2. Try DML *) + 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 _ -> + (* 3. Try DCL *) + 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" + +(* ============================================================================ + Prelude registration + ============================================================================ *) + +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 + ] + +(* ============================================================================ + TCP server + ============================================================================ *) + +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 |