diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 87b108b..e44806c 100644 --- a/bin/builder_web_app.ml +++ b/bin/builder_web_app.ml @@ -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 diff --git a/builder-web.opam b/builder-web.opam index fa87dd3..c4e164c 100644 --- a/builder-web.opam +++ b/builder-web.opam @@ -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"] -] diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 1d0ccc8..24e5126 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -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 diff --git a/lib/link.ml b/lib/link.ml new file mode 100644 index 0000000..bd990d7 --- /dev/null +++ b/lib/link.ml @@ -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 diff --git a/lib/views.ml b/lib/views.ml index 951f3f6..75f5d05 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -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 "."; ] diff --git a/test/dune b/test/dune index a759c27..b854a8d 100644 --- a/test/dune +++ b/test/dune @@ -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 + )) + ) diff --git a/test/router.ml b/test/router.ml new file mode 100644 index 0000000..e0b9fcb --- /dev/null +++ b/test/router.ml @@ -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"; + "/"; + ""; + ] + ]