bound queries from sakurasakura-karuta-contract

4 files changed, 159 insertions, 47 deletions

diff --git a/subsystem/karuta/Beam.ml b/subsystem/karuta/Beam.ml
index 82ae827..e0def90 100644
--- a/subsystem/karuta/Beam.ml
+++ b/subsystem/karuta/Beam.ml
@@ -8,12 +8,14 @@ module Error = struct
 
   let malformed () =
     condition "malformed-beam-program"
-      "A beam program is not {Module, Function, Beam, #{Name => Domain}} of binaries" empty
+      "A beam program is not {Module, Beam, #{Name => Domain}} of binaries" empty
 
   let not_a_program () =
     condition "not-a-beam-program" "The evaluator was given a program of another kind" empty
 
-  let inputs () = condition "beam-program-inputs" "A beam program takes no inputs" empty
+  let inputs () =
+    condition "beam-program-inputs"
+      "A beam program takes at most one input, of at most one tuple: what its caller knows" empty
 
   let failed message =
     condition "beam-failed" "The BEAM node failed to answer a call"
@@ -79,7 +81,6 @@ let name = "karuta"
 
 type program =
   { module_: string;
-    function_: string;
     beam: string;
     heading: Protocols.Schematics.relation_description }
 
@@ -90,12 +91,11 @@ let decode source =
     | Concepts.Value.String domain -> Some {Protocols.Schematics.domain; provenance= []}
     | Concepts.Value.Integer _ -> None
   in
-  match Translator.read 4 source with
-  | Some ([module_; function_; beam], attributes)
-    when String.length module_ <= 0xffff && String.length function_ <= 0xffff ->
+  match Translator.read 3 source with
+  | Some ([module_; beam], attributes) when String.length module_ <= 0xffff ->
       let heading = BatMap.String.filter_map domain attributes in
       if BatMap.String.cardinal heading = BatMap.String.cardinal attributes then
-        Ok (Beam {module_; function_; beam; heading})
+        Ok (Beam {module_; beam; heading})
       else Error (Error.malformed ())
   | _ -> Error (Error.malformed ())
 
@@ -104,19 +104,22 @@ let decode source =
    can call back into RNT, and so on, as deep as the calls nest.
 
    RNT asks the node:
-   - h                                 run every loaded rnt_init/0  -> o | e
-   - i Id:64 M:16 Module F:16 Function B:32 Beam
-                                       start Module:Function() from Beam
+   - h                                 run every loaded rnt-init    -> o | e
+   - i Id:64 M:16 Module B:32 Beam [Bound]
+                                       start Module's query from Beam
    - f Id:64 Limit:32                  the next batch of it         -> b | e
    - c Id:64                           forget it
    The node asks RNT:
    - D Path Evaluator:16 Source        define a program at Path     -> o | e
-   - X Path                            invoke the program at Path   -> r Id:64 | e
+   - X Path [Bound]                    invoke what is at Path       -> r Id:64 | e
    - E Evaluator:16 Source             invoke a program of no path  -> r Id:64 | e
    - N Id:64 Limit:32                  the next batch of its result -> b | e
    - C Id:64                           release that result
    A Path is Count:16 then each segment as Length:16 Segment, and a
-   batch b is Exhausted:8 then each tuple as Size:32 term_to_binary. *)
+   batch b is Exhausted:8 then each tuple as Size:32 term_to_binary.
+   Bound, when present, is the tuple of the attributes the caller
+   already knows as term_to_binary, which is how a procedural program,
+   one that can only check what it is given, gets called. *)
 module Make (T : TRANSPORT) = struct
   (* [root] is borrowed, not held: the evaluator lives under it, so
      holding it would keep both alive forever. [cursors] are the
@@ -132,7 +135,7 @@ module Make (T : TRANSPORT) = struct
   module Request = struct
     type t =
       | Define of string list * string * string
-      | Invoke of string list
+      | Invoke of string list * Concepts.Tuple.t option
       | Evaluate of string * string
       | Next of int * int
       | Close of int
@@ -165,7 +168,13 @@ module Make (T : TRANSPORT) = struct
       | 'E' ->
           let evaluator = sized () in
           Some (Evaluate (evaluator, String.sub message !at (length - !at)))
-      | 'X' -> finished (Invoke (path ()))
+      | 'X' -> (
+          let path = path () in
+          if !at = length then Some (Invoke (path, None))
+          else
+            match Translator.decode (String.sub message !at (length - !at)) with
+            | Ok bound -> Some (Invoke (path, Some bound))
+            | Error _ -> None )
       | 'N' ->
           let id = u64 () in
           finished (Next (id, u32 ()))
@@ -216,14 +225,17 @@ module Make (T : TRANSPORT) = struct
             Error (Error.program_taken (Kernel.Path.of_list path))
         | Error c -> Protocols.Handle.release program; Error c )
 
