Logs over websockets

.gitignore

@@ -8,3 +8,6 @@ var
 .vscode
 /capnp-secrets/
 .DS_Store
+
+/* The file below is generated by jsoo */
+web-ui/static/js/step-logs.js

dune-project

@@ -124,4 +124,9 @@
   (prometheus-app (>= 1.2))
   tyxml
   tailwindcss
-  (timedesc (>= 0.9.0))))
+  (timedesc (>= 0.9.0))
+  js_of_ocaml
+  js_of_ocaml-ppx
+  (js_of_ocaml (>= 5.1.1))
+  (brr (>= 0.0.4))
+  ))

ocaml-ci-web.opam

@@ -21,6 +21,9 @@ depends: [
   "tyxml"
   "tailwindcss"
   "timedesc" {>= "0.9.0"}
+  "js_of_ocaml"
+  "js_of_ocaml-ppx"
+  "brr"
   "odoc" {with-doc}
 ]
 build: [

web-ui/controller/git_forge.ml

@@ -33,6 +33,15 @@ module type Controller = sig
     Backend.t ->
     Dream.server Dream.message Lwt.t
 
+  val ws_show_step :
+    org:string ->
+    repo:string ->
+    hash:string ->
+    variant:string ->
+    Dream.client Dream.message ->
+    Backend.t ->
+    Dream.server Dream.message Lwt.t
+
   val cancel_step :
     org:string ->
     repo:string ->
@@ -190,10 +199,11 @@ module Make (View : View) : Controller = struct
         let can_rebuild = status.Current_rpc.Job.can_rebuild in
         let can_cancel = status.can_cancel in
 
-        View.show_step ~org ~repo ~refs ~hash ~variant ~status:step_info.outcome
-          ~csrf_token ~flash_messages ~timestamps ~build_created_at
-          ~step_created_at ~step_finished_at ~can_rebuild ~can_cancel
-          ~job:job_cap chunk
+        Dream.respond
+        @@ View.show_step ~org ~repo ~refs ~hash ~variant
+             ~status:step_info.outcome ~csrf_token ~flash_messages ~timestamps
+             ~build_created_at ~step_created_at ~step_finished_at ~can_rebuild
+             ~can_cancel ~job:job_cap chunk
 
   let cancel_step ~org ~repo ~hash ~variant request ci =
     Backend.ci ci >>= fun ci ->
@@ -319,4 +329,34 @@ module Make (View : View) : Controller = struct
     in
     List.iter (fun (s, m) -> Dream.add_flash_message request s m) flash_messages;
     Dream.redirect request (Fmt.str "/github/%s/%s/commit/%s" org repo hash)
+
+  let ws_show_step ~org ~repo ~hash ~variant _request ci =
+    Backend.ci ci >>= fun ci ->
+    Capability.with_ref (Client.CI.org ci org) @@ fun org_cap ->
+    Capability.with_ref (Client.Org.repo org_cap repo) @@ fun repo_cap ->
+    Capability.with_ref (Client.Repo.commit_of_hash repo_cap hash)
+    @@ fun commit_cap ->
+    let refs = Client.Commit.refs commit_cap in
+    let jobs = Client.Commit.jobs commit_cap in
+    Capability.with_ref (Client.Commit.job_of_variant commit_cap variant)
+    @@ fun job_cap ->
+    let status = Current_rpc.Job.status job_cap in
+    Current_rpc.Job.log job_cap ~start:0L >>!= fun (data, next) ->
+    (* (these will have resolved by now) *)
+    refs >>!= fun _refs ->
+    jobs >>!= fun _jobs ->
+    status >>!= fun _status ->
+    Capability.inc_ref job_cap;
+
+    Dream.websocket @@ fun websocket ->
+    Dream.send websocket data >>= fun () ->
+    let rec loop next =
+      Current_rpc.Job.log job_cap ~start:next >>= function
+      | Ok ("", _) -> Dream.close_websocket websocket
+      | Ok (data, next) -> Dream.send websocket data >>= fun () -> loop next
+      | Error (`Capnp ex) ->
+          Dream.log "Error fetching logs: %a" Capnp_rpc.Error.pp ex;
+          Dream.close_websocket websocket
+    in
+    loop next
 end

web-ui/jsoo/dune

@@ -0,0 +1,7 @@
+(executable
+ (modules process_chunk main steps_to_reproduce_build)
+ (name main)
+ (modes js)
+ (preprocess
+  (pps js_of_ocaml-ppx))
+ (libraries ansi astring brr))

web-ui/jsoo/main.ml

@@ -0,0 +1,78 @@
+module WebSocket = Brr_io.Websocket
+module Ev = Brr.Ev
+module El = Brr.El
+module Document = Brr.Document
+module Window = Brr.Window
+
+let regexp_left_paren = Re.Str.regexp_string "("
+let regexp_right_paren = Re.Str.regexp_string ")"
+let encoded_left_paren = "%28"
+let encoded_right_paren = "%29"
+
+let encode_parens s : Jstr.t =
+  let s_lp_encoded =
+    Jstr.to_string s
+    |> Re.Str.global_replace regexp_left_paren encoded_left_paren
+  in
+  let s_rp_encoded =
+    Re.Str.global_replace regexp_right_paren encoded_right_paren s_lp_encoded
+  in
+  Jstr.of_string s_rp_encoded
+
+let inject_log_lines first_line_repro_block last_line_repro_block data =
+  match Document.find_el_by_id Brr.G.document (Jstr.of_string "logs-pre") with
+  | None -> assert false
+  | Some scroller ->
+      El.append_children scroller data;
+      if !last_line_repro_block <> 0 then
+        Steps_to_reproduce_build.go !first_line_repro_block
+          !last_line_repro_block;
+      ()
+
+let ws_path window =
+  let location = Brr.Window.location window in
+  let pathname = Brr.Uri.path location in
+  let port = Brr.Uri.port location in
+  let hostname = Brr.Uri.host location in
+  match port with
+  | None ->
+      Jstr.concat ~sep:(Jstr.of_string "/")
+        [
+          Jstr.of_string "ws:/";
+          hostname;
+          encode_parens @@ Jstr.append (Jstr.of_string "ws") pathname;
+        ]
+  | Some port ->
+      Jstr.concat ~sep:(Jstr.of_string "/")
+        [
+          Jstr.of_string "ws:/";
+          Jstr.concat ~sep:(Jstr.of_string ":") [ hostname; Jstr.of_int port ];
+          encode_parens @@ Jstr.append (Jstr.of_string "ws") pathname;
+        ]
+
+(* It looks like parens are not being percent encoded - see https://github.com/dbuenzli/brr/issues/47.
+   Once this is fixed then something similar to the below should work:
+   Brr.Uri.with_uri ~scheme:(Jstr.of_string "ws") ~path:(pathname) location *)
+
+let fetch_logs =
+  let line_number = ref 0 in
+  let first_line_repro_block = ref 0 in
+  let last_line_repro_block = ref 0 in
+
+  let window = Brr.G.window in
+  (* this will throw an exception if the encoding fails *)
+  let ws_path = ws_path window in
+  let socket = WebSocket.create ws_path in
+  let target = WebSocket.as_target socket in
+  let (_result : Ev.listener) =
+    Ev.listen Brr_io.Message.Ev.message
+      (fun e ->
+        let data = Brr_io.Message.Ev.data (Ev.as_type e) in
+        inject_log_lines first_line_repro_block last_line_repro_block
+        @@ Process_chunk.go line_number first_line_repro_block
+             last_line_repro_block (Jstr.to_string data))
+      target
+  in
+  ()
+
+let () = ignore fetch_logs

web-ui/jsoo/process_chunk.ml

@@ -0,0 +1,78 @@
+module El = Brr.El
+module At = Brr.At
+
+let ansi = Ansi.create ()
+
+let set_inner_html el html =
+  Jv.set (El.to_jv el) "innerHTML" (Jv.of_string html)
+
+let collapse_carriage_returns log_line =
+  let rec last = function
+    | [] -> raise (Failure "Trying to take log_line from empty list (BUG)")
+    | [ s ] -> s
+    | _ :: l -> last l
+  in
+  match log_line with
+  | "" -> ""
+  | log_line -> Astring.String.cuts ~sep:"\r" log_line |> last
+
+let to_element ~line_number_id ~log_line ~code_line_class : El.t =
+  ignore line_number_id;
+
+  let colon_class_str =
+    "parseInt($el.id.substring(1, $el.id.length)) >= startingLine && \
+     parseInt($el.id.substring(1, $el.id.length)) <= endingLine ? 'highlight' \
+     : ''"
+  in
+  let code = El.code [] in
+  let () = set_inner_html code log_line in
+  if code_line_class <> "" then El.set_class (Jstr.v code_line_class) true code;
+
+  let span = El.span [] in
+  El.set_class (Jstr.v "th") true span;
+  El.set_at (Jstr.v "data-line-number") (Some (Jstr.v line_number_id)) span;
+
+  let result = El.span ~at:At.[ id (Jstr.v line_number_id) ] [ span; code ] in
+  El.set_class (Jstr.v "tr") true result;
+  El.set_at (Jstr.v ":class") (Some (Jstr.v colon_class_str)) result;
+  (* Note x-on:click is another way of doing @click
+     https://github.com/alpinejs/alpine/issues/396
+  *)
+  El.set_at (Jstr.v "x-on:click") (Some (Jstr.v "highlightLine")) result;
+  result
+
+let tabulate line_number first_line_repro_block last_line_repro_block data =
+  let last_line_blank = ref false in
+  let aux log_line =
+    if !last_line_blank && log_line = "" then
+      (* Squash consecutive new lines *)
+      None
+    else (
+      line_number := !line_number + 1;
+      let is_start_of_steps_to_reproduce =
+        Astring.String.is_infix ~affix:"To reproduce locally:" log_line
+      in
+      let is_end_of_steps_to_reproduce =
+        Astring.String.is_infix ~affix:"END-REPRO-BLOCK" log_line
+      in
+      let code_line_class =
+        if is_start_of_steps_to_reproduce then (
+          first_line_repro_block := !line_number;
+          "repro-block-start")
+        else if is_end_of_steps_to_reproduce then (
+          last_line_repro_block := !line_number;
+          "repro-block-end")
+        else ""
+      in
+      last_line_blank := log_line = "";
+      let line_number_id = Printf.sprintf "L%d" !line_number in
+      let line = to_element ~line_number_id ~log_line ~code_line_class in
+      Some line)
+  in
+  List.filter_map aux data
+
+let go line_number first_line_repro_block last_line_repro_block data =
+  Astring.String.(with_range ~len:(length data - 1)) data
+  |> Astring.String.cuts ~sep:"\n"
+  |> List.map (fun l -> collapse_carriage_returns l |> Ansi.process ansi)
+  |> tabulate line_number first_line_repro_block last_line_repro_block

web-ui/jsoo/steps_to_reproduce_build.ml

@@ -0,0 +1,15 @@
+module Ev = Brr.Ev
+module El = Brr.El
+module At = Brr.At
+module Document = Brr.Document
+module Window = Brr.Window
+
+let go first_line_repro_block last_line_repro_block =
+  (* extractStepsToReproduce is declared in step-page-poll.js
+     Until it is cut across to jsoo/brr call it directly *)
+  let extractStepsToReproduce' = Jv.get Jv.global "extractStepsToReproduce" in
+  let _ =
+    Jv.apply extractStepsToReproduce'
+      [| Jv.of_int first_line_repro_block; Jv.of_int last_line_repro_block |]
+  in
+  ()

web-ui/router.ml

@@ -48,6 +48,18 @@ struct
           ~variant:(Dream.param request "variant")
           request F.backend)
 
+  let variant_websockets =
+    let url =
+      Printf.sprintf "/ws/%s/:org/:repo/commit/:hash/variant/:variant" F.prefix
+    in
+    Dream.get url (fun request ->
+        F.Controller.ws_show_step
+          ~org:(Dream.param request "org")
+          ~repo:(Dream.param request "repo")
+          ~hash:(Dream.param request "hash")
+          ~variant:(Dream.param request "variant")
+          request F.backend)
+
   let branch_history =
     let url = Printf.sprintf "/%s/:org/:repo/history/branch/**" F.prefix in
     Dream.get url (fun request ->
@@ -208,6 +220,7 @@ struct
       rebuild_variant;
       build_api;
       variant_api;
+      variant_websockets;
       badge;
     ]
     @ F.extra_routes

web-ui/static/css/style.css

@@ -10,6 +10,7 @@ html {
 body {
   font-family: "Inter", sans-serif;
   @apply bg-gray-50 dark:bg-gray-900 text-gray-500 dark:text-gray-100;
+  counter-reset: linenum;
 }
 
 .container-fluid {
@@ -330,3 +331,13 @@ pre.code span.tr:last-child span.th {
 .svg-fill {
     @apply fill-gray-900 dark:fill-gray-100;
 }
+
+/* https://css-tricks.com/books/greatest-css-tricks/pin-scrolling-to-bottom/ */
+#logs-scroller * {
+  overflow-anchor: none;
+}
+
+#anchor {
+  overflow-anchor: auto;
+  height: 1px;
+}

web-ui/static/js/dune

@@ -0,0 +1,7 @@
+(rule
+ (deps ../../jsoo/main.bc.js)
+ (target ./step-logs.js)
+ (mode
+  (promote (until-clean)))
+ (action
+  (copy %{deps} %{target})))