bound queries from sakurasakura-karuta-contract

1 files changed, 83 insertions, 39 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]