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

Reviewed-on: https://git.robur.io/robur/builder-web/pulls/122

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
 

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"]
-]

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 redirect_latest req ~job_name ~platform ~artifact =
-    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
     (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
+    let artifact = `File main_binary.Builder_db.filepath in
-      (Fmt.str "/job/%s/build/%a/f/%a" job_name Uuidm.pp uuid
+    Link.Job_build_artifact.make ~job_name ~build:uuid ~artifact ()
-         Fpath.pp main_binary.Builder_db.filepath)
+    |> 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);
+    `Get, "/", (w builds);
-    Dream.get "/job" (w redirect_parent);
+    `Get, "/job", (w redirect_parent);
-    Dream.get "/job/:job" (w job);
+    `Get, "/job/:job", (w job);
-    Dream.get "/job/:job/build" (w redirect_parent);
+    `Get, "/job/:job/build", (w redirect_parent);
-    Dream.get "/job/:job/failed" (w job_with_failed);
+    `Get, "/job/:job/failed", (w job_with_failed);
-    Dream.get "/job/:job/build/latest/**" (w redirect_latest);
+    `Get, "/job/:job/build/latest/**", (w redirect_latest);
-    Dream.get "/job/:job/build/:build" (w job_build);
+    `Get, "/job/:job/build/latest", (w redirect_latest_no_slash);
-    Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
+    `Get, "/job/:job/build/:build", (w job_build);
-    Dream.get "/job/:job/build/:build/main-binary" (w redirect_main_binary);
+    `Get, "/job/:job/build/:build/f/**", (w job_build_file);
-    Dream.get "/job/:job/build/:build/viztreemap" (w @@ job_build_viz `Treemap);
+    `Get, "/job/:job/build/:build/main-binary", (w redirect_main_binary);
-    Dream.get "/job/:job/build/:build/vizdependencies" (w @@ job_build_viz `Dependencies);
+    `Get, "/job/:job/build/:build/viztreemap", (w @@ job_build_viz `Treemap);
-    Dream.get "/job/:job/build/:build/script" (w (job_build_static_file `Script));
+    `Get, "/job/:job/build/:build/vizdependencies", (w @@ job_build_viz `Dependencies);
-    Dream.get "/job/:job/build/:build/console" (w (job_build_static_file `Console));
+    `Get, "/job/:job/build/:build/script", (w (job_build_static_file `Script));
-    Dream.get "/failed-builds" (w failed_builds);
+    `Get, "/job/:job/build/:build/console", (w (job_build_static_file `Console));
-    Dream.get "/job/:job/build/:build/all.tar.gz" (w job_build_targz);
+    `Get, "/failed-builds", (w failed_builds);
-    Dream.get "/hash" (w hash);
+    `Get, "/job/:job/build/:build/all.tar.gz", (w job_build_targz);
-    Dream.get "/compare/:build_left/:build_right" (w compare_builds);
+    `Get, "/hash", (w hash);
-    Dream.post "/upload" (Authorization.authenticate (w upload));
+    `Get, "/compare/:build_left/:build_right", (w compare_builds);
-    Dream.post "/job/:job/platform/:platform/upload" (Authorization.authenticate (w upload_binary));
+    `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

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

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"
+        Link.Job.make ~job_name
-          job_name
+          ~queries:[ `Platform build.Builder_db.Build.platform ] ()
-          pp_platform_query (Some build.Builder_db.Build.platform)
       );
       (
         txtf "Build %a" pp_ptime build.Builder_db.Build.start,
-        Fmt.str "/job/%s/build/%a"
+        Link.Job_build.make ~job_name ~build:build.Builder_db.Build.uuid ()
-          job_name
-          Uuidm.pp 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"
+        Link.Compare_builds.make 
-          Uuidm.pp build_left.uuid
+          ~left:build_left.uuid
-          Uuidm.pp build_right.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"
+    Link.Job_build_artifact.make
-      job_name
+      ~job_name
-      Uuidm.pp build.Builder_db.Build.uuid
+      ~build:build.Builder_db.Build.uuid
-      Fpath.pp filepath
+      ~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"
+        H.a_href @@ Link.Job.make ~job_name
-          job_name
+          ~queries:[ `Platform platform ] ()
-          pp_platform_query (Some platform)]
+      ]
         [H.txt platform];
       H.txt " ";
       H.a ~a:[
-        Fmt.kstr H.a_href "/job/%s/build/%a/"
+        H.a_href @@ Link.Job_build.make
-          job_name
+          ~job_name
-          Uuidm.pp latest_build.Builder_db.Build.uuid]
+          ~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"
+            a_href @@ Link.Job_build.make 
-              job_name
+              ~job_name
-              Uuidm.pp build.Builder_db.Build.uuid ]
+              ~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" 
+              a_href @@ Link.Job.make ~job_name ~queries ()
-                job_name
-                pp_platform_query platform
             ]
             [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"
+              a_href @@ Link.Job.make_failed ~job_name ~queries ()
-                job_name
-                pp_platform_query platform
             ]
             [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"
+          H.a ~a:H.[a_href @@ Link.Job_build_artifact.make
-                      job_name
+                      ~job_name
-                      Uuidm.pp build_uuid
+                      ~build:build_uuid
-                      Fpath.pp file.filepath
+                      ~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"
+                a_href @@ Link.Compare_builds.make
-                  Uuidm.pp build'.uuid
+                  ~left:build'.uuid
-                  Uuidm.pp 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"
+                    a_href @@ Link.Compare_builds.make
-                      Uuidm.pp build'.uuid
+                      ~left:build'.uuid
-                      Uuidm.pp 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"
+                     H.a_href @@ Link.Compare_builds.make 
-                       Uuidm.pp b.uuid
+                       ~left:b.uuid
-                       Uuidm.pp build.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))
+      ~nav:(`Build (job_name, build))
-      ~title:(Fmt.str "Job %s %a" name pp_ptime build.start)
+      ~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
+        H.a ~a:H.[ a_href @@
-                    (Fmt.str "/job/%s/build/%a"
+                   Link.Job_build.make
-                       job_left
+                     ~job_name:job_left
-                       Uuidm.pp build_left.uuid)]
+                     ~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
+        H.a ~a:H.[ a_href @@
-                    (Fmt.str "/job/%s/build/%a"
+                   Link.Job_build.make
-                       job_right
+                     ~job_name:job_right
-                       Uuidm.pp build_right.uuid)]
+                     ~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"
+          a_href @@ Link.Compare_builds.make
-            Uuidm.pp build_right.uuid
+            ~left:build_right.uuid
-            Uuidm.pp build_left.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"
+                a_href @@ Link.Failed_builds.make
-                  count (start + count) ]
+                  ~count ~start:(start + count) () ]
               [ H.txt "here"];
             H.txt ".";
           ]

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
+   ))
+ )

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";
+        "/";
+        "";
+      ]
+  ]