Reynir Björnsson
3de78b1113
- Dream.path is deprecated. For now the deprecation is suppressed. - Remove unused dream_svg. - Remove datadir global. The datadir variable is in scope already, and global variables were removed in alpha3. - Dream_tar.tar_response: flush before closing. It's unclear if this is necessary. - Change Builder_web.add_routes to Builder_web.routes returning a list of routes, and in Builder_web_app construct the router. - Builder_web.not_found is removed due to changes in Dream.router. It seems an error handler might be the way forward.
44 lines
1.5 KiB
OCaml
44 lines
1.5 KiB
OCaml
open Lwt.Infix
|
|
|
|
module Writer = struct
|
|
type out_channel = Dream.stream
|
|
type 'a t = 'a Lwt.t
|
|
let really_write stream cs =
|
|
Dream.write stream (Cstruct.to_string cs)
|
|
end
|
|
|
|
module HW = Tar.HeaderWriter(Lwt)(Writer)
|
|
|
|
let write_block (header : Tar.Header.t) lpath stream =
|
|
HW.write ~level:Tar.Header.Ustar header stream >>= 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 stream (Bytes.sub_string buf 0 r) >>= fun () ->
|
|
loop ()
|
|
in
|
|
loop () >>= fun () ->
|
|
Dream.write stream (Cstruct.to_string (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) (stream : Dream.stream) =
|
|
Lwt_list.iter_s (fun file ->
|
|
let hdr = header_of_file finish file in
|
|
write_block hdr Fpath.(datadir // file.localpath) stream)
|
|
files >>= fun () ->
|
|
Writer.really_write stream Tar.Header.zero_block >>= fun () ->
|
|
Writer.really_write stream Tar.Header.zero_block >>= fun () ->
|
|
Dream.flush stream >>= fun () ->
|
|
Dream.close stream
|