diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index 7602e87..599e450 100644 --- a/bin/builder_web_app.ml +++ b/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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index caa437b..b7fe5e4 100644 --- a/lib/builder_web.ml +++ b/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 diff --git a/lib/views.ml b/lib/views.ml index 704e40d..2d30e42 100644 --- a/lib/views.ml +++ b/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 =