From 02bfbc956ff58351b7f463074d68652d7a0b4ad8 Mon Sep 17 00:00:00 2001 From: Robur Date: Wed, 9 Jun 2021 09:48:51 +0000 Subject: [PATCH] Improve HTTP status codes (4xx on user data failure) Fixes #43 --- bin/builder_db.ml | 22 +++++++++--------- db/builder_db.ml | 2 +- db/builder_db.mli | 2 +- lib/builder_web.ml | 57 +++++++++++++++++++++++----------------------- lib/model.ml | 10 ++++---- lib/model.mli | 6 ++--- test/builder_db.ml | 23 +++++++++++-------- 7 files changed, 65 insertions(+), 57 deletions(-) diff --git a/bin/builder_db.ml b/bin/builder_db.ml index be5bce3..8c65271 100644 --- a/bin/builder_db.ml +++ b/bin/builder_db.ml @@ -73,24 +73,24 @@ let access_add () dbpath username jobname = Caqti_blocking.connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ()) >>= fun (module Db : Caqti_blocking.CONNECTION) -> - Db.find_opt Builder_db.User.get_user username >>= function - | None -> Error (`Msg "unknown user") - | Some (user_id, _) -> - Db.find Builder_db.Job.get_id_by_name jobname >>= fun job_id -> - Db.exec Builder_db.Access_list.add (user_id, job_id) + Db.find_opt Builder_db.User.get_user username >>= + Option.to_result ~none:(`Msg "unknown user") >>= fun (user_id, _) -> + Db.find_opt Builder_db.Job.get_id_by_name jobname >>= + Option.to_result ~none:(`Msg "job not found") >>= fun job_id -> + Db.exec Builder_db.Access_list.add (user_id, job_id) in or_die 1 r - let access_remove () dbpath username jobname = +let access_remove () dbpath username jobname = let r = Caqti_blocking.connect (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ()) >>= fun (module Db : Caqti_blocking.CONNECTION) -> - Db.find_opt Builder_db.User.get_user username >>= function - | None -> Error (`Msg "unknown user") - | Some (user_id, _) -> - Db.find Builder_db.Job.get_id_by_name jobname >>= fun job_id -> - Db.exec Builder_db.Access_list.remove (user_id, job_id) + Db.find_opt Builder_db.User.get_user username >>= + Option.to_result ~none:(`Msg "unknown user") >>= fun (user_id, _) -> + Db.find_opt Builder_db.Job.get_id_by_name jobname >>= + Option.to_result ~none:(`Msg "job not found") >>= fun job_id -> + Db.exec Builder_db.Access_list.remove (user_id, job_id) in or_die 1 r diff --git a/db/builder_db.ml b/db/builder_db.ml index da79b16..bdefe38 100644 --- a/db/builder_db.ml +++ b/db/builder_db.ml @@ -66,7 +66,7 @@ module Job = struct "SELECT name FROM job WHERE id = ?" let get_id_by_name = - Caqti_request.find + Caqti_request.find_opt Caqti_type.string id "SELECT id FROM job WHERE name = ?" diff --git a/db/builder_db.mli b/db/builder_db.mli index 3639297..f14406b 100644 --- a/db/builder_db.mli +++ b/db/builder_db.mli @@ -54,7 +54,7 @@ module Job : sig (id, string, [< `Many | `One | `Zero > `One ]) Caqti_request.t val get_id_by_name : - (string, id, [< `Many | `One | `Zero > `One ]) Caqti_request.t + (string, id, [< `Many | `One | `Zero > `One `Zero ]) Caqti_request.t val get_all : (unit, id * string, [ `Many | `One | `Zero ]) Caqti_request.t val try_add : diff --git a/lib/builder_web.ml b/lib/builder_web.ml index aad9388..8468a23 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -60,9 +60,11 @@ let or_error_response r = | 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 if_error ?(status = `Internal_Server_Error) ?(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 `Not_found -> + Lwt_result.fail (message, `Not_Found) | Error (#Model.error as e) -> log e; Lwt_result.fail (message, status) @@ -76,15 +78,15 @@ let get_uuid s = (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)) + | None -> Error ("Bad uuid", `Bad_Request) + else Error ("Bad uuid", `Bad_Request)) let add_routes datadir = let datadir_global = Dream.new_global ~name:"datadir" (fun () -> datadir) in let builder req = Dream.sql req Model.jobs - |> if_error ~status:`Internal_Server_Error "Error getting jobs" + |> if_error "Error getting jobs" ~log:(fun e -> Log.warn (fun m -> m "Error getting jobs: %a" pp_error e)) >>= fun jobs -> List.fold_right @@ -98,7 +100,7 @@ let add_routes datadir = Lwt_result.return acc) jobs (Lwt_result.return []) - |> if_error ~status:`Internal_Server_Error "Error getting jobs" + |> if_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 @@ -107,7 +109,7 @@ let add_routes datadir = let job req = let job_name = Dream.param "job" req in Dream.sql req (Model.job job_name) - |> if_error ~status:`Internal_Server_Error "Error getting job" + |> if_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 @@ -116,10 +118,10 @@ let add_routes datadir = let redirect_latest req = let job_name = Dream.param "job" req in let path = Dream.path req |> String.concat "/" in - (Dream.sql req (Model.job_id job_name) >>= fun job_id -> + (Dream.sql req (Model.job_id job_name) >>= Model.not_found >>= 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 -> + |> if_error "Error getting job" >>= fun build -> Dream.redirect req (Fmt.strf "/job/%s/build/%a/%s" job_name Uuidm.pp build path) |> Lwt_result.ok @@ -134,7 +136,7 @@ let add_routes datadir = 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" + |> if_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 @@ -154,14 +156,17 @@ let add_routes datadir = 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 -> + |> if_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 -> + |> if_error "Error getting build artifact" + ~log:(fun e -> Log.warn (fun m -> m "Error getting build artifact data for file %a in %a: %a" + Fpath.pp file.Builder_db.filepath Fpath.pp file.Builder_db.localpath + pp_error e)) >>= fun data -> let headers = [ "Content-Type", mime_lookup file.Builder_db.filepath; "ETag", etag; @@ -180,7 +185,7 @@ let add_routes datadir = Authorization.authorized req name |> if_error ~status:`Forbidden "Forbidden" >>= fun () -> Dream.sql req (Model.build_exists uuid) - |> if_error ~status:`Internal_Server_Error "Internal server error" + |> if_error "Internal server error" ~log:(fun e -> Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e)) >>= function @@ -192,7 +197,7 @@ let add_routes datadir = | 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" + |> if_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 @@ -204,15 +209,11 @@ let add_routes datadir = 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 "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 + Dream.sql req (Model.build_hash hash) >>= Model.not_found + |> if_error "Internal server error" >>= fun (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 = @@ -221,16 +222,16 @@ let add_routes datadir = let build_right = Dream.param "build_right" req in 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_left) >>= fun (_id, build_left) -> Dream.sql req (Model.build build_right) >>= fun (_id, build_right) -> + Dream.sql req (Model.build_artifact build_left.Builder_db.Build.uuid (Fpath.v "opam-switch")) >>= + Model.build_artifact_data datadir >>= fun switch_left -> + Dream.sql req (Model.build_artifact build_right.Builder_db.Build.uuid (Fpath.v "opam-switch")) >>= + Model.build_artifact_data datadir >>= fun switch_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" + |> if_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 diff --git a/lib/model.ml b/lib/model.ml index b7735d7..66650ae 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -78,10 +78,10 @@ let main_binary id main_binary (module Db : CONN) = Some file let job_id job_name (module Db : CONN) = - Db.find Builder_db.Job.get_id_by_name job_name + Db.find_opt Builder_db.Job.get_id_by_name job_name let job job (module Db : CONN) = - job_id job (module Db) >>= fun job_id -> + job_id job (module Db) >>= not_found >>= fun job_id -> Db.collect_list Builder_db.Build.get_all_meta job_id >|= List.map (fun (_id, meta, main_binary) -> (meta, main_binary)) @@ -95,7 +95,8 @@ let user username (module Db : CONN) = Db.find_opt Builder_db.User.get_user username let authorized user_id job_name (module Db : CONN) = - job_id job_name (module Db) >>= fun job_id -> + job_id job_name (module Db) >>= + (function None -> Lwt_result.fail (`Msg "No such job") | Some r -> Lwt_result.return r) >>= fun job_id -> Db.find Builder_db.Access_list.get (user_id, job_id) >|= fun _id -> () @@ -209,7 +210,8 @@ let add_build let r = Db.start () >>= fun () -> Db.exec Job.try_add job_name >>= fun () -> - Db.find Job.get_id_by_name job_name >>= fun job_id -> + Db.find_opt Job.get_id_by_name job_name >>= fun job_id -> + Lwt.return (Option.to_result ~none:(`Msg "No such job id") job_id) >>= fun job_id -> Db.exec Build.add { Build.uuid; start; finish; result; console; script = job.Builder.script; main_binary = None; job_id } >>= fun () -> diff --git a/lib/model.mli b/lib/model.mli index 5b46d48..5a2e12f 100644 --- a/lib/model.mli +++ b/lib/model.mli @@ -43,10 +43,10 @@ val main_binary : Builder_db.id -> Fpath.t option -> Caqti_lwt.connection -> (Builder_db.file option, [> Caqti_error.call_or_retrieve ]) result Lwt.t val job : string -> Caqti_lwt.connection -> - ((Builder_db.Build.Meta.t * Builder_db.file option) list, [> Caqti_error.call_or_retrieve ]) result Lwt.t + ((Builder_db.Build.Meta.t * Builder_db.file option) list, [> error ]) result Lwt.t val job_id : string -> Caqti_lwt.connection -> - (Builder_db.id, [> Caqti_error.call_or_retrieve ]) result Lwt.t + (Builder_db.id option, [> Caqti_error.call_or_retrieve ]) result Lwt.t val jobs : Caqti_lwt.connection -> ((Builder_db.id * string) list, [> Caqti_error.call_or_retrieve ]) result Lwt.t @@ -57,7 +57,7 @@ val job_name : Builder_db.id -> Caqti_lwt.connection -> val user : string -> Caqti_lwt.connection -> ((Builder_db.id * Builder_web_auth.scrypt Builder_web_auth.user_info) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t -val authorized : Builder_db.id -> string -> Caqti_lwt.connection -> (unit, [> Caqti_error.call_or_retrieve ]) result Lwt.t +val authorized : Builder_db.id -> string -> Caqti_lwt.connection -> (unit, [> Caqti_error.call_or_retrieve | `Msg of string ]) result Lwt.t val add_build : Fpath.t -> diff --git a/test/builder_db.ml b/test/builder_db.ml index 69a1dd9..07802c0 100644 --- a/test/builder_db.ml +++ b/test/builder_db.ml @@ -12,6 +12,8 @@ let get_opt message = function let or_fail x = match x with | Ok x -> x + | Error (`Msg msg) -> + Alcotest.failf "Error: %s" msg | Error (#Caqti_error.t as e) -> Alcotest.failf "DB error: %a" Caqti_error.pp e @@ -148,12 +150,15 @@ let main_binary = let size = String.length data in { Builder_db.Rep.filepath; localpath; sha256; size } +let fail_if_none = + Option.to_result ~none:(`Msg "Failed to retrieve job id") + let add_test_build (module Db : CONN) = let r = let open Builder_db in Db.start () >>= fun () -> Db.exec Job.try_add job_name >>= fun () -> - Db.find Job.get_id_by_name job_name >>= fun job_id -> + Db.find_opt Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.exec Build.add { Build.uuid; start; finish; result; console; script; main_binary = None; job_id } >>= fun () -> @@ -178,11 +183,11 @@ let test_job_get_all (module Db : CONN) = Alcotest.(check int) "one job" (List.length jobs) 1 let test_job_get_id_by_name (module Db : CONN) = - Db.find Builder_db.Job.get_id_by_name job_name >>| fun _id -> + Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>| fun _id -> () let test_job_get (module Db : CONN) = - Db.find Builder_db.Job.get_id_by_name job_name >>= fun job_id -> + Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.find_opt Builder_db.Job.get job_id >>| fun job_name' -> Alcotest.(check (option string)) "job equal" job_name' (Some job_name) @@ -190,7 +195,7 @@ let test_job_remove () = let r = setup_db () >>= fun (module Db : CONN) -> Db.exec Builder_db.Job.try_add "test-job" >>= fun () -> - Db.find Builder_db.Job.get_id_by_name "test-job" >>= fun id -> + Db.find_opt Builder_db.Job.get_id_by_name "test-job" >>= fail_if_none >>= fun id -> Db.exec Builder_db.Job.remove id >>= fun () -> Db.collect_list Builder_db.Job.get_all () >>| fun jobs -> Alcotest.(check int) "no jobs" (List.length jobs) 0 @@ -203,12 +208,12 @@ let test_build_get_by_uuid (module Db : CONN) = Alcotest.(check Testable.uuid) "same uuid" build.uuid uuid let test_build_get_all (module Db : CONN) = - Db.find Builder_db.Job.get_id_by_name job_name >>= fun job_id -> + Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.collect_list Builder_db.Build.get_all job_id >>| fun builds -> Alcotest.(check int) "one build" (List.length builds) 1 let test_build_get_all_meta (module Db : CONN) = - Db.find Builder_db.Job.get_id_by_name job_name >>= fun job_id -> + Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.collect_list Builder_db.Build.get_all_meta job_id >>| fun builds -> Alcotest.(check int) "one build" (List.length builds) 1 @@ -220,7 +225,7 @@ let add_second_build (module Db : CONN) = let uuid = uuid' and start = start' and finish = finish' in let open Builder_db in Db.start () >>= fun () -> - Db.find Job.get_id_by_name job_name >>= fun job_id -> + Db.find_opt Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.exec Build.add { Build.uuid; start; finish; result; console; script; main_binary = None; job_id; } >>= fun () -> @@ -233,7 +238,7 @@ let add_second_build (module Db : CONN) = let test_build_get_latest (module Db : CONN) = add_second_build (module Db) >>= fun () -> (* Test *) - Db.find Builder_db.Job.get_id_by_name job_name >>= fun job_id -> + Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.find_opt Builder_db.Build.get_latest job_id >>| get_opt "no latest build" >>| fun (_id, meta, main_binary') -> Alcotest.(check (option Testable.file)) "same main binary" main_binary' (Some main_binary); @@ -242,7 +247,7 @@ let test_build_get_latest (module Db : CONN) = let test_build_get_latest_uuid (module Db : CONN) = add_second_build (module Db) >>= fun () -> (* Test *) - Db.find Builder_db.Job.get_id_by_name job_name >>= fun job_id -> + Db.find_opt Builder_db.Job.get_id_by_name job_name >>= fail_if_none >>= fun job_id -> Db.find_opt Builder_db.Build.get_latest_uuid job_id >>| get_opt "no latest build" >>| fun (_id, latest_uuid) -> Alcotest.(check Testable.uuid) "same uuid" latest_uuid uuid'