(* $Id: netfs.ml 1809 2012-11-05 23:09:14Z gerd $ *)
type read_flag =
[ `Skip of int64 | `Binary | `Streaming | `Dummy ]
type read_file_flag =
[ `Binary | `Dummy ]
type write_flag =
[ `Create | `Exclusive | `Truncate | `Binary | `Streaming | `Dummy ]
type write_file_flag =
[ `Create | `Exclusive | `Truncate | `Binary | `Link | `Dummy ]
type write_common =
[ `Create | `Exclusive | `Truncate | `Binary | `Dummy ]
(* The intersection of write_flag and write_file_flag *)
type size_flag =
[ `Dummy ]
type test_flag =
[ `Link | `Dummy ]
type remove_flag =
[ `Recursive | `Dummy ]
type rename_flag =
[ `Dummy ]
type symlink_flag =
[ `Dummy ]
type readdir_flag =
[ `Dummy ]
type readlink_flag =
[ `Dummy ]
type mkdir_flag =
[ `Path | `Nonexcl | `Dummy ]
type rmdir_flag =
[ `Dummy ]
type copy_flag =
[ `Dummy ]
type test_type =
[ `N | `E | `D | `F | `H | `R | `W | `X | `S ]
class type local_file =
object
method filename : string
method close : unit -> unit
end
class type stream_fs =
object
method path_encoding : Netconversion.encoding option
method path_exclusions : (int * int) list
method nominal_dot_dot : bool
method read : read_flag list -> string -> Netchannels.in_obj_channel
method read_file : read_file_flag list -> string -> local_file
method write : write_flag list -> string -> Netchannels.out_obj_channel
method write_file : write_file_flag list -> string -> local_file -> unit
method size : size_flag list -> string -> int64
method test : test_flag list -> string -> test_type -> bool
method test_list : test_flag list -> string -> test_type list -> bool list
method remove : remove_flag list -> string -> unit
method rename : rename_flag list -> string -> string -> unit
method symlink : symlink_flag list -> string -> string -> unit
method readdir : readdir_flag list -> string -> string list
method readlink : readlink_flag list -> string -> string
method mkdir : mkdir_flag list -> string -> unit
method rmdir : rmdir_flag list -> string -> unit
method copy : copy_flag list -> string -> string -> unit
method cancel : unit -> unit
end
class empty_fs detail : stream_fs =
let enosys path =
raise (Unix.Unix_error(Unix.ENOSYS, path, detail)) in
object
method path_encoding = enosys ""
method path_exclusions = enosys ""
method nominal_dot_dot = enosys ""
method read _ p = enosys p
method read_file _ p = enosys p
method write _ p = enosys p
method write_file _ p _ = enosys p
method size _ p = enosys p
method test _ p _ = enosys p
method test_list _ p _ = enosys p
method remove _ p = enosys p
method rename _ p _ = enosys p
method symlink _ p _ = enosys p
method readdir _ p = enosys p
method readlink _ p = enosys p
method mkdir _ p = enosys p
method rmdir _ p = enosys p
method copy _ p _ = enosys p
method cancel () = enosys ""
end
let slash_re = Netstring_str.regexp "/+"
let drive_re = Netstring_str.regexp "^[a-zA-Z]:$"
exception Not_absolute
exception Unavailable
let list_isect_empty l1 l2 = (* whether intersection is empty *)
List.for_all
(fun x1 -> not (List.mem x1 l2))
l1
let readdir d =
try
let l = ref [] in
( try
while true do
l := (Unix.readdir d) :: !l
done;
assert false
with End_of_file -> ()
);
Unix.closedir d;
List.rev !l
with
| error -> Unix.closedir d; raise error
let copy_prim ~streaming orig_fs orig_name dest_fs dest_name =
let sflags =
if streaming then [`Streaming] else [] in
Netchannels.with_in_obj_channel
(orig_fs#read (sflags @ [`Binary]) orig_name)
(fun r_ch ->
Netchannels.with_out_obj_channel
(dest_fs#write (sflags @ [`Binary; `Truncate; `Create]) dest_name)
(fun w_ch ->
w_ch # output_channel r_ch
)
)
let local_fs ?encoding ?root ?(enable_relative_paths=false) () : stream_fs =
let enc =
match encoding with
| None ->
( match Sys.os_type with
| "Win32" -> Netconversion.user_encoding()
| _ -> None
)
| Some e -> Some e in
( match enc with
| None -> ()
| Some e ->
if not (Netconversion.is_ascii_compatible e) then
failwith
"Netfs.local_fs: the encoding is not ASCII-compatible";
);
let excl =
match Sys.os_type with
| "Win32" | "Cygwin" ->
(* http://msdn.microsoft.com/en-us/library/aa365247%28v=VS.85%29.aspx *)
[ 0, 31; (* control chars *)
42, 42; (* <, >, :, quotation mark, /, backslash, |, ?, * *)
47, 47;
58, 58;
60, 60;
62, 63;
92, 92;
124, 124
]
| _ ->
[ 0, 0; 47, 47 ] in
let excl_array_size =
List.fold_left (fun mx (from,upto) -> max mx upto) 0 excl + 1 in
let excl_array = (
let a = Array.make excl_array_size false in
List.iter
(fun (from,upto) ->
for k = from to upto do a.(k) <- true done
)
excl;
a) in
let check_component path c =
let iter f s =
match enc with
| None ->
String.iter (fun c -> f (Char.code c)) s
| Some e ->
Netconversion.ustring_iter e f s in
try
iter
(fun code ->
if code < excl_array_size && excl_array.(code) then
raise (Unix.Unix_error(Unix.EINVAL,
"Netfs: invalid char in path",
path))
)
c
with Netconversion.Malformed_code ->
raise (Unix.Unix_error(Unix.EINVAL,
"Netfs: path does not comply to charset encoding",
path)) in
let win32_root =
root = None && Sys.os_type = "Win32" in
let is_drive_letter s =
Netstring_str.string_match drive_re s 0 <> None in
let is_unc s =
String.length s >= 3 && s.[0] = '/' && s.[1] = '/' && s.[2] <> '/' in
let check_and_norm_path p =
let l = Netstring_str.split_delim slash_re p in
List.iter (check_component p) l;
try
( match l with
| [] -> raise (Unix.Unix_error(Unix.EINVAL,
"Netfs: empty path",
p))
| "" :: first :: rest ->
if win32_root then (
if ((not (is_drive_letter first) || rest=[]) &&
not (is_unc p))
then
raise Not_absolute
)
| first :: rest ->
if win32_root then (
if not(is_drive_letter first) || rest=[] then
raise Not_absolute
)
else raise Not_absolute
);
let np = String.concat "/" l in
if win32_root then (
if is_unc p then
"/" ^ np
else
if np.[0] = '/' then
String.sub np 1 (String.length np - 1) (* remove leading / *)
else np
)
else np
with
| Not_absolute ->
if enable_relative_paths then
String.concat "/" l
else
raise (Unix.Unix_error(Unix.EINVAL,
"Netfs: path not absolute",
p))
in
let real_root =
match root with
| None ->
""
| Some r ->
if (Unix.stat r).Unix.st_kind <> Unix.S_DIR then
failwith "Netfs.local_fs: root is not a directory";
r in
( object(self)
method path_encoding = enc
method path_exclusions = excl
method nominal_dot_dot = false
method read flags filename =
let fn = real_root ^ check_and_norm_path filename in
let binary = List.mem `Binary flags in
let skip_d =
try
List.find
(fun flag ->
match flag with
| `Skip _ -> true
| _ -> false
)
flags
with Not_found -> `Skip 0L in
let skip =
match skip_d with
| `Skip n -> n
| _ -> assert false in
(* Use Unix.openfile to open so we get Unix_errors on error *)
let fd = Unix.openfile fn [Unix.O_RDONLY] 0 in
let st = Unix.fstat fd in
if st.Unix.st_kind = Unix.S_DIR then
raise(Unix.Unix_error(Unix.EISDIR,"Netfs.read",""));
if skip > 0L then
ignore(Unix.LargeFile.lseek fd skip Unix.SEEK_SET);
let ch = Unix.in_channel_of_descr fd in
set_binary_mode_in ch binary;
new Netchannels.input_channel ch
method read_file flags filename =
let fn = real_root ^ check_and_norm_path filename in
let st = Unix.stat fn in
if st.Unix.st_kind = Unix.S_DIR then
raise(Unix.Unix_error(Unix.EISDIR,"Netfs.read_file",""));
( object
method filename = fn
method close() = ()
end
)
method write flags filename =
let fn = real_root ^ check_and_norm_path filename in
let binary = List.mem `Binary flags in
let create = List.mem `Create flags in
let truncate = List.mem `Truncate flags in
let exclusive = List.mem `Exclusive flags in
let mode =
List.flatten
[ [Unix.O_WRONLY];
if create then [ Unix.O_CREAT ] else [];
if truncate then [ Unix.O_TRUNC ] else [];
if exclusive then [ Unix.O_EXCL ] else [];
] in
(* Use Unix.openfile to open so we get Unix_errors on error *)
let fd = Unix.openfile fn mode 0o666 in
let ch = Unix.out_channel_of_descr fd in
set_binary_mode_out ch binary;
new Netchannels.output_channel ch
method write_file flags filename local =
(* This is just a copy operation *)
let fn = real_root ^ check_and_norm_path filename in
let binary = List.mem `Binary flags in
let link = List.mem `Link flags in
let local_filename = local#filename in
let wflags =
List.map
(function
| #write_common as x ->
(x :> write_flag)
| _ -> `Dummy
)
flags in
try
let do_copy =
try
not link || (
Unix.link local_filename fn;
false
)
with
| Unix.Unix_error( ( Unix.EACCES | Unix.ELOOP |
Unix.ENAMETOOLONG | Unix.ENOENT |
Unix.ENOTDIR | Unix.EPERM |
Unix.EROFS ), _, _) as e ->
(* These errors cannot be fixed by doing copies instead *)
raise e
| Unix.Unix_error(_,_,_) ->
true in
if do_copy then (
let fd_local = Unix.openfile local_filename [Unix.O_RDONLY] 0 in
let ch_local = Unix.in_channel_of_descr fd_local in
set_binary_mode_in ch_local binary;
Netchannels.with_in_obj_channel
(new Netchannels.input_channel ch_local)
(fun obj_local ->
Netchannels.with_out_obj_channel
(self # write wflags filename)
(fun out ->
out # output_channel obj_local
)
);
);
local#close()
with
| error ->
local#close();
raise error
method size flags filename =
let fn = real_root ^ check_and_norm_path filename in
let fd = Unix.openfile fn [Unix.O_RDONLY] 0 in
try
let n = Unix.LargeFile.lseek fd 0L Unix.SEEK_END in
Unix.close fd;
n
with
| error -> Unix.close fd; raise error (* esp. non-seekable *)
method private test_list_NH flags fn =
try
let st = Unix.LargeFile.lstat fn in
if st.Unix.LargeFile.st_kind = Unix.S_LNK then
[ `N; `H ]
else
[ `N ]
with
| Unix.Unix_error(Unix.ENOENT,_,_) -> []
method private test_list_EDFS flags fn =
try
let st =
if List.mem `Link flags then
Unix.LargeFile.lstat fn
else
Unix.LargeFile.stat fn in
let non_empty = st.Unix.LargeFile.st_size <> 0L in
let kind_l =
match st.Unix.LargeFile.st_kind with
| Unix.S_REG -> [ `F ]
| Unix.S_DIR -> [ `D ]
| _ -> [] in
[ `E ] @ kind_l @ (if non_empty then [`S] else [])
with
| Unix.Unix_error(Unix.ENOENT,_,_) -> []
method private test_list_RWX flags fn =
let r_ok =
try Unix.access fn [Unix.R_OK]; true with _ -> false in
let w_ok =
try Unix.access fn [Unix.W_OK]; true with _ -> false in
let x_ok =
try Unix.access fn [Unix.X_OK]; true with _ -> false in
List.flatten
[ if r_ok then [`R] else [];
if w_ok then [`W] else [];
if x_ok then [`X] else []
]
method test flags filename ttype =
let fn = real_root ^ check_and_norm_path filename in
let l =
match ttype with
| `N | `H -> self#test_list_NH flags fn
| `E | `D | `F | `S -> self#test_list_EDFS flags fn
| `R | `W | `X -> self#test_list_RWX flags fn in
List.mem ttype l
method test_list flags filename tests =
let fn = real_root ^ check_and_norm_path filename in
let nh =
if not(list_isect_empty tests [`N;`H]) then
self#test_list_NH flags fn
else
[] in
let edfs =
if not(list_isect_empty tests [`E;`D;`F;`S]) then
self#test_list_EDFS flags fn
else
[] in
let rwx =
if not(list_isect_empty tests [`R;`W;`X]) then
self#test_list_RWX flags fn
else
[] in
List.map
(fun t ->
match t with
| `N | `H -> List.mem t nh
| `E | `D | `F | `S -> List.mem t edfs
| `R | `W | `X -> List.mem t rwx
)
tests
method remove flags filename =
let fn = real_root ^ check_and_norm_path filename in
if List.mem `Recursive flags then (
try
self#rm_r_safe fn
with Unavailable ->
self#rm_r_trad fn
)
else
Unix.unlink fn
(* A rename race: while the recursive removal progresses, a second
process renames the directory. The removal function suddenly
does not find the directory anymore. Even worse, the second
process could move a different directory into the place of the
old directory being deleted. In this case, the wrong data would
be deleted.
We can avoid this in the style of rm_r_safe, or by chdir-ing
into the directory hierarchy. The latter is incompatible with
multi-threading, so we don't do it here.
*)
method private rm_r_trad fn =
(* "traditional" implemenation w/o protection against rename races *)
let is_dir fn =
try (Unix.stat fn).Unix.st_kind = Unix.S_DIR
with _ -> false in
let rec recurse fn =
if is_dir fn then (
let files = readdir (Unix.opendir fn) in
List.iter
(fun file ->
if file <> "." && file <> ".." then (
recurse (fn ^ "/" ^ file)
)
)
files;
Unix.rmdir fn;
)
else
Unix.unlink fn in
recurse fn
method private rm_r_safe fn =
(* safer implemention using openat and fdopendir *)
let rec rm_dir_entries fd =
let files = readdir (Netsys_posix.fdopendir (Unix.dup fd)) in
List.iter
(fun file ->
if file <> "." && file <> ".." then
rm_dir_or_file fd file
)
files
and rm_dir_or_file fd file =
let file_fd = Netsys_posix.openat fd file [Unix.O_RDONLY] 0 in
let file_is_dir =
try (Unix.fstat file_fd).Unix.st_kind = Unix.S_DIR
with _ -> false in
if file_is_dir then (
( try rm_dir_entries file_fd
with error -> Unix.close file_fd; raise error
);
Unix.close file_fd;
Netsys_posix.unlinkat fd file [Netsys_posix.AT_REMOVEDIR]
)
else (
Unix.close file_fd;
Netsys_posix.unlinkat fd file []
) in
let test_availability() =
if not (Netsys_posix.have_at()) then raise Unavailable;
try
let dir =
Netsys_posix.fdopendir(Unix.openfile "." [Unix.O_RDONLY] 0) in
Unix.closedir dir
with _ -> raise Unavailable in
test_availability();
rm_dir_or_file Netsys_posix.at_fdcwd fn
method rename flags oldname newname =
let oldfn = real_root ^ check_and_norm_path oldname in
let newfn = real_root ^ check_and_norm_path newname in
Unix.rename oldfn newfn
method symlink flags oldpath newpath =
let oldfn = real_root ^ check_and_norm_path oldpath in
let newfn = real_root ^ check_and_norm_path newpath in
Unix.symlink oldfn newfn
method readdir flags filename =
let fn = real_root ^ check_and_norm_path filename in
readdir (Unix.opendir fn)
method readlink flags filename =
let fn = real_root ^ check_and_norm_path filename in
Unix.readlink fn
method mkdir flags filename =
if List.mem `Path flags then
self#mkdir_p filename
else (
let fn = real_root ^ check_and_norm_path filename in
try
Unix.mkdir fn 0o777
with
| Unix.Unix_error(Unix.EEXIST,_,_) when List.mem `Nonexcl flags ->
()
)
method private mkdir_p filename =
let rec traverse curdir todo =
match todo with
| [] -> ()
| d :: todo' ->
let curdir' = curdir @ [d] in
let p = String.concat "/" curdir' in
let fn = real_root ^ p in
( try Unix.mkdir fn 0o777
with Unix.Unix_error(Unix.EEXIST,_,_) -> ()
);
traverse curdir' todo' in
let fn1 = check_and_norm_path filename in
let l = Netstring_str.split_delim slash_re fn1 in
traverse [List.hd l] (List.tl l)
method rmdir flags filename =
let fn = real_root ^ check_and_norm_path filename in
Unix.rmdir fn
method copy flags srcfilename destfilename =
copy_prim ~streaming:false self srcfilename self destfilename
method cancel () = ()
(* This is totally legal here - the user has to invoke close_out
anyway as part of the cancellation protocol.
*)
end
)
let convert_path ?subst oldfs newfs oldpath =
match oldfs#path_encoding, newfs#path_encoding with
| Some oldenc, Some newenc ->
Netconversion.convert ?subst ~in_enc:oldenc ~out_enc:newenc oldpath
| _ ->
oldpath
let copy ?(replace=false) ?(streaming=false)
orig_fs0 orig_name dest_fs0 dest_name =
let orig_fs = (orig_fs0 :> stream_fs) in
let dest_fs = (dest_fs0 :> stream_fs) in
if replace then
dest_fs # remove [] dest_name;
try
if orig_fs = dest_fs then
orig_fs # copy [] orig_name dest_name
else
raise(Unix.Unix_error(Unix.ENOSYS,"",""))
with
| Unix.Unix_error(Unix.ENOSYS,_,_) | Unix.Unix_error(Unix.EXDEV,_,_) ->
copy_prim ~streaming orig_fs orig_name dest_fs dest_name
type file_kind = [ `Regular | `Directory | `Symlink | `Other | `None ]
let iter ~pre ?(post=fun _ -> ()) fs0 start =
let fs = (fs0 :> stream_fs) in
let rec iter_members dir rdir =
let files = fs # readdir [] dir in
List.iter
(fun file ->
if file <> "." && file <> ".." then (
let absfile = dir ^ "/" ^ file in
let relfile = if rdir="" then file else rdir ^ "/" ^ file in
let l0 = fs#test_list [] absfile [`D; `F; `E] in
let l1 = fs#test_list [`Link] absfile [`D; `F; `H] in
let (is_dir0, is_reg0, is_existing) =
match l0 with
| [is_dir; is_reg; is_ex] -> (is_dir, is_reg, is_ex)
| _ -> assert false in
let (is_dir1, is_reg1, is_link) =
match l1 with
| [is_dir; is_reg; is_link] -> (is_dir, is_reg, is_link)
| _ -> assert false in
if is_dir1 then (
pre relfile `Directory `Directory;
iter_members absfile relfile;
post relfile
)
else (
let t0 =
if is_reg0 then `Regular
else if is_dir0 then `Directory
else if is_existing then `Other
else `None in
let t1 =
if is_reg1 then `Regular
else if is_dir1 then `Directory
else if is_link then `Symlink
else `Other in
pre relfile t0 t1
)
)
)
files in
iter_members start ""
let copy_into ?(replace=false) ?subst ?streaming
orig_fs0 orig_name dest_fs0 dest_name =
let orig_fs = (orig_fs0 :> stream_fs) in
let dest_fs = (dest_fs0 :> stream_fs) in
let orig_base = Filename.basename orig_name in
let dest_start =
dest_name ^ "/" ^ convert_path ?subst orig_fs dest_fs orig_base in
if not(dest_fs # test [] dest_name `D) then
raise(Unix.Unix_error
(Unix.ENOENT,
"Netfs.copy_into: destination directory does not exist",
dest_name));
if orig_fs # test [] orig_name `D then (
if replace then
dest_fs # remove [ `Recursive ] dest_start;
dest_fs # mkdir [ `Nonexcl ] dest_start;
iter
~pre:(fun rpath typ link_typ ->
let dest_rpath =
convert_path ?subst orig_fs dest_fs rpath in
match link_typ with
| `Regular ->
copy
?streaming
orig_fs (orig_name ^ "/" ^ rpath)
dest_fs (dest_start ^ "/" ^ dest_rpath)
| `Directory ->
dest_fs # mkdir
[ `Nonexcl ] (dest_start ^ "/" ^ dest_rpath)
| `Symlink ->
dest_fs # symlink
[]
(orig_fs # readlink [] (orig_name ^ "/" ^ rpath))
(dest_start ^ "/" ^ dest_rpath)
| `Other ->
()
)
orig_fs
orig_name
)
else
copy ~replace ?streaming orig_fs orig_name dest_fs dest_start
