diff options
| -rw-r--r-- | bin/dune | 9 | ||||
| -rw-r--r-- | bin/server.ml | 101 | ||||
| -rw-r--r-- | config-unix.sexp | 4 | ||||
| -rw-r--r-- | config.sexp | 8 | ||||
| -rw-r--r-- | lib/configuration.ml | 84 | ||||
| -rw-r--r-- | lib/dcl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/ddl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/dml/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/drl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/dune | 1 | ||||
| -rw-r--r-- | lib/icl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/management/physical.ml | 28 | ||||
| -rw-r--r-- | lib/scl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/system.ml | 111 | ||||
| -rw-r--r-- | lib/transport.ml | 65 | ||||
| -rw-r--r-- | lib/utilities.ml | 10 |
17 files changed, 314 insertions, 121 deletions
@@ -1,13 +1,6 @@ (executable - (public_name sakura) - (name main) - (modules main) - (libraries relational_engine) - (package sakura) - (modes byte exe)) - -(executable (name server) + (public_name sakura-server) (modules server) (libraries relational_engine unix) (modes byte exe)) diff --git a/bin/server.ml b/bin/server.ml index 1d4d5b3..2423c37 100644 --- a/bin/server.ml +++ b/bin/server.ml @@ -1,95 +1,12 @@ open Relational_engine -module B = Management.Physical.Memory -module T = Transport.TCP -module Listener = Listener.Make(T)(B) - -module Memory = Manipulation.Make (B) - -(* TODO: registration failures are silently ignored; a broken prelude - relation leaves the catalog in a partially-seeded state with no - indication to the user. *) -(* TODO: think of a better way to initialize new databases *) -let register_prelude_relations storage db = - let open Prelude.Standard in - List.fold_left - (fun db (rel : Relation.t) -> - match - 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 e -> - Printf.eprintf - "Warning: failed to register prelude relation %s: %s\n%!" rel.name - (Sexplib.Sexp.to_string (Error.sexp_of_error e)); - 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; - ] - -(* let register_branch_relations storage db = *) -(* (\* Register ephemeral sakura:branch and sakura:head relations backed by *) -(* the raw branch registry — no stored tuples, no circularity. *\) *) -(* let register db rel = *) -(* match *) -(* Memory.create_immutable_relation storage db *) -(* ~name:rel.Relation.name ~schema:rel.Relation.schema *) -(* ~generator:(Option.get rel.Relation.generator) *) -(* ~membership_criteria:rel.Relation.membership_criteria *) -(* ~cardinality:rel.Relation.cardinality *) -(* with *) -(* | Ok (db, _) -> db *) -(* | Error e -> *) -(* Printf.eprintf "Warning: failed to register %s: %s\n%!" *) -(* rel.Relation.name *) -(* (Manipulation.Error.string_of_error e); *) -(* db *) -(* in *) -(* db *) -(* |> Fun.flip register (BranchOps.branch_relation storage) *) -(* |> Fun.flip register (BranchOps.head_relation storage) *) - -let setup () = - let ( let* ) = Result.bind in - let* storage = - Management.Physical.Memory.create () - |> Result.map_error (Fun.const "Failed to create storage") - in - let* db = - Memory.create_database storage ~name:"sakura" - |> Result.map_error (Fun.const "Failed to create initial database") - in - Ok (storage, db) - -let address = "127.0.0.1" -let port = 7777 - let () = - match setup () with - | Error msg -> Printf.eprintf "Couldn't initialize: %s" msg - | Ok (storage, db) -> - let db = - db - |> register_prelude_relations storage - (* |> register_branch_relations storage *) - in - let transport = - T.create - { address_family = Unix.PF_INET; - address = Unix.ADDR_INET (Unix.inet_addr_of_string address, port) } - in - Printf.printf "Listening on %s:%d" address port; print_newline (); - Listener.run transport db storage + if Array.length Sys.argv <> 2 then begin + Printf.eprintf "Usage: %s <config-file>\n%!" Sys.argv.(0); + exit 1; + end; + match System.run_from_config Sys.argv.(1) with + | Error e -> + Printf.eprintf "Couldn't initialize: %s\n%!" e; + exit 1 + | Ok run -> run () diff --git a/config-unix.sexp b/config-unix.sexp new file mode 100644 index 0000000..7598840 --- /dev/null +++ b/config-unix.sexp @@ -0,0 +1,4 @@ +(server + (storage (memory)) + (transport (tcp + (path "/tmp/sakura.sock")))) diff --git a/config.sexp b/config.sexp new file mode 100644 index 0000000..2e56f4d --- /dev/null +++ b/config.sexp @@ -0,0 +1,8 @@ +;; Sakura server configuration +;; storage: memory +;; transport: tcp (address, port) +(server + (storage (memory)) + (transport (tcp + (address "127.0.0.1") + (port 7777)))) 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 @@ -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 |