(* $Id: webdav_netfs.ml 14 2015-01-13 12:36:25Z gerd $ *) (* FIXME: - use If headers where appropriate problem: WebDAV servers seem not to return E-Tags ALSO: - Support patchprop - Support If headers - Support locks *) open Webdav_compat class type webdav_stream_fs = object inherit Http_fs.http_stream_fs method webdav_client : Webdav_client.webdav_client_t method last_webdav_response_status : Webdav_http.webdav_status * int * string end let slash_re = Netstring_str.regexp "/+" let has_trailing_slash p = p <> "" && p.[ String.length p - 1 ] = '/' let find_flag f flags = let rec loop l = match l with | flag :: l' -> ( match f flag with | None -> loop l' | Some x -> x ) | [] -> raise Not_found in loop flags let norm_path path = let einval path detail = raise(Unix.Unix_error(Unix.EINVAL, detail, path)) in if path = "" then einval path "Webdav_netfs: path is empty"; if path.[0] <> '/' then einval path "Webdav_netfs: path is not absolute"; if String.contains path '\000' then einval path "Webdav_netfs: path contains NUL byte"; ( try Netconversion.verify `Enc_utf8 path with | Netconversion.Malformed_code_at _ -> einval path "Webdav_netfs: path is not properly encoded" ); let npath = Neturl.norm_path(Neturl.split_path path) in let npath_s = Neturl.join_path npath in ( match npath with | "" :: ".." :: _ -> (* CHECK: maybe ENOENT? *) einval path "Webdav_netfs: path starts with /.." | _ -> () ); npath_s let translate_status (st : Webdav_http.webdav_status) path = match st with | `Not_found -> Unix.Unix_error(Unix.ENOENT, "Webdav_netfs", path) | `Forbidden | `Unauthorized -> Unix.Unix_error(Unix.EACCES, "Webdav_netfs", path) | `Method_not_allowed -> (* CHECK: isn't this EPERM? *) Unix.Unix_error(Unix.EEXIST, "Webdav_netfs", path) | `Conflict -> Unix.Unix_error(Unix.ENOTDIR, "Webdav_netfs", path) | _ -> Unix.Unix_error(Unix.EPERM, "Webdav_netfs", path) let base_code code = if code >= 100 && code < 200 then 100 else if code >= 200 && code < 300 then 200 else if code >= 300 && code < 400 then 300 else if code >= 400 && code < 500 then 400 else 500 class webdav_netfs_layer ?ip http_fs : webdav_stream_fs = let () = if http_fs#path_encoding <> Some `Enc_utf8 then failwith "Webdav_netfs: The http_fs must use UTF-8 as path encoding" in let pipeline = http_fs # pipeline in let baseurl = http_fs # translate "/" in let wc = match ip with | None -> Webdav_client.webdav_client ~pipeline baseurl | Some ip -> Webdav_client_ha.webdav_client ~pipeline (baseurl,ip) in let translate_error path call = match call#call_status with | `Unserved -> assert false | `Successful -> assert false | `Http_protocol_error e -> raise e | `Redirection | `Client_error | `Server_error -> raise(translate_status call#response_webdav_status path) | `Multi_status -> (* This can only happen for a partially successful operation *) raise(Unix.Unix_error(Unix.EPERM, "Webdav_netfs: partially successful", path)) in let last_response_header = ref `No_response in object(self) method path_encoding = Some `Enc_utf8 method path_exclusions = [0,0; 47,47] method nominal_dot_dot = true method translate = http_fs#translate method last_response_header = match !last_response_header with | `No_response -> raise Not_found | `Http_fs -> http_fs # last_response_header | `This(hdr,triple) -> hdr method last_response_status = match !last_response_header with | `No_response -> raise Not_found | `Http_fs -> http_fs # last_response_status | `This(hdr,(st,code,text)) -> let st = try Nethttp.http_status_of_int code with Not_found -> Nethttp.http_status_of_int (base_code code) in (st, code, text) method last_webdav_response_status = match !last_response_header with | `No_response -> raise Not_found | `Http_fs -> let (st,code,text) = http_fs # last_response_status in ((st :> Webdav_http.webdav_status),code,text) | `This(hdr,(st,code,text)) -> (st,code,text) method private set_response r = let hdr = r#response_header in let code = r#response_status_code in let text = r#response_status_text in let status = try Webdav_http.webdav_status_of_int code with Not_found -> (Nethttp.http_status_of_int (base_code code) :> Webdav_http.webdav_status) in let triple = (status, code, text) in last_response_header := `This (hdr, triple) method webdav_client = wc method read flags path = last_response_header := `No_response; let path = norm_path path in last_response_header := `Http_fs; http_fs # read flags path method read_file flags path = last_response_header := `No_response; let path = norm_path path in last_response_header := `Http_fs; http_fs # read_file flags path method write flags path = last_response_header := `No_response; let path = norm_path path in last_response_header := `Http_fs; http_fs # write flags path method write_file flags path local = last_response_header := `No_response; let path = norm_path path in last_response_header := `Http_fs; http_fs # write_file flags path local method cancel() = http_fs # cancel() method size flags path = last_response_header := `No_response; let path = norm_path path in let plist = [ Webdav_client_methods.propname_getcontentlength ] in let r = wc # propfind ~depth:`Zero ~propfind_request:(`Prop plist) path in self # set_response r; if r # fully_successful then try let eff_path = r # effective_query_path in match (r # response_of_path eff_path) # prop_getcontentlength with | Some n -> n | None -> raise Not_found with | Not_found -> raise(Unix.Unix_error(Unix.EPERM, "Webdav_netfs.size", path)) else translate_error path r method test flags path t = List.hd(self # test_list flags path [t]) method test_list flags path tl = last_response_header := `No_response; let path = norm_path path in let plist = [ Webdav_client_methods.propname_resourcetype; Webdav_client_methods.propname_getcontentlength ] in let r = wc # propfind ~depth:`Zero ~propfind_request:(`Prop plist) path in self # set_response r; let exists = match r # call_status with | `Unserved -> assert false | `Successful -> true | `Http_protocol_error e -> raise e | `Redirection | `Client_error | `Server_error -> false | `Multi_status -> true in if exists then ( let eff_path = r # effective_query_path in let is_regular, is_dir = try match (r # response_of_path eff_path) # prop_resourcetype_is_collection with | None -> false, false | Some flag -> (not flag), flag with Not_found -> false, false in let not_empty = try match (r # response_of_path eff_path) # prop_getcontentlength with | None -> false | Some n -> n > 0L with Not_found -> false in List.map (function | `N -> true | `E -> true | `F -> is_regular | `D -> is_dir | `H -> false | `R -> true | `W -> true | `X -> is_dir | `S -> not_empty ) tl ) else List.map (fun _ -> false) tl method readdir flags path = last_response_header := `No_response; let path = norm_path path in let r = wc # list ~depth:`One `Standard path in self # set_response r; (* So first check whether there is info about [path] itself. If it is not a directory, raise ENOTDIR. *) if r#status = `Successful then ( let eff_path = r # effective_query_path in ( match (r # response_of_path eff_path) # prop_resourcetype_is_collection with | None -> raise(Unix.Unix_error(Unix.EPERM, "Webdav_netfs", path)) | Some flag -> if not flag then raise(Unix.Unix_error(Unix.ENOTDIR, "Webdav_netfs", path)) ); (* Now extract all children paths. We ignore bad paths *) [ "."; ".." ] @ ( List.map (fun p -> Filename.basename p ) (List.filter (fun p -> p <> eff_path) r#good_paths ) ) ) else translate_error path r method remove flags path = last_response_header := `No_response; let path = norm_path path in (* In WebDAV deletes are always recursive. So we have here an extra check for the non-recursive case. *) if not (List.mem `Recursive flags) then ( let r = wc # list ~depth:`Zero `Existence path in self # set_response r; if r # fully_successful then ( let eff_path = r # effective_query_path in match (r # response_of_path eff_path) # prop_resourcetype_is_collection with | None -> raise(Unix.Unix_error(Unix.EPERM, "Webdav_netfs", path)) | Some flag -> if flag then raise(Unix.Unix_error(Unix.EISDIR, "Webdav_netfs", path)) ) else translate_error path r ); (* FIXME: In the non-recursive case we should supply an If header to the DELETE so we only delete if the resource does not change in the meantime *) let r = wc # delete path in self # set_response r; if not (r # fully_successful) then translate_error path r method copy flags path1 path2 = last_response_header := `No_response; let path1 = norm_path path1 in let path2 = norm_path path2 in let r = wc # copy ~depth:`Zero ~overwrite:true path1 path2 in self # set_response r; if not (r # fully_successful) then translate_error path1 r method rename flags path1 path2 = last_response_header := `No_response; let path1 = norm_path path1 in let path2 = norm_path path2 in let r = wc # move ~overwrite:true path1 path2 in self # set_response r; if not (r # fully_successful) then translate_error path1 r method mkdir flags path = last_response_header := `No_response; let path = norm_path path in let p_flag = List.mem `Path flags in let nx_flag = List.mem `Nonexcl flags in let prim_mkcol p = let r = wc # mkcol p in self # set_response r; if not (r # fully_successful) then translate_error path r in if not p_flag then try prim_mkcol path with Unix.Unix_error(Unix.EEXIST,_,_) when nx_flag -> () else ( let rec traverse curdir todo = match todo with | [] -> () | d :: todo' -> let curdir' = curdir @ [d] in let p = String.concat "/" curdir' in ( try prim_mkcol p with Unix.Unix_error(Unix.EEXIST,_,_) -> () ); traverse curdir' todo' in let l = Netstring_str.split_delim slash_re path in traverse [List.hd l] (List.tl l) ) method rmdir flags path = raise(Unix.Unix_error(Unix.ENOSYS, "Webdav_netfs.rmdir", path)) method symlink flags path = raise(Unix.Unix_error(Unix.ENOSYS, "Webdav_netfs.symlink", path)) method readlink flags path = raise(Unix.Unix_error(Unix.ENOSYS, "Webdav_netfs.readlink", path)) method pipeline = pipeline end let webdav_netfs_layer = new webdav_netfs_layer class webdav_netfs ?tmp_directory ?tmp_prefix ?ip baseurl : webdav_stream_fs = let path_encoding = `Enc_utf8 in let http_fs = Http_fs.http_fs ?tmp_directory ?tmp_prefix ~path_encoding baseurl in webdav_netfs_layer ?ip http_fs let webdav_netfs = new webdav_netfs