ci: include test name in links from GitHub

Highlight the test when showing the target page.

Signed-off-by: Thomas Leonard <thomas.leonard@docker.com>

ci/src/cI_engine.ml

@@ -360,7 +360,9 @@ let set_status t tr job =
     let commit = CI_target.head target.v in
     let { Repo.user; repo } = CI_target.repo_v target.v in
     let hash = Commit.hash commit in
-    let url = Uri.with_path t.web_ui (Fmt.strf "/%s/%s/commit/%s" user repo hash) in
+    let url =
+      let test = Uri.pct_encode ~component:`Query_value job.name in
+      Uri.with_path t.web_ui (Fmt.strf "/%s/%s/commit/%s?test=%s" user repo hash test) in
     Log.debug (fun f -> f "Set state of %a: %s = %a"
                   Commit.pp_hash hash
                   job.name

ci/src/cI_target.ml

@@ -85,9 +85,18 @@ let escape_ref path =
 let ref_path { Repo.user; repo} r =
     Fmt.strf "/%s/%s/ref/%s" user repo (escape_ref r)
 
-let path = function
-  | `PR (repo, pr) -> pr_path repo pr
-  | `Ref (repo, r) -> ref_path repo r
+let path ?test target =
+  let path =
+    match target with
+    | `PR (repo, pr) -> pr_path repo pr
+    | `Ref (repo, r) -> ref_path repo r
+  in
+  let query =
+    match test with
+    | None -> []
+    | Some test -> ["test", [test]]
+  in
+  Uri.make ~path ~query ()
 
 type v = [ `PR of PR.t | `Ref of Ref.t ]
 

ci/src/cI_target.mli

@@ -8,7 +8,7 @@ val equal : t -> t -> bool
 val arg : t Cmdliner.Arg.converter
 val repo : t -> Repo.t
 val id : t -> [`PR of int | `Ref of string list ]
-val path: t -> string
+val path: ?test:string -> t -> Uri.t
 
 module Map: Map.S with type key = t
 module Set: Set.S with type elt = t
@@ -17,7 +17,7 @@ val map_of_list : t list -> Set.t Repo.Map.t
 type v = [ `PR of PR.t | `Ref of Ref.t ]
 val head: v -> Commit.t
 val compare_v: v -> v -> int
-val path_v: v -> string
+val path_v: v -> Uri.t
 val repo_v : v -> Repo.t
 val unescape_ref: string -> Ref.name
 val pp_v : v Fmt.t

ci/src/cI_web.ml

@@ -14,6 +14,11 @@ type t = {
   dashboards : CI_target.Set.t Repo.Map.t;
 }
 
+let opt_query_decode name rd =
+  match Uri.get_query_param rd.Rd.uri name with
+  | None -> None
+  | Some x -> Some (Uri.pct_decode x)
+
 class user_page t = object(self)
   inherit CI_web_utils.html_page t.server
 
@@ -135,6 +140,7 @@ class pr_page t = object(self)
     let repo = Repo.v ~user ~repo in
     let prs = CI_engine.prs t.ci in
     let target = `PR (repo, id) in
+    let test = opt_query_decode "test" rd in
     match Repo.Map.find repo prs with
     | None  -> Wm.respond 404 rd ~body:(`String "No such project")
     | Some prs ->
@@ -149,7 +155,7 @@ class pr_page t = object(self)
           | `PR pr -> Some (PR.title pr)
           | _ -> assert false
       in
-      Wm.continue (CI_web_templates.target_page ~csrf_token ?title ~target commit) rd
+      Wm.continue (CI_web_templates.target_page ?test ~csrf_token ?title ~target commit) rd
 end
 
 class ref_page t = object(self)
@@ -163,10 +169,11 @@ class ref_page t = object(self)
     let id = CI_target.unescape_ref rd.Rd.dispatch_path in
     let repo = Repo.v ~user ~repo in
     let target = `Ref (repo, id) in
+    let test = opt_query_decode "test" rd in
     load_jobs t target rd >>= fun state ->
     self#session rd >>= fun session_data ->
     let csrf_token = CI_web_utils.Session_data.csrf_token session_data in
-    Wm.continue (CI_web_templates.target_page ~csrf_token ~target state) rd
+    Wm.continue (CI_web_templates.target_page ?test ~csrf_token ~target state) rd
 end
 
 class commit_page t = object
@@ -178,6 +185,7 @@ class commit_page t = object
     let user = Rd.lookup_path_info_exn "user" rd in
     let repo = Rd.lookup_path_info_exn "repo" rd in
     let commit = Rd.lookup_path_info_exn "id" rd in
+    let test = opt_query_decode "test" rd in
     let repo = Datakit_github.Repo.v ~user ~repo in
     let live_targets = CI_engine.targets_of_commit t.ci repo commit in
     CI_engine.dk t.ci >>= fun dk ->
@@ -190,8 +198,8 @@ class commit_page t = object
       |> CI_target.Map.bindings
     in
     match live_targets, archived_targets with
-    | [t], [] -> Wm.respond 307 (Rd.redirect (CI_target.path t) rd)
-    | _ -> Wm.continue (CI_web_templates.commit_page ~commit ~archived_targets live_targets) rd
+    | [t], [] -> Wm.respond 307 (Rd.redirect (Uri.to_string (CI_target.path ?test t)) rd)
+    | _ -> Wm.continue (CI_web_templates.commit_page ~commit ~archived_targets ?test live_targets) rd
 end
 
 let max_escape_length = 20

ci/src/cI_web_templates.ml

@@ -195,7 +195,7 @@ let ref_job (_repo, id) ref =
   | [] -> []
   | jobs ->
     let summary = summarise jobs in
-    let ref_url = CI_target.path_v (CI_engine.target ref) in
+    let ref_url = Uri.to_string (CI_target.path_v (CI_engine.target ref)) in
     [
       tr [
         td [a ~a:[a_href ref_url] [pcdata (Fmt.to_to_string Ref.pp_name id)]];
@@ -209,7 +209,7 @@ let pr_job (_repo, id) open_pr =
   | [] -> []
   | jobs ->
     let summary = summarise jobs in
-    let pr_url = CI_target.path_v (CI_engine.target open_pr) in
+    let pr_url = Uri.to_string (CI_target.path_v (CI_engine.target open_pr)) in
     [
       tr [
         td [a ~a:[a_href pr_url] [pcdata (string_of_int id)]];
@@ -389,7 +389,7 @@ let html_of_user ~csrf_token ((job, label), log) =
   ] in
   let action = Printf.sprintf "/cancel/%s?%s" branch (Uri.encoded_of_query query) in
   let target, job_name = job in
-  let link = CI_target.path target in
+  let link = Uri.to_string (CI_target.path target) in
   let reason = Fmt.strf "%a:%s%a" CI_target.pp target job_name pp_opt_label label in
   [
     br ();
@@ -575,7 +575,7 @@ let logs ~csrf_token ~page_url state =
       seen := String.Set.add branch !seen;
       let query = [
         "CSRFToken", [csrf_token];
-        "redirect", [page_url];
+        "redirect", [Uri.to_string page_url];
       ] in
       let action = Printf.sprintf "/log/rebuild/%s?%s" branch (Uri.encoded_of_query query) in
       let status = if failed then `Failure else `Success in
@@ -609,13 +609,17 @@ let logs ~csrf_token ~page_url state =
     let descr = CI_output.descr state in
     items @ [p [status_flag status; pcdata descr]]
 
-let job_row ~csrf_token ~page_url (job_name, state) =
+let job_row ?selected ~csrf_token ~page_url (job_name, state) =
   let output =
     match state with
     | None -> (Error (`Pending "(new)"), CI_output.Empty)
     | Some state -> state
   in
