(* $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