Repositories / agent-snapshot.git
agent-snapshot.git
Clone (read-only): git clone http://git.guha-anderson.com/git/agent-snapshot.git
@@ -10,4 +10,5 @@ yojson camomile ocaml-git - fpath)) + fpath + fileutils))
@@ -138,11 +138,9 @@ let dirname (path : string) : string = if path = "" then "." else Fpath.to_string (Fpath.parent (Fpath.normalize (Fpath.v path))) -let rec mkdir_p (path : string) : unit = - if path = "" || path = "/" || Sys.file_exists path then () - else ( - mkdir_p (dirname path); - try Unix.mkdir path 0o777 with Unix.Unix_error (Unix.EEXIST, _, _) -> ()) +let mkdir_p (path : string) : unit = + if path = "" || path = "/" || FileUtil.test FileUtil.Exists path then () + else FileUtil.mkdir ~parent:true ~mode:(`Octal 0o777) path let is_absolute (path : string) : bool = path <> "" && Fpath.is_abs (Fpath.v path) @@ -153,7 +151,7 @@ let best_effort_canonical (path : string) : string = match realpath_opt path with | Some path -> normalize_path path | None when is_absolute path -> normalize_path path - | None -> concat_path (Sys.getcwd ()) path + | None -> concat_path (FileUtil.pwd ()) path let path_is_at_or_under (path : string) (root : string) : bool = path = root || @@ -253,7 +251,7 @@ let writable_by_current_user (meta : metadata) : bool = let existing_anchor (path : string) : string option = let rec loop path = if path = "" || path = "." then None - else if Sys.file_exists path then Some path + else if FileUtil.test FileUtil.Exists path then Some path else let parent = dirname path in if parent = path then None else loop parent @@ -334,28 +332,12 @@ let fnv1a_file_digest (path : string) : string = with End_of_file -> ()); Printf.sprintf "%016Lx" !hash) -let copy_file (src : string) (dst : string) : unit = - let ic = open_in_bin src in - Fun.protect - ~finally:(fun () -> close_in_noerr ic) - (fun () -> - let oc = open_out_bin dst in - Fun.protect - ~finally:(fun () -> close_out_noerr oc) - (fun () -> - let bytes = Bytes.create 65536 in - let rec loop () = - let n = input ic bytes 0 (Bytes.length bytes) in - if n > 0 then ( - output oc bytes 0 n; - loop ()) - in - loop ())) +let copy_file (src : string) (dst : string) : unit = FileUtil.cp [ src ] dst let store_blob (path : string) : string = let digest = fnv1a_file_digest path in let out = concat_path !blob_dir digest in - if not (Sys.file_exists out) then copy_file path out; + if not (FileUtil.test FileUtil.Exists out) then copy_file path out; digest let should_capture_content (path : string) (meta : metadata) (git : git_info) : bool = @@ -456,7 +438,7 @@ let write_manifest (out : string) (command : string list) (exit_status : int) : ("format_version", `Int 1); ("command", `List (List.map jstr command)); ("exit_status", `Int exit_status); - ("start_cwd", jstr (Sys.getcwd ())); + ("start_cwd", jstr (FileUtil.pwd ())); ("uid", `Int tracer_uid); ("gid", `Int tracer_gid); ("git_repositories", `List repo_items); @@ -605,7 +587,7 @@ let trace_command (command : string list) : unit = let state = match Hashtbl.find_opt processes parent with | Some state -> clone_proc_state state - | None -> { cwd = Sys.getcwd (); fds = Hashtbl.create 8; pending = None } + | None -> { cwd = FileUtil.pwd (); fds = Hashtbl.create 8; pending = None } in Hashtbl.replace processes child state | Ptrace.Process_exit pid -> Hashtbl.remove processes pid @@ -614,7 +596,7 @@ let trace_command (command : string list) : unit = match Hashtbl.find_opt processes pid with | Some state -> state | None -> - let state = { cwd = Sys.getcwd (); fds = Hashtbl.create 8; pending = None } in + let state = { cwd = FileUtil.pwd (); fds = Hashtbl.create 8; pending = None } in refresh_proc_cwd pid state; Hashtbl.add processes pid state; state @@ -624,16 +606,12 @@ let trace_command (command : string list) : unit = Option.iter (fun state -> handle_syscall_exit pid state regs) (Hashtbl.find_opt processes pid) | Ptrace.Exec pid | Ptrace.Exit pid | Ptrace.Signal (pid, _) -> if not (Hashtbl.mem processes pid) then ( - let state = { cwd = Sys.getcwd (); fds = Hashtbl.create 8; pending = None } in + let state = { cwd = FileUtil.pwd (); fds = Hashtbl.create 8; pending = None } in refresh_proc_cwd pid state; Hashtbl.add processes pid state)) -let rec remove_all (path : string) : unit = - if Sys.file_exists path then - if Sys.is_directory path then ( - Array.iter (fun name -> if name <> "." && name <> ".." then remove_all (concat_path path name)) (Sys.readdir path); - Unix.rmdir path) - else Unix.unlink path +let remove_all (path : string) : unit = + if FileUtil.test FileUtil.Exists path then FileUtil.rm ~recurse:true ~force:FileUtil.Force [ path ] (** Restore only blobbed final states and tombstones; Git-reconstructable files remain manifest references. *) let restore_snapshot (dir : string) : unit = @@ -652,24 +630,29 @@ let restore_snapshot (dir : string) : unit = let exists = match List.assoc_opt "exists" after with Some (`Bool b) -> b | _ -> false in if not exists then ( let tombstone = match List.assoc_opt "tombstone" after with Some (`Bool b) -> b | _ -> false in - if tombstone then try Unix.unlink path with Unix.Unix_error _ -> ()) + if tombstone then + try FileUtil.rm ~force:FileUtil.Force [ path ] + with FileUtil.RmError _ | Unix.Unix_error (_, _, _) -> ()) else ( match List.assoc_opt "blob" after with | None -> () | Some (`String digest) -> mkdir_p (dirname path); let same = - Sys.file_exists path && not (Sys.is_directory path) && fnv1a_file_digest path = digest + FileUtil.test (FileUtil.And (FileUtil.Exists, FileUtil.Not FileUtil.Is_dir)) path + && fnv1a_file_digest path = digest in if not same then ( let tmp = path ^ ".agent-snapshot.tmp" in copy_file (concat_path (concat_path dir "blobs") digest) tmp; Unix.rename tmp path); (match List.assoc_opt "mode" after with - | Some (`Int mode) -> Unix.chmod path (mode land 0o7777) + | Some (`Int mode) -> + FileUtil.chmod (`Octal (mode land 0o7777)) [ path ] | _ -> ()); (match List.assoc_opt "mtime" after with - | Some (`Int mtime) -> Unix.utimes path (float_of_int mtime) (float_of_int mtime) + | Some (`Int mtime) -> + FileUtil.touch ~time:(FileUtil.Touch_timestamp (float_of_int mtime)) path | _ -> ()) | _ -> ()) | _ -> ())
@@ -4,4 +4,4 @@ (foreign_stubs (language c) (names ptrace_stubs)) - (libraries unix yojson camomile ocaml-git fpath)) + (libraries unix yojson camomile ocaml-git fpath fileutils))