diff --git a/bin/builder_web_app.ml b/bin/builder_web_app.ml index eb9f5fe..45995c9 100644 --- a/bin/builder_web_app.ml +++ b/bin/builder_web_app.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 () -> diff --git a/db/builder_db.ml b/db/builder_db.ml index 146e4a0..fc2eac0 100644 --- a/db/builder_db.ml +++ b/db/builder_db.ml @@ -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 |} diff --git a/db/builder_db.mli b/db/builder_db.mli index d59a6b2..9cdb99c 100644 --- a/db/builder_db.mli +++ b/db/builder_db.mli @@ -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 diff --git a/lib/builder_web.ml b/lib/builder_web.ml index fc49c26..ac0376e 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -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)); ] diff --git a/lib/model.ml b/lib/model.ml index 8a82179..85ece75 100644 --- a/lib/model.ml +++ b/lib/model.ml @@ -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 ()