unikernel/duniverse/mirage/lib/functoria/action.ml

@@ -0,0 +1,652 @@
+(*
+ * 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