Browse Source

Fix warnings.

master
linse 2 years ago
parent
commit
306e8a2b0d
  1. 2
      app/dune
  2. 2
      src/dune
  3. 4
      src/properties.ml
  4. 2
      src/webdav_api.ml
  5. 2
      src/webdav_api.mli
  6. 2
      src/webdav_fs.ml
  7. 2
      src/webdav_fs.mli
  8. 72
      src/webdav_server.ml
  9. 8
      test/test.ml

2
app/dune

@ -1,3 +1,3 @@
(test
(name caldav_server)
(libraries checkseum.ocaml digestif.ocaml logs logs.fmt caldav webmachine nocrypto lwt ptime ptime.clock.os cohttp cohttp-lwt-unix mirage-kv-lwt rresult oUnit mirage-clock-unix irmin-mirage io-page-unix mirage-conduit tcpip tcpip.stack-socket mirage-random-test mirage-kv-mem))
(libraries checkseum.ocaml digestif.ocaml logs logs.fmt caldav webmachine nocrypto lwt ptime ptime.clock.os cohttp cohttp-lwt-unix mirage-kv rresult oUnit mirage-clock-unix irmin-mirage io-page-unix tcpip tcpip.stack-socket mirage-random-test mirage-kv-mem))

2
src/dune

@ -2,4 +2,4 @@
(name carddav)
(public_name carddav)
(preprocess (pps ppx_deriving.std ppx_sexp_conv))
(libraries logs lwt ptime mirage-kv-lwt cohttp xmlm tyxml icalendar rresult nocrypto webmachine cohttp-lwt mirage-clock mirage-random))
(libraries logs lwt ptime mirage-kv cohttp xmlm tyxml icalendar rresult nocrypto webmachine cohttp-lwt mirage-clock mirage-random))

4
src/properties.ml

@ -201,7 +201,7 @@ let inherited_acls ~auth_user_props resource_props =
(* helper computing "current-user-privilege-set", not public *)
let current_user_privilege_set ~auth_user_props map =
let make_node p = Xml.dav_node "privilege" [ Xml.priv_to_xml p ] in
let privileges = privileges auth_user_props map in
let privileges = privileges ~auth_user_props map in
let uniq =
(* workaround for Firefox OS which doesn't understand <privilege><all/></privilege> *)
if List.mem `All privileges
@ -230,7 +230,7 @@ let authorized_properties_for_resource ~auth_user_props requested_props propmap_
(requested_allowed, requested_forbidden)
let find ~auth_user_props ~resource_props property_fqname =
let privileges = privileges auth_user_props resource_props in
let privileges = privileges ~auth_user_props resource_props in
if Privileges.can_read_prop property_fqname privileges
then match get_prop auth_user_props resource_props property_fqname with
| None -> Error `Not_found

2
src/webdav_api.ml

@ -57,7 +57,7 @@ end
let src = Logs.Src.create "webdav.robur.io" ~doc:"webdav api logs"
module Log = (val Logs.src_log src : Logs.LOG)
module Make(R : Mirage_random.C)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) = struct
module Make(R : Mirage_random.S)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) = struct
open Lwt.Infix
type state = Fs.t

2
src/webdav_api.mli

@ -52,4 +52,4 @@ sig
val connect : state -> config -> string option -> state Lwt.t
end
module Make(R : Mirage_random.C)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) : S with type state = Fs.t
module Make(R : Mirage_random.S)(Clock : Mirage_clock.PCLOCK)(Fs: Webdav_fs.S) : S with type state = Fs.t

2
src/webdav_fs.ml

@ -63,7 +63,7 @@ module Log = (val Logs.src_log src : Logs.LOG)
let propfile_ext = ".prop"
module Make (Fs:Mirage_kv_lwt.RW) = struct
module Make (Fs:Mirage_kv.RW) = struct
open Lwt.Infix

2
src/webdav_fs.mli

