robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Migrate to dream

Browse source
This commit is contained in:
Robur 2021-06-01 14:06:36 +00:00
parent af1ed4cbc7
commit 10351c65bd
5 changed files with 142 additions and 198 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

55
bin/builder_web_app.ml
View file

@ -1,5 +1,3 @@
open Opium
open Lwt.Infix open Lwt.Infix
let safe_close fd = let safe_close fd =
@ -80,30 +78,7 @@ let init_influx name data =
in in
Lwt.async report Lwt.async report
let timestamp_reporter () = let setup_app level influx port host datadir =
let report src level ~over k msgf =
let k _ = over (); k () in
msgf @@ fun ?header ?tags:_ fmt ->
let posix_time = Ptime_clock.now () in
let src_name = Logs.Src.name src in
Format.kfprintf k Format.std_formatter
("%a [%s] %a @[" ^^ fmt ^^ "@]@.")
(Ptime.pp_rfc3339 ()) posix_time src_name
Logs.pp_header (level, header)
in
{ Logs.report }
let setup_log style_renderer level =
Fmt_tty.setup_std_outputs ?style_renderer ();
Logs.set_level level;
Logs.set_reporter (timestamp_reporter ()) (* (Logs_fmt.reporter ~dst:Format.std_formatter ()) *)
let app t =
App.empty
|> App.cmd_name "Builder Web"
|> Builder_web.add_routes t
let setup_app () influx port host datadir =
let dbpath = Printf.sprintf "%s/builder.sqlite3" datadir in let dbpath = Printf.sprintf "%s/builder.sqlite3" datadir in
let datadir = Fpath.v datadir in let datadir = Fpath.v datadir in
let () = init_influx "builder-web" influx in let () = init_influx "builder-web" influx in
@ -114,12 +89,14 @@ let setup_app () influx port host datadir =
| Error (#Builder_web.db_error | `Wrong_version _ as e) -> | Error (#Builder_web.db_error | `Wrong_version _ as e) ->
Format.eprintf "Error: %a\n%!" Builder_web.pp_error e; Format.eprintf "Error: %a\n%!" Builder_web.pp_error e;
exit 1 exit 1
| Ok t -> | Ok () ->
app t let level = match level with None -> None | Some Logs.Debug -> Some `Debug | Some Info -> Some `Info | Some Warning -> Some `Warning | Some Error -> Some `Error | Some App -> None in
|> App.port port Dream.initialize_log ?level ();
|> App.host host Dream.run ~port ~interface:host ~https:false
|> (match Logs.level () with Some Debug -> (fun x -> x |> App.debug true |> App.verbose true) | Some Info -> App.verbose true | _ -> (fun x -> x)) @@ Dream.logger
|> App.start @@ Dream.sql_pool ("sqlite3:" ^ dbpath)
@@ Builder_web.add_routes datadir
@@ Dream.not_found
open Cmdliner open Cmdliner
@ -142,9 +119,6 @@ let ip_port : (Ipaddr.V4.t * int) Arg.converter =
in in
parse, fun ppf (ip, port) -> Format.fprintf ppf "%a:%d" Ipaddr.V4.pp ip port parse, fun ppf (ip, port) -> Format.fprintf ppf "%a:%d" Ipaddr.V4.pp ip port
let setup_log =
Term.(const setup_log $ Fmt_cli.style_renderer () $ Logs_cli.level ())
let datadir = let datadir =
let doc = "data directory" in let doc = "data directory" in
Arg.(value & opt dir "/var/db/builder-web/" & info [ "d"; "datadir" ] ~doc) Arg.(value & opt dir "/var/db/builder-web/" & info [ "d"; "datadir" ] ~doc)
@ -161,17 +135,10 @@ let influx =
let doc = "IP address and port (default: 8094) to report metrics to in influx line protocol" in let doc = "IP address and port (default: 8094) to report metrics to in influx line protocol" in
Arg.(value & opt (some ip_port) None & info [ "influx" ] ~doc ~docv:"INFLUXHOST[:PORT]") Arg.(value & opt (some ip_port) None & info [ "influx" ] ~doc ~docv:"INFLUXHOST[:PORT]")
let () = let () =
let () = Mirage_crypto_rng_unix.initialize () in let term = Term.(pure setup_app $ Logs_cli.level () $ influx $ port $ host $ datadir) in
let term = Term.(pure setup_app $ setup_log $ influx $ port $ host $ datadir) in
let info = Term.info "Builder web" ~doc:"Builder web" ~man:[] in let info = Term.info "Builder web" ~doc:"Builder web" ~man:[] in
match Term.eval (term, info) with match Term.eval (term, info) with
| `Ok s -> | `Ok () -> exit 0
Sys.(set_signal sigpipe Signal_ignore);
Printexc.record_backtrace true;
let () = Lwt.async (fun () -> Lwt.bind s (fun _ -> Lwt.return_unit)) in
let forever, _ = Lwt.wait () in
Lwt_main.run forever
| `Error _ -> exit 1 | `Error _ -> exit 1
| _ -> exit 0 | _ -> exit 0

2
bin/dune
View file

@ -2,7 +2,7 @@
(public_name builder-web) (public_name builder-web)
(name builder_web_app) (name builder_web_app)
(modules builder_web_app) (modules builder_web_app)
(libraries builder_web mirage-crypto-rng.unix cmdliner logs.cli fmt.cli fmt.tty ptime.clock.os metrics metrics-lwt metrics-influx metrics-rusage ipaddr ipaddr.unix)) (libraries builder_web mirage-crypto-rng.unix cmdliner logs.cli metrics metrics-lwt metrics-influx metrics-rusage ipaddr ipaddr.unix))
(executable (executable
(public_name builder-db) (public_name builder-db)

2
builder-web.opam
View file

@ -14,7 +14,7 @@ build: [
depends: [ depends: [
"builder" "builder"
"opium" "dream"
"bos" "bos"
"hex" "hex"
"caqti" "caqti"

279
lib/builder_web.ml
View file

@ -1,7 +1,6 @@
let src = Logs.Src.create "builder-web" ~doc:"Builder_web" let src = Logs.Src.create "builder-web" ~doc:"Builder_web"
module Log = (val Logs.src_log src : Logs.LOG) module Log = (val Logs.src_log src : Logs.LOG)
open Opium
open Lwt.Syntax open Lwt.Syntax
open Lwt_result.Infix open Lwt_result.Infix
@ -15,11 +14,6 @@ let pp_error ppf = function
then Format.fprintf ppf "Wrong database version: %Ld" version then Format.fprintf ppf "Wrong database version: %Ld" version
else Format.fprintf ppf "Wrong database application id: %ld" application_id else Format.fprintf ppf "Wrong database application id: %ld" application_id
type 'a t = {
pool : (Caqti_lwt.connection, [> db_error ] as 'a) Caqti_lwt.Pool.t;
datadir : Fpath.t;
}
let realm = "builder-web" let realm = "builder-web"
let init_datadir datadir = let init_datadir datadir =
@ -30,33 +24,19 @@ let init_datadir datadir =
else Error (`Msg "Datadir does not exist")) >>= fun () -> else Error (`Msg "Datadir does not exist")) >>= fun () ->
Bos.OS.Dir.create ~path:false (Model.staging datadir) >>| fun _ -> () Bos.OS.Dir.create ~path:false (Model.staging datadir) >>| fun _ -> ()
let init ?(pool_size = 10) dbpath datadir = let init dbpath datadir =
Rresult.R.bind Rresult.R.bind (init_datadir datadir) @@ fun () ->
(init_datadir datadir) @@ Lwt_main.run (
fun () -> Caqti_lwt.connect
match Caqti_lwt.connect_pool (Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ())
~max_size:pool_size >>= fun (module Db : Caqti_lwt.CONNECTION) ->
(Uri.make ~scheme:"sqlite3" ~path:dbpath ~query:["create", ["false"]] ()) Db.find Builder_db.get_application_id () >>= fun application_id ->
with Db.find Builder_db.get_version () >>= (fun version ->
| Error e -> if (application_id, version) = Builder_db.(application_id, current_version)
Error e then Lwt_result.return ()
| Ok pool -> else Lwt_result.fail (`Wrong_version (application_id, version)))
Lwt_main.run (Caqti_lwt.Pool.use (fun (module Db : Caqti_lwt.CONNECTION) -> >>= fun () ->
Db.find Builder_db.get_application_id () >>= fun application_id -> Model.cleanup_staging datadir (module Db))
Db.find Builder_db.get_version () >>= (fun version ->
if (application_id, version) = Builder_db.(application_id, current_version)
then Lwt_result.return ()
else Lwt_result.fail (`Wrong_version (application_id, version)))
>>= fun () ->
Model.cleanup_staging datadir (module Db))
pool)
|> (function
| Error e -> Error (e :> [> db_error | `Wrong_version of int32 * int64 ])
| Ok () ->
Ok {
pool = (pool :> (Caqti_lwt.connection, [> db_error ]) Caqti_lwt.Pool.t);
datadir;
})
let pp_exec ppf (job, uuid, _, _, _, _, _) = let pp_exec ppf (job, uuid, _, _, _, _, _) =
Format.fprintf ppf "%s(%a)" job.Builder.name Uuidm.pp uuid Format.fprintf ppf "%s(%a)" job.Builder.name Uuidm.pp uuid
@ -78,45 +58,60 @@ let mime_lookup path =
then "application/octet-stream" then "application/octet-stream"
else Magic_mime.lookup (Fpath.to_string path) else Magic_mime.lookup (Fpath.to_string path)
let authorized t handler = fun req -> let authorized handler = fun req ->
let unauthorized = let unauthorized () =
Response.of_plain_text "Forbidden!\n" ~status:`Unauthorized let headers = ["WWW-Authenticate", Printf.sprintf "Basic realm=\"%s\"" realm] in
|> Response.add_header ("WWW-Authenticate", Auth.string_of_challenge (Basic realm)) Dream.respond ~headers ~status:`Unauthorized "Forbidden!"
in in
match Request.authorization req with match Dream.header "Authorization" req with
| None | Some (Other _) -> | None -> unauthorized ()
Lwt.return unauthorized | Some data -> match String.split_on_char ' ' data with
| Some (Basic (username, password)) -> | [ "Basic" ; user_pass ] ->
let* user_info = Caqti_lwt.Pool.use (Model.user username) t.pool in (match Base64.decode user_pass with
match user_info with | Error `Msg msg ->
| Ok (Some user_info) -> Log.info (fun m -> m "Invalid user / pasword encoding in %S: %S" data msg);
if Builder_web_auth.verify_password password user_info Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
then handler req | Ok user_pass -> match String.split_on_char ':' user_pass with
else Lwt.return unauthorized | [] | [_] ->
| Ok None -> Log.info (fun m -> m "Invalid user / pasword encoding in %S" data);
let _ : _ Builder_web_auth.user_info = Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
Builder_web_auth.hash ~username ~password () in | user :: password ->
Lwt.return unauthorized let pass = String.concat ":" password in
| Error e -> let* user_info = Dream.sql req (Model.user user) in
Log.warn (fun m -> m "Error getting user: %a" pp_error e); match user_info with
Response.of_plain_text "Internal server error\n" ~status:`Internal_server_error | Ok (Some user_info) ->
|> Lwt.return if Builder_web_auth.verify_password pass user_info
then handler req
else unauthorized ()
| Ok None ->
let _ : _ Builder_web_auth.user_info =
Builder_web_auth.hash ~username:user ~password:pass () in
unauthorized ()
| Error e ->
Log.warn (fun m -> m "Error getting user: %a" pp_error e);
Dream.respond ~status:`Internal_Server_Error "Internal server error")
| _ ->
Log.warn (fun m -> m "Error retrieving authorization %S" data);
Dream.respond ~status:`Bad_Request "Couldn't decode authorization"
let routes t = let string_of_html =
let builder _req = Format.asprintf "%a" (Tyxml.Html.pp ())
let* jobs = Caqti_lwt.Pool.use Model.jobs t.pool in
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 match jobs with
| Error e -> | Error e ->
Log.warn (fun m -> m "Error getting jobs: %a" pp_error e); Log.warn (fun m -> m "Error getting jobs: %a" pp_error e);
Response.of_plain_text ~status:`Internal_server_error Dream.respond ~status:`Internal_Server_Error "Error getting jobs"
"Error getting jobs"
|> Lwt.return
| Ok jobs -> | Ok jobs ->
let+ jobs = let* jobs =
List.fold_right List.fold_right
(fun (job_id, job_name) r -> (fun (job_id, job_name) r ->
r >>= fun acc -> r >>= fun acc ->
Caqti_lwt.Pool.use (Model.build_meta job_id) t.pool >>= function Dream.sql req (Model.build_meta job_id) >>= function
| Some (latest_build, latest_artifact) -> | Some (latest_build, latest_artifact) ->
Lwt_result.return ((job_name, latest_build, latest_artifact) :: acc) Lwt_result.return ((job_name, latest_build, latest_artifact) :: acc)
| None -> | None ->
@ -128,179 +123,161 @@ let routes t =
match jobs with match jobs with
| Error e -> | Error e ->
Log.warn (fun m -> m "Error getting jobs: %a" pp_error e); Log.warn (fun m -> m "Error getting jobs: %a" pp_error e);
Response.of_plain_text ~status:`Internal_server_error Dream.respond ~status:`Internal_Server_Error "Error getting jobs"
"Error getting jobs"
| Ok jobs -> | Ok jobs ->
Views.builder jobs |> Response.of_html Views.builder jobs |> string_of_html |> Dream.html
in in
let job req = let job req =
let job_name = Router.param req "job" in let job_name = Dream.param "job" req in
let+ job = let* job = Dream.sql req (Model.job job_name) in
Caqti_lwt.Pool.use (Model.job job_name) t.pool
in
match job with match job with
| Error e -> | Error e ->
Log.warn (fun m -> m "Error getting job: %a" pp_error e); Log.warn (fun m -> m "Error getting job: %a" pp_error e);
Response.of_plain_text ~status:`Internal_server_error Dream.respond ~status:`Internal_Server_Error "Error getting job"
"Error getting job"
| Ok builds -> | Ok builds ->
Views.job job_name builds |> Response.of_html Views.job job_name builds |> string_of_html |> Dream.html
in in
let job_build req = let job_build req =
let job_name = Router.param req "job" let job_name = Dream.param "job" req
and build = Router.param req "build" in and build = Dream.param "build" req in
match Uuidm.of_string build with match Uuidm.of_string build with
| None -> | None ->
Response.of_plain_text ~status:`Bad_request Dream.respond "Bad request." ~status:`Bad_Request
"Bad request.\n"
|> Lwt.return
| Some uuid -> | Some uuid ->
let+ data = let* data =
Caqti_lwt.Pool.use (Model.build uuid) t.pool >>= fun (build_id, build) -> Dream.sql req (Model.build uuid) >>= fun (build_id, build) ->
Caqti_lwt.Pool.use (Model.build_artifacts build_id) t.pool >>= fun artifacts -> Dream.sql req (Model.build_artifacts build_id) >>= fun artifacts ->
Caqti_lwt.Pool.use (Model.latest_build_uuid build.job_id) t.pool >>= fun latest_uuid -> Dream.sql req (Model.latest_build_uuid build.job_id) >>= fun latest_uuid ->
Caqti_lwt.Pool.use (Model.build_previous build_id) t.pool >|= fun previous_build -> Dream.sql req (Model.build_previous build_id) >|= fun previous_build ->
(build, artifacts, latest_uuid, previous_build) (build, artifacts, latest_uuid, previous_build)
in in
match data with match data with
| Error e -> | Error e ->
Log.warn (fun m -> m "Error getting job build: %a" pp_error e); Log.warn (fun m -> m "Error getting job build: %a" pp_error e);
Response.of_plain_text ~status:`Internal_server_error Dream.respond "Error getting job build" ~status:`Internal_Server_Error
"Error getting job build"
| Ok (build, artifacts, latest_uuid, previous_build) -> | Ok (build, artifacts, latest_uuid, previous_build) ->
Views.job_build job_name build artifacts latest_uuid previous_build |> Response.of_html Views.job_build job_name build artifacts latest_uuid previous_build |> string_of_html |> Dream.html
in in
let job_build_file req = let job_build_file req =
let _job_name = Router.param req "job" let _job_name = Dream.param "job" req
and build = Router.param req "build" and build = Dream.param "build" req
and filepath = Router.splat req |> String.concat "/" in and filepath = Dream.path req |> String.concat "/" in
(* XXX: We don't check safety of [file]. This should be fine however since (* 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 * 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. *) * lookup in the data table of the 'full' file. *)
match Uuidm.of_string build, Fpath.of_string filepath with match Uuidm.of_string build, Fpath.of_string filepath with
| None, _ -> | None, _ ->
Log.debug (fun m -> m "bad uuid: %s" build); Log.debug (fun m -> m "bad uuid: %s" build);
Response.of_plain_text ~status:`Not_found "File not found" Dream.respond ~status:`Not_Found "File not found"
|> Lwt.return
| _, Error (`Msg e) -> | _, Error (`Msg e) ->
Log.debug (fun m -> m "bad path: %s" e); Log.debug (fun m -> m "bad path: %s" e);
Response.of_plain_text ~status:`Not_found "File not found" Dream.respond ~status:`Not_Found "File not found"
|> Lwt.return
| Some build, Ok filepath -> | Some build, Ok filepath ->
let+ artifact = Caqti_lwt.Pool.use (Model.build_artifact build filepath) t.pool in let* artifact = Dream.sql req (Model.build_artifact build filepath) in
match artifact with match artifact with
| Error e -> | Error e ->
Log.warn (fun m -> m "Error getting build artifact: %a" pp_error e); Log.warn (fun m -> m "Error getting build artifact: %a" pp_error e);
Response.of_plain_text ~status:`Internal_server_error Dream.respond ~status:`Internal_Server_Error "Error getting build artifact"
"Error getting build artifact"
| Ok (data, digest) -> | Ok (data, digest) ->
let body = Body.of_string data in let headers = [
Response.make ~body () "Content-Type", mime_lookup filepath;
|> Response.add_header ("Content-type", mime_lookup filepath) "ETag",(Base64.encode_string (Cstruct.to_string digest));
|> Response.set_etag (Base64.encode_string (Cstruct.to_string digest)) ] in
Dream.respond ~headers data
in in
let upload req = let upload req =
let* body = Request.to_plain_text req in let* body = Dream.body req in
match Builder.Asn.exec_of_cs (Cstruct.of_string body) with match Builder.Asn.exec_of_cs (Cstruct.of_string body) with
| Error (`Msg e) -> | Error (`Msg e) ->
Log.warn (fun m -> m "Received bad builder ASN.1"); Log.warn (fun m -> m "Received bad builder ASN.1");
Log.debug (fun m -> m "Parse error: %s" e); Log.debug (fun m -> m "Parse error: %s" e);
Lwt.return (Response.of_plain_text "Bad request\n" ~status:`Bad_request) Dream.respond ~status:`Bad_Request "Bad request"
| Ok ((_, uuid, _, _, _, _, _) as exec) -> | Ok ((_, uuid, _, _, _, _, _) as exec) ->
Log.info (fun m -> m "Received build %a" pp_exec exec); Log.info (fun m -> m "Received build %a" pp_exec exec);
let* r = Caqti_lwt.Pool.use (Model.build_exists uuid) t.pool in let* r = Dream.sql req (Model.build_exists uuid) in
match r with match r with
| Error e -> | Error e ->
Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e); Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e);
Lwt.return (Response.of_plain_text "Internal server error\n" ~status:`Internal_server_error) Dream.respond ~status:`Internal_Server_Error "Internal server error"
| Ok true -> | Ok true ->
Log.warn (fun m -> m "Build with same uuid exists: %a" pp_exec exec); Log.warn (fun m -> m "Build with same uuid exists: %a" pp_exec exec);
Lwt.return (Response.of_plain_text Dream.respond ~status:`Conflict
(Fmt.strf "Build with same uuid exists: %a\n" Uuidm.pp uuid) (Fmt.strf "Build with same uuid exists: %a\n" Uuidm.pp uuid)
~status:`Conflict)
| Ok false -> | Ok false ->
let* r = Caqti_lwt.Pool.use (Model.add_build t.datadir exec) t.pool in let datadir = Dream.global datadir_global req in
let* r = Dream.sql req (Model.add_build datadir exec) in
match r with match r with
| Ok () -> | Ok () ->
Lwt.return (Response.of_plain_text "Success!\n") Dream.respond ""
| Error e -> | Error e ->
Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e); Log.warn (fun m -> m "Error saving build %a: %a" pp_exec exec pp_error e);
Lwt.return (Response.of_plain_text "Internal server error\n" ~status:`Internal_server_error) Dream.respond ~status:`Internal_Server_Error "Internal server error"
in in
let hash req = let hash req =
let hash_hex = Request.query "sha256" req in let hash_hex = Dream.query "sha256" req in
match Option.map (fun h -> Hex.to_cstruct (`Hex h)) hash_hex with match Option.map (fun h -> Hex.to_cstruct (`Hex h)) hash_hex with
| None -> | None ->
Log.debug (fun m -> m "sha256 query parameter not provided"); Log.debug (fun m -> m "sha256 query parameter not provided");
Response.of_plain_text "Bad request\n" ~status:`Bad_request Dream.respond ~status:`Bad_Request "Bad request"
|> Lwt.return
| Some hash -> | Some hash ->
let+ build = Caqti_lwt.Pool.use (Model.build_hash hash) t.pool in let* build = Dream.sql req (Model.build_hash hash) in
(match build with (match build with
| Error e -> | Error e ->
Log.warn (fun m -> m "Database error: %a" pp_error e); Log.warn (fun m -> m "Database error: %a" pp_error e);
Response.of_plain_text "Internal server error\n" ~status:`Internal_server_error Dream.respond ~status:`Internal_Server_Error "Internal server error"
| Ok None -> | Ok None ->
Log.debug (fun m -> m "Hash not found: %S" (Request.query_exn "sha256" req)); Log.debug (fun m -> m "Hash not found: %S" (Option.get hash_hex));
Response.of_plain_text "Artifact not found\n" ~status:`Not_found Dream.respond ~status:`Not_Found "Artifact not found"
| Ok (Some (job_name, build)) -> | Ok (Some (job_name, build)) ->
Response.redirect_to (Fmt.strf "/job/%s/build/%a/" job_name Dream.redirect req
Uuidm.pp build.Builder_db.Build.uuid)) (Fmt.strf "/job/%s/build/%a/" job_name Uuidm.pp build.Builder_db.Build.uuid))
| exception Invalid_argument _ -> | exception Invalid_argument _ ->
Log.debug (fun m -> m "Invalid hash hex %S" (Request.query_exn "sha256" req)); Log.debug (fun m -> m "Invalid hash hex %S" (Option.get hash_hex));
Response.of_plain_text "Bad request\n" ~status:`Bad_request Dream.respond ~status:`Bad_Request "Bad request"
|> Lwt.return
in in
let compare_opam req = let compare_opam req =
let build_left = Router.param req "build_left" in let build_left = Dream.param "build_left" req in
let build_right = Router.param req "build_right" in let build_right = Dream.param "build_right" req in
match Uuidm.of_string build_left, Uuidm.of_string build_right with match Uuidm.of_string build_left, Uuidm.of_string build_right with
| None, _ | _, None -> | None, _ | _, None ->
Response.of_plain_text "Bad request" ~status:`Bad_request Dream.respond ~status:`Bad_Request "Bad request"
|> Lwt.return
| Some build_left, Some build_right -> | Some build_left, Some build_right ->
let+ r = let* r =
Caqti_lwt.Pool.use (Model.build_artifact build_left (Fpath.v "opam-switch")) Dream.sql req (Model.build_artifact build_left (Fpath.v "opam-switch"))
t.pool >>= fun switch_left -> >>= fun switch_left ->
Caqti_lwt.Pool.use (Model.build_artifact build_right (Fpath.v "opam-switch")) Dream.sql req (Model.build_artifact build_right (Fpath.v "opam-switch"))
t.pool >>= fun switch_right -> >>= fun switch_right ->
Caqti_lwt.Pool.use (Model.build build_left) t.pool >>= fun (_id, build_left) -> Dream.sql req (Model.build build_left) >>= fun (_id, build_left) ->
Caqti_lwt.Pool.use (Model.build build_right) t.pool >>= fun (_id, build_right) -> Dream.sql req (Model.build build_right) >>= fun (_id, build_right) ->
Caqti_lwt.Pool.use (Model.job_name build_left.job_id) t.pool >>= fun job_left -> Dream.sql req (Model.job_name build_left.job_id) >>= fun job_left ->
Caqti_lwt.Pool.use (Model.job_name build_right.job_id) t.pool >>= fun job_right -> 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) Lwt_result.return (job_left, job_right, build_left, build_right, switch_left, switch_right)
in in
match r with match r with
| Error e -> | Error e ->
Log.warn (fun m -> m "Database error: %a" pp_error e); Log.warn (fun m -> m "Database error: %a" pp_error e);
Response.of_plain_text "Internal server error\n" ~status:`Internal_server_error Dream.respond ~status:`Internal_Server_Error "Internal server error"
| Ok (job_left, job_right, build_left, build_right, | Ok (job_left, job_right, build_left, build_right,
(switch_left, _sha256_left), (switch_right, _sha256_right)) -> (switch_left, _sha256_left), (switch_right, _sha256_right)) ->
let switch_left = OpamFile.SwitchExport.read_from_string switch_left let switch_left = OpamFile.SwitchExport.read_from_string switch_left
and switch_right = OpamFile.SwitchExport.read_from_string switch_right in and switch_right = OpamFile.SwitchExport.read_from_string switch_right in
Opamdiff.compare switch_left switch_right Opamdiff.compare switch_left switch_right
|> Views.compare_opam job_left job_right build_left build_right |> Views.compare_opam job_left job_right build_left build_right
|> Response.of_html |> string_of_html |> Dream.html
in in
[ Dream.router [
App.get "/" builder; Dream.get "/" builder;
App.get "/job/:job/" job; Dream.get "/job/:job/" job;
App.get "/job/:job/build/:build/" job_build; Dream.get "/job/:job/build/:build/" job_build;
App.get "/job/:job/build/:build/f/**" job_build_file; Dream.get "/hash" hash;
App.post "/upload" (authorized t upload); Dream.get "/job/:job/build/:build/f/**" job_build_file;
App.get "/hash" hash; Dream.post "/upload" (authorized upload);
App.get "/compare/:build_left/:build_right/opam-switch" compare_opam; Dream.get "/compare/:build_left/:build_right/opam-switch" compare_opam;
] ]
let add_routes t (app : App.t) =
List.fold_right
(fun route app -> route app)
(routes t)
app

2
lib/dune
View file

@ -1,3 +1,3 @@
(library (library
(name builder_web) (name builder_web)
(libraries builder builder_db opium tyxml bos rresult duration hex caqti-lwt opamdiff)) (libraries builder builder_db dream tyxml bos rresult duration hex caqti-lwt opamdiff))