(* $Id: webdav_netfs.ml 3 2011-08-30 18:32:23Z gerd $ *) (* FIXME: - use If headers where appropriate problem: WebDAV servers seem not to return E-Tags ALSO: - Support patchprop - Support If headers - Support locks *) class type webdav_stream_fs = object inherit Http_fs.http_stream_fs method webdav_client : Webdav_client.webdav_client_t end let slash_re = Netstring_pcre.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 -> 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) 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 -> hdr 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 last_response_header := `This r#response_header; 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 last_response_header := `This r#response_header; 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 last_response_header := `This r#response_header; (* 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 -> if has_trailing_slash p then Filename.basename(Filename.dirname p) else 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 last_response_header := `This r#response_header; 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 last_response_header := `This r#response_header; 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 last_response_header := `This r#response_header; 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 last_response_header := `This r#response_header; 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 last_response_header := `This r#response_header; 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_pcre.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