Improve HTTP status codes (4xx on user data failure)

Fixes #43

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
+    Db.find_opt Builder_db.User.get_user username >>=
-    | None -> Error (`Msg "unknown user")
+    Option.to_result ~none:(`Msg "unknown user") >>= fun (user_id, _) ->
-    | Some (user_id, _) ->
+    Db.find_opt Builder_db.Job.get_id_by_name jobname >>=
-      Db.find Builder_db.Job.get_id_by_name jobname >>= fun job_id ->
+    Option.to_result ~none:(`Msg "job not found") >>= fun job_id ->
-      Db.exec Builder_db.Access_list.add (user_id, 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
+    Db.find_opt Builder_db.User.get_user username >>=
-    | None -> Error (`Msg "unknown user")
+    Option.to_result ~none:(`Msg "unknown user") >>= fun (user_id, _) ->
-    | Some (user_id, _) ->
+    Db.find_opt Builder_db.Job.get_id_by_name jobname >>=
-      Db.find Builder_db.Job.get_id_by_name jobname >>= fun job_id ->
+    Option.to_result ~none:(`Msg "job not found") >>= fun job_id ->
-      Db.exec Builder_db.Access_list.remove (user_id, job_id)
+    Db.exec Builder_db.Access_list.remove (user_id, job_id)
    in
    or_die 1 r
 

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 = ?"

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 :

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)
+       | None -> Error ("Bad uuid", `Bad_Request)
-     else Error ("Bad uuid", `Not_Found))
+     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)
+    Dream.sql req (Model.build_hash hash) >>= Model.not_found
-    |> if_error ~status:`Internal_Server_Error "Internal server error" >>= function
+    |> if_error "Internal server error" >>= fun (job_name, build) ->
-    | None ->
+    Dream.redirect req
-      Log.debug (fun m -> m "Hash not found: %S" hash_hex);
+      (Fmt.strf "/job/%s/build/%a/" job_name Uuidm.pp build.Builder_db.Build.uuid)
-      Dream.respond ~status:`Not_Found "Artifact not found" |> Lwt_result.ok
+    |> 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 =
@@ -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")) >>=
+    (Dream.sql req (Model.build build_left) >>= fun (_id, build_left) ->
-     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.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

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 () ->

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 ->

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'