diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 7d20e03..0b246de 100644 --- a/bin/builder_web_app.ml +++ b/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 diff --git a/builder-web.opam b/builder-web.opam index 5af5369..e2cf4bf 100644 --- a/builder-web.opam +++ b/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"} diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 1d918d6..d55c57a 100644 --- a/lib/builder_web.ml +++ b/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 = - 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 + Utils.Path.to_url ~path:parent_path ~queries in - let parent = parent ^ "/" in - let url = match Dream.all_queries req with - | [] -> parent - | xs -> parent ^ "?" ^ (Dream.to_form_urlencoded xs) - 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 diff --git a/lib/dune b/lib/dune index 55de30f..a56c8ea 100644 --- a/lib/dune +++ b/lib/dune @@ -6,4 +6,5 @@ opamdiff ptime.clock.os omd tar owee solo5-elftool + uri )) diff --git a/lib/utils.ml b/lib/utils.ml index 4db0e83..c3bd6d2 100644 --- a/lib/utils.ml +++ b/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 diff --git a/lib/views.ml b/lib/views.ml index 7acc1c3..951f3f6 100644 --- a/lib/views.ml +++ b/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; ]