Builder-web: Implemented better page-not-found

bin/builder_web_app.ml

@@ -97,7 +97,7 @@ let setup_app level influx port host datadir =
     @@ Dream.sql_pool ("sqlite3:" ^ dbpath)
     @@ Http_status_metrics.handle
     @@ Builder_web.add_routes datadir
-    @@ Dream.not_found
+    @@ Builder_web.not_found
 
 open Cmdliner
 

lib/builder_web.ml

@@ -59,10 +59,22 @@ let mime_lookup path =
     then "application/octet-stream"
     else Magic_mime.lookup (Fpath.to_string path)
 
+let string_of_html =
+  Format.asprintf "%a" (Tyxml.Html.pp ())
+
+let not_found req =
+  let path = "/" ^ String.concat "/" (Dream.path req) in
+  let referer = Dream.header "referer" req in
+  Views.page_not_found ~path ~referer
+  |> string_of_html |> Dream.html ~status:`Not_Found
+
 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 =
@@ -81,9 +93,6 @@ let if_error
     Lwt_result.fail (message, status)
   | Ok _ as r -> Lwt.return r
 
-let string_of_html =
-  Format.asprintf "%a" (Tyxml.Html.pp ())
-
 let get_uuid s =
   Lwt.return
     (if String.length s = 36 then

lib/views.ml

@@ -209,6 +209,35 @@ let artifact
     txtf " (%a)" Fmt.byte_size size;
   ]
 
+let resource_not_found ~text =
+  [
+    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
+    ];
+  ] @ (
+    match referer with
+    | None -> []
+    | Some prev_url -> [
+        H.p [
+          H.txt "Go back to ";
+          H.a ~a:H.[ a_href prev_url ] [ H.txt prev_url ];
+        ];
+      ]
+  )
+  |> layout ~title:"Page not found"
+
 module Builds = struct
 
   let make_header =