@ -59,4 +59,4 @@ sig
val valid : t -> Webdav_config.config -> (unit, [> `Msg of string ]) result Lwt.t
end
module Make (Fs: Mirage_kv_lwt.RW) : S with type t = Fs.t
module Make (Fs: Mirage_kv.RW) : S with type t = Fs.t

72
src/webdav_server.ml

@ -58,7 +58,7 @@ end
let to_status x = Cohttp.Code.code_of_status (x :> Cohttp.Code.status_code)
module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.S) (S: Cohttp_lwt.S.Server) = struct
module Make (R : Mirage_random.S) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.S) (S: Cohttp_lwt.S.Server) = struct
module WmClock = struct
let now () =
@ -99,18 +99,18 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
let rd' = with_resp_headers (Headers.replace_content_type content_type) rd in
Wm.continue (`String body) rd'
method allowed_methods rd =
method !allowed_methods rd =
Wm.continue [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `Other "PROPFIND"; `Other "PROPPATCH"; `Other "MKCOL"; `Other "MKCALENDAR" ; `Other "REPORT" ; `Other "ACL" ] rd
method known_methods rd =
method !known_methods rd =
Wm.continue [`GET; `HEAD; `PUT; `DELETE; `OPTIONS; `Other "PROPFIND"; `Other "PROPPATCH"; `Other "MKCOL"; `Other "MKCALENDAR" ; `Other "REPORT" ; `Other "ACL"] rd
method charsets_provided rd =
method !charsets_provided rd =
Wm.continue [
"utf-8", (fun id -> id)
] rd
method resource_exists rd =
method !resource_exists rd =
Fs.exists fs (self#path rd) >>= fun v ->
Wm.continue v rd
@ -126,7 +126,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
"text/calendar", self#write_component
] rd
method is_authorized rd =
method !is_authorized rd =
(* TODO implement digest authentication! *)
match Headers.get_authorization rd.req_headers with
| None -> Wm.continue (`Basic "calendar") rd
@ -154,13 +154,13 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
let rd' = with_req_headers (Headers.replace_authorization user) rd in
Wm.continue `Authorized rd'
method forbidden rd =
method !forbidden rd =
let path = self#path rd in
let user = Headers.get_user rd.req_headers in
Dav.access_granted_for_acl fs config ~path rd.meth ~user >>= fun granted ->
Wm.continue (not granted) rd
method process_property rd =
method !process_property rd =
let path = self#path rd in
let user = Headers.get_user rd.req_headers in
let depth = Headers.get_depth rd.req_headers in
@ -178,7 +178,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
let rd' = with_resp_headers (Headers.replace_content_type "application/xml") rd in
Wm.continue `Multistatus { rd' with resp_body = `String body }
method report rd =
method !report rd =
let path = self#path rd in
let user = Headers.get_user rd.req_headers in
Cohttp_lwt.Body.to_string rd.req_body >>= fun body ->
@ -190,13 +190,13 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
Wm.continue `Multistatus { rd' with resp_body = `String body }
(* required by webmachine API *)
method cannot_create rd =
method !cannot_create rd =
let xml = Xml.node ~ns:Xml.dav_ns "error" [Xml.node ~ns:Xml.dav_ns "resource-must-be-null" []] in
let err = Xml.tree_to_string xml in
let rd' = { rd with resp_body = `String err } in
Wm.continue () rd'
method create_collection rd =
method !create_collection rd =
let path = self#path rd in
let user = Headers.get_user rd.req_headers in
Cohttp_lwt.Body.to_string rd.req_body >>= fun body ->
@ -207,18 +207,18 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
| Error `Conflict -> Wm.continue `Conflict rd
| Ok _ -> Wm.continue `Created rd
method delete_resource rd =
method !delete_resource rd =
let path = self#path rd in
Logs.debug (fun m -> m "delete_resource path %s" path);
Dav.delete fs ~path (now ()) >>= fun deleted ->
Wm.continue deleted rd
method last_modified rd =
method !last_modified rd =
let path = self#path rd in
Dav.last_modified fs ~path >>= fun lm ->
Wm.continue lm rd
method generate_etag rd =
method !generate_etag rd =
let path = self#path rd in
(Dav.last_modified fs ~path >|= function
| None -> rd
@ -226,7 +226,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
Dav.compute_etag fs ~path >>= fun etag ->
Wm.continue etag rd'
method finish_request rd =
method !finish_request rd =
let rd' = if rd.meth = `OPTIONS then
(* access-control, access-control, calendar-access, calendar-schedule, calendar-auto-schedule,
calendar-availability, inbox-availability, calendar-proxy, calendarserver-private-events,
@ -247,10 +247,10 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
class redirect config = object(self)
inherit [Cohttp_lwt.Body.t] Wm.resource
method allowed_methods rd =
method !allowed_methods rd =
Wm.continue [`GET ; `Other "PROPFIND"] rd
method known_methods = self#allowed_methods
method !known_methods = self#allowed_methods
method content_types_provided rd =
Wm.continue [ ("*/*", self#redirect) ] rd
@ -258,7 +258,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
method content_types_accepted rd =
Wm.continue [] rd
method process_property rd =
method !process_property rd =
Logs.debug (fun m -> m "Redirecting %s to %s %s" (Uri.to_string rd.uri) (Uri.to_string config.host) config.calendars);
let rd' = redirect (Uri.to_string @@ Uri.with_path config.host config.calendars) rd in
(* TODO add redirect to addressbook *)
@ -285,10 +285,10 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
| None -> Error `Bad_request
| Some x -> Ok x
method allowed_methods rd =
method !allowed_methods rd =
Wm.continue [`PUT; `OPTIONS; `DELETE ] rd
method known_methods rd =
method !known_methods rd =
Wm.continue [`PUT; `OPTIONS; `DELETE ] rd
method private create_user rd =
@ -303,7 +303,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
(* TODO? allow a user to delete themselves *)
(* TODO? soft-delete: "mark as deleted" *)
method delete_resource rd =
method !delete_resource rd =
match self#requested_user rd with
| Error `Bad_request -> Wm.respond (to_status `Bad_request) rd
| Ok name ->
@ -311,7 +311,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
| Error e -> Wm.respond (to_status e) rd
| Ok () -> Wm.continue true rd
method is_conflict rd =
method !is_conflict rd =
match self#requested_user rd with
| Error `Bad_request -> Wm.respond (to_status `Bad_request) rd
| Ok name ->
@ -335,7 +335,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
("application/octet-stream", self#create_user)
] rd
method is_authorized rd =
method !is_authorized rd =
(* TODO implement digest authentication! *)
match Headers.get_authorization rd.req_headers with
| None -> Wm.continue (`Basic "calendar") rd
@ -350,7 +350,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
let rd' = with_req_headers (Headers.replace_authorization user) rd in
Wm.continue `Authorized rd'
method forbidden rd =
method !forbidden rd =
let user = Headers.get_user rd.req_headers in
match self#requested_user rd with
| Error `Bad_request -> Wm.respond (to_status `Bad_request) rd
@ -376,10 +376,10 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
then Ok members
else Error `Bad_request
method allowed_methods rd =
method !allowed_methods rd =
Wm.continue [`PUT; `OPTIONS; `DELETE ] rd
method known_methods rd =
method !known_methods rd =
Wm.continue [`PUT; `OPTIONS; `DELETE ] rd
method private create_group rd =
@ -391,7 +391,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
let rd' = with_resp_headers (Headers.replace_location principal_url) rd in
Wm.continue true rd'
method delete_resource rd =
method !delete_resource rd =
match self#requested_group rd with
| Error `Bad_request -> Wm.respond (to_status `Bad_request) rd
| Ok name ->
@ -399,7 +399,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
| Error e -> Wm.respond (to_status e) rd
| Ok () -> Wm.continue true rd
method is_conflict rd =
method !is_conflict rd =
match self#requested_group rd with
| Error `Bad_request -> Wm.respond (to_status `Bad_request) rd
| Ok name ->
@ -418,7 +418,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
("application/octet-stream", self#create_group)
] rd
method is_authorized rd =
method !is_authorized rd =
(* TODO implement digest authentication! *)
match Headers.get_authorization rd.req_headers with
| None -> Wm.continue (`Basic "calendar") rd
@ -433,7 +433,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
let rd' = with_req_headers (Headers.replace_authorization user) rd in
Wm.continue `Authorized rd'
method forbidden rd =
method !forbidden rd =
let user = Headers.get_user rd.req_headers in
match self#requested_group rd with
| Error `Bad_request -> Wm.respond (to_status `Bad_request) rd
@ -455,10 +455,10 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
| None -> Error `Bad_request
| Some x -> if not (sane x) then Error `Bad_request else Ok x
method allowed_methods rd =
method !allowed_methods rd =
Wm.continue [`PUT; `OPTIONS; `DELETE ] rd
method known_methods rd =
method !known_methods rd =
Wm.continue [`PUT; `OPTIONS; `DELETE ] rd
method private add_group_member rd =
@ -468,7 +468,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
Dav.enroll fs config ~group ~member >>= fun () ->
Wm.continue true rd
method delete_resource rd =
method !delete_resource rd =
match self#requested_group rd, self#requested_member rd with
| Error `Bad_request, _ | _, Error `Bad_request -> Wm.respond (to_status `Bad_request) rd
| Ok group, Ok member ->
@ -483,10 +483,10 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
("application/octet-stream", self#add_group_member)
] rd
method is_conflict rd =
method !is_conflict rd =
Wm.continue false rd
method is_authorized rd =
method !is_authorized rd =
(* TODO implement digest authentication! *)
match Headers.get_authorization rd.req_headers with
| None -> Wm.continue (`Basic "calendar") rd
@ -501,7 +501,7 @@ module Make (R : Mirage_random.C) (Clock : Mirage_clock.PCLOCK) (Fs : Webdav_fs.
let rd' = with_req_headers (Headers.replace_authorization user) rd in
Wm.continue `Authorized rd'
method forbidden rd =
method !forbidden rd =
let user = Headers.get_user rd.req_headers in
match self#requested_group rd with
| Error `Bad_request -> Wm.respond (to_status `Bad_request) rd

8
test/test.ml

@ -549,8 +549,8 @@ let appendix_b_data acl =
let props name = Properties.create_dir acl now name in
Fs.mkdir res_fs (`Dir [ "bernard" ]) (props "bernard") >>= fun _ ->
Fs.mkdir res_fs (`Dir [ "bernard" ; "work" ]) (props "bernard/work") >>= fun _ ->
Lwt_list.iter_s (fun (fn, etag, data) ->
let props = Properties.create ~content_type:"text/calendar" ~etag
Lwt_list.iter_s (fun (fn, _etag, data) ->
let props = Properties.create ~content_type:"text/calendar"
acl now (String.length data) ("bernard/work/" ^ fn)
in
Fs.write res_fs (`File [ "bernard" ; "work" ; fn ])
@ -569,8 +569,8 @@ let appendix_b_1_data acl =
Fs.mkdir res_fs (`Dir [ "bernard" ; "work" ]) (props "bernard/work") >>= fun _ ->
(match Appendix_b.all with
| [] -> assert false
| (fn, etag, data) :: _ ->
let props = Properties.create ~content_type:"text/calendar" ~etag
| (fn, _etag, data) :: _ ->
let props = Properties.create ~content_type:"text/calendar"
acl now (String.length data) ("bernard/work/" ^ fn)
in
Fs.write res_fs (`File [ "bernard" ; "work" ; fn ])

Loading…
Cancel
Save