diff --git a/builder-web.opam b/builder-web.opam index e205641..07ad60e 100644 --- a/builder-web.opam +++ b/builder-web.opam @@ -47,6 +47,7 @@ depends: [ "uri" "fmt" {>= "0.8.7"} "omd" + "tar" ] synopsis: "Web interface for builder" diff --git a/lib/builder_web.ml b/lib/builder_web.ml index 3d88525..3f94e84 100644 --- a/lib/builder_web.ml +++ b/lib/builder_web.ml @@ -254,6 +254,23 @@ let add_routes datadir = Views.failed_builds ~start ~count builds |> string_of_html |> Dream.html |> Lwt_result.ok in + let job_build_tar req = + let datadir = Dream.global datadir_global req in + let _job_name = Dream.param "job" req + and build = Dream.param "build" req in + get_uuid build >>= fun build -> + Dream.sql req (Model.build build) + |> if_error "Error getting build" >>= fun (build_id, build) -> + Dream.sql req (Model.build_artifacts build_id) + |> if_error "Error getting artifacts" >>= fun artifacts -> + Ptime.diff build.finish Ptime.epoch |> Ptime.Span.to_int_s + |> Option.to_result ~none:(`Msg "bad finish time") |> Result.map Int64.of_int + |> Lwt.return |> if_error "Internal server error" >>= fun finish -> + Dream.stream ~headers:["Content-Type", "application/x-tar"] + (Dream_tar.tar_response datadir finish artifacts) + |> Lwt_result.ok + in + let upload req = let* body = Dream.body req in Builder.Asn.exec_of_cs (Cstruct.of_string body) |> Lwt.return @@ -390,6 +407,7 @@ let add_routes datadir = Dream.get "/job/:job/build/:build/script" (w (job_build_static_file `Script)); Dream.get "/job/:job/build/:build/console" (w (job_build_static_file `Console)); Dream.get "/failed-builds/" (w failed_builds); + Dream.get "/job/:job/build/:build/all.tar" (w job_build_tar); Dream.get "/hash" (w hash); Dream.get "/compare/:build_left/:build_right/" (w compare_builds); Dream.post "/upload" (Authorization.authenticate (w upload)); diff --git a/lib/dream_tar.ml b/lib/dream_tar.ml new file mode 100644 index 0000000..56f4f67 --- /dev/null +++ b/lib/dream_tar.ml @@ -0,0 +1,43 @@ +open Lwt.Infix + +module Writer = struct + type out_channel = Dream.response + type 'a t = 'a Lwt.t + let really_write response cs = + Dream.write response (Cstruct.to_string cs) +end + +module HW = Tar.HeaderWriter(Lwt)(Writer) + +let write_block (header : Tar.Header.t) lpath response = + HW.write ~level:Tar.Header.Ustar header response >>= fun () -> + Lwt_io.open_file ~mode:Lwt_io.Input (Fpath.to_string lpath) >>= fun ic -> + let buf_len = 4 * 1024 * 1024 in + let buf = Bytes.create buf_len in + let rec loop () = + Lwt_io.read_into ic buf 0 buf_len >>= fun r -> + if r = 0 then + Lwt.return_unit + else + Dream.write response (Bytes.sub_string buf 0 r) >>= fun () -> + loop () + in + loop () >>= fun () -> + Dream.write_buffer response (Cstruct.to_bigarray (Tar.Header.zero_padding header)) + +let header_of_file mod_time (file : Builder_db.file) = + let file_mode = if Fpath.is_prefix Fpath.(v "bin/") file.filepath then + 0o755 + else + 0o644 + in + Tar.Header.make ~file_mode ~mod_time (Fpath.to_string file.filepath) (Int64.of_int file.size) + +let tar_response datadir finish (files : Builder_db.file list) (response : Dream.response) = + Lwt_list.iter_s (fun file -> + let hdr = header_of_file finish file in + write_block hdr Fpath.(datadir // file.localpath) response) + files >>= fun () -> + Writer.really_write response Tar.Header.zero_block >>= fun () -> + Writer.really_write response Tar.Header.zero_block >>= fun () -> + Dream.close_stream response diff --git a/lib/dune b/lib/dune index 5c950f8..6af0763 100644 --- a/lib/dune +++ b/lib/dune @@ -1,3 +1,3 @@ (library (name builder_web) - (libraries builder builder_db dream tyxml bos duration hex caqti-lwt opamdiff ptime.clock.os omd)) + (libraries builder builder_db dream tyxml bos duration hex caqti-lwt opamdiff ptime.clock.os omd tar))