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>
This commit is contained in:
parent
e5a2b6fc0e
commit
0f493e9b47
6 changed files with 123 additions and 42 deletions
|
@ -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
|
||||
|
||||
|
|
|
@ -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"}
|
||||
|
|
|
@ -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 =
|
||||
Dream.target req |>
|
||||
String.split_on_char '/' |>
|
||||
List.rev |> List.tl |> List.rev |>
|
||||
String.concat "/"
|
||||
let queries = Dream.all_queries req in
|
||||
let parent_url =
|
||||
let parent_path =
|
||||
Dream.target req
|
||||
|> Utils.Path.of_url
|
||||
|> List.rev |> List.tl |> List.rev
|
||||
in
|
||||
let parent = parent ^ "/" in
|
||||
let url = match Dream.all_queries req with
|
||||
| [] -> parent
|
||||
| xs -> parent ^ "?" ^ (Dream.to_form_urlencoded xs)
|
||||
Utils.Path.to_url ~path:parent_path ~queries
|
||||
in
|
||||
Dream.redirect ~status:`Temporary_Redirect req url
|
||||
Dream.redirect ~status:`Temporary_Redirect req parent_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
|
||||
|
|
1
lib/dune
1
lib/dune
|
@ -6,4 +6,5 @@
|
|||
opamdiff ptime.clock.os omd tar
|
||||
owee
|
||||
solo5-elftool
|
||||
uri
|
||||
))
|
||||
|
|
36
lib/utils.ml
36
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
|
||||
|
|
62
lib/views.ml
62
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
|
||||
);
|
||||
|
@ -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,7 +411,9 @@ 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 "." ]
|
||||
|
@ -419,7 +421,9 @@ module Job = struct
|
|||
H.p [
|
||||
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;
|
||||
]
|
||||
|
|
Loading…
Reference in a new issue