-  (* Runs [program], which it releases, keeping a cursor on the result
-     for the node to read. *)
-  let invoke node program =
+  (* Runs [target], which it releases, keeping a cursor on the result
+     for the node to read: a program's result given [inputs], or the
+     relation itself when [target] is not a program. *)
+  let invoke node ?(inputs = []) target =
     let open Utilities.Result in
     let* relation =
-      Protocols.Handle.releasing program (fun () ->
-          let* executable = Protocols.Executable.require program in
-          Protocols.Executable.invoke executable [] ~within:node.root )
+      match Protocols.Executable.from target with
+      | None -> Ok target
+      | Some executable ->
+          Protocols.Handle.releasing target (fun () ->
+              Protocols.Executable.invoke executable inputs ~within:node.root )
     in
     match Protocols.Enumerable.cursor relation with
     | Error c -> Protocols.Handle.release relation; Error c
@@ -243,6 +255,19 @@ module Make (T : TRANSPORT) = struct
     if batch.exhausted then forget node id;
     Ok (batch_message batch)
 
+  (* What a caller already knows, as the one-tuple relation a program
+     is invoked with. *)
+  let literal ({Concepts.Tuple.attributes; _} as tuple) =
+    let domain = function
+      | Concepts.Value.String _ -> "string"
+      | Concepts.Value.Integer _ -> "integer"
+    in
+    Kernel.EphemeralRelation.literal
+      (BatMap.String.map
+         (fun value -> {Protocols.Schematics.domain= domain value; provenance= []})
+         attributes )
+      [tuple]
+
   let serve node request =
     let answer = function
       | Ok message -> T.send node.transport message
@@ -250,8 +275,15 @@ module Make (T : TRANSPORT) = struct
     in
     match request with
     | Request.Define (path, evaluator, source) -> answer (define node path evaluator source)
-    | Request.Invoke path ->
-        answer (Result.bind (Kernel.Path.lookup node.root (Kernel.Path.of_list path)) (invoke node))
+    | Request.Invoke (path, bound) ->
+        let inputs = Option.to_list (Option.map literal bound) in
+        let result =
+          Result.bind
+            (Kernel.Path.lookup node.root (Kernel.Path.of_list path))
+            (invoke node ~inputs)
+        in
+        List.iter Protocols.Handle.release inputs;
+        answer result
     | Request.Evaluate (evaluator, source) ->
         answer (Result.bind (Kernel.Program.load node.root ~evaluator ~source) (invoke node))
     | Request.Next (id, limit) -> answer (fetch node id limit)
@@ -291,7 +323,7 @@ module Make (T : TRANSPORT) = struct
           let* () = serve node request in
           await node )
 
