Merge pull request 'Bringing back nice error pages' (#126) from 20220626_bringing_back_nice_error_pages into main

Reviewed-on: https://git.robur.io/robur/builder-web/pulls/126

bin/builder_web_app.ml

@@ -146,13 +146,14 @@ let setup_app level influx port host datadir cachedir configdir run_batch_viz_fl
       | Some Error -> Some `Error
       | Some App -> None
     in
+    let error_handler = Dream.error_template Builder_web.error_template in
     Dream.initialize_log ?level ();
     let dream_routes = Builder_web.(
         routes ~datadir ~cachedir ~configdir
         |> to_dream_routes
       )
     in
-    Dream.run ~port ~interface:host ~tls:false
+    Dream.run ~port ~interface:host ~tls:false ~error_handler
     @@ Dream.logger
     @@ Dream.sql_pool ("sqlite3:" ^ dbpath)
     @@ Http_status_metrics.handle

lib/builder_web.ml

@@ -64,9 +64,6 @@ let or_error_response r =
   let* r = r in
   match r with
   | Ok response -> Lwt.return response
-  | Error (text, `Not_Found) ->
-    Views.resource_not_found ~text
-    |> string_of_html |> Dream.html ~status:`Not_Found
   | Error (text, status) -> Dream.respond ~status text
 
 let default_log_warn ~status e =
@@ -85,6 +82,13 @@ let if_error
     Lwt_result.fail (message, status)
   | Ok _ as r -> Lwt.return r
 
+let not_found_error r =
+  let* r = r in
+  match r with
+  | Error `Not_found ->
+    Lwt_result.fail ("Resource not found", `Not_Found)
+  | Ok _ as r -> Lwt.return r
+
 let get_uuid s =
   Lwt.return
     (if String.length s = 36 then
@@ -99,11 +103,11 @@ let main_binary_of_uuid uuid db =
   |> if_error "Error getting job build"
     ~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
   >>= fun (_id, build) ->
-  match build.Builder_db.Build.main_binary with
+  Model.not_found build.Builder_db.Build.main_binary
-  | None -> Lwt_result.fail ("Resource not found", `Not_Found)
+  |> not_found_error
-  | Some main_binary ->
+  >>= fun main_binary ->
-    Model.build_artifact_by_id main_binary db
+  Model.build_artifact_by_id main_binary db
-    |> if_error "Error getting main binary" 
+  |> if_error "Error getting main binary"
 
 module Viz_aux = struct
 
@@ -203,12 +207,11 @@ module Viz_aux = struct
           artifacts
       in
       begin
-        match debug_binary with
+        Model.not_found debug_binary
-        | None -> Lwt_result.fail ("Error getting debug-binary", `Not_Found)
+        |> not_found_error >>= fun debug_binary ->
-        | Some debug_binary ->
+        debug_binary.sha256
-          debug_binary.sha256
+        |> hex
-          |> hex
+        |> Lwt_result.return
-          |> Lwt_result.return
       end 
     | `Dependencies -> 
       let opam_switch =
@@ -216,12 +219,11 @@ module Viz_aux = struct
           (fun p -> Fpath.(equal (v "opam-switch") (base p.localpath)))
           artifacts
       in
-      match opam_switch with
+      Model.not_found opam_switch
-      | None -> Lwt_result.fail ("Error getting opam-switch", `Not_Found)
+      |> not_found_error >>= fun opam_switch ->
-      | Some opam_switch ->
+      opam_switch.sha256
-        opam_switch.sha256
+      |> hex
-        |> hex
+      |> Lwt_result.return
-        |> Lwt_result.return
 
   let try_load_cached_visualization ~cachedir ~uuid viz_typ db =
     Lwt.return (get_viz_version_from_dirs ~cachedir ~viz_typ)
@@ -662,4 +664,31 @@ module Middleware = struct
 
 end
 
+let is_iframe_page ~req =
+  match Option.bind req (fun r -> Dream.header r "Sec-Fetch-Dest") with
+  | Some "iframe" -> true
+  | _ -> false
+
+let error_template error _debug_info suggested_response =
+  let target =
+    match error.Dream.request with
+    | None -> "?"
+    | Some req -> Dream.target req in
+  let referer =
+    Option.bind error.Dream.request (fun req -> Dream.header req "referer")
+  in
+  match Dream.status suggested_response with
+  | `Not_Found ->
+    let html =
+      if is_iframe_page ~req:error.Dream.request then
+        Views.viz_not_found
+      else
+        Views.page_not_found ~target ~referer
+    in
+    Dream.set_header suggested_response "Content-Type" Dream.text_html;
+    Dream.set_body suggested_response @@ string_of_html html;
+    Lwt.return suggested_response
+  | _ ->
+    Lwt.return suggested_response
+
 module Link = Link

lib/model.ml

@@ -15,7 +15,7 @@ let pp_error ppf = function
     Caqti_error.pp ppf e
 
 let not_found = function
-  | None -> Lwt.return (Error `Not_found :> (_, [> error ]) result)
+  | None -> Lwt_result.fail `Not_found
   | Some v -> Lwt_result.return v
 
 let staging datadir = Fpath.(datadir / "_staging")

lib/model.mli

@@ -2,7 +2,7 @@ type error = [ Caqti_error.call_or_retrieve | `Not_found | `File_error of Fpath.
 
 val pp_error : Format.formatter -> error -> unit
 
-val not_found : 'a option -> ('a, [> error ]) result Lwt.t
+val not_found : 'a option -> ('a, [> `Not_found ]) result Lwt.t
 
 val staging : Fpath.t -> Fpath.t
 

lib/views.ml

@@ -206,22 +206,12 @@ let artifact
     txtf " (%a)" Fmt.byte_size size;
   ]
 
-let resource_not_found ~text =
+let page_not_found ~target ~referer =
-  [
-    H.h2 ~a:[ H.a_style "padding-top: 33vh" ]
-      [ txtf "This resource does not exist" ];
-    H.p [
-      H.txt @@ Fmt.str "Error: '%s'" text
-    ];
-  ]
-  |> layout ~title:"Resource not found"
-
-let page_not_found ~path ~referer =
   [
     H.h2 ~a:[ H.a_style "padding-top: 33vh" ]
       [ txtf "This page does not exist" ];
     H.p [
-      H.txt @@ Fmt.str "You requested the page %s" path
+      H.txt @@ Fmt.str "You requested the page %s" target
     ];
   ] @ (
     match referer with
@@ -235,6 +225,30 @@ let page_not_found ~path ~referer =
   )
   |> layout ~title:"Page not found"
 
+let viz_not_found =
+  let title = "Visualization not found" in
+  let content =
+    [
+      H.h2 ~a:[ H.a_style "\
+        padding-top: 41vh;\
+        text-align: center;\
+      "]
+        [ txtf "%s" title ];
+    ]
+  in
+  let static_css = static_css :: [ Tyxml.Html.Unsafe.data "\
+    body { background: rgb(191,191,191); }\
+  "]
+  in
+  let body = [ H.div content ] in
+  H.html
+    (H.head (H.title (H.txt title))
+       [H.style ~a:H.[a_mime_type "text/css"] static_css])
+    (H.body [
+        H.main body
+      ])
+
+
 module Builds = struct
 
   let data =