path: root/test/integration/Karuta.ml

open Alcotest
open Rnt
module Beam = Subsystem.Karuta.Beam

let fixtures = "integration/beam"

(* rnt and shelf boot with the node; library is only ever loaded from
   the images that carry it. *)
let booted = ["rnt"; "shelf"]
let carried = ["library"]

type node = {root: Protocols.Handle.t; image: string -> string}

let term image module_ function_ heading =
  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
  Buffer.add_uint8 buffer 131;
  Buffer.add_uint8 buffer 104;
  Buffer.add_uint8 buffer 4;
  binary module_;
  binary function_;
  binary (image module_);
  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

(* \system\evaluator\fol, so the node can define FOL programs. *)
let mount_fol root =
  let open Utilities.Result in
  let evaluators = Kernel.Namespace.make () in
  let 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 ()

let with_node test () =
  if Sys.command "command -v erl > /dev/null 2>&1 && command -v erlc > /dev/null 2>&1" <> 0 then
    skip ();
  Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
  Helpers.with_temporary_directory "beam" (fun directory ->
      let boot = Filename.concat directory "boot" and images = Filename.concat directory "images" in
      let compile into modules =
        Unix.mkdir into 0o755;
        let sources = List.map (fun m -> Filename.concat fixtures (m ^ ".erl")) modules in
        if Sys.command (Filename.quote_command "erlc" (["-o"; into] @ sources)) <> 0 then
          fail "the fixtures did not compile"
      in
      compile boot booted;
      compile images carried;
      let image module_ =
        let at = if List.mem module_ booted then boot else images in
        In_channel.with_open_bin (Filename.concat at (module_ ^ ".beam")) In_channel.input_all
      in
      let root = Kernel.Namespace.make () in
      Fun.protect
        ~finally:(fun () -> Protocols.Handle.release root)
        (fun () ->
          Helpers.condition_as_failure (mount_fol root);
          Helpers.condition_as_failure (Beam.register root [boot]);
          test {root; image} ) )

let run {root; image} module_ function_ heading =
  let open Utilities.Result in
  let* program =
    Kernel.Program.load root ~evaluator:"karuta:beam" ~source:(term image module_ function_ heading)
  in
  let* executable = Protocols.Executable.require program in
  Protocols.Executable.invoke executable [] ~within:root

let titles batch =
  BatFingerTree.to_list batch.Protocols.Cursor.tuples
  |> List.map (fun {Concepts.Tuple.attributes; _} ->
      Concepts.Value.to_string (BatMap.String.find "title" attributes) )

let reads_in_batches node =
  let batches =
    begin
      let open Utilities.Result in
      let* relation = run node "library" "books" ["title"; "author"] in
      Protocols.Handle.releasing relation (fun () ->
          let* heading = Protocols.Relation.heading relation in
          check (list string) "the heading the term declares" ["author"; "title"]
            (BatMap.String.bindings heading |> List.map fst);
          Protocols.Enumerable.scan relation (fun scan ->
              let rec pull read =
                let* batch = Protocols.Cursor.fetch scan 4 in
                let read = (titles batch, batch.exhausted) :: read in
                if batch.exhausted then Ok (List.rev read) else pull read
              in
              pull [] ) )
    end
    |> Helpers.condition_as_failure
  in
  check
    (list (pair (list string) bool))
    "four, then the rest"
    [ ( [ "Structure and Interpretation of Computer Programs";
          "The Art of Computer Programming";
          "An Introduction to Database Systems";
          "Less Than Words Can Say" ],
        false );
      ["The Graves of Academe"; "The Leaning Tower of Babel"; "The Gift of Fire"], true ]
    batches

let reads_back_through_the_kernel ({root; image} as node) =
  begin
    let open Utilities.Result in
    let* books =
      Kernel.Program.load root ~evaluator:"karuta:beam"
        ~source:(term image "library" "books" ["title"; "author"])
    in
    let* bound =
      Kernel.Path.update root Kernel.Path.("karuta" @/ "program" @/ this) "books" None (Some books)
    in
    check bool "the books are defined beside what the node defined" true bound;
    let* relation = run node "shelf" "titles" ["title"] in
    Protocols.Handle.releasing relation (fun () -> Helpers.titles relation)
  end
  |> Helpers.condition_as_failure
  |> check (list Helpers.value) "the node read its FOL program over the books"
       (List.map
          (fun title -> Concepts.Value.String title)
          [ "An Introduction to Database Systems";
            "Less Than Words Can Say";
            "Structure and Interpretation of Computer Programs";
            "The Art of Computer Programming";
            "The Gift of Fire";
            "The Graves of Academe";
            "The Leaning Tower of Babel" ] )

let reads_a_program_of_no_path ({root; image} as node) =
  begin
    let open Utilities.Result in
    let* books =
      Kernel.Program.load root ~evaluator:"karuta:beam"
        ~source:(term image "library" "books" ["title"; "author"])
    in
    let* _ =
      Kernel.Path.update root Kernel.Path.("karuta" @/ "program" @/ this) "books" None (Some books)
    in
    let* relation = run node "shelf" "authors" ["author"] in
    Protocols.Handle.releasing relation (fun () -> Protocols.Relation.read relation)
  end
  |> Helpers.condition_as_failure
  |> snd
  |> List.map (fun {Concepts.Tuple.attributes; _} -> BatMap.String.find "author" attributes)
  |> List.sort compare
  |> check (list Helpers.value) "each author once"
       (List.map
          (fun author -> Concepts.Value.String author)
          ["C. J. Date"; "Donald Knuth"; "Harold Abelson"; "Richard Mitchell"] )

let a_missing_function_fails node =
  Helpers.refuses "a missing function fails the call" "beam-failed"
    (Result.bind (run node "library" "nope" ["title"]) (fun relation ->
         Protocols.Handle.releasing relation (fun () -> Protocols.Relation.read relation) ) )

let a_malformed_term_is_refused {root; _} =
  Helpers.refuses "a term that is not a program is refused" "malformed-beam-program"
    (Kernel.Program.load root ~evaluator:"karuta:beam" ~source:"not a term")

let suites () =
  [ ( "integration/karuta",
      [ test_case "reads-in-batches" `Quick (with_node reads_in_batches);
        test_case "reads-back-through-the-kernel" `Quick (with_node reads_back_through_the_kernel);
        test_case "reads-a-program-of-no-path" `Quick (with_node reads_a_program_of_no_path);
        test_case "a-missing-function-fails" `Quick (with_node a_missing_function_fails);
        test_case "a-malformed-term-is-refused" `Quick (with_node a_malformed_term_is_refused) ] )
  ]