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..8f5de34 100644 --- a/lib/builder_web.ml +++ b/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 - | None -> Lwt_result.fail ("Resource not found", `Not_Found) - | Some main_binary -> - Model.build_artifact_by_id main_binary db - |> if_error "Error getting main binary" + Model.not_found build.Builder_db.Build.main_binary + |> not_found_error + >>= fun main_binary -> + Model.build_artifact_by_id main_binary db + |> 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 - | None -> Lwt_result.fail ("Error getting debug-binary", `Not_Found) - | Some debug_binary -> - debug_binary.sha256 - |> hex - |> Lwt_result.return + Model.not_found debug_binary + |> not_found_error >>= fun debug_binary -> + debug_binary.sha256 + |> hex + |> 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 - | None -> Lwt_result.fail ("Error getting opam-switch", `Not_Found) - | Some opam_switch -> - opam_switch.sha256 - |> hex - |> Lwt_result.return + Model.not_found opam_switch + |> not_found_error >>= fun opam_switch -> + opam_switch.sha256 + |> hex + |> 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 diff --git a/lib/model.ml b/lib/model.ml index d7f9cc7..3e796ba 100644 --- a/lib/model.ml +++ b/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") diff --git a/lib/model.mli b/lib/model.mli index 6982c61..c81857e 100644 --- a/lib/model.mli +++ b/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 diff --git a/lib/views.ml b/lib/views.ml index 75f5d05..9e5ae72 100644 --- a/lib/views.ml +++ b/lib/views.ml @@ -206,22 +206,12 @@ 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 = +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 +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 =