Removing trailing slashes (#80)

This PR solves the issue of there being both "<url>/" and "<url>" paths, that in the builder-web context shouldn't mean different things.

The slashes are now removed using a `Dream` middleware, and the request is redirected using a permanent redirect (that doesn't change the method used): https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Location

Notable changes:
* Trailing slashes from the hardcoded link urls were removed, as unneccesary redirects are then avoided.
* All links in `Views` were rewritten to be absolute instead of relative.
* As `Dream` deprecated `path` - `Utils.Path` was created containing some helpers for manipulating paths. *Note that `String.split_on_char` has a different semantics.*
* A blacklist `routeprefix_blacklist_when_removing_trailing_slash` was added, containing `Dream` route-prefixes to ignore.
* Only `GET` and `HEAD` requests are redirected.
* `redirect_parent` helper was rewritten using new `Utils.Path` functions to avoid brittle string manipulation + fixed the edgecase of redirecting to `/`.
* Added `Uri` dependency to make URL manipulation safer.

Co-authored-by: rand00 <oth.rand@gmail.com>
Co-authored-by: Reynir Björnsson <reynir@reynir.dk>
Reviewed-on: https://git.robur.io/robur/builder-web/pulls/80
Co-authored-by: rand <rand@r7p5.earth>
Co-committed-by: rand <rand@r7p5.earth>

bin/builder_web_app.ml

@@ -112,6 +112,7 @@ let setup_app level influx port host datadir cachedir configdir =
     @@ Dream.logger
     @@ Dream.sql_pool ("sqlite3:" ^ dbpath)
     @@ Http_status_metrics.handle
+    @@ Builder_web.Middleware.remove_trailing_url_slash
     @@ Builder_web.add_routes ~datadir ~cachedir ~configdir
     @@ Builder_web.not_found
 

builder-web.opam

@@ -15,7 +15,7 @@ build: [
 ]
 
 depends: [
-  "ocaml" {>= "4.10.0"}
+  "ocaml" {>= "4.13.0"}
   "dune" {>= "2.7.0"}
   "builder" {>= "0.2.0"}
   "dream" {= "1.0.0~alpha2"}

lib/builder_web.ml

@@ -379,7 +379,7 @@ let add_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)
+      (Fmt.str "/job/%s/build/%a" job_name Uuidm.pp build.Builder_db.Build.uuid)
     |> Lwt_result.ok
   in
 
@@ -469,18 +469,16 @@ let add_routes ~datadir ~cachedir ~configdir =
   in
 
   let redirect_parent req =
-    let parent =
+    let queries = Dream.all_queries req in
-      Dream.target req |>
+    let parent_url =
-      String.split_on_char '/' |>
+      let parent_path =
-      List.rev |> List.tl |> List.rev |>
+        Dream.target req
-      String.concat "/"
+        |> Utils.Path.of_url
+        |> List.rev |> List.tl |> List.rev
+      in
+      Utils.Path.to_url ~path:parent_path ~queries
     in
-    let parent = parent ^ "/" in
+    Dream.redirect ~status:`Temporary_Redirect req parent_url
-    let url = match Dream.all_queries req with
-      | [] -> parent
-      | xs -> parent ^ "?" ^ (Dream.to_form_urlencoded xs)
-    in
-    Dream.redirect ~status:`Temporary_Redirect req url
     |> Lwt_result.ok
   in
 
@@ -489,21 +487,48 @@ let add_routes ~datadir ~cachedir ~configdir =
   Dream.router [
     Dream.get "/" (w builds);
     Dream.get "/job" (w redirect_parent);
-    Dream.get "/job/:job/" (w job);
+    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/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" (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 "/failed-builds" (w failed_builds);
     Dream.get "/job/:job/build/:build/all.tar" (w job_build_tar);
     Dream.get "/hash" (w hash);
-    Dream.get "/compare/:build_left/:build_right/" (w compare_builds);
+    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));
   ]
