Revise error handling

- also validate UUID to be 36 characters
- also error with not_found for unknown jobs
login
Reynir Björnsson 2 years ago committed by Robur
parent e4407902f5
commit 8f4a45bf76
  1. 2
      bin/builder_web_app.ml
  2. 18
      db/builder_db.ml
  3. 4
      db/builder_db.mli
  4. 315
      lib/builder_web.ml
  5. 9
      lib/model.ml

@ -86,7 +86,7 @@ let setup_app level influx port host datadir =
| Error (#Caqti_error.load as e) ->
Format.eprintf "Error: %a\n%!" Caqti_error.pp e;
exit 2
| Error (#Builder_web.db_error | `Wrong_version _ as e) ->
| Error (#Caqti_error.connect | #Caqti_error.call_or_retrieve | `Msg _ | `Wrong_version _ as e) ->
Format.eprintf "Error: %a\n%!" Builder_web.pp_error e;
exit 1
| Ok () ->

@ -335,22 +335,8 @@ module Build = struct
let get_all_meta =
Caqti_request.collect
Caqti_type.int64
(Caqti_type.tup2
id Meta.t)
{| SELECT id, uuid, start_d, start_ps, finish_d, finish_ps,
result_kind, result_code, result_msg, main_binary, job
FROM build
WHERE job = ?
ORDER BY start_d DESC, start_ps DESC
|}
let get_all_meta_by_name =
Caqti_request.collect
Caqti_type.string
(Caqti_type.tup3
id
Meta.t
file_opt)
id Meta.t file_opt)
{| SELECT build.id, build.uuid,
build.start_d, build.start_ps, build.finish_d, build.finish_ps,
build.result_kind, build.result_code, build.result_msg,
@ -359,7 +345,7 @@ module Build = struct
FROM build, job
LEFT JOIN build_artifact ON
build.main_binary = build_artifact.id
WHERE job.name = ? AND build.job = job.id
WHERE job.id = ? AND build.job = job.id
ORDER BY start_d DESC, start_ps DESC
|}

@ -140,9 +140,7 @@ sig
val get_all :
(id, id * t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_all_meta :
(id, id * Meta.t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_all_meta_by_name :
(string, id * Meta.t * file option, [ `Many | `One | `Zero ]) Caqti_request.t
(id, id * Meta.t * file option, [ `Many | `One | `Zero ]) Caqti_request.t
val get_latest :
(id, id * Meta.t * file option, [< `Many | `One | `Zero > `One `Zero ])
Caqti_request.t

@ -4,8 +4,6 @@ module Log = (val Logs.src_log src : Logs.LOG)
open Lwt.Syntax
open Lwt_result.Infix
type db_error = [ Caqti_error.connect | Model.error ]
let pp_error ppf = function
| #Caqti_error.connect as e -> Caqti_error.pp ppf e
| #Model.error as e -> Model.pp_error ppf e
@ -58,6 +56,20 @@ let mime_lookup path =
then "application/octet-stream"
else Magic_mime.lookup (Fpath.to_string path)
let or_error_response r =
let* r = r in
match r with
| Ok response -> Lwt.return response
| Error (text, status) -> Dream.respond ~status text
let if_error ~status ?(log=(fun e -> Log.warn (fun m -> m "%s: %a" (Dream.status_to_string status) pp_error e))) message r =
let* r = r in
match r with
| Error (#Model.error as e) ->
log e;
Lwt_result.fail (message, status)
| Ok _ as r -> Lwt.return r
let authorized handler = fun req ->
let unauthorized () =
let headers = ["WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" realm] in
@ -97,85 +109,74 @@ let authorized handler = fun req ->
let string_of_html =
Format.asprintf "%a" (Tyxml.Html.pp ())
let get_uuid s =
Lwt.return
(if String.length s = 36 then
match Uuidm.of_string s with
| Some uuid -> Ok uuid
| None -> Error ("Bad uuid", `Not_Found)
else Error ("Bad uuid", `Not_Found))
let add_routes datadir =
let datadir_global = Dream.new_global ~name:"datadir" (fun () -> datadir) in
let builder req =
let* jobs = Dream.sql req Model.jobs in
match jobs with
| Error e ->
Log.warn (fun m -> m "Error getting jobs: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Error getting jobs"
| Ok jobs ->
let* jobs =
List.fold_right
(fun (job_id, job_name) r ->
r >>= fun acc ->
Dream.sql req (Model.build_meta job_id) >>= function
| Some (latest_build, latest_artifact) ->
Lwt_result.return ((job_name, latest_build, latest_artifact) :: acc)
| None ->
Log.warn (fun m -> m "Job without builds: %s" job_name);
Lwt_result.return acc)
jobs
(Lwt_result.return [])
in
match jobs with
| Error e ->
Log.warn (fun m -> m "Error getting jobs: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Error getting jobs"
| Ok jobs ->
Views.builder jobs |> string_of_html |> Dream.html
Dream.sql req Model.jobs
|> if_error ~status:`Internal_Server_Error "Error getting jobs"
~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
>>= fun jobs ->
List.fold_right
(fun (job_id, job_name) r ->
r >>= fun acc ->
Dream.sql req (Model.build_meta job_id) >>= function
| Some (latest_build, latest_artifact) ->
Lwt_result.return ((job_name, latest_build, latest_artifact) :: acc)
| None ->
Log.warn (fun m -> m "Job without builds: %s" job_name);
Lwt_result.return acc)
jobs
(Lwt_result.return [])
|> if_error ~status:`Internal_Server_Error "Error getting jobs"
~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e))
>>= fun jobs ->
Views.builder jobs |> string_of_html |> Dream.html |> Lwt_result.ok
in
let job req =
let job_name = Dream.param "job" req in
let* job = Dream.sql req (Model.job job_name) in
match job with
| Error e ->
Log.warn (fun m -> m "Error getting job: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Error getting job"
| Ok builds ->
Views.job job_name builds |> string_of_html |> Dream.html
Dream.sql req (Model.job job_name)
|> if_error ~status:`Internal_Server_Error "Error getting job"
~log:(fun e -> Log.warn (fun m -> m "Error getting job: %a" pp_error e))
>>= fun builds ->
Views.job job_name builds |> string_of_html |> Dream.html |> Lwt_result.ok
in
let redirect_latest req =
let job_name = Dream.param "job" req in
let path = Dream.path req |> String.concat "/" in
let* build =
Dream.sql req (Model.job_id job_name) >>= fun job_id ->
Dream.sql req (Model.latest_successful_build_uuid job_id)
>>= Model.not_found
in
match build with
| Error e ->
Log.warn (fun m -> m "Error getting job: %a" pp_error e);
Dream.respond ~status:`Not_Found "Error getting job"
| Ok build ->
Dream.redirect req
(Fmt.strf "/job/%s/build/%a/%s" job_name Uuidm.pp build path)
(Dream.sql req (Model.job_id job_name) >>= fun job_id ->
Dream.sql req (Model.latest_successful_build_uuid job_id))
>>= Model.not_found
|> if_error ~status:`Not_Found "Error getting job" >>= fun build ->
Dream.redirect req
(Fmt.strf "/job/%s/build/%a/%s" job_name Uuidm.pp build path)
|> Lwt_result.ok
in
let job_build req =
let job_name = Dream.param "job" req
and build = Dream.param "build" req in
match Uuidm.of_string build with
| None ->
Dream.respond "Bad request." ~status:`Bad_Request
| Some uuid ->
let* data =
Dream.sql req (Model.build uuid) >>= fun (build_id, build) ->
Dream.sql req (Model.build_artifacts build_id) >>= fun artifacts ->
Dream.sql req (Model.latest_successful_build_uuid build.job_id) >>= fun latest_uuid ->
Dream.sql req (Model.previous_successful_build build_id) >|= fun previous_build ->
(build, artifacts, latest_uuid, previous_build)
in
match data with
| Error e ->
Log.warn (fun m -> m "Error getting job build: %a" pp_error e);
Dream.respond "Error getting job build" ~status:`Internal_Server_Error
| Ok (build, artifacts, latest_uuid, previous_build) ->
Views.job_build job_name build artifacts latest_uuid previous_build |> string_of_html |> Dream.html
get_uuid build >>= fun uuid ->
(Dream.sql req (Model.build uuid) >>= fun (build_id, build) ->
Dream.sql req (Model.build_artifacts build_id) >>= fun artifacts ->
Dream.sql req (Model.latest_successful_build_uuid build.job_id) >>= fun latest_uuid ->
Dream.sql req (Model.previous_successful_build build_id) >|= fun previous_build ->
(build, artifacts, latest_uuid, previous_build))
|> if_error ~status:`Internal_Server_Error "Error getting job build"
~log:(fun e -> Log.warn (fun m -> m "Error getting job build: %a" pp_error e))
>>= fun (build, artifacts, latest_uuid, previous_build) ->
Views.job_build job_name build artifacts latest_uuid previous_build |> string_of_html |> Dream.html
|> Lwt_result.ok
in
let job_build_file req =
@ -187,128 +188,102 @@ let add_routes datadir =
(* XXX: We don't check safety of [file]. This should be fine however since
* we don't use [file] for the filesystem but is instead used as a key for
* lookup in the data table of the 'full' file. *)
match Uuidm.of_string build, Fpath.of_string filepath with
| None, _ ->
Log.debug (fun m -> m "bad uuid: %s" build);
Dream.respond ~status:`Not_Found "File not found"
| _, Error (`Msg e) ->
Log.debug (fun m -> m "bad path: %s" e);
Dream.respond ~status:`Not_Found "File not found"
| Some build, Ok filepath ->
let* file = Dream.sql req (Model.build_artifact build filepath) in
match file with
| Error e ->
Log.warn (fun m -> m "Error getting build artifact: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Error getting build artifact"
| Ok file ->
let etag = Base64.encode_string (Cstruct.to_string file.Builder_db.sha256) in
match if_none_match with
| Some etag' when etag = etag' ->
Dream.empty `Not_Modified
| _ ->
let* data = Model.build_artifact_data datadir file in
match data with
| Ok data ->
let headers = [
"Content-Type", mime_lookup file.Builder_db.filepath;
"ETag", etag;
] in
Dream.respond ~headers data
| Error e ->
Log.warn (fun m -> m "Error getting build artifact: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Error getting build artifact"
get_uuid build >>= fun build ->
Fpath.of_string filepath |> Rresult.R.open_error_msg |> Lwt_result.lift
|> if_error ~status:`Not_Found "File not found" >>= fun filepath ->
Dream.sql req (Model.build_artifact build filepath)
|> if_error ~status:`Internal_Server_Error "Error getting build artifact" >>= fun file ->
let etag = Base64.encode_string (Cstruct.to_string file.Builder_db.sha256) in
match if_none_match with
| Some etag' when etag = etag' ->
Dream.empty `Not_Modified |> Lwt_result.ok
| _ ->
Model.build_artifact_data datadir file
|> if_error ~status:`Internal_Server_Error "Error getting build artifact" >>= fun data ->
let headers = [
"Content-Type", mime_lookup file.Builder_db.filepath;
"ETag", etag;
] in
Dream.respond ~headers data |> Lwt_result.ok
in
let upload req =
let* body = Dream.body req in
match Builder.Asn.exec_of_cs (Cstruct.of_string body) with
| Error (`Msg e) ->
Log.warn (fun m -> m "Received bad builder ASN.1");
Log.debug (fun m -> m "Parse error: %s" e);
Dream.respond ~status:`Bad_Request "Bad request"
| Ok ((_, uuid, _, _, _, _, _) as exec) ->
Log.info (fun m -> m "Received build %a" pp_exec exec);
let* r = Dream.sql req (Model.build_exists uuid) in
match r with
| Error e ->
Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e);
Dream.respond ~status:`Internal_Server_Error "Internal server error"
| Ok true ->
Log.warn (fun m -> m "Build with same uuid exists: %a" pp_exec exec);
Dream.respond ~status:`Conflict
(Fmt.strf "Build with same uuid exists: %a\n" Uuidm.pp uuid)
| Ok false ->
let datadir = Dream.global datadir_global req in
let* r = Dream.sql req (Model.add_build datadir exec) in
match r with
| Ok () ->
Dream.respond ""
| Error e ->
Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e);
Dream.respond ~status:`Internal_Server_Error "Internal server error"
Builder.Asn.exec_of_cs (Cstruct.of_string body) |> Lwt.return
|> if_error ~status:`Bad_Request "Bad request"
~log:(fun e ->
Log.warn (fun m -> m "Received bad builder ASN.1: %a" pp_error e))
>>= fun ((_, uuid, _, _, _, _, _) as exec) ->
Log.debug (fun m -> m "Received build %a" pp_exec exec);
Dream.sql req (Model.build_exists uuid)
|> if_error ~status:`Internal_Server_Error "Internal server error"
~log:(fun e ->
Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e))
>>= function
| true ->
Log.warn (fun m -> m "Build with same uuid exists: %a" pp_exec exec);
Dream.respond ~status:`Conflict
(Fmt.strf "Build with same uuid exists: %a\n" Uuidm.pp uuid)
|> Lwt_result.ok
| false ->
let datadir = Dream.global datadir_global req in
Dream.sql req (Model.add_build datadir exec)
|> if_error ~status:`Internal_Server_Error "Internal server error"
~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e))
>>= fun () -> Dream.respond "" |> Lwt_result.ok
in
let hash req =
let hash_hex = Dream.query "sha256" req in
match Option.map (fun h -> Hex.to_cstruct (`Hex h)) hash_hex with
Dream.query "sha256" req |> Option.to_result ~none:(`Msg "Missing sha256 query parameter") |> Lwt.return
|> if_error ~status:`Bad_Request "Bad request" >>= fun hash_hex ->
begin try Hex.to_cstruct (`Hex hash_hex) |> Lwt_result.return
with Invalid_argument e -> Lwt_result.fail (`Msg ("Bad hex: " ^ e))
end
|> if_error ~status:`Bad_Request "Bad request" >>= fun hash ->
Dream.sql req (Model.build_hash hash)
|> if_error ~status:`Internal_Server_Error "Internal server error" >>= function
| None ->
Log.debug (fun m -> m "sha256 query parameter not provided");
Dream.respond ~status:`Bad_Request "Bad request"
| Some hash ->
let* build = Dream.sql req (Model.build_hash hash) in
(match build with
| Error e ->
Log.warn (fun m -> m "Database error: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Internal server error"
| Ok None ->
Log.debug (fun m -> m "Hash not found: %S" (Option.get hash_hex));
Dream.respond ~status:`Not_Found "Artifact not found"
| Ok (Some (job_name, build)) ->
Dream.redirect req
(Fmt.strf "/job/%s/build/%a/" job_name Uuidm.pp build.Builder_db.Build.uuid))
| exception Invalid_argument _ ->
Log.debug (fun m -> m "Invalid hash hex %S" (Option.get hash_hex));
Dream.respond ~status:`Bad_Request "Bad request"
Log.debug (fun m -> m "Hash not found: %S" hash_hex);
Dream.respond ~status:`Not_Found "Artifact not found" |> Lwt_result.ok
| Some (job_name, build) ->
Dream.redirect req
(Fmt.strf "/job/%s/build/%a/" job_name Uuidm.pp build.Builder_db.Build.uuid)
|> Lwt_result.ok
in
let compare_opam req =
let datadir = Dream.global datadir_global req in
let build_left = Dream.param "build_left" req in
let build_right = Dream.param "build_right" req in
match Uuidm.of_string build_left, Uuidm.of_string build_right with
| None, _ | _, None ->
Dream.respond ~status:`Bad_Request "Bad request"
| Some build_left, Some build_right ->
let* r =
Dream.sql req (Model.build_artifact build_left (Fpath.v "opam-switch")) >>=
Model.build_artifact_data datadir >>= fun switch_left ->
Dream.sql req (Model.build_artifact build_right (Fpath.v "opam-switch")) >>=
Model.build_artifact_data datadir >>= fun switch_right ->
Dream.sql req (Model.build build_left) >>= fun (_id, build_left) ->
Dream.sql req (Model.build build_right) >>= fun (_id, build_right) ->
Dream.sql req (Model.job_name build_left.job_id) >>= fun job_left ->
Dream.sql req (Model.job_name build_right.job_id) >>= fun job_right ->
Lwt_result.return (job_left, job_right, build_left, build_right, switch_left, switch_right)
in
match r with
| Error e ->
Log.warn (fun m -> m "Database error: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Internal server error"
| Ok (job_left, job_right, build_left, build_right, switch_left, switch_right) ->
let switch_left = OpamFile.SwitchExport.read_from_string switch_left
and switch_right = OpamFile.SwitchExport.read_from_string switch_right in
Opamdiff.compare switch_left switch_right
|> Views.compare_opam job_left job_right build_left build_right
|> string_of_html |> Dream.html
get_uuid build_left >>= fun build_left ->
get_uuid build_right >>= fun build_right ->
(Dream.sql req (Model.build_artifact build_left (Fpath.v "opam-switch")) >>=
Model.build_artifact_data datadir >>= fun switch_left ->
Dream.sql req (Model.build_artifact build_right (Fpath.v "opam-switch")) >>=
Model.build_artifact_data datadir >>= fun switch_right ->
Dream.sql req (Model.build build_left) >>= fun (_id, build_left) ->
Dream.sql req (Model.build build_right) >>= fun (_id, build_right) ->
Dream.sql req (Model.job_name build_left.job_id) >>= fun job_left ->
Dream.sql req (Model.job_name build_right.job_id) >|= fun job_right ->
(job_left, job_right, build_left, build_right, switch_left, switch_right))
|> if_error ~status:`Internal_Server_Error "Internal server error"
>>= fun (job_left, job_right, build_left, build_right, switch_left, switch_right) ->
let switch_left = OpamFile.SwitchExport.read_from_string switch_left
and switch_right = OpamFile.SwitchExport.read_from_string switch_right in
Opamdiff.compare switch_left switch_right
|> Views.compare_opam job_left job_right build_left build_right
|> string_of_html |> Dream.html |> Lwt_result.ok
in
let w f req = or_error_response (f req) in
Dream.router [
Dream.get "/" builder;
Dream.get "/job/:job/" job;
Dream.get "/job/:job/build/latest/**" redirect_latest;
Dream.get "/job/:job/build/:build/" job_build;
Dream.get "/job/:job/build/:build/f/**" job_build_file;
Dream.get "/hash" hash;
Dream.get "/compare/:build_left/:build_right/opam-switch" compare_opam;
Dream.post "/upload" (authorized upload);
Dream.get "/" (w builder);
Dream.get "/job/:job/" (w job);
Dream.get "/job/:job/build/latest/**" (w redirect_latest);
Dream.get "/job/:job/build/:build/" (w job_build);
Dream.get "/job/:job/build/:build/f/**" (w job_build_file);
Dream.get "/hash" (w hash);
Dream.get "/compare/:build_left/:build_right/opam-switch" (w compare_opam);
Dream.post "/upload" (authorized (w upload));
]

@ -77,13 +77,14 @@ let main_binary id main_binary (module Db : CONN) =
Db.find Builder_db.Build_artifact.get_by_build (id, main_binary) >|= fun (_id, file) ->
Some file
let job job (module Db : CONN) =
Db.collect_list Builder_db.Build.get_all_meta_by_name job >|=
List.map (fun (_id, meta, main_binary) -> (meta, main_binary))
let job_id job_name (module Db : CONN) =
Db.find Builder_db.Job.get_id_by_name job_name
let job job (module Db : CONN) =
job_id job (module Db) >>= fun job_id ->
Db.collect_list Builder_db.Build.get_all_meta job_id >|=
List.map (fun (_id, meta, main_binary) -> (meta, main_binary))
let jobs (module Db : CONN) =
Db.collect_list Builder_db.Job.get_all ()

Loading…
Cancel
Save