Source file `archive_extract.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
open Lwt.Infix

let invoke_fetcher base destdir =
  Os.with_pipe_between_children @@ fun ~r ~w ->
    let stdin = `FD_move_safely r in
    let stdout = `FD_move_safely w in
    let stderr = stdout in
    let fetcher =
      Os.exec ~stdout ~stderr ["fetch"; "-q" ; "-o" ; "-" ; base ]
    in
    let extracter =
      Os.sudo ~stdin [ "tar" ; "-C"; destdir ; "-xzpf"; "-" ]
    in
    fetcher >>= fun () ->
    extracter

let fetch ~log:_ ~root:_ ~rootfs base =
  Lwt.catch
    (fun () ->
     invoke_fetcher base rootfs >>= fun () ->
     let env = [] in
     Lwt.return env)
    (function
     | Sys_error s ->
       Fmt.failwith "Archive fetcher encountered a system error: %s" s
     | ex -> Lwt.reraise ex)