builder-web/test/router.ml

module Param_verification = struct

  (*> None is 'verified'*)
  type t = wrong_type option 
  [@@deriving yojson,show,eq]

  and wrong_type = {
    param : string;
    expected : string;
  }

  let alcotyp = Alcotest.testable pp equal

  module P = struct

    let is_string : (string * string) -> _ option  =
      Fun.const None

    let is_uuid (param, value) =
      match Uuidm.of_string value with
      | Some _ when String.length value = 36 -> None
      | _ -> Some {
          param;
          expected = "Uuidm.t"
        }
    
  end
  
  let verify parameters req =
    let verified_params =
      List.fold_left (fun acc p ->
        match acc with
        | None ->
          if String.starts_with ~prefix:"build" p then
           P.is_uuid (p, Dream.param req p)
          else
            P.is_string (p, Dream.param req p)
        | Some _ as x -> x)
      None parameters
    in
    let response_json =
      verified_params |> to_yojson |> Yojson.Safe.to_string
    in
    Dream.respond response_json

end

let find_parameters path =
  List.filter_map (fun s ->
      if String.length s > 0 && String.get s 0 = ':' then
        Some (String.sub s 1 (String.length s - 1))
      else
        None)
    (String.split_on_char '/' path)
                   
let router =
  (* XXX: this relies on [Builder_web.routes] only using {data,cache,config}dir
   * in the handlers which are never called here. The path /nonexistant is
   * assumed to not exist. *)
  let nodir = Fpath.v "/nonexistant" in
  Builder_web.routes ~datadir:nodir ~cachedir:nodir ~configdir:nodir
  |> List.map (fun (meth, route, _handler) ->
      meth, route, Param_verification.verify (find_parameters route))
  |> Builder_web.to_dream_routes
  |> Dream.router
  (* XXX: we test without remove_trailing_url_slash to ensure we don't produce
   * urls with trailing slashes: *)
  (* |> Builder_web.Middleware.remove_trailing_url_slash *)
  |> Dream.test

let test_link method_ target () =
  let req = Dream.request ~method_ ~target "" in
  let resp = router req in
  let status_code = Dream.(status resp |> status_to_int) in
  Alcotest.(check' int ~msg:"status-code" ~actual:status_code ~expected:200);
  let body =
    Dream.body resp
    |> Lwt_main.run
    |> Yojson.Safe.from_string
    |> Param_verification.of_yojson
  in
  Alcotest.(check' (result Param_verification.alcotyp string) ~msg:"param-verification"
              ~actual:body ~expected:(Ok None))

let test_link_artifact artifact = 
  let job_name = "test" in
  let build = Uuidm.v `V4 in
  test_link `GET @@
  Builder_web.Link.Job_build_artifact.make ~job_name ~build ~artifact ()

let () =
  Alcotest.run "Router" [
    "Link module synced", Alcotest.[
        test_case "Link.Root.make" `Quick begin
          test_link `GET @@ Builder_web.Link.Root.make ()
        end;
        test_case "Link.Job.make" `Quick begin
          let queries = [ `Platform "test" ] in
          let job_name = "test" in
          test_link `GET @@ Builder_web.Link.Job.make ~queries ~job_name ()
        end;
        test_case "Link.Job.make_failed" `Quick begin
          let queries = [ `Platform "test" ] in
          let job_name = "test" in
          test_link `GET @@
          Builder_web.Link.Job.make_failed ~queries ~job_name ()
        end;
        test_case "Link.Job_build.make" `Quick begin
          let job_name = "test" in
          let build = Uuidm.v `V4 in
          test_link `GET @@ Builder_web.Link.Job_build.make ~job_name ~build ()
        end;
        test_case "Link.Job_build_artifact.make_from_string" `Quick begin
          let job_name = "test" in
          let build = Uuidm.v `V4 in
          let artifact = "" in
          test_link `GET @@
          Builder_web.Link.Job_build_artifact.make_from_string
            ~job_name ~build ~artifact ()
        end;
      ] @ Alcotest.(
        [
          `Main_binary;
          `Viz_treemap;
          `Viz_dependencies;
          `Script;
          `Console;
          `All_targz;
          `File Fpath.(v "some" / "path");
        ]
        |> List.map (fun artifact ->
            let descr =
              Fmt.str "Job_build_artifact.make: %s" @@
              Builder_web.Link.Job_build_artifact.encode_artifact artifact
            in
            test_case descr `Quick begin
              test_link_artifact artifact
            end
          )
      ) @ Alcotest.[
        test_case "Link.Compare_builds.make" `Quick begin
          let left = Uuidm.v `V4 in
          let right = Uuidm.v `V4 in
          test_link `GET @@
          Builder_web.Link.Compare_builds.make ~left ~right ()
        end;
        test_case "Link.Failed_builds.make" `Quick begin
          test_link `GET @@
          Builder_web.Link.Failed_builds.make ~count:2 ~start:1 () 
        end;
      ];
    (* this doesn't actually test the redirects, unfortunately *)
    "Latest", List.map (fun p -> Alcotest.(test_case ("…"^p) `Quick begin
        test_link `GET @@ "/job/test/build/latest" ^ p end))
      [
        "/f/bin/unikernel.hvt";
        "/";
        "";
      ];
    "Albatross hardcoded links",
    [
      (*> Note: these links can be found in
          albatross/command-line/albatross_client_update.ml
          .. to find them I follewed the trails of 'Albatross_cli.http_host'
      *)
      begin
        let `Hex sha_str =
          Cstruct.of_string "foo"
          |> Mirage_crypto.Hash.SHA256.digest
          |> Hex.of_cstruct
        in
        Fmt.str "/hash?sha256=%s" sha_str
      end;
      begin
        let jobname = "foo" in
        "/job/" ^ jobname ^ "/build/latest"
      end;
      begin
        let job = "foo" in
        let build = Uuidm.(v `V4 |> to_string) in
        "/job/" ^ job ^ "/build/" ^ build ^ "/main-binary"
      end;
      begin
        let old_uuid = Uuidm.(v `V4 |> to_string) in
        let new_uuid = Uuidm.(v `V4 |> to_string) in
        Fmt.str "/compare/%s/%s" old_uuid new_uuid
      end;
    ]
    |> List.map Alcotest.(fun p ->
        test_case ("…" ^ p) `Quick (test_link `GET p))
  ]