From 29e00769046cbc8cd020b2b7c47448d89f21ab39 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Wed, 22 Apr 2026 22:46:41 -0300 Subject: Prototype for configuration --- lib/configuration.ml | 84 ++++++++++++++++++++++++++++++++++ lib/dcl/sublanguage.ml | 2 + lib/ddl/sublanguage.ml | 2 + lib/dml/sublanguage.ml | 2 + lib/drl/sublanguage.ml | 2 + lib/dune | 1 + lib/icl/sublanguage.ml | 2 + lib/management/physical.ml | 28 ++++++++++-- lib/scl/sublanguage.ml | 2 + lib/sublanguage.ml | 2 + lib/system.ml | 111 +++++++++++++++++++++++++++++++++++++++++++++ lib/transport.ml | 65 +++++++++++++++++++------- lib/utilities.ml | 10 ++++ 13 files changed, 292 insertions(+), 21 deletions(-) create mode 100644 lib/configuration.ml create mode 100644 lib/system.ml create mode 100644 lib/utilities.ml (limited to 'lib') diff --git a/lib/configuration.ml b/lib/configuration.ml new file mode 100644 index 0000000..6229ce6 --- /dev/null +++ b/lib/configuration.ml @@ -0,0 +1,84 @@ +module type CONFIGURABLE = sig + type configuration + + val parse : Sexplib.Sexp.t -> (configuration, string) result +end + +type t = Sexplib.Sexp.t Utilities.StringMap.t +(** Section name -> raw sexp subtree. *) + +let find_section (key : string) (config : t) : Sexplib.Sexp.t option = + Utilities.StringMap.find_opt key config + +let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt + +(** Check that [key] is expected and not duplicate, then add it. *) +let insert_section ~expected acc key body = + let ( let* ) = Result.bind in + let* () = + if Utilities.StringSet.mem key expected then Ok () + else errorf "Unknown configuration section: %s" key + in + let* () = + if Utilities.StringMap.mem key acc then + errorf "Duplicate configuration section: %s" key + else Ok () + in + match body with + | [ subtree ] -> Ok (Utilities.StringMap.add key subtree acc) + | [] -> errorf "Configuration section %s is empty (expected a tagged value)" key + | _ -> + errorf "Configuration section %s has multiple values (expected exactly one)" + key + +(** [(server ...)] sexp -> section map. Rejects unknown/duplicate keys. *) +let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, string) result = + let open Sexplib.Sexp in + match sexp with + | List (Atom "server" :: sections) -> + let expected = + List.fold_right Utilities.StringSet.add expected_keys + Utilities.StringSet.empty + in + let rec go acc = function + | [] -> Ok acc + | List (Atom key :: body) :: rest -> + Result.bind (insert_section ~expected acc key body) (fun acc -> + go acc rest) + | bad :: _ -> + errorf "Malformed configuration section: %s" (to_string bad) + in + go Utilities.StringMap.empty sections + | _ -> Error "Configuration must be a (server ...) s-expression" + +(** Read a file from disk and run [parse_server] on it. *) +let load ~expected_keys (path : string) : (t, string) result = + match Sexplib.Sexp.load_sexp path with + | sexp -> parse_server ~expected_keys sexp + | exception Sys_error msg -> + errorf "Failed to load configuration file %s: %s" path msg + | exception Failure msg -> + errorf "Failed to parse configuration file %s: %s" path msg + +(** [(tag field1 ...)] -> [(tag, List [field1; ...])]. *) +let extract_tagged_section (sexp : Sexplib.Sexp.t) : + (string * Sexplib.Sexp.t, string) result = + let open Sexplib.Sexp in + match sexp with + | List (Atom tag :: body) -> Ok (tag, List body) + | _ -> errorf "Expected (tag ...) but got: %s" (to_string sexp) + +(** Look up a section by name, extract its tag, and check the tag is allowed. *) +let require_section ~(name : string) ~(valid_tags : string list) (config : t) : + (string * Sexplib.Sexp.t, string) result = + let ( let* ) = Result.bind in + let* sexp = + find_section name config + |> Option.to_result + ~none:(Printf.sprintf "Missing (%s ...) section in configuration" name) + in + let* tag, body = extract_tagged_section sexp in + let* () = + if List.mem tag valid_tags then Ok () else errorf "Unknown %s: %s" name tag + in + Ok (tag, body) diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml index c36e2a4..9253374 100644 --- a/lib/dcl/sublanguage.ml +++ b/lib/dcl/sublanguage.ml @@ -1,11 +1,13 @@ module Make (Storage : Management.Physical.S with type error = string) = struct module Exec = Executor.Make (Storage) + type configuration = unit type storage = Storage.t type ast = Ast.statement type error = Exec.error let name = "dcl" + let parse _ = Ok () let parse_sexp sexp = match Parser.of_sexp sexp with diff --git a/lib/ddl/sublanguage.ml b/lib/ddl/sublanguage.ml index bf40a05..6b9f412 100644 --- a/lib/ddl/sublanguage.ml +++ b/lib/ddl/sublanguage.ml @@ -1,11 +1,13 @@ module Make (Storage : Management.Physical.S) = struct module Exec = Executor.Make (Storage) + type configuration = unit type storage = Storage.t type ast = Ast.statement type error = Exec.error let name = "ddl" + let parse _ = Ok () let parse_sexp sexp = match Parser.of_sexp sexp with diff --git a/lib/dml/sublanguage.ml b/lib/dml/sublanguage.ml index 29b1b77..ed4206b 100644 --- a/lib/dml/sublanguage.ml +++ b/lib/dml/sublanguage.ml @@ -1,11 +1,13 @@ module Make (Storage : Management.Physical.S) = struct module Exec = Executor.Make (Storage) + type configuration = unit type storage = Storage.t type ast = Ast.statement type error = Exec.error let name = "dml" + let parse _ = Ok () let parse_sexp sexp = match Parser.of_sexp sexp with diff --git a/lib/drl/sublanguage.ml b/lib/drl/sublanguage.ml index ce69b56..3496f9c 100644 --- a/lib/drl/sublanguage.ml +++ b/lib/drl/sublanguage.ml @@ -1,11 +1,13 @@ module Make (Storage : Management.Physical.S) = struct module Exec = Executor.Make (Storage) + type configuration = unit type storage = Storage.t type ast = Ast.query type error = Exec.error let name = "drl" + let parse _ = Ok () let parse_sexp sexp = match Parser.of_sexp sexp with diff --git a/lib/dune b/lib/dune index 7833c8a..165ef24 100644 --- a/lib/dune +++ b/lib/dune @@ -2,6 +2,7 @@ (library (name relational_engine) + (public_name sakura.relational_engine) (libraries sha data-encoding diff --git a/lib/icl/sublanguage.ml b/lib/icl/sublanguage.ml index 56f3e4b..ab70165 100644 --- a/lib/icl/sublanguage.ml +++ b/lib/icl/sublanguage.ml @@ -1,11 +1,13 @@ module Make (Storage : Management.Physical.S) = struct module Exec = Executor.Make (Storage) + type configuration = unit type storage = Storage.t type ast = Ast.statement type error = Exec.error let name = "icl" + let parse _ = Ok () let parse_sexp sexp = match Parser.of_sexp sexp with diff --git a/lib/management/physical.ml b/lib/management/physical.ml index 3fc2cf7..0f26bca 100644 --- a/lib/management/physical.ml +++ b/lib/management/physical.ml @@ -9,10 +9,12 @@ (** Backend module signature that any storage driver must implement *) module type BACKEND = sig + include Configuration.CONFIGURABLE + type connection type error - val connect : unit -> (connection, error) result + val connect : configuration -> (connection, error) result (** Connect to the storage backend *) val disconnect : connection -> unit @@ -47,10 +49,12 @@ end (** Storage operations built on top of a backend *) module type S = sig + include Configuration.CONFIGURABLE + type t type error - val create : unit -> (t, error) result + val create : configuration -> (t, error) result (** Create a storage instance from a backend connection *) val close : t -> unit @@ -80,11 +84,14 @@ module type S = sig end (** Functor to create storage operations from a backend *) -module Make (B : BACKEND) : S with type error = B.error = struct +module Make (B : BACKEND) : + S with type error = B.error and type configuration = B.configuration = struct + type configuration = B.configuration type t = B.connection type error = B.error - let create () = B.connect () + let parse = B.parse + let create config = B.connect config let close = B.disconnect let store_attribute conn value = @@ -115,7 +122,10 @@ module Make (B : BACKEND) : S with type error = B.error = struct end (** In-memory backend for testing and development *) -module MemoryBackend : BACKEND with type error = string = struct +module MemoryBackend : + BACKEND with type error = string and type configuration = unit = struct + type configuration = unit + type connection = { data : (string, bytes) Hashtbl.t; mutable in_transaction : bool; @@ -124,6 +134,14 @@ module MemoryBackend : BACKEND with type error = string = struct type error = string + let parse sexp = + match sexp with + | Sexplib.Sexp.List [] -> Ok () + | _ -> + Error + (Printf.sprintf "memory backend takes no configuration, got: %s" + (Sexplib.Sexp.to_string sexp)) + let connect () = Ok { diff --git a/lib/scl/sublanguage.ml b/lib/scl/sublanguage.ml index b39e720..e361ff9 100644 --- a/lib/scl/sublanguage.ml +++ b/lib/scl/sublanguage.ml @@ -1,11 +1,13 @@ module Make (Storage : Management.Physical.S) = struct module Exec = Executor.Make (Storage) + type configuration = unit type storage = Storage.t type ast = Ast.statement type error = Exec.error let name = "scl" + let parse _ = Ok () let parse_sexp sexp = match Parser.of_sexp sexp with diff --git a/lib/sublanguage.ml b/lib/sublanguage.ml index 4cfe913..86d8cb4 100644 --- a/lib/sublanguage.ml +++ b/lib/sublanguage.ml @@ -26,6 +26,8 @@ type result = | Cursor of cursor_result module type S = sig + include Configuration.CONFIGURABLE + type storage type ast type error diff --git a/lib/system.ml b/lib/system.ml new file mode 100644 index 0000000..4280dda --- /dev/null +++ b/lib/system.ml @@ -0,0 +1,111 @@ +(** System assembly: registry-based configuration dispatch. This module is the + composition root. It owns the mapping from configuration tags to concrete + implemenations and assembles a server from a configuration file. *) + +type storage_parcel = + | StorageParcel : + (module Management.Physical.S with type t = 't and type error = string) + * 't + -> storage_parcel + +type transport_parcel = + | TransportParcel : + (module Transport.TRANSPORT with type t = 't) * 't + -> transport_parcel + +type storage_provider = Sexplib.Sexp.t -> (storage_parcel, string) result +type transport_provider = Sexplib.Sexp.t -> (transport_parcel, string) result + +type registry = { + storage : storage_provider Utilities.StringMap.t; + transport : transport_provider Utilities.StringMap.t; +} + +let registry : registry = + let open Utilities.StringMap in + { storage = + empty + |> add "memory" (fun sexp -> + let ( let* ) = Result.bind in + let* config = Management.Physical.MemoryBackend.parse sexp in + let* storage = Management.Physical.Memory.create config in + Ok (StorageParcel ((module Management.Physical.Memory), storage))) + ; transport = + empty + |> add "tcp" (fun sexp -> + let ( let* ) = Result.bind in + let* config = Transport.TCP.parse sexp in + let transport = Transport.TCP.create config in + Ok (TransportParcel ((module Transport.TCP), transport))) } + +let initialize_multigroup create_immutable_relation storage multigroup = + let open Prelude.Standard in + List.fold_left + (fun multigroup (rel : Relation.t) -> + match + create_immutable_relation storage multigroup ~name:rel.name + ~schema:rel.schema ~generator:(Option.get rel.generator) + ~membership_criteria:rel.membership_criteria + ~cardinality:rel.cardinality + with + | Ok (new_multigroup, _) -> new_multigroup + | Error e -> + Printf.eprintf + "Warning: failed to register prelude relation %s: %s\n%!" rel.name + (Sexplib.Sexp.to_string (Error.sexp_of_error e)); + multigroup) + multigroup + [ 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 ] + +let assemble (config : Configuration.t) : (unit -> unit, string) result = + let open Utilities.Result in + let* storage_tag, storage_body = + Configuration.require_section ~name:"storage" + ~valid_tags:(Utilities.StringMap.bindings registry.storage |> List.map fst) + config + in + let* storage_provider = + Utilities.StringMap.find_opt storage_tag registry.storage + |> Option.to_result + ~none:(Printf.sprintf "Unknown storage backend: %s" storage_tag) + in + let* packed_storage = storage_provider storage_body in + let* transport_tag, transport_body = + Configuration.require_section ~name:"transport" + ~valid_tags: + (Utilities.StringMap.bindings registry.transport |> List.map fst) + config + in + let* transport_provider = + Utilities.StringMap.find_opt transport_tag registry.transport + |> Option.to_result + ~none:(Printf.sprintf "Unknown transport backend: %s" transport_tag) + in + let* packed_transport = transport_provider transport_body in + let (StorageParcel ((module S), storage)) = packed_storage in + let (TransportParcel ((module T), transport)) = packed_transport in + let module Manip = Manipulation.Make (S) in + let* multigroup = + Manip.create_database storage ~name:"sakura" + |> Result.map (initialize_multigroup Manip.create_immutable_relation storage) + |> Result.map_error (fun _ -> "Failed to create initial database") + in + let module L = Listener.Make (T) (S) in + Ok (fun () -> Scl.Executor.set_sessions (Session.create ()); + L.run transport multigroup storage) + +let run_from_config (path : string) : (unit -> unit, string) result = + let ( let* ) = Result.bind in + let* config = + Configuration.load ~expected_keys:[ "storage"; "transport" ] path + in + assemble config diff --git a/lib/transport.ml b/lib/transport.ml index 5130a2d..8c8a2bd 100644 --- a/lib/transport.ml +++ b/lib/transport.ml @@ -1,39 +1,72 @@ module type TRANSPORT = sig + include Configuration.CONFIGURABLE + type t type connection - type options - - val create : options -> t + val create : configuration -> t val listen : t -> unit val accept : t -> connection - val input : connection -> in_channel val output : connection -> out_channel end -(* TODO: move this into TCP once we have a proper configuration system *) -type tcp_options = { - address_family : Unix.socket_domain; - address : Unix.sockaddr -} +module TCP : TRANSPORT = struct + type configuration = { + address_family : Unix.socket_domain; + sockaddr : Unix.sockaddr; + } -module TCP : (TRANSPORT with type options = tcp_options) = struct type t = Unix.file_descr type connection = Unix.file_descr - type options = tcp_options - let create { address_family; address } = + let sockaddr_of_fields = function + | `Inet (addr, port) -> + Ok { address_family = Unix.PF_INET; + sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) } + | `Unix path -> + Ok { address_family = Unix.PF_UNIX; + sockaddr = Unix.ADDR_UNIX path } + + let parse sexp = + let open Sexplib.Sexp in + let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt in + let rec go addr port path = function + | [] -> + (match addr, port, path with + | Some a, Some p, None -> sockaddr_of_fields (`Inet (a, p)) + | None, None, Some s -> sockaddr_of_fields (`Unix s) + | None, None, None -> errorf "transport/tcp: no address fields" + | _ -> errorf "transport/tcp: use (address + port) or (path), not both") + | List [ Atom "address"; Atom a ] :: rest -> go (Some a) port path rest + | List [ Atom "port"; Atom p ] :: rest -> + (match int_of_string_opt p with + | Some n -> go addr (Some n) path rest + | None -> errorf "transport/tcp: invalid port: %s" p) + | List [ Atom "path"; Atom p ] :: rest -> go addr port (Some p) rest + | bad :: _ -> errorf "transport/tcp: unexpected: %s" (to_string bad) + in + match sexp with + | List children -> go None None None children + | _ -> Error "transport/tcp: expected a list of fields" + + let string_of_sockaddr = function + | Unix.ADDR_INET (host, port) -> + Printf.sprintf "%s:%d" (Unix.string_of_inet_addr host) port + | Unix.ADDR_UNIX path -> path + + let create { address_family; sockaddr } = let socket = Unix.socket address_family Unix.SOCK_STREAM 0 in Unix.setsockopt socket Unix.SO_REUSEADDR true; - Unix.setsockopt socket Unix.SO_REUSEPORT true; - Unix.bind socket address; + Unix.bind socket sockaddr; socket - let listen fd = Unix.listen fd 5 + let listen fd = + Unix.listen fd 5; + Printf.printf "Listening on %s\n%!" (string_of_sockaddr (Unix.getsockname fd)) let accept fd = - let (conn, _) = Unix.accept fd in + let conn, _ = Unix.accept fd in conn let input = Unix.in_channel_of_descr diff --git a/lib/utilities.ml b/lib/utilities.ml new file mode 100644 index 0000000..d0c5673 --- /dev/null +++ b/lib/utilities.ml @@ -0,0 +1,10 @@ +module StringMap = Map.Make (String) +module StringSet = Set.Make (String) + +module Result = struct + let (let*) = Result.bind +end + +module Option = struct + let (let*) = Option.bind +end -- cgit v1.2.3