path: root/tools/driver/main.ml

(* 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