-  (* Lets the node's rnt_init/0 functions define their programs. *)
+  (* Lets the node's rnt-init closures define their programs. *)
   let handshake node =
     let open Utilities.Result in
     let* () = T.send node.transport "h" in
@@ -299,17 +331,15 @@ module Make (T : TRANSPORT) = struct
     match reply with `Done -> Ok () | `Batch _ -> Error (Error.unexpected ())
 
   module Poll = struct
-    let invoke_message id {module_; function_; beam; _} =
+    let invoke_message id {module_; beam; _} bound =
       let buffer = Buffer.create (64 + String.length beam) in
       Buffer.add_char buffer 'i';
       Buffer.add_int64_be buffer (Int64.of_int id);
-      List.iter
-        (fun name ->
-          Buffer.add_uint16_be buffer (String.length name);
-          Buffer.add_string buffer name )
-        [module_; function_];
+      Buffer.add_uint16_be buffer (String.length module_);
+      Buffer.add_string buffer module_;
       Buffer.add_int32_be buffer (Int32.of_int (String.length beam));
       Buffer.add_string buffer beam;
+      Option.iter (fun tuple -> Buffer.add_string buffer (Translator.encode tuple)) bound;
       Buffer.contents buffer
 
     let fetch_message id limit =
@@ -341,12 +371,25 @@ module Make (T : TRANSPORT) = struct
         method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self]
       end
 
-    let start node program =
+    let start node program bound =
       let poll = new t node in
-      T.send node.transport (invoke_message (Oo.id poll) program)
+      T.send node.transport (invoke_message (Oo.id poll) program bound)
       |> Result.map (fun () -> Protocols.Handle.make poll)
   end
 
+  (* The tuple a program is invoked with, if any: what its caller
+     already knows. It is read now, so the input is only borrowed. *)
+  let bound = function
+    | [] -> Ok None
+    | [input] -> (
+        let open Utilities.Result in
+        let* _, tuples = Protocols.Relation.read input in
+        match tuples with
+        | [] -> Ok None
+        | [tuple] -> Ok (Some tuple)
+        | _ -> Error (Error.inputs ()) )
+    | _ -> Error (Error.inputs ())
+
   class evaluator node =
     object (self)
       inherit Kernel.Lifecycle.counted
@@ -365,14 +408,15 @@ module Make (T : TRANSPORT) = struct
           within:Protocols.Handle.t ->
           (Protocols.Handle.t, Concepts.Condition.condition) result =
         fun kind inputs ~within:_ ->
-          match kind, inputs with
-          | Beam program, [] ->
-              Ok
-                (Kernel.EphemeralRelation.instantiate program.heading
-                   ~modes:(fun () -> Ok [Concepts.Mode.mode [] Concepts.Cardinality.Countable])
-                   (Kernel.EphemeralRelation.temporary program.heading)
-                   (fun () -> Poll.start node program) )
-          | Beam _, _ -> Error (Error.inputs ())
+          match kind with
+          | Beam program ->
+              Result.map
+                (fun bound ->
+                  Kernel.EphemeralRelation.instantiate program.heading
+                    ~modes:(fun () -> Ok [Concepts.Mode.mode [] Concepts.Cardinality.Countable])
+                    (Kernel.EphemeralRelation.temporary program.heading)
+                    (fun () -> Poll.start node program bound) )
+                (bound inputs)
           | _ -> Error (Error.not_a_program ())
 
       method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self]
diff --git a/tools/driver/main.ml b/tools/driver/main.ml
index 662032c..d22baf0 100644
--- a/tools/driver/main.ml
+++ b/tools/driver/main.ml
@@ -1,5 +1,5 @@
 (* Boots a BEAM node on a directory of .beam images (Karuta's runtime
-   plus compiled modules), lets their rnt_init/0 register programs, and
+   plus compiled modules), lets their rnt-init closures register programs, and
    reads them back through the kernel.
 
    dune exec ./tools/driver/main.exe -- <image directory> *)
@@ -20,8 +20,8 @@ let mount_fol root =
   let* _ = Kernel.Path.update root Kernel.Path.this "system" None (Some system) in
   Ok ()
 
