(* $Id: netftp_fs.ml 2195 2015-01-01 12:23:39Z gerd $ *)
open Printf
open Netftp_client
class type ftp_stream_fs =
object
inherit Netfs.stream_fs
method ftp_client : Netftp_client.ftp_client
method last_ftp_state : Netftp_client.ftp_state
method translate : string -> string
method close : unit -> unit
end
let ftp_syn =
Hashtbl.find Neturl.common_url_syntax "ftp"
let ftp_schemes =
let ht = Hashtbl.create 5 in
Hashtbl.add ht "ftp" ftp_syn;
ht
type any_wflag = [ Netfs.write_flag | Netfs.write_file_flag ]
class ftp_fs ?(config_client = fun _ -> ())
?tmp_directory
?tmp_prefix
?(get_password = fun _ -> "")
?(get_account = fun _ -> "")
?(keep_open = false)
?tls_config
?(tls_enabled=false)
?(tls_required=false)
?gssapi_provider
?(gssapi_config = Netsys_gssapi.create_client_config())
?(gssapi_required=false)
base_url_s : ftp_stream_fs =
let get_tls_config() =
match tls_config with
| None ->
Netsys_tls.create_x509_config
~system_trust:true
~peer_auth:`Required
(Netsys_crypto.current_tls())
| Some c -> c in
(* parse base_url: *)
let base_url =
Neturl.parse_url
~schemes:ftp_schemes
~accept_8bits:true
(Neturl.fixup_url_string base_url_s) in
(* create client and log in: *)
let ftp = new Netftp_client.ftp_client () in
let () = config_client ftp in
let last_ftp_state = ref None in
let uerror code path detail =
raise(Unix.Unix_error(code, detail, path)) in
let einval path detail =
raise(Unix.Unix_error(Unix.EINVAL, detail, path)) in
let enosys path detail =
raise(Unix.Unix_error(Unix.ENOSYS, detail, path)) in
let translate_error err path detail =
match err with
| FTP_method_perm_failure(550,_) ->
(* This can mean a lot. ENOENT is only the most frequent reason *)
uerror Unix.ENOENT path (detail ^ " [code 550]")
| FTP_method_perm_failure((500|502) as code,_) ->
enosys path (detail ^ "[ code " ^ string_of_int code ^ "]")
| FTP_method_perm_failure(553, _) ->
uerror Unix.EINVAL path (detail ^ " [code 553]")
| FTP_method_temp_failure(450, _) ->
uerror Unix.EPERM path (detail ^ " [code 450]")
| FTP_method_temp_failure(452, _) ->
uerror Unix.ENOSPC path (detail ^ " [code 452]")
| FTP_method_perm_failure(code,_) ->
uerror Unix.EPERM path (detail ^ " [code " ^ string_of_int code ^ "]")
| FTP_method_temp_failure(code,_) ->
uerror Unix.EPERM path (detail ^ " [code " ^ string_of_int code ^ "]")
| _ ->
err
in
let transaction f path detail =
try
let connected =
try (ftp # pi # ftp_state).ftp_connected
with Failure _ -> false in
if not connected then (
ftp # exec (Netftp_client.connect_method
~host:(Neturl.url_host base_url)
?port:(try Some(Neturl.url_port base_url)
with Not_found -> None)
()
);
if tls_enabled then (
let config = get_tls_config() in
ftp # exec
(Netftp_client.tls_method ~config ~required:tls_required ())
);
( match gssapi_provider with
| None -> ()
| Some g ->
ftp # exec
(Netftp_client.gssapi_method ~config:gssapi_config
~required:gssapi_required g)
);
let user =
try Neturl.url_user base_url
with Not_found -> "anonymous" in
ftp # exec (Netftp_client.login_method
~user
~get_password:(fun () -> get_password user)
~get_account:(fun () -> get_account user)
()
);
);
let r = f() in
last_ftp_state := Some(ftp # pi # ftp_state);
if not keep_open then
ftp # exec (Netftp_client.quit_method());
r
with
| error ->
last_ftp_state := Some(ftp # pi # ftp_state);
if not keep_open then
ftp # reset();
raise (translate_error error path detail) in
let (supports_tvfs, supports_utf8) =
transaction
(fun () ->
( try
ftp # exec (Netftp_client.feat_method())
with
| FTP_method_perm_failure _ -> ()
);
(ftp # pi # supports_tvfs,
ftp # pi # supports_utf8
)
) "" "Netftp_fs" in
let path_encoding =
if supports_utf8 then Some `Enc_utf8 else None in
let translate path =
(* Check path. Also prepend the path from the base URL. The returned
path does not start with /. If just the root dir is meant this function
returns the empty string.
*)
if path = "" then
einval path "Netftp_fs: path is empty";
if path.[0] <> '/' then
einval path "Netftp_fs: path is not absolute";
if String.contains path '\000' then
einval path "Netftp_fs: path contains NUL byte";
( match path_encoding with
| None -> ()
| Some pe ->
( try
Netconversion.verify pe path
with
| Netconversion.Malformed_code_at _ ->
einval path "Netftp_fs: path is not properly encoded"
)
);
let npath = Neturl.norm_path(Neturl.split_path path) in
( match npath with
| "" :: ".." :: _ -> (* CHECK: maybe ENOENT? *)
einval path "Netftp_fs: path starts with /.."
| _ -> ()
);
let base_path =
match Neturl.url_path base_url with
| [] -> [ "" ]
| p -> p in
let base_path_n = (* no slash at the end, no at the beginning *)
if List.hd (List.rev base_path) = "" && base_path <> [""] then
List.tl (List.rev (List.tl (List.rev base_path)))
else
List.tl base_path in
let path_trans =
base_path_n @ (List.tl npath) in
let p =
String.concat "/" path_trans in
(* `TVFS "" does not work for accessing the home dir, so switch
to `NVFS in this case
*)
if supports_tvfs && p <> "" then `TVFS p else `NVFS p in
let cancel_flag = ref (ref false) in
object(self)
method path_encoding = path_encoding
method path_exclusions = [0,0; 47,47]
method nominal_dot_dot = true
method ftp_client = ftp
method translate path =
let ftp_path = translate path in
let raw_path =
match ftp_path with
| `TVFS p -> p
| `NVFS p -> p in
let url_path = "" :: Neturl.split_path raw_path in
Neturl.string_of_url
(Neturl.modify_url
~path:url_path
(Neturl.remove_from_url
~password:true
base_url
))
method last_ftp_state =
match !last_ftp_state with
| None ->
raise Not_found
| Some st ->
st
method close() =
ftp # reset()
method private read_impl binary path =
last_ftp_state := None;
let vfs = translate path in
let representation = if binary then `Image else `ASCII None in
let cur_tmp = ref None in
let cleanup() =
match !cur_tmp with
| None -> ()
| Some (tmp_name,inch,outch) ->
(* Success *)
close_in inch;
close_out outch;
( try Unix.unlink tmp_name with _ -> ()); (* CHECK Win32 *)
cur_tmp := None in
try
transaction
(fun () ->
ftp # exec (Netftp_client.get_method
~file:vfs
~representation
~store:(fun _ ->
let (tmp_name, inch, outch) =
Netchannels.make_temporary_file
?tmp_directory ?tmp_prefix () in
cur_tmp := Some (tmp_name, inch, outch);
let obj_outch =
new Netchannels.output_channel outch in
`File_structure obj_outch
)
()
);
) path "Netftp_fs.read";
match !cur_tmp with
| None ->
assert false
| Some (tmp_name,inch,outch) ->
(tmp_name,inch,outch,cleanup)
with error ->
cleanup();
raise error
method read flags path =
let binary = List.mem `Binary flags in
let (tmp_name,inch,outch,cleanup) = self # read_impl binary path in
let skip =
try
Nethttp_fs.find_flag (function `Skip p -> Some p | _ -> None) flags
with Not_found -> 0L in
LargeFile.seek_in inch skip;
new Netchannels.input_channel
~onclose:cleanup
inch
method read_file flags path =
let binary = List.mem `Binary flags in
let (tmp_name,inch,outch,cleanup) = self # read_impl binary path in
close_in inch;
close_out outch;
( object
method filename = tmp_name
method close() = cleanup()
end
)
method write_file flags path local =
Netchannels.with_in_obj_channel
(new Netchannels.input_channel (open_in_bin local#filename))
(fun obj_inch ->
self # write_file_impl
(flags :> any_wflag list) path obj_inch local#close
)
method private write_file_impl flags path obj_inch close =
last_ftp_state := None;
let vfs = translate path in
let representation =
if List.mem `Binary flags then `Image else `ASCII None in
let create_flag = List.mem `Create flags in
let trunc_flag = List.mem `Truncate flags in
let excl_flag = List.mem `Exclusive flags in
if not create_flag && not trunc_flag then
einval path "Netftp_fs.write: you need to request either file creation \
or file truncation";
if create_flag && excl_flag then
einval path "Netftp_fs.write: exclusive file creation not supported";
let req =
if create_flag && not excl_flag && not trunc_flag then
Some false
else
if not create_flag then
Some true
else
None in
transaction
(fun () ->
try
( match req with
| None -> ()
| Some r_exists ->
let exists =
try
ftp # exec (Netftp_client.mlst_method
~file:vfs
~process_result:(fun _ -> ())
()
);
true
with
| FTP_method_perm_failure(550,_) -> false in
if exists <> r_exists then
let ecode =
if r_exists then Unix.ENOENT else Unix.EEXIST in
raise(uerror ecode path "Netftp_fs.write");
);
ftp # exec (Netftp_client.put_method
~file:vfs
~representation
~store:(fun _ -> `File_structure obj_inch)
()
);
close()
with
| error ->
close();
raise error
)
path
"Netftp_fs.write"
method write flags path =
let this_cancel_flag = !cancel_flag in
let (tmp_name, inch, outch) =
Netchannels.make_temporary_file
?tmp_directory ?tmp_prefix () in
let obj_inch =
new Netchannels.input_channel inch in
let close() =
close_in inch;
close_out outch;
( try Unix.unlink tmp_name with _ -> () ) in
let do_write() =
if !this_cancel_flag then
close()
else
self # write_file_impl (flags :> any_wflag list) path obj_inch close in
let obj_outch =
new Netchannels.output_channel
~onclose:do_write
outch in
obj_outch
method cancel() =
(* This cancellation affects all [write]s that were started until
now...
*)
let this_cancel_flag = !cancel_flag in
this_cancel_flag := true;
(* All new [write]s are not cancelled, of course: *)
cancel_flag := (ref false)
method size flags path =
last_ftp_state := None;
let vfs = translate path in
transaction
(fun () ->
let n = ref 0L in
ftp # exec (Netftp_client.size_method
~file:vfs
~representation:`Image
~process_result:(fun k -> n := k)
());
!n
)
path
"Netftp_fs.size"
method test flags path typ =
List.hd (self # test_list flags path [typ])
method test_list flags path typl =
last_ftp_state := None;
let vfs = translate path in
transaction
(fun () ->
let entries = ref [] in
( try
ftp # exec (Netftp_client.mlst_method
~file:vfs
~process_result:(fun e -> entries := e)
());
with
| FTP_method_perm_failure _
| FTP_method_temp_failure _ -> ()
);
List.map
(fun typ ->
match typ with
| `N -> !entries <> []
| `E -> !entries <> []
| `D -> (List.exists
(fun e ->
try get_type e = `Dir with Not_found -> false)
!entries
)
| `F -> (List.exists
(fun e ->
try get_type e = `File with Not_found -> false)
!entries
)
| `H -> false
| `R -> (List.exists
(fun e ->
let p = try get_perm e with Not_found -> [] in
List.mem `List p || List.mem `Read p
)
!entries
)
| `W -> (List.exists
(fun e ->
let p = try get_perm e with Not_found -> [] in
List.mem `Mkdir p || List.mem `Delete_member p ||
List.mem `Write p
)
!entries
)
| `X -> (List.exists
(fun e ->
let p = try get_perm e with Not_found -> [] in
List.mem `Enter p
)
!entries
)
| `S -> (List.exists
(fun e ->
let s = try get_size e with Not_found -> 0L in
s > 0L
)
!entries
)
)
typl
)
path
"Netftp_fs.test_list"
method remove flags path =
last_ftp_state := None;
if List.mem `Recursive flags then
einval path "Netftp_fs.remove: recursion not supported";
let vfs = translate path in
transaction
(fun () ->
ftp # exec (Netftp_client.delete_method vfs)
)
path
"Netftp_fs.remove"
method rename flags path1 path2 =
last_ftp_state := None;
let vfs1 = translate path1 in
let vfs2 = translate path2 in
transaction
(fun () ->
ftp # exec (Netftp_client.rename_method ~file_from:vfs1 ~file_to:vfs2 ())
)
path1
"Netftp_fs.rename"
method readdir flags path =
last_ftp_state := None;
let vfs = translate path in
transaction
(fun () ->
let b = Buffer.create 500 in
let ch = new Netchannels.output_buffer b in
ftp#exec (Netftp_client.nlst_method
~dir:vfs
~representation:(`ASCII None)
~store:(fun _ -> `File_structure ch)
()
);
List.map
Filename.basename
(parse_nlst_document (Buffer.contents b))
)
path
"Netftp_fs.readdir"
method mkdir flags path =
(* FIXME: flags *)
last_ftp_state := None;
let vfs = translate path in
transaction
(fun () ->
ftp # exec (Netftp_client.mkdir_method vfs)
)
path
"Netftp_fs.mkdir"
method rmdir flags path =
last_ftp_state := None;
let vfs = translate path in
transaction
(fun () ->
ftp # exec (Netftp_client.rmdir_method vfs)
)
path
"Netftp_fs.rmdir"
(* Unsupported *)
method symlink _ path1 path2 = enosys path1 "Netftp_fs.symlink not supported"
method copy flags path1 path2 = enosys path1 "Netftp_fs.copy not supported"
method readlink flags path = enosys path "Netftp_fs.readlink not supported"
end
let ftp_fs = new ftp_fs
