From 3e23b4a5bff585946aa18310599b6ae9bf98d2c0 Mon Sep 17 00:00:00 2001
From: rand00 <oth.rand@gmail.com>
Date: Sun, 26 Jun 2022 18:14:15 +0200
Subject: [PATCH] Implemented general error-handler + Added special error-page
 for iframes/vizs

---
 bin/builder_web_app.ml |  3 ++-
 lib/builder_web.ml     | 25 +++++++++++++++++++++++++
 lib/views.ml           | 38 ++++++++++++++++++++++++++++++++++++--
 3 files changed, 63 insertions(+), 3 deletions(-)

diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml
index e44806c..55a3dba 100644
--- a/bin/builder_web_app.ml
+++ b/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
diff --git a/lib/builder_web.ml b/lib/builder_web.ml
index 7d4e24a..7754bf8 100644
--- a/lib/builder_web.ml
+++ b/lib/builder_web.ml
@@ -662,4 +662,29 @@ 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 =
+    error.Dream.request
+    |> Option.map (fun req -> Dream.header req "referer")
+    |> Option.value ~default:None
+  in
+  let html =
+    if is_iframe_page ~req:error.Dream.request then
+      Views.viz_not_found ~target 
+    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
+
 module Link = Link
diff --git a/lib/views.ml b/lib/views.ml
index 75f5d05..6d9a6a4 100644
--- a/lib/views.ml
+++ b/lib/views.ml
@@ -216,12 +216,12 @@ let resource_not_found ~text =
   ]
   |> layout ~title:"Resource not found"
 
-let page_not_found ~path ~referer =
+let page_not_found ~target ~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 +235,40 @@ let page_not_found ~path ~referer =
   )
   |> layout ~title:"Page not found"
 
+let viz_not_found ~target =
+  let title = "Visualization not found" in
+  let content =
+    [
+      H.h2 ~a:[ H.a_style "\
+        padding-top: 41vh;\
+        text-align: center;\
+      "]
+        [ txtf "%s" title ];
+      (* H.p [
+       *   H.txt @@ Fmt.str "You requested the page %s" target
+       * ]; *)
+    ]
+  in
+  let static_css = static_css :: [ Tyxml.Html.Unsafe.data "\
+    body {\
+      background: rgb(191,191,191);\
+    }\
+    "]
+  in
+  let body =
+    let style = H.a_style "\
+    "
+    in
+    [ H.div ~a:[ style ] 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 =