+
+let routeprefix_blacklist_when_removing_trailing_slash = [
+  "/job/:job/build/:build/f"
+]
+
+module Middleware = struct
+
+  let remove_trailing_url_slash : Dream.middleware =
+    fun handler req ->
+      let path = Dream.target req |> Utils.Path.of_url in
+      let is_blacklisted =
+        routeprefix_blacklist_when_removing_trailing_slash
+        |> List.exists (Utils.Path.matches_dreamroute ~path)
+      in
+      if not (List.mem (Dream.method_ req) [`GET; `HEAD]) || is_blacklisted then
+        handler req
+      else match List.rev path with
+        | "" :: [] (* / *) -> handler req
+        | "" :: path (* /.../ *) ->
+          let path = List.rev path in
+          let queries = Dream.all_queries req in
+          let url = Utils.Path.to_url ~path ~queries in
+          (*> Note: See https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Location*)
+          Dream.redirect ~status:`Permanent_Redirect req url
+        | _ (* /... *) -> handler req
+
+end

lib/dune

@@ -6,4 +6,5 @@
   opamdiff ptime.clock.os omd tar
   owee
   solo5-elftool
+  uri
   ))

lib/utils.ml

@@ -124,3 +124,39 @@ module Omd = struct
     |> Omd.to_html
 
 end
+
+module Path = struct
+
+  let to_url ~path ~queries =
+    let path = match path with
+      | "" :: [] -> "/"
+      | path -> "/" ^ String.concat "/" path
+    in
+    let query = queries |> List.map (fun (k, v) -> k, [v]) in
+    Uri.make ~path ~query () |> Uri.to_string
+
+  (* Like Dream.path in 1.0.0~alpha2 but on Dream.target *)
+  let of_url uri_str =
+    let path_str = uri_str |> Uri.of_string |> Uri.path in
+    match String.split_on_char '/' path_str with
+    | "" :: (_ :: _ as tail) -> tail
+    | path -> path
+
+  let matches_dreamroute ~path dreamroute =
+    let is_match path_elem dpath_elem =
+      (dpath_elem |> String.starts_with ~prefix:":")
+      || path_elem = dpath_elem
+    in
+    let rec aux path dreampath =
+      match path, dreampath with
+      | []     , _ :: _   -> false   (*length path < length dreampath*)
+      | _      , []       -> true    (*length path >= length dreampath *)
+      | _ :: _ , "" :: [] -> true    (*dreampath ends in '/'*)
+      | p_elem :: path, dp_elem :: dreampath ->
+        is_match p_elem dp_elem
+        && aux path dreampath
+    in
+    let dreampath = dreamroute |> of_url in
+    aux path dreampath
+
+end

lib/views.ml

@@ -95,7 +95,7 @@ let make_breadcrumbs nav =
   | `Job (job_name, platform) ->
     to_nav [
       H.txt "Home", "/";
-      txtf "Job %s" job_name, Fmt.str "/job/%s/" job_name ;
+      txtf "Job %s" job_name, Fmt.str "/job/%s" job_name ;
       (
         txtf "%a" pp_platform platform,
         Fmt.str "/job/%s/%a" job_name pp_platform_query platform
@@ -104,7 +104,7 @@ let make_breadcrumbs nav =
   | `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, Fmt.str "/job/%s" job_name;
       (
         txtf "%a" pp_platform (Some build.Builder_db.Build.platform),
         Fmt.str "/job/%s/%a"
@@ -113,7 +113,7 @@ let make_breadcrumbs nav =
       );
       (
         txtf "Build %a" pp_ptime build.Builder_db.Build.start,
-        Fmt.str "/job/%s/build/%a/"
+        Fmt.str "/job/%s/build/%a"
           job_name
           Uuidm.pp build.Builder_db.Build.uuid
       );
@@ -125,7 +125,7 @@ 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/"
+        Fmt.str "/compare/%a/%a"
           Uuidm.pp build_left.uuid
           Uuidm.pp build_right.uuid
       );
@@ -231,7 +231,7 @@ let page_not_found ~path ~referer =
     | None -> []
     | Some prev_url -> [
         H.p [
-          H.txt "Go back to ";
+          H.txt "Go back to "; 
           H.a ~a:H.[ a_href prev_url ] [ H.txt prev_url ];
         ];
       ]
@@ -297,13 +297,13 @@ 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"
+        Fmt.kstr H.a_href "/job/%s/%a"
           job_name
           pp_platform_query (Some platform)]
         [H.txt platform];
       H.txt " ";
       H.a ~a:[
-        Fmt.kstr H.a_href "job/%s/build/%a/"
+        Fmt.kstr H.a_href "/job/%s/build/%a/"
           job_name
           Uuidm.pp latest_build.Builder_db.Build.uuid]
         [txtf "%a" pp_ptime latest_build.Builder_db.Build.start];
@@ -326,7 +326,7 @@ have questions or suggestions.
     jobs |> List.map (fun (job_name, synopsis, platform_builds) ->
         H.li (
           [
-            H.a ~a:H.[a_href ("job/" ^ job_name ^ "/")]
+            H.a ~a:H.[a_href ("/job/" ^ job_name ^ "/")]
               [H.txt job_name];
             H.br ();
             H.txt (Option.value ~default:"" synopsis);
@@ -348,7 +348,7 @@ have questions or suggestions.
   let make_failed_builds =
     [ H.p [
           H.txt "View the latest failed builds ";
-          H.a ~a:H.[a_href "/failed-builds/"]
+          H.a ~a:H.[a_href "/failed-builds"]
             [H.txt "here"];
           H.txt "."
         ]]
@@ -382,7 +382,7 @@ 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/"
+            Fmt.kstr a_href "/job/%s/build/%a"
               job_name
               Uuidm.pp build.Builder_db.Build.uuid ]
           [
@@ -411,15 +411,19 @@ module Job = struct
         H.p [
           H.txt "Excluding failed builds " ;
           H.a ~a:H.[
-              a_href @@ Fmt.str "../%a" pp_platform_query platform
+              a_href @@ Fmt.str "/job/%s%a" 
+                job_name
+                pp_platform_query platform
             ]
             [H.txt "here"] ;
           H.txt "." ]
       else
         H.p [
-          H.txt "Including failed builds " ;
+          H.txt "Including failed builds " ; 
           H.a ~a:H.[
-              a_href @@ Fmt.str "failed/%a" pp_platform_query platform
+              a_href @@ Fmt.str "/job/%s/failed%a"
+                job_name
+                pp_platform_query platform
             ]
             [H.txt "here"] ;
           H.txt "." ]
@@ -445,7 +449,12 @@ module Job_build = struct
     in
     List.exists check artifacts
 
-  let make_artifacts ~artifacts ~main_binary ~solo5_manifest =
+  let make_artifacts
+      ~job_name
+      ~build_uuid
+      ~artifacts
+      ~main_binary
+      ~solo5_manifest =
     let solo5_devices solo5_manifest =
       let pp_devices =
         let pp_device_name ppf = function
@@ -471,7 +480,11 @@ module Job_build = struct
       let (`Hex sha256_hex) = Hex.of_cstruct file.sha256 in
       [
         H.dt [
-          H.a ~a:H.[Fmt.kstr a_href "f/%a" Fpath.pp file.filepath]
+          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.code [txtf "%a" Fpath.pp file.filepath]] ];
         H.dd ([
             H.code [H.txt "SHA256:"; H.txt sha256_hex];
@@ -498,7 +511,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.[Fmt.kstr a_href "/job/%s/build/%a" name Uuidm.pp build.uuid]
               [txtf "%a" pp_ptime build.start]
           ])
         same_input_same_output
@@ -508,7 +521,7 @@ module Job_build = struct
           H.li [
             txtf "on %s, different input, " build'.platform;
             H.a ~a:H.[
-                Fmt.kstr a_href "/compare/%a/%a/"
+                Fmt.kstr a_href "/compare/%a/%a"
                   Uuidm.pp build'.uuid
                   Uuidm.pp build.uuid]
               [txtf "%a" pp_ptime build'.start]
@@ -538,7 +551,7 @@ module Job_build = struct
               H.li [
                 txtf "on %s, " build'.platform ;
                 H.a ~a:H.[
-                    Fmt.kstr a_href "/compare/%a/%a/"
+                    Fmt.kstr a_href "/compare/%a/%a"
                       Uuidm.pp build'.uuid
                       Uuidm.pp build.uuid]
                   [txtf "%a" pp_ptime build'.start]
@@ -559,7 +572,7 @@ 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/"
+                     Fmt.kstr H.a_href "/compare/%a/%a"
                        Uuidm.pp b.uuid
                        Uuidm.pp build.uuid ]
                      [txtf "%a" pp_ptime b.start]]
@@ -604,7 +617,12 @@ module Job_build = struct
         ]
       ];
     ]
