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_name, latest_build, latest_artifact) ->
          li ([
              a ~a:[a_href ("job/" ^ job_name ^ "/")]
                [txt job_name];
              txt " ";
              check_icon latest_build.Builder_db.Build.Meta.result;
              br ();
              a ~a:[a_href (Fmt.strf "job/%s/build/%a/" job_name Uuidm.pp
                              latest_build.Builder_db.Build.Meta.uuid)]
                [txtf "%a" (Ptime.pp_human ()) latest_build.Builder_db.Build.Meta.start];
              txt " ";
            ] @ match latest_artifact with
            | Some main_binary ->
              [
                a ~a:[a_href (Fmt.strf
                                "job/%s/build/%a/f/%a"
                                job_name
                                Uuidm.pp latest_build.Builder_db.Build.Meta.uuid
                                Fpath.pp main_binary.Builder_db.filepath)]
                  [txtf "%s" (Fpath.basename main_binary.Builder_db.filepath)];
                txt " ";
                code [txtf "SHA256:%a" Hex.pp (Hex.of_cstruct main_binary.Builder_db.sha256)];
              ]
            | None ->
              [
                txtf "Build failed";
              ]))
        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, main_binary) ->
          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;
              br ();
            ] @ match main_binary with
            | Some main_binary ->
              [
                a ~a:[a_href Fpath.(to_string (v "build" / Uuidm.to_string build.Builder_db.Build.Meta.uuid
                                               / "f" // main_binary.Builder_db.filepath))]
                  [txtf "%s" (Fpath.basename main_binary.Builder_db.filepath)];
                txt " ";
                code [txtf "SHA256:%a" Hex.pp (Hex.of_cstruct main_binary.Builder_db.sha256)];
              ]
            | None ->
              [
                txtf "Build failed";
              ]))
          builds);

    ]

let job_build
  name
  { Builder_db.Build.uuid = _; start; finish; result; console; script; main_binary = _; 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));
        ];
    ]