driver due to the lack of an init system for headless runkaruta-subsystem

1 files changed, 94 insertions, 0 deletions

diff --git a/tools/driver/main.ml b/tools/driver/main.ml
new file mode 100644
index 0000000..662032c
--- /dev/null
+++ b/tools/driver/main.ml
@@ -0,0 +1,94 @@
+(* Boots a BEAM node on a directory of .beam images (Karuta's runtime
+   plus compiled modules), lets their rnt_init/0 register programs, and
+   reads them back through the kernel.
+
+   dune exec ./tools/driver/main.exe -- <image directory> *)
+
+open Rnt
+module Beam = Subsystem.Karuta.Beam
+
+let ( let* ) = Result.bind
+let program = Kernel.Path.("karuta" @/ "program" @/ this)
+
+(* \system\evaluator\fol, so programs can name the "fol" evaluator. *)
+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 ()
+
+(* {Module, Function, Beam, #{Attribute => <<"string">>}} as term_to_binary. *)
+let image directory module_ function_ heading =
+  let beam =
+    In_channel.with_open_bin (Filename.concat directory (module_ ^ ".beam")) In_channel.input_all
+  in
+  let buffer = Buffer.create 64 in
+  let binary s =
+    Buffer.add_uint8 buffer 109;
+    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];
+  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;
+  Buffer.contents buffer
+
+let print title relation =
+  Protocols.Handle.releasing relation (fun () ->
+      let* _, tuples = Protocols.Relation.read relation in
+      Printf.printf "%s\n" title;
+      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 root =
+  let* () = mount_fol root in
+  (* Boots erl on the images; the handshake runs every rnt_init/0. *)
+  let* () = Beam.register root [directory] in
+  let* listing = Kernel.Path.lookup root program in
+  let* names =
+    Protocols.Handle.releasing listing (fun () ->
+        Result.bind
+          (Protocols.Handle.require Protocols.Directory.from listing)
+          Protocols.Directory.list )
+  in
+  Printf.printf "\\karuta\\program holds: %s\n" (String.concat ", " (BatFingerTree.to_list names));
+  (* 1. The FOL program librarian defined from inside the node. *)
+  let* authors = Kernel.Path.lookup root Kernel.Path.("karuta" @/ "program" @/ "authors" @/ this) in
+  let* relation =
+    Protocols.Handle.releasing authors (fun () ->
+        let* executable = Protocols.Executable.require authors in
+        Protocols.Executable.invoke executable [] ~within:root )
+  in
+  let* () = print "FOL \\karuta\\program\\authors (project author over main):" relation in
+  (* 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"])
+  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
+
+let () =
+  Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
+  let root = Kernel.Namespace.make () in
+  let outcome = Protocols.Handle.releasing root (fun () -> run Sys.argv.(1) root) in
+  match outcome with
+  | Ok () -> ()
+  | Error c ->
+      prerr_endline (Concepts.Condition.to_string_hum c);
+      exit 1