652 lines
21 KiB
OCaml
652 lines
21 KiB
OCaml
(*
|
|
* Copyright (c) 2013-2020 Thomas Gazagnaire <thomas@gazagnaire.org>
|
|
* Copyright (c) 2013-2020 Anil Madhavapeddy <anil@recoil.org>
|
|
* Copyright (c) 2015-2020 Gabriel Radanne <drupyog@zoho.com>
|
|
* Copyright (c) 2019-2020 Etienne Millon <etienne@tarides.com>
|
|
*
|
|
* Permission to use, copy, modify, and distribute this software for any
|
|
* purpose with or without fee is hereby granted, provided that the above
|
|
* copyright notice and this permission notice appear in all copies.
|
|
*
|
|
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
*)
|
|
|
|
let src = Logs.Src.create "functoria.action" ~doc:"functoria library"
|
|
|
|
module Log = (val Logs.src_log src : Logs.LOG)
|
|
open Astring
|
|
|
|
type 'a or_err = ('a, Rresult.R.msg) result
|
|
type tmp_name_pat = Bos.OS.File.tmp_name_pat
|
|
|
|
type 'a with_output = {
|
|
mode : int option;
|
|
path : Fpath.t;
|
|
purpose : string;
|
|
contents : Format.formatter -> 'a;
|
|
append : bool;
|
|
}
|
|
|
|
type channel = [ `Null | `Fmt of Format.formatter ]
|
|
type cmd = { cmd : Bos.Cmd.t; err : channel; out : channel; trim : bool }
|
|
type ls = { root : Fpath.t; filter : Fpath.t -> bool }
|
|
|
|
type _ command =
|
|
| Rmdir : Fpath.t -> unit command
|
|
| Mkdir : Fpath.t -> bool command
|
|
| Ls : ls -> Fpath.t list command
|
|
| Rm : Fpath.t -> unit command
|
|
| Is_file : Fpath.t -> bool command
|
|
| Is_dir : Fpath.t -> bool command
|
|
| Size_of : Fpath.t -> int option command
|
|
| Run_cmd : cmd -> unit command
|
|
| Run_cmd_out : cmd -> string command
|
|
| Run_cmd_cli : Bos.Cmd.t -> unit command
|
|
| Get_var : string -> string option command
|
|
| Set_var : string * string option -> unit command
|
|
| With_dir : Fpath.t * (unit -> 'a t) -> 'a command
|
|
| Pwd : Fpath.t command
|
|
| Tmp_file : int option * tmp_name_pat -> Fpath.t command
|
|
| Write_file : Fpath.t * string -> unit command
|
|
| Read_file : Fpath.t -> string command
|
|
| With_output : 'a with_output -> 'a command
|
|
|
|
and _ t =
|
|
| Done : 'a -> 'a t
|
|
| Fail : string -> 'a t
|
|
| Run : 'r command * ('r -> 'a t) -> 'a t
|
|
|
|
let ok x = Done x
|
|
let error e = Fail e
|
|
let errorf fmt = Fmt.kstr error fmt
|
|
|
|
let rec bind ~f = function
|
|
| Done r -> f r
|
|
| Fail s -> Fail s
|
|
| Run (c, k) ->
|
|
let k2 r = bind ~f (k r) in
|
|
Run (c, k2)
|
|
|
|
let map ~f x = bind x ~f:(fun y -> ok (f y))
|
|
let rec seq = function [] -> ok () | h :: t -> bind ~f:(fun () -> seq t) h
|
|
let wrap x = Run (x, ok)
|
|
let ( ! ) = Fpath.normalize
|
|
let rm path = wrap @@ Rm !path
|
|
let rmdir path = wrap @@ Rmdir !path
|
|
let mkdir path = wrap @@ Mkdir !path
|
|
let ls path filter = wrap @@ Ls { root = !path; filter }
|
|
let with_dir path f = wrap @@ With_dir (!path, f)
|
|
let pwd () = wrap @@ Pwd
|
|
let is_file path = wrap @@ Is_file !path
|
|
let is_dir path = wrap @@ Is_dir !path
|
|
let size_of path = wrap @@ Size_of !path
|
|
let set_var c v = wrap @@ Set_var (c, v)
|
|
let get_var c = wrap @@ Get_var c
|
|
|
|
let run_cmd ?(err = `Fmt Fmt.stderr) ?(out = `Fmt Fmt.stdout) cmd =
|
|
wrap @@ Run_cmd { cmd; out; err; trim = false }
|
|
|
|
let run_cmd_out ?(err = `Fmt Fmt.stderr) cmd =
|
|
wrap @@ Run_cmd_out { cmd; out = `Null; err; trim = true }
|
|
|
|
let run_cmd_cli cmd = wrap @@ Run_cmd_cli cmd
|
|
let write_file path contents = wrap @@ Write_file (!path, contents)
|
|
let read_file path = wrap @@ Read_file !path
|
|
let tmp_file ?mode pat = wrap @@ Tmp_file (mode, pat)
|
|
|
|
let with_output ?mode ?(append = false) ~path ~purpose contents =
|
|
wrap @@ With_output { append; mode; path; purpose; contents }
|
|
|
|
let pfo ppf s = match ppf with `Null -> () | `Fmt ppf -> Fmt.pf ppf "%s%!" s
|
|
|
|
let interpret_cmd { cmd; err; out; trim } =
|
|
Log.debug (fun l -> l "RUN: %a" Bos.Cmd.pp cmd);
|
|
let open Rresult in
|
|
let err =
|
|
match err with
|
|
| `Null -> Ok (Bos.OS.Cmd.err_null, fun () -> Ok ())
|
|
| `Fmt ppf ->
|
|
Bos.OS.File.tmp "cmd-err-%s" >>| fun path ->
|
|
let flush () = Bos.OS.File.read path >>| fun s -> Fmt.pf ppf "%s%!" s in
|
|
(Bos.OS.Cmd.err_file path, flush)
|
|
in
|
|
err >>= fun (err, flush_err) ->
|
|
let res = Bos.OS.Cmd.run_out ~err cmd in
|
|
let res = Bos.OS.Cmd.out_string ~trim res in
|
|
res >>= fun (str_out, _) ->
|
|
pfo out str_out;
|
|
flush_err () >>= fun () -> Bos.OS.Cmd.success res
|
|
|
|
let interpret_cmd_cli cmd =
|
|
Log.debug (fun l -> l "RUN-CLI: %a" Bos.Cmd.pp cmd);
|
|
let res = Bos.OS.Cmd.run_out cmd in
|
|
match Bos.OS.Cmd.out_stdout res with
|
|
| Ok ((), (_, `Exited 0)) -> Ok ()
|
|
| Ok ((), (_, `Exited _)) -> Error (`Msg "")
|
|
| failure -> Bos.OS.Cmd.success failure
|
|
|
|
let rec interpret_command : type r. r command -> r or_err = function
|
|
| Rmdir path ->
|
|
Log.debug (fun l -> l "rmdir %a" Fpath.pp path);
|
|
Bos.OS.Dir.delete ~recurse:true path
|
|
| Mkdir path ->
|
|
Log.debug (fun l -> l "mkdir %a" Fpath.pp path);
|
|
Bos.OS.Dir.create ~path:true path
|
|
| Ls { root; filter } ->
|
|
let open Rresult in
|
|
Log.debug (fun l -> l "ls %a" Fpath.pp root);
|
|
Bos.OS.Path.matches ~dotfiles:true Fpath.(root / "$(file)")
|
|
>>| fun files -> List.filter filter files
|
|
| Rm path ->
|
|
Log.debug (fun l -> l "rm %a" Fpath.pp path);
|
|
Bos.OS.File.delete ~must_exist:false path
|
|
| Is_file path ->
|
|
Log.debug (fun l -> l "is-file %a" Fpath.pp path);
|
|
Bos.OS.File.exists path
|
|
| Is_dir path ->
|
|
Log.debug (fun l -> l "is-dir %a" Fpath.pp path);
|
|
Bos.OS.Dir.exists path
|
|
| Size_of path -> (
|
|
Log.debug (fun l -> l "size-of %a" Fpath.pp path);
|
|
match Bos.OS.Path.stat path with
|
|
| Ok s -> Ok (Some s.Unix.st_size)
|
|
| _ -> Ok None)
|
|
| Run_cmd cmd -> Rresult.(interpret_cmd cmd >>| fun _ -> ())
|
|
| Run_cmd_out cmd -> interpret_cmd cmd
|
|
| Run_cmd_cli cmd -> interpret_cmd_cli cmd
|
|
| Set_var (c, v) ->
|
|
Log.debug (fun l ->
|
|
l "set_var %s %a" c Fmt.(option ~none:(any "<unset>") string) v);
|
|
Bos.OS.Env.set_var c v
|
|
| Get_var c ->
|
|
Log.debug (fun l -> l "get_var %s" c);
|
|
Ok (Bos.OS.Env.var c)
|
|
| With_dir (dir, f) ->
|
|
let f () = run (f ()) in
|
|
let open Rresult in
|
|
Bos.OS.Dir.current () >>= fun old ->
|
|
Log.debug (fun l -> l "entering %a" Fpath.pp dir);
|
|
Rresult.R.join @@ Bos.OS.Dir.with_current dir f () >>| fun r ->
|
|
Log.debug (fun l -> l "entering %a" Fpath.pp old);
|
|
r
|
|
| Pwd ->
|
|
Log.debug (fun l -> l "pwd");
|
|
Bos.OS.Dir.current ()
|
|
| Write_file (path, contents) ->
|
|
Log.debug (fun l -> l "write %a" Fpath.pp path);
|
|
Bos.OS.File.write path contents
|
|
| Read_file path ->
|
|
Log.debug (fun l -> l "read-file %a" Fpath.pp path);
|
|
Bos.OS.File.read path
|
|
| Tmp_file (mode, pat) ->
|
|
Log.debug (fun l -> l "tmp-file %s" Fmt.(str pat "*"));
|
|
Bos.OS.File.tmp ?mode pat
|
|
| With_output { mode; path; purpose; contents; append } -> (
|
|
try
|
|
let oc =
|
|
let path = Fpath.to_string path in
|
|
let mode = match mode with None -> 0o666 | Some m -> m in
|
|
if append then
|
|
open_out_gen [ Open_wronly; Open_append; Open_text ] mode path
|
|
else open_out path
|
|
in
|
|
let ppf = Format.formatter_of_out_channel oc in
|
|
let r = contents ppf in
|
|
Fmt.pf ppf "%!";
|
|
flush oc;
|
|
close_out oc;
|
|
Ok r
|
|
with e ->
|
|
Rresult.R.error_msgf "couldn't open output channel for %s: %a" purpose
|
|
Fmt.exn e)
|
|
|
|
and run : type r. r t -> r or_err = function
|
|
| Done r -> Ok r
|
|
| Fail f -> Error (`Msg f)
|
|
| Run (cmd, k) -> Rresult.R.bind (interpret_command cmd) (fun x -> run @@ k x)
|
|
|
|
type files = [ `Passtrough of Fpath.t | `Files of (Fpath.t * string) list ]
|
|
|
|
let default_exec cmd =
|
|
let cmd =
|
|
Fmt.str "$(%a)\n" Fmt.(list ~sep:(any " ") string) (Bos.Cmd.to_list cmd)
|
|
in
|
|
Some (cmd, "")
|
|
|
|
(* (simple) virtual environment *)
|
|
module Env : sig
|
|
type t
|
|
|
|
val eq : t -> t -> bool
|
|
val pp : t Fmt.t
|
|
val diff_files : old:t -> t -> Fpath.Set.t
|
|
val pwd : t -> Fpath.t
|
|
val chdir : t -> Fpath.t -> t
|
|
val ls : t -> Fpath.t -> Fpath.t list option
|
|
|
|
val v :
|
|
?exec:(Bos.Cmd.t -> (string * string) option) ->
|
|
?env:(string * string) list ->
|
|
?pwd:Fpath.t ->
|
|
?files:files ->
|
|
unit ->
|
|
t
|
|
|
|
val exec : t -> Bos.Cmd.t -> (string * string) option
|
|
val is_file : t -> Fpath.t -> bool
|
|
val is_dir : t -> Fpath.t -> bool
|
|
val mkdir : t -> Fpath.t -> (t * bool) option
|
|
val rm : t -> Fpath.t -> (t * bool) option
|
|
val rmdir : t -> Fpath.t -> t
|
|
val size_of : t -> Fpath.t -> int option
|
|
val write : t -> Fpath.t -> string -> t
|
|
val read : t -> Fpath.t -> string option
|
|
val tmp_file : t -> tmp_name_pat -> Fpath.t
|
|
val set_var : t -> string -> string option -> t
|
|
val get_var : t -> string -> string option
|
|
end = struct
|
|
type t = {
|
|
files : string Fpath.Map.t;
|
|
pwd : Fpath.t;
|
|
env : string String.Map.t;
|
|
exec : Bos.Cmd.t -> (string * string) option;
|
|
}
|
|
|
|
let diff_files ~old t =
|
|
let to_set t =
|
|
Fpath.Map.fold
|
|
(fun f _ acc ->
|
|
match Fpath.rem_prefix t.pwd f with
|
|
| None -> acc
|
|
| Some f -> Fpath.Set.add f acc)
|
|
t.files Fpath.Set.empty
|
|
in
|
|
Fpath.Set.diff (to_set t) (to_set old)
|
|
|
|
let scan dir =
|
|
(let open Rresult in
|
|
Bos.OS.Path.fold ~dotfiles:true ~elements:`Files ~traverse:`Any
|
|
(fun file files ->
|
|
files >>= fun files ->
|
|
Bos.OS.File.read file >>| fun c -> (file, c) :: files)
|
|
(Ok []) [ dir ])
|
|
|> Rresult.R.join
|
|
|> Rresult.R.error_msg_to_invalid_arg
|
|
|
|
let v ?(exec = default_exec) ?env ?pwd ?(files = `Files []) () =
|
|
let env =
|
|
match env with Some e -> String.Map.of_list e | None -> String.Map.empty
|
|
in
|
|
let pwd = match pwd with None -> Fpath.v "/" | Some p -> p in
|
|
let files =
|
|
let files =
|
|
match files with `Passtrough dir -> scan dir | `Files files -> files
|
|
in
|
|
let files =
|
|
List.map
|
|
(fun (f, c) ->
|
|
match Fpath.is_rel f with
|
|
| false -> (f, c)
|
|
| true -> (Fpath.(pwd // f), c))
|
|
files
|
|
in
|
|
List.map (fun (f, c) -> (Fpath.normalize f, c)) files
|
|
in
|
|
{ files = Fpath.Map.of_list files; pwd; env; exec }
|
|
|
|
let eq x y =
|
|
Fpath.Map.equal ( = ) x.files y.files
|
|
&& Fpath.equal x.pwd y.pwd
|
|
&& String.Map.equal ( = ) x.env y.env
|
|
|
|
let pp =
|
|
let open Fmt.Dump in
|
|
record
|
|
[
|
|
field "files" (fun t -> t.files) (Fpath.Map.dump string);
|
|
field "pwd" (fun t -> t.pwd) Fpath.dump;
|
|
field "env" (fun t -> t.env) (String.Map.dump string);
|
|
]
|
|
|
|
let pwd t = t.pwd
|
|
let exec t cmd = t.exec cmd
|
|
|
|
let mk_path t path =
|
|
match (Fpath.to_string t.pwd, Fpath.is_rel path) with
|
|
| _, true -> Fpath.(normalize @@ (t.pwd // path))
|
|
| _, false -> Fpath.normalize path
|
|
|
|
let chdir t path =
|
|
let pwd = mk_path t path in
|
|
{ t with pwd }
|
|
|
|
let is_root path = Fpath.to_string path = "/"
|
|
|
|
let mkdir t path =
|
|
let path = mk_path t path in
|
|
if is_root path then Some (t, false)
|
|
else
|
|
match Fpath.Map.find path t.files with
|
|
| Some f when f <> "<DIR>" -> None
|
|
| r ->
|
|
let t = { t with files = Fpath.Map.add path "<DIR>" t.files } in
|
|
Some (t, r = None)
|
|
|
|
let rmdir t path =
|
|
let path = mk_path t path in
|
|
let files =
|
|
Fpath.Map.filter
|
|
(fun f _ ->
|
|
let f = mk_path t f in
|
|
let b = not (Fpath.is_prefix path f) in
|
|
b)
|
|
t.files
|
|
in
|
|
{ t with files }
|
|
|
|
let ls t path =
|
|
let root = mk_path t path in
|
|
match Fpath.Map.find root t.files with
|
|
| Some "<DIR>" -> Some []
|
|
| Some _ -> Some [ path ]
|
|
| None -> (
|
|
Fpath.Map.fold
|
|
(fun file _ acc ->
|
|
let file = mk_path t file in
|
|
match Fpath.relativize ~root file with
|
|
| None -> acc
|
|
| Some f -> f :: acc)
|
|
t.files []
|
|
|> function
|
|
| [] -> None
|
|
| x -> Some (List.rev x))
|
|
|
|
let write t path f =
|
|
let path = mk_path t path in
|
|
{ t with files = Fpath.Map.add path f t.files }
|
|
|
|
let read t path =
|
|
let path = mk_path t path in
|
|
Fpath.Map.find path t.files
|
|
|
|
let tmp_file t pat =
|
|
let rec aux n =
|
|
let dir = Fpath.v "/tmp" in
|
|
let file = Fpath.(dir / Fmt.str pat (string_of_int n)) in
|
|
if Fpath.Map.mem file t.files then aux (n + 1) else file
|
|
in
|
|
aux 0
|
|
|
|
let is_dir t path =
|
|
let path = mk_path t path in
|
|
match Fpath.Map.find path t.files with
|
|
| Some "<DIR>" -> true
|
|
| Some _ -> false
|
|
| None ->
|
|
Fpath.Map.exists
|
|
(fun f _ ->
|
|
let f = mk_path t f in
|
|
Fpath.is_prefix path f)
|
|
t.files
|
|
|
|
let is_file t path =
|
|
let path = mk_path t path in
|
|
match Fpath.Map.find path t.files with
|
|
| Some "<DIR>" | None -> false
|
|
| Some _ -> true
|
|
|
|
let rm t path =
|
|
let path = mk_path t path in
|
|
match Fpath.Map.find path t.files with
|
|
| Some "<DIR>" -> None
|
|
| Some _ -> Some ({ t with files = Fpath.Map.remove path t.files }, true)
|
|
| None -> if is_dir t path then None else Some (t, false)
|
|
|
|
let size_of t path =
|
|
let path = mk_path t path in
|
|
match Fpath.Map.find path t.files with
|
|
| None -> None
|
|
| Some "<DIR>" -> Some 0
|
|
| Some f -> Some (String.length f)
|
|
|
|
let set_var t c = function
|
|
| None -> { t with env = String.Map.remove c t.env }
|
|
| Some v -> { t with env = String.Map.add c v t.env }
|
|
|
|
let get_var t c = String.Map.find c t.env
|
|
end
|
|
|
|
let error_msg = Rresult.R.error_msgf
|
|
|
|
type env = Env.t
|
|
|
|
let env = Env.v
|
|
|
|
type 'a domain = { result : 'a or_err; env : Env.t; logs : string list }
|
|
|
|
let pp_or_err pp_a = Rresult.R.pp ~error:Rresult.R.pp_msg ~ok:pp_a
|
|
let eq_or_err eq_a = Rresult.R.equal ~error:( = ) ~ok:eq_a
|
|
|
|
let pp_domain pp_a =
|
|
let open Fmt.Dump in
|
|
record
|
|
[
|
|
field "result" (fun t -> t.result) (pp_or_err pp_a);
|
|
field "env" (fun t -> t.env) Env.pp;
|
|
field "logs" (fun t -> t.logs) Fmt.Dump.(list string);
|
|
]
|
|
|
|
let eq_domain eq a b =
|
|
eq_or_err eq a.result b.result && Env.eq a.env b.env && a.logs = b.logs
|
|
|
|
let dom result env logs = { result; env; logs }
|
|
|
|
let interpret_dry_cmd env { cmd; err; out; _ } : string domain =
|
|
Log.debug (fun l -> l "Run_cmd '%a'" Bos.Cmd.pp cmd);
|
|
let log x = Fmt.str "Run_cmd '%a' (%s)" Bos.Cmd.pp cmd x in
|
|
match Env.exec env cmd with
|
|
| None -> dom (error_msg "'%a' not found" Bos.Cmd.pp cmd) env [ log "error" ]
|
|
| Some (o, e) ->
|
|
pfo out o;
|
|
pfo err e;
|
|
dom (Ok o) env [ log "ok" ]
|
|
|
|
let interpret_dry_cmd_cli env cmd : unit domain =
|
|
Log.debug (fun l -> l "Run_cmd_cli '%a'" Bos.Cmd.pp cmd);
|
|
let log x = Fmt.str "Run_cmd_cli '%a' (%s)" Bos.Cmd.pp cmd x in
|
|
match Env.exec env cmd with
|
|
| None -> dom (error_msg "'%a' not found" Bos.Cmd.pp cmd) env [ log "error" ]
|
|
| Some _ -> dom (Ok ()) env [ log "ok" ]
|
|
|
|
let rec interpret_dry : type r. env:Env.t -> r command -> r domain =
|
|
fun ~env -> function
|
|
| Mkdir path -> (
|
|
Log.debug (fun l -> l "Mkdir %a" Fpath.pp path);
|
|
let log s = Fmt.str "Mkdir %a (%s)" Fpath.pp path s in
|
|
match Env.mkdir env path with
|
|
| Some (env, true) -> dom (Ok true) env [ log "created" ]
|
|
| Some (env, false) -> dom (Ok false) env [ log "already exists" ]
|
|
| None ->
|
|
dom
|
|
(error_msg "a file named '%a' already exists" Fpath.pp path)
|
|
env
|
|
[ log "error" ])
|
|
| Rmdir path ->
|
|
Log.debug (fun l -> l "Rmdir %a" Fpath.pp path);
|
|
let log s = Fmt.str "Rmdir %a (%s)" Fpath.pp path s in
|
|
if Env.is_dir env path || Env.is_file env path then
|
|
dom (Ok ()) (Env.rmdir env path) [ log "removed" ]
|
|
else dom (Ok ()) env [ log "no-op" ]
|
|
| Ls { root; filter } -> (
|
|
Log.debug (fun l -> l "Ls %a" Fpath.pp root);
|
|
let logs fmt = Fmt.kstr (Fmt.str "Ls %a (%s)" Fpath.pp root) fmt in
|
|
match Env.ls env root with
|
|
| None ->
|
|
dom
|
|
(error_msg "%a: no such file or directory" Fpath.pp root)
|
|
env
|
|
[ logs "error" ]
|
|
| Some es -> (
|
|
match List.filter filter es with
|
|
| ([] | [ _ ]) as e ->
|
|
dom (Ok e) env [ logs "%d entry" (List.length e) ]
|
|
| es -> dom (Ok es) env [ logs "%d entries" (List.length es) ]))
|
|
| Rm path -> (
|
|
Log.debug (fun l -> l "Rm %a" Fpath.pp path);
|
|
let log s = Fmt.str "Rm %a (%s)" Fpath.pp path s in
|
|
match Env.rm env path with
|
|
| Some (env, b) ->
|
|
dom (Ok ()) env [ log (if b then "removed" else "no-op") ]
|
|
| None ->
|
|
dom (error_msg "%a is a directory" Fpath.pp path) env [ log "error" ])
|
|
| Is_file path ->
|
|
Log.debug (fun l -> l "Is_file %a" Fpath.pp path);
|
|
let r = Env.is_file env path in
|
|
dom (Ok r) env [ Fmt.str "Is_file? %a -> %b" Fpath.pp path r ]
|
|
| Is_dir path ->
|
|
Log.debug (fun l -> l "Is_dir %a" Fpath.pp path);
|
|
let r = Env.is_dir env path in
|
|
dom (Ok r) env [ Fmt.str "Is_dir? %a -> %b" Fpath.pp path r ]
|
|
| Size_of path ->
|
|
Log.debug (fun l -> l "Size_of %a" Fpath.pp path);
|
|
let r = Env.size_of env path in
|
|
dom (Ok r) env
|
|
[
|
|
Fmt.str "Size_of %a -> %a" Fpath.pp path
|
|
Fmt.(option ~none:(any "error") int)
|
|
r;
|
|
]
|
|
| Run_cmd cmd -> (
|
|
let domain = interpret_dry_cmd env cmd in
|
|
match domain.result with
|
|
| Ok _ -> { domain with result = Ok () }
|
|
| Error _ as r -> { domain with result = r })
|
|
| Run_cmd_out cmd -> interpret_dry_cmd env cmd
|
|
| Run_cmd_cli cmd -> interpret_dry_cmd_cli env cmd
|
|
| Write_file (path, s) ->
|
|
Log.debug (fun l -> l "Write_file %a" Fpath.pp path);
|
|
dom (Ok ()) (Env.write env path s)
|
|
[ Fmt.str "Write to %a (%d bytes)" Fpath.pp path (String.length s) ]
|
|
| Read_file path -> (
|
|
Log.debug (fun l -> l "Read_file %a" Fpath.pp path);
|
|
match Env.read env path with
|
|
| None ->
|
|
let log = Fmt.str "Read: %a" Fpath.pp path in
|
|
dom (error_msg "read_file: file does not exist") env [ log ]
|
|
| Some r ->
|
|
let log =
|
|
Fmt.str "Read %a (%d bytes)" Fpath.pp path (String.length r)
|
|
in
|
|
dom (Ok r) env [ log ])
|
|
| Tmp_file (_, pat) ->
|
|
Log.debug (fun l -> l "Tmp_file %s" Fmt.(str pat "*"));
|
|
let r = Env.tmp_file env pat in
|
|
dom (Ok r) env [ Fmt.str "Tmp_file -> %a" Fpath.pp r ]
|
|
| Set_var (c, v) ->
|
|
Log.debug (fun l ->
|
|
l "Set_var %s %a" c Fmt.(option ~none:(any "<none>") string) v);
|
|
let env = Env.set_var env c v in
|
|
let log =
|
|
Fmt.str "Set_var %s %a" c Fmt.(option ~none:(any "<unset>") string) v
|
|
in
|
|
dom (Ok ()) env [ log ]
|
|
| Get_var c ->
|
|
Log.debug (fun l -> l "Get_var %s" c);
|
|
let v = Env.get_var env c in
|
|
let log =
|
|
Fmt.str "Get_var %s -> %a" c
|
|
Fmt.(option ~none:(any "<not set>") string)
|
|
v
|
|
in
|
|
dom (Ok v) env [ log ]
|
|
| With_dir (dir, f) ->
|
|
Log.debug (fun l -> l "With_dir %a" Fpath.pp dir);
|
|
let old = Env.pwd env in
|
|
let env = Env.chdir env dir in
|
|
let domain = dry_run ~env (f ()) in
|
|
let env = Env.chdir domain.env old in
|
|
let log =
|
|
Fmt.str "With_dir %a [%a]" Fpath.pp dir
|
|
Fmt.(vbox ~indent:2 (list ~sep:(any "@,") string))
|
|
domain.logs
|
|
in
|
|
{ domain with env; logs = [ log ] }
|
|
| Pwd ->
|
|
Log.debug (fun l -> l "Pwd");
|
|
let r = Env.pwd env in
|
|
dom (Ok r) env [ Fmt.str "Pwd -> %a" Fpath.pp r ]
|
|
| With_output { mode; path; purpose; contents; append } ->
|
|
let pp_append ppf () = if append then Fmt.string ppf "[append]" else () in
|
|
Log.debug (fun l ->
|
|
l "With_output%a %a (%s)" pp_append () Fpath.pp path purpose);
|
|
let buf = Buffer.create 0 in
|
|
let fmt = Format.formatter_of_buffer buf in
|
|
let pp_mode fmt = function
|
|
| None -> Format.fprintf fmt "default"
|
|
| Some n -> Format.fprintf fmt "%#o" n
|
|
in
|
|
let r = contents fmt in
|
|
Fmt.pf fmt "%!";
|
|
let f = Buffer.contents buf in
|
|
let log =
|
|
Fmt.str "Write to %a (mode: %a, purpose: %s)" Fpath.pp path pp_mode mode
|
|
purpose
|
|
in
|
|
dom (Ok r) (Env.write env path f) [ log ]
|
|
|
|
and dry_run : type r. env:Env.t -> r t -> r domain =
|
|
fun ~env t ->
|
|
let rec go t ~env log =
|
|
match t with
|
|
| Done r -> dom (Ok r) env log
|
|
| Fail e -> dom (Error (`Msg e)) env log
|
|
| Run (cmd, k) -> (
|
|
let domain = interpret_dry ~env cmd in
|
|
let new_log = List.rev domain.logs @ log in
|
|
match domain.result with
|
|
| Ok x -> go (k x) ~env:domain.env new_log
|
|
| Error _ as e -> dom e domain.env new_log)
|
|
in
|
|
let domain = go t ~env [] in
|
|
{ domain with logs = List.rev domain.logs }
|
|
|
|
let dry_run ?(env = env ()) t = dry_run ~env t
|
|
|
|
let dry_run_trace ?env t =
|
|
let domain = dry_run ?env t in
|
|
List.iter print_endline domain.logs
|
|
|
|
let generated_files ?(env = env ~exec:(fun _ -> None) ()) t =
|
|
let domain = dry_run ~env t in
|
|
Env.diff_files ~old:env domain.env
|
|
|
|
module Infix = struct
|
|
let ( >>= ) x f = bind ~f x
|
|
let ( >|= ) x f = map ~f x
|
|
end
|
|
|
|
module Syntax = struct
|
|
open Infix
|
|
|
|
let ( let* ) = ( >>= )
|
|
let ( let+ ) = ( >|= )
|
|
end
|
|
|
|
module List = struct
|
|
open Infix
|
|
|
|
let iter ~f l = List.fold_left (fun acc e -> acc >>= fun () -> f e) (ok ()) l
|
|
|
|
let map ~f l =
|
|
List.fold_left
|
|
(fun acc e ->
|
|
acc >>= fun acc ->
|
|
f e >|= fun e -> e :: acc)
|
|
(ok []) l
|
|
end
|