From 93dc0d6d87b06647521e6612edb7ab25b19e305d Mon Sep 17 00:00:00 2001 From: rand00 Date: Tue, 7 Jun 2022 16:43:44 +0200 Subject: [PATCH] Made all links safe via a Links module --- lib/builder_web.ml | 14 ++-- lib/link.ml | 98 ++++++++++++++++++++++++++++ lib/views.ml | 156 +++++++++++++++++++++++---------------------- 3 files changed, 185 insertions(+), 83 deletions(-) create mode 100644 lib/link.ml diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 1d0ccc8..c66ac12 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -306,13 +306,13 @@ let routes ~datadir ~cachedir ~configdir = 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 artifact = 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 @@ -321,9 +321,9 @@ let routes ~datadir ~cachedir ~configdir = 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 filepath = main_binary.Builder_db.filepath in + Link.Job_build_f.make ~job_name ~build:uuid ~filepath () + |> Dream.redirect req |> Lwt_result.ok in @@ -360,7 +360,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 +488,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 diff --git a/lib/link.ml b/lib/link.ml new file mode 100644 index 0000000..4ee0781 --- /dev/null +++ b/lib/link.ml @@ -0,0 +1,98 @@ +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" + + 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 Job_build_f = struct + + let make ~job_name ~build ~filepath () = + Fmt.str "/job/%a/build/%a/f/%a" + pctencode job_name + Uuidm.pp build + fpath_url_pp filepath + +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..d3ffd5a 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_f.make + ~job_name + ~build:build.Builder_db.Build.uuid + ~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_f.make + ~job_name + ~build:build_uuid + ~filepath: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 "."; ]