-(* {Module, Function, Beam, #{Attribute => <<"string">>}} as term_to_binary. *)
-let image directory module_ function_ heading =
+(* {Module, Beam, #{Attribute => <<"string">>}} as term_to_binary. *)
+let image directory module_ heading =
   let beam =
     In_channel.with_open_bin (Filename.concat directory (module_ ^ ".beam")) In_channel.input_all
   in
@@ -31,8 +31,8 @@ let image directory module_ function_ heading =
     Buffer.add_int32_be buffer (Int32.of_int (String.length s));
     Buffer.add_string buffer s
   in
-  List.iter (Buffer.add_uint8 buffer) [131; 104; 4];
-  List.iter binary [module_; function_; beam];
+  List.iter (Buffer.add_uint8 buffer) [131; 104; 3];
+  List.iter binary [module_; beam];
   Buffer.add_uint8 buffer 116;
   Buffer.add_int32_be buffer (Int32.of_int (List.length heading));
   List.iter (fun name -> binary name; binary "string") heading;
@@ -53,7 +53,7 @@ let print title relation =
 
 let run directory root =
   let* () = mount_fol root in
-  (* Boots erl on the images; the handshake runs every rnt_init/0. *)
+  (* Boots erl on the images; the handshake runs every rnt-init. *)
   let* () = Beam.register root [directory] in
   let* listing = Kernel.Path.lookup root program in
   let* names =
@@ -74,14 +74,14 @@ let run directory root =
   (* 2. A beam program that itself issues a FOL plan back to RNT. *)
   let* titles =
     Kernel.Program.load root ~evaluator:"karuta:beam"
-      ~source:(image directory "librarian" "titles" ["title"])
+      ~source:(image directory "librarian" ["title"])
   in
   let* relation =
     Protocols.Handle.releasing titles (fun () ->
         let* executable = Protocols.Executable.require titles in
         Protocols.Executable.invoke executable [] ~within:root )
   in
-  print "librarian:titles (BEAM -> RNT fol -> BEAM main):" relation
+  print "librarian's query (BEAM -> RNT fol -> BEAM main):" relation
 
 let () =
   Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
diff --git a/tools/run/dune b/tools/run/dune
new file mode 100644
index 0000000..429a4fc
--- /dev/null
+++ b/tools/run/dune
@@ -0,0 +1,3 @@
+(executable
+ (name main)
+ (libraries rnt subsystem batteries unix))
diff --git a/tools/run/main.ml b/tools/run/main.ml
new file mode 100644
index 0000000..d4bbf56
--- /dev/null
+++ b/tools/run/main.ml
@@ -0,0 +1,65 @@
+(* Boots a BEAM node on a directory of images and prints the programs
+   named on the command line, read from \karuta\program.
+
+   dune exec ./tools/run/main.exe -- <image directory> <program>... *)
+
+open Rnt
+module Beam = Subsystem.Karuta.Beam
+
+let ( let* ) = Result.bind
+
+let mount_fol root =
+  let evaluators = Kernel.Namespace.make () and system = Kernel.Namespace.make () in
+  let* _ =
+    Kernel.Path.update evaluators Kernel.Path.this "fol" None (Some (Evaluators.FOL.make ()))
+  in
+  let* _ = Kernel.Path.update system Kernel.Path.this "evaluator" None (Some evaluators) in
+  let* _ = Kernel.Path.update root Kernel.Path.this "system" None (Some system) in
+  Ok ()
+
+(* Where calendar.skr's persisted predicates live, made of plain
+   namespaces since this kernel has no branches. *)
+let rec directories root prefix = function
+  | [] -> Ok ()
+  | segment :: rest ->
+      let* _ =
+        Kernel.Path.update root (Kernel.Path.of_list prefix) segment None
+          (Some (Kernel.Namespace.make ()))
+      in
+      directories root (prefix @ [segment]) rest
+
+let show root name =
+  let* handle = Kernel.Path.lookup root Kernel.Path.("karuta" @/ "program" @/ name @/ this) in
+  let* relation =
+    Protocols.Handle.releasing handle (fun () ->
+        let* executable = Protocols.Executable.require handle in
+        Protocols.Executable.invoke executable [] ~within:root )
+  in
+  Protocols.Handle.releasing relation (fun () ->
+      let* _, tuples = Protocols.Relation.read relation in
+      Printf.printf "\\karuta\\program\\%s:\n" name;
+      List.iter
+        (fun {Concepts.Tuple.type_; attributes} ->
+          Printf.printf "  %s {%s}\n" type_
+            ( BatMap.String.bindings attributes
+            |> List.map (fun (k, v) -> k ^ " = " ^ Concepts.Value.to_string v)
+            |> String.concat ", " ) )
+        tuples;
+      Ok () )
+
+let run directory names root =
+  let* () = mount_fol root in
+  let* () =
+    directories root ["system"]
+      ["branch"; "master"; "multigroup"; "calendar"; "schema"; "public"; "relation"]
+  in
+  let* () = Beam.register root [directory] in
+  List.fold_left (fun acc name -> let* () = acc in show root name) (Ok ()) names
+
+let () =
+  Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
+  let root = Kernel.Namespace.make () in
+  let names = Array.to_list (Array.sub Sys.argv 2 (Array.length Sys.argv - 2)) in
+  match Protocols.Handle.releasing root (fun () -> run Sys.argv.(1) names root) with
+  | Ok () -> ()
+  | Error c -> prerr_endline (Concepts.Condition.to_string_hum c); exit 1