-  tr [
+  let attrs =
+    if selected = Some job_name then [a_class ["selected-job"]]
+    else []
+  in
+  tr ~a:attrs [
     th [pcdata job_name];
     td [status (CI_output.status output)];
     td (
@@ -631,19 +635,21 @@ let map_or_none f = function
   | [] -> [li [pcdata "(none)"]]
   | xs -> List.map f xs
 
-let commit_page ~commit ~archived_targets targets t =
+let commit_page ?test ~commit ~archived_targets targets t =
   let title = Fmt.strf "Commit %s" commit in
   let target_link target =
+    let uri = Uri.to_string (CI_target.path ?test target) in
     li [
-      a ~a:[a_href (CI_target.path target)] [
+      a ~a:[a_href uri] [
         pcdata (Fmt.to_to_string CI_target.pp target)
       ]
     ]
   in
   let archive_target_link (target, commit) =
     let commit = CI_utils.DK.Commit.id commit in
+    let uri = Uri.to_string (Uri.add_query_param' (CI_target.path ?test target) ("history", commit)) in
     li [
-      a ~a:[a_href (Fmt.strf "%s?history=%s" (CI_target.path target) commit)] [
+      a ~a:[a_href uri] [
         pcdata (Fmt.to_to_string CI_target.pp target)
       ]
     ]
@@ -679,15 +685,15 @@ let history_nav t target state =
   | [x] -> p (pcdata "Previous state: " :: state_link x :: links)
   | xs -> p (pcdata "Previous states: " :: (intersperse (pcdata ", ") (List.map state_link xs)) @ links)
 
-let target_page ~csrf_token ?(title="(no title)") ~(target:CI_target.t) state t =
+let target_page ?test ~csrf_token ?(title="(no title)") ~(target:CI_target.t) state t =
   let jobs = CI_history.State.jobs state |> String.Map.bindings |> List.map (fun (name, s) -> name, Some s) in
   let title = target_title ~title target in
   let repo = CI_target.repo target in
   let commit = CI_history.State.source_commit state in
   let metadata_commit = CI_history.State.metadata_commit state |> CI_utils.default "MISSING-COMMIT" in
   let page_url = target_page_url target in
   let state_summary = [
-    table ~a:[a_class ["table"; "table-bordered"; "results"]] (List.map (job_row ~csrf_token ~page_url) jobs)
+    table ~a:[a_class ["table"; "table-bordered"; "results"]] (List.map (job_row ?selected:test ~csrf_token ~page_url) jobs)
   ] in
   let nav =
     match target with

ci/src/cI_web_templates.mli

@@ -81,13 +81,15 @@ val tags_page :
   page
 
 val commit_page :
+  ?test:string ->
   commit:string ->
   archived_targets:(CI_target.t * CI_utils.DK.Commit.t) list ->
   CI_target.t list ->
   t ->
   page
 
 val target_page :
+  ?test:string ->
   csrf_token:string ->
   ?title:string ->
   target:CI_target.t ->

ci/static/css/style.css

@@ -110,6 +110,10 @@ a.selected-log {
   background: yellow;
 }
 
+tr.selected-job {
+  background: #ffffd0;
+}
+
 span.status {
   border: 1px solid black;
   padding: 1px;