-    @ make_artifacts ~artifacts ~main_binary ~solo5_manifest
+    @ make_artifacts
+      ~job_name:name
+      ~build_uuid:build.uuid
+      ~artifacts
+      ~main_binary
+      ~solo5_manifest
     @ make_reproductions
       ~name
       ~build
@@ -823,7 +841,7 @@ let compare_builds
       H.h2 [
         H.txt "Builds ";
         H.a ~a:H.[a_href
-                    (Fmt.str "/job/%s/build/%a/"
+                    (Fmt.str "/job/%s/build/%a"
                        job_left
                        Uuidm.pp build_left.uuid)]
           [ txtf "%s@%a %a"
@@ -832,7 +850,7 @@ let compare_builds
               pp_platform (Some build_left.platform)];
         H.txt " and ";
         H.a ~a:H.[a_href
-                    (Fmt.str "/job/%s/build/%a/"
+                    (Fmt.str "/job/%s/build/%a"
                        job_right
                        Uuidm.pp build_right.uuid)]
           [ txtf "%s@%a %a"
@@ -841,7 +859,7 @@ let compare_builds
               pp_platform (Some build_right.platform)];
       ];
       H.h3 [ H.a ~a:H.[
-          Fmt.kstr a_href "/compare/%a/%a/"
+          Fmt.kstr a_href "/compare/%a/%a"
             Uuidm.pp build_right.uuid
             Uuidm.pp build_left.uuid ]
           [H.txt "Compare in reverse direction"]] ;
@@ -929,7 +947,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.[Fmt.kstr a_href "/job/%s/build/%a" job_name Uuidm.pp build.uuid]
         [txtf "%a" pp_ptime build.start];
       txtf " %a" Builder.pp_execution_result build.result;
     ]