robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request 'Tests for router and safe links' (#122) from 20220621_tests_for_router into main

Browse source 
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/122
This commit is contained in:
Reynir Björnsson 2022-07-12 11:20:01 +00:00
commit 35fa4cd0f1
7 changed files with 408 additions and 114 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
bin/builder_web_app.ml
View file

@ -147,12 +147,17 @@ let setup_app level influx port host datadir cachedir configdir run_batch_viz_fl
| Some App -> None
in
Dream.initialize_log ?level ();
let dream_routes = Builder_web.(
routes ~datadir ~cachedir ~configdir
|> to_dream_routes
)
in
Dream.run ~port ~interface:host ~tls:false
@@ Dream.logger
@@ Dream.sql_pool ("sqlite3:" ^ dbpath)
@@ Http_status_metrics.handle
@@ Builder_web.Middleware.remove_trailing_url_slash
@@ Dream.router (Builder_web.routes ~datadir ~cachedir ~configdir)
@@ Dream.router dream_routes
open Cmdliner

9
builder-web.opam
View file

@ -29,7 +29,6 @@ depends: [
"pbkdf"
"mirage-crypto-rng"
"scrypt-kdf"
"alcotest" {with-test}
"opam-core"
"opam-format" {>= "2.1.0"}
"metrics" {>= "0.3.0"}
@ -51,6 +50,9 @@ depends: [
"owee"
"solo5-elftool" {>= "0.3.0"}
"decompress"
"alcotest" {with-test}
"ppx_deriving" {with-test}
"ppx_deriving_yojson" {with-test}
]
synopsis: "Web interface for builder"
@ -59,8 +61,3 @@ Builder-web takes in submissions of builds, typically from [builder](https://git
Produced binaries can be downloaded and executed.
[builds.robur.coop](https://builds.robur.coop/) itself runs builder-web.
"""
pin-depends: [
["modulectomy.dev" "git+https://github.com/roburio/modulectomy.git"]
["opam-graph.dev" "git+https://git.robur.io/robur/opam-graph.git"]
]

87
lib/builder_web.ml
View file

@ -302,28 +302,43 @@ let routes ~datadir ~cachedir ~configdir =
|> string_of_html |> Dream.html |> Lwt_result.ok
in
let redirect_latest req =
let job_name = Dream.param req "job" in
let platform = Dream.query req "platform" in
(* FIXME *)
let path = begin[@alert "-deprecated"] Dream.path req |> String.concat "/" end in
let redirect_latest req ~job_name ~platform ~artifact =
(Dream.sql req (Model.job_id job_name) >>= Model.not_found >>= fun job_id ->
Dream.sql req (Model.latest_successful_build_uuid job_id platform))
>>= Model.not_found
|> if_error "Error getting job" >>= fun build ->
Dream.redirect req
(Fmt.str "/job/%s/build/%a/%s" job_name Uuidm.pp build path)
(Link.Job_build_artifact.make_from_string ~job_name ~build ~artifact ())
|> Lwt_result.ok
in
let redirect_latest req =
let job_name = Dream.param req "job" in
let platform = Dream.query req "platform" in
let artifact =
(* FIXME Dream.path deprecated *)
let path = begin[@alert "-deprecated"] Dream.path req end in
if path = [] then
"" (* redirect without trailing slash *)
else
"/" ^ (List.map Uri.pct_encode path |> String.concat "/")
in
redirect_latest req ~job_name ~platform ~artifact
and redirect_latest_no_slash req =
let job_name = Dream.param req "job" in
let platform = Dream.query req "platform" in
redirect_latest req ~job_name ~platform ~artifact:""
in
let redirect_main_binary req =
let job_name = Dream.param req "job"
and build = Dream.param req "build" in
get_uuid build >>= fun uuid ->
Dream.sql req (main_binary_of_uuid uuid) >>= fun main_binary ->
Dream.redirect req
(Fmt.str "/job/%s/build/%a/f/%a" job_name Uuidm.pp uuid
Fpath.pp main_binary.Builder_db.filepath)
let artifact = `File main_binary.Builder_db.filepath in
Link.Job_build_artifact.make ~job_name ~build:uuid ~artifact ()
|> Dream.redirect req
|> Lwt_result.ok
in
@ -360,7 +375,7 @@ let routes ~datadir ~cachedir ~configdir =
>>= fun (build, main_binary, artifacts, same_input_same_output, different_input_same_output, same_input_different_output, latest, next, previous) ->
let solo5_manifest = Option.bind main_binary (Model.solo5_manifest datadir) in
Views.Job_build.make
~name:job_name
~job_name
~build
~artifacts
~main_binary
@ -488,7 +503,7 @@ let routes ~datadir ~cachedir ~configdir =
Dream.sql req (Model.build_hash hash) >>= Model.not_found
|> if_error "Internal server error" >>= fun (job_name, build) ->
Dream.redirect req
(Fmt.str "/job/%s/build/%a" job_name Uuidm.pp build.Builder_db.Build.uuid)
(Link.Job_build.make ~job_name ~build:build.Builder_db.Build.uuid ())
|> Lwt_result.ok
in
@ -591,29 +606,37 @@ let routes ~datadir ~cachedir ~configdir =
let w f req = or_error_response (f req) in
[
Dream.get "/" (w builds);
Dream.get "/job" (w redirect_parent);
Dream.get "/job/:job" (w job);
Dream.get "/job/:job/build" (w redirect_parent);
Dream.get "/job/:job/failed" (w job_with_failed);
Dream.get "/job/:job/build/latest/**" (w redirect_latest);
Dream.get "/job/:job/build/:build" (w job_build);
Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
Dream.get "/job/:job/build/:build/main-binary" (w redirect_main_binary);
Dream.get "/job/:job/build/:build/viztreemap" (w @@ job_build_viz `Treemap);
Dream.get "/job/:job/build/:build/vizdependencies" (w @@ job_build_viz `Dependencies);
Dream.get "/job/:job/build/:build/script" (w (job_build_static_file `Script));
Dream.get "/job/:job/build/:build/console" (w (job_build_static_file `Console));
Dream.get "/failed-builds" (w failed_builds);
Dream.get "/job/:job/build/:build/all.tar.gz" (w job_build_targz);
Dream.get "/hash" (w hash);
Dream.get "/compare/:build_left/:build_right" (w compare_builds);
Dream.post "/upload" (Authorization.authenticate (w upload));
Dream.post "/job/:job/platform/:platform/upload" (Authorization.authenticate (w upload_binary));
`Get, "/", (w builds);
`Get, "/job", (w redirect_parent);
`Get, "/job/:job", (w job);
`Get, "/job/:job/build", (w redirect_parent);
`Get, "/job/:job/failed", (w job_with_failed);
`Get, "/job/:job/build/latest/**", (w redirect_latest);
`Get, "/job/:job/build/latest", (w redirect_latest_no_slash);
`Get, "/job/:job/build/:build", (w job_build);
`Get, "/job/:job/build/:build/f/**", (w job_build_file);
`Get, "/job/:job/build/:build/main-binary", (w redirect_main_binary);
`Get, "/job/:job/build/:build/viztreemap", (w @@ job_build_viz `Treemap);
`Get, "/job/:job/build/:build/vizdependencies", (w @@ job_build_viz `Dependencies);
`Get, "/job/:job/build/:build/script", (w (job_build_static_file `Script));
`Get, "/job/:job/build/:build/console", (w (job_build_static_file `Console));
`Get, "/failed-builds", (w failed_builds);
`Get, "/job/:job/build/:build/all.tar.gz", (w job_build_targz);
`Get, "/hash", (w hash);
`Get, "/compare/:build_left/:build_right", (w compare_builds);
`Post, "/upload", (Authorization.authenticate (w upload));
`Post, "/job/:job/platform/:platform/upload", (Authorization.authenticate (w upload_binary));
]
let to_dream_route = function
| `Get, path, handler -> Dream.get path handler
| `Post, path, handler -> Dream.post path handler
let to_dream_routes l = List.map to_dream_route l
let routeprefix_ignorelist_when_removing_trailing_slash = [
"/job/:job/build/:build/f"
"/job/:job/build/:build/f";
"/job/:job/build/latest";
]
module Middleware = struct
@ -638,3 +661,5 @@ module Middleware = struct
| _ (* /... *) -> handler req
end
module Link = Link

89
lib/link.ml Normal file
View file

@ -0,0 +1,89 @@
let fpath_url_pp ppf f =
Fpath.segs f
|> List.map Uri.pct_encode
|> Fmt.(list ~sep:(any "/") string) ppf
module Queries_aux = struct
let flatten = Option.value ~default:[]
let add_raw url_str queries =
let uri = Uri.of_string url_str in
let uri = Uri.add_query_params uri queries in
Uri.to_string uri
let add ~encode_query queries url_str =
queries |> flatten |> List.map encode_query |> add_raw url_str
end
let pctencode fmt str = Format.fprintf fmt "%s" (Uri.pct_encode str)
module Root = struct
let make () = "/"
end
module Job = struct
let encode_query = function
| `Platform p -> "platform", [ p ]
let make ?queries ~job_name () =
Fmt.str "/job/%a" pctencode job_name
|> Queries_aux.add ~encode_query queries
let make_failed ?queries ~job_name () =
Fmt.str "/job/%a/failed" pctencode job_name
|> Queries_aux.add ~encode_query queries
end
module Job_build = struct
let make ~job_name ~build () =
Fmt.str "/job/%a/build/%a"
pctencode job_name
Uuidm.pp build
end
module Job_build_artifact = struct
let encode_artifact = function
| `Main_binary -> "/main-binary"
| `Viz_treemap -> "/viztreemap"
| `Viz_dependencies -> "/vizdependencies"
| `Script -> "/script"
| `Console -> "/console"
| `All_targz -> "/all.tar.gz"
| `File f -> "/f/" ^ Fmt.to_to_string fpath_url_pp f
let make_from_string ~job_name ~build ~artifact () =
Fmt.str "/job/%a/build/%a%s"
pctencode job_name
Uuidm.pp build
artifact
let make ~job_name ~build ~artifact () =
let artifact = encode_artifact artifact in
make_from_string ~job_name ~build ~artifact ()
end
module Compare_builds = struct
let make ~left ~right () =
Fmt.str "/compare/%a/%a"
Uuidm.pp left
Uuidm.pp right
end
module Failed_builds = struct
let make ~count ~start () =
Fmt.str "/failed-builds?count=%d&start=%d" count start
end

156
lib/views.ml
View file

@ -31,8 +31,6 @@ type nav = [
let pp_platform =
Fmt.(option ~none:(any "") (append (any "on ") string))
let pp_platform_query =
Fmt.(option ~none:(any "") (append (any "?platform=") string))
let static_css = Tyxml.Html.Unsafe.data {|
body {
@ -93,29 +91,28 @@ let make_breadcrumbs nav =
| `Default ->
to_nav [H.txt "Home", "/"]
| `Job (job_name, platform) ->
let queries =
platform |> Option.map (fun v -> `Platform v) |> Option.to_list in
to_nav [
H.txt "Home", "/";
txtf "Job %s" job_name, Fmt.str "/job/%s" job_name ;
txtf "Job %s" job_name, Link.Job.make ~job_name ();
(
txtf "%a" pp_platform platform,
Fmt.str "/job/%s/%a" job_name pp_platform_query platform
Link.Job.make ~job_name ~queries ()
)
]
| `Build (job_name, build) ->
to_nav [
H.txt "Home", "/";
txtf "Job %s" job_name, Fmt.str "/job/%s" job_name;
txtf "Job %s" job_name, Link.Job.make ~job_name ();
(
txtf "%a" pp_platform (Some build.Builder_db.Build.platform),
Fmt.str "/job/%s/%a"
job_name
pp_platform_query (Some build.Builder_db.Build.platform)
Link.Job.make ~job_name
~queries:[ `Platform build.Builder_db.Build.platform ] ()
);
(
txtf "Build %a" pp_ptime build.Builder_db.Build.start,
Fmt.str "/job/%s/build/%a"
job_name
Uuidm.pp build.Builder_db.Build.uuid
Link.Job_build.make ~job_name ~build:build.Builder_db.Build.uuid ()
);
]
| `Comparison ((job_left, build_left), (job_right, build_right)) ->
@ -125,9 +122,9 @@ let make_breadcrumbs nav =
txtf "Comparison between %s@%a and %s@%a"
job_left pp_ptime build_left.Builder_db.Build.start
job_right pp_ptime build_right.Builder_db.Build.start,
Fmt.str "/compare/%a/%a"
Uuidm.pp build_left.uuid
Uuidm.pp build_right.uuid
Link.Compare_builds.make
~left:build_left.uuid
~right:build_right.uuid ()
);
]
@ -194,10 +191,10 @@ let artifact
~file:{ Builder_db.filepath; localpath = _; sha256; size }
=
let artifact_link =
Fmt.str "/job/%s/build/%a/f/%a"
job_name
Uuidm.pp build.Builder_db.Build.uuid
Fpath.pp filepath
Link.Job_build_artifact.make
~job_name
~build:build.Builder_db.Build.uuid
~artifact:(`File filepath) ()
in
[
H.a ~a:H.[a_href artifact_link] [
@ -297,15 +294,15 @@ have questions or suggestions.
check_icon latest_build.Builder_db.Build.result;
H.txt " ";
H.a ~a:[
Fmt.kstr H.a_href "/job/%s/%a"
job_name
pp_platform_query (Some platform)]
H.a_href @@ Link.Job.make ~job_name
~queries:[ `Platform platform ] ()
]
[H.txt platform];
H.txt " ";
H.a ~a:[
Fmt.kstr H.a_href "/job/%s/build/%a/"
job_name
Uuidm.pp latest_build.Builder_db.Build.uuid]
H.a_href @@ Link.Job_build.make
~job_name
~build:latest_build.Builder_db.Build.uuid ()]
[txtf "%a" pp_ptime latest_build.Builder_db.Build.start];
H.txt " ";
]
@ -382,9 +379,9 @@ module Job = struct
check_icon build.Builder_db.Build.result;
txtf " %s " build.platform;
H.a ~a:H.[
Fmt.kstr a_href "/job/%s/build/%a"
job_name
Uuidm.pp build.Builder_db.Build.uuid ]
a_href @@ Link.Job_build.make
~job_name
~build:build.Builder_db.Build.uuid () ]
[
txtf "%a" pp_ptime build.Builder_db.Build.start;
];
@ -407,13 +404,14 @@ module Job = struct
H.h2 ~a:H.[a_id "builds"] [H.txt "Builds"];
H.a ~a:H.[a_href "#readme"] [H.txt "Back to readme"];
H.ul (builds |> List.map (make_build ~job_name));
let queries =
platform |> Option.map (fun p -> `Platform p) |> Option.to_list
in
if failed then
H.p [
H.txt "Excluding failed builds " ;
H.a ~a:H.[
a_href @@ Fmt.str "/job/%s%a"
job_name
pp_platform_query platform
a_href @@ Link.Job.make ~job_name ~queries ()
]
[H.txt "here"] ;
H.txt "." ]
@ -421,9 +419,7 @@ module Job = struct
H.p [
H.txt "Including failed builds " ;
H.a ~a:H.[
a_href @@ Fmt.str "/job/%s/failed%a"
job_name
pp_platform_query platform
a_href @@ Link.Job.make_failed ~job_name ~queries ()
]
[H.txt "here"] ;
H.txt "." ]
@ -480,10 +476,10 @@ module Job_build = struct
let (`Hex sha256_hex) = Hex.of_cstruct file.sha256 in
[
H.dt [
H.a ~a:H.[Fmt.kstr a_href "/job/%s/build/%a/f/%a"
job_name
Uuidm.pp build_uuid
Fpath.pp file.filepath
H.a ~a:H.[a_href @@ Link.Job_build_artifact.make
~job_name
~build:build_uuid
~artifact:(`File file.filepath) ()
]
[H.code [txtf "%a" Fpath.pp file.filepath]] ];
H.dd ([
@ -502,7 +498,7 @@ module Job_build = struct
]
let make_reproductions
~name
~job_name
~(build:Builder_db.Build.t)
~same_input_same_output
~different_input_same_output
@ -511,7 +507,7 @@ module Job_build = struct
List.map (fun (build:Builder_db.Build.t) ->
H.li [
txtf "on %s, same input, " build.platform;
H.a ~a:H.[Fmt.kstr a_href "/job/%s/build/%a" name Uuidm.pp build.uuid]
H.a ~a:H.[a_href @@ Link.Job_build.make ~job_name ~build:build.uuid ()]
[txtf "%a" pp_ptime build.start]
])
same_input_same_output
@ -521,9 +517,9 @@ module Job_build = struct
H.li [
txtf "on %s, different input, " build'.platform;
H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build'.uuid
Uuidm.pp build.uuid]
a_href @@ Link.Compare_builds.make
~left:build'.uuid
~right:build.uuid ()]
[txtf "%a" pp_ptime build'.start]
])
different_input_same_output
@ -551,9 +547,9 @@ module Job_build = struct
H.li [
txtf "on %s, " build'.platform ;
H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build'.uuid
Uuidm.pp build.uuid]
a_href @@ Link.Compare_builds.make
~left:build'.uuid
~right:build.uuid ()]
[txtf "%a" pp_ptime build'.start]
])
same_input_different_output)
@ -572,9 +568,9 @@ module Job_build = struct
| Some b when not (Uuidm.equal build.uuid b.Builder_db.Build.uuid) ->
[ H.li [ H.txt ctx;
H.a ~a:[
Fmt.kstr H.a_href "/compare/%a/%a"
Uuidm.pp b.uuid
Uuidm.pp build.uuid ]
H.a_href @@ Link.Compare_builds.make
~left:b.uuid
~right:build.uuid () ]
[txtf "%a" pp_ptime b.start]]
]
| _ -> []
@ -587,7 +583,7 @@ module Job_build = struct
]
let make_build_info
~name
~job_name
~delta
~(build:Builder_db.Build.t)
~artifacts
@ -607,24 +603,30 @@ module Job_build = struct
H.ul [
H.li [
H.a ~a:H.[
Fmt.kstr a_href "/job/%s/build/%a/console" name Uuidm.pp build.uuid
a_href @@ Link.Job_build_artifact.make
~job_name
~build:build.uuid
~artifact:`Console ()
] [H.txt "Console output"];
];
H.li [
H.a ~a:H.[
Fmt.kstr a_href "/job/%s/build/%a/script" name Uuidm.pp build.uuid
a_href @@ Link.Job_build_artifact.make
~job_name
~build:build.uuid
~artifact:`Script ()
] [H.txt "Build script"];
]
];
]
@ make_artifacts
~job_name:name
~job_name
~build_uuid:build.uuid
~artifacts
~main_binary
~solo5_manifest
@ make_reproductions
~name
~job_name
~build
~same_input_same_output
~different_input_same_output
@ -664,10 +666,11 @@ module Job_build = struct
"
]
let make_viz_section ~name ~artifacts ~uuid =
let make_viz_section ~job_name ~artifacts ~uuid =
let viz_deps =
let iframe =
let src = Fmt.str "/job/%s/build/%a/vizdependencies" name Uuidm.pp uuid in
let src = Link.Job_build_artifact.make ~job_name ~build:uuid
~artifact:`Viz_dependencies () in
H.iframe ~a:H.[
a_src src;
a_title "Opam dependencies";
@ -698,7 +701,8 @@ dependency.\
in
let viz_treemap = lazy (
let iframe =
let src = Fmt.str "/job/%s/build/%a/viztreemap" name Uuidm.pp uuid in
let src = Link.Job_build_artifact.make ~job_name ~build:uuid
~artifact:`Viz_treemap () in
H.iframe ~a:H.[
a_src src;
a_title "Binary dissection";
@ -726,7 +730,7 @@ and the rest of the unaccounted data.\
]
let make
~name
~job_name
~(build:Builder_db.Build.t)
~artifacts
~main_binary
@ -737,10 +741,10 @@ and the rest of the unaccounted data.\
~latest ~next ~previous
=
let delta = Ptime.diff build.finish build.start in
let right_column = make_viz_section ~name ~artifacts ~uuid:build.uuid in
let right_column = make_viz_section ~job_name ~artifacts ~uuid:build.uuid in
let left_column =
make_build_info
~name
~job_name
~delta
~build
~artifacts
@ -756,7 +760,7 @@ and the rest of the unaccounted data.\
H.a_style "width: 45em; min-width: 43em;" in
let style_col_right = H.a_style "width: 50%" in
let body = [
H.h1 [txtf "Job %s" name];
H.h1 [txtf "Job %s" job_name];
H.div~a:[ style_grid ] [
H.div~a:[ style_col_left ] left_column;
H.div~a:[ style_col_right ] right_column
@ -764,8 +768,8 @@ and the rest of the unaccounted data.\
]
in
layout
~nav:(`Build (name, build))
~title:(Fmt.str "Job %s %a" name pp_ptime build.start)
~nav:(`Build (job_name, build))
~title:(Fmt.str "Job %s %a" job_name pp_ptime build.start)
~manual_width:true
body
@ -840,28 +844,28 @@ let compare_builds
H.h1 [H.txt "Comparing builds"];
H.h2 [
H.txt "Builds ";
H.a ~a:H.[a_href
(Fmt.str "/job/%s/build/%a"
job_left
Uuidm.pp build_left.uuid)]
H.a ~a:H.[ a_href @@
Link.Job_build.make
~job_name:job_left
~build:build_left.uuid () ]
[ txtf "%s@%a %a"
job_left
pp_ptime build_left.start
pp_platform (Some build_left.platform)];
H.txt " and ";
H.a ~a:H.[a_href
(Fmt.str "/job/%s/build/%a"
job_right
Uuidm.pp build_right.uuid)]
H.a ~a:H.[ a_href @@
Link.Job_build.make
~job_name:job_right
~build:build_right.uuid () ]
[ txtf "%s@%a %a"
job_right
pp_ptime build_right.start
pp_platform (Some build_right.platform)];
];
H.h3 [ H.a ~a:H.[
Fmt.kstr a_href "/compare/%a/%a"
Uuidm.pp build_right.uuid
Uuidm.pp build_left.uuid ]
a_href @@ Link.Compare_builds.make
~left:build_right.uuid
~right:build_left.uuid () ]
[H.txt "Compare in reverse direction"]] ;
H.ul [
H.li [
@ -947,7 +951,7 @@ let failed_builds ~start ~count builds =
H.li [
check_icon build.Builder_db.Build.result;
txtf " %s %a " job_name pp_platform (Some build.platform);
H.a ~a:H.[Fmt.kstr a_href "/job/%s/build/%a" job_name Uuidm.pp build.uuid]
H.a ~a:H.[ a_href @@ Link.Job_build.make ~job_name ~build:build.uuid () ]
[txtf "%a" pp_ptime build.start];
txtf " %a" Builder.pp_execution_result build.result;
]
@ -958,8 +962,8 @@ let failed_builds ~start ~count builds =
H.ul (List.map build builds);
H.p [ txtf "View the next %d failed builds " count;
H.a ~a:H.[
Fmt.kstr a_href "/failed-builds/?count=%d&start=%d"
count (start + count) ]
a_href @@ Link.Failed_builds.make
~count ~start:(start + count) () ]
[ H.txt "here"];
H.txt ".";
]

11
test/dune
View file

@ -7,3 +7,14 @@
(name markdown_to_html)
(modules markdown_to_html)
(libraries builder_web alcotest))
(test
(name router)
(modules router)
(libraries builder_web fmt dream yojson alcotest)
(preprocess
(pps
ppx_deriving.std
ppx_deriving_yojson
))
)

163
test/router.ml Normal file
View file

@ -0,0 +1,163 @@
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 -> _ option = function
| Some _ -> None
| None -> None
let is_uuid = function
| Some (param, value) ->
begin match Uuidm.of_string value with
| Some _ when String.length value = 36 -> None
| _ -> Some {
param;
expected = "Uuidm.t"
}
end
| None -> None
end
let param req tag =
match Dream.param req tag with
| param -> Some (tag, param)
| exception _ -> None
let ( &&& ) v v' =
match v with
| None -> v'
| Some _ as some -> some
let verify req =
let verified_params =
P.is_string (param req "job")
&&& P.is_uuid (param req "build")
&&& P.is_uuid (param req "build_left")
&&& P.is_uuid (param req "build_right")
&&& P.is_string (param req "platform")
in
let response_json =
verified_params |> to_yojson |> Yojson.Safe.to_string
in
Dream.respond response_json
end
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)
|> 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";
"/";
"";
]
]