builder-web/lib/views.ml

open Tyxml.Html

let txtf fmt = Fmt.kstrf txt fmt
let a_titlef fmt = Fmt.kstrf a_title fmt

let check_icon result =
  match result with
  | Builder.Exited 0 ->
    span ~a:[
      a_style "color: green; cursor: pointer;";
      a_titlef "%a" Builder.pp_execution_result result;
    ]
      [txt "☑"]
  | _ ->
    span ~a:[
      a_style "color: red; cursor: pointer;";
      a_titlef "%a" Builder.pp_execution_result result;
    ]
      [txt "☒"]

let layout ~title:title_ body_ =
  html
    (head (title (txt title_))
       [style ~a:[a_mime_type "text/css"]
          [
            txt "body {\
                 margin: 40px auto;\
                 line-height: 1.6;\
                 color: #444;\
                 padding: 0 10px;\
                 }";
            txt "h1,h2,h3{line-height:1.2}";
            txt ".output-ts {\
                 white-space: nowrap;\
                 cursor: pointer;\
                 user-select: none;\
                 }";
            txt ".output-ts a {text-decoration: none;}";
            txt ".output-ts a:hover {text-decoration: underline;}";
            txt ".output-code {\
                 overflow: visible;\
                 white-space: pre;\
                 }";
            txt ".toggleable {\
                 display: none;\
                 }";
            txt ".toggleable-descr {\
                 cursor: pointer;\
                 text-decoration: underline;\
                 user-select: none;\
                 }";
            txt ":checked + .toggleable {\
                 display: block;\
                 }";
          ]])
    (body body_)

let toggleable ?(hidden=true) id description content =
  let checked = if hidden then [] else [a_checked ()] in
  div [
    label
      ~a:[
        a_label_for id;
        a_class ["toggleable-descr"];
      ]
      [txt description];
    input
      ~a:(checked @ [
          a_input_type `Checkbox;
          a_id id;
          a_style "display: none;";
        ]) ();
    div
      ~a:[
        a_class ["toggleable"]
      ]
      content;
  ]



let builder jobs =
  layout ~title:"Builder Web"
    [ h1 [txt "Builder web"];
      p [
        txtf "We have currently %d jobs."
          (List.length jobs);
      ];
      ul (List.map (fun job ->
          li [
            a ~a:[a_href ("job/" ^ job ^ "/")]
              [txt job];
          ])
          jobs);
    ]

let job name builds =
  layout ~title:(Printf.sprintf "Job %s" name)
    [ h1 [txtf "Job %s" name];
      p [
        txtf "Currently %d builds."
          (List.length builds)
      ];
      ul (List.map (fun build ->
          li [
            a ~a:[a_href Fpath.(to_string (v "build" / Uuidm.to_string build.Builder_db.Build.Meta.uuid) ^ "/")]
              [
                txtf "%a" (Ptime.pp_human ()) build.Builder_db.Build.Meta.start;
              ];
            txt " ";
            check_icon build.result;
          ])
          builds);

    ]

let job_build
  name
  { Builder_db.Build.uuid = _; start; finish; result; console; script; job_id = _ }
  artifacts
  =
  let ptime_pp = Ptime.pp_human () in
  let delta = Ptime.diff finish start in
  layout ~title:(Fmt.strf "Job build %s %a" name ptime_pp start)
    [ h1 [txtf "Job build %s %a" name ptime_pp start];
      p [txtf "Build took %a." Ptime.Span.pp delta ];
      p [txtf "Execution result: %a." Builder.pp_execution_result result];
      h3 [txt "Digests of build artifacts"];
      dl (List.concat_map
            (fun { Builder_db.filepath; localpath=_; sha256; } ->
               let (`Hex sha256_hex) = Hex.of_cstruct sha256 in
               [
                 dt [a
                       ~a:[Fmt.kstr a_href "f/%a" Fpath.pp filepath]
                       [code [txtf "%a" Fpath.pp filepath]];
                     txt "(SHA256)"];
                 dd [code [txt sha256_hex]];
               ])
            artifacts);
      h3 [txt "Job script"];
      toggleable "job-script" "Show/hide"
        [ pre [txt script] ];
      h3 [txt "Build log"];
      toggleable ~hidden:false "build-log" "Show/hide build log"
        [
          table
            (List.mapi (fun idx (ts, line) ->
                 let ts_id = "L" ^ string_of_int idx in
                 tr [
                   td ~a:[
                     a_class ["output-ts"];
                     a_id ts_id;
                   ]
                     [a ~a:[a_href ("#"^ts_id); a_class ["output-ts-anchor"]]
                        [code [txtf "%#d ms" (Duration.to_ms (Int64.of_int ts))]]];
                   td ~a:[a_class ["output-code"]]
                     [code [txt line]];
                 ])
                (List.rev console));
        ];
    ]