Browse Source

Initial commit, copy of CalDAV.

master
linse 4 years ago
commit
2ad313e464
  1. 19
      .gitignore
  2. 6
      .merlin
  3. 15
      .travis.yml
  4. 1
      CHANGES.md
  5. 1
      LICENSE.md
  6. 28
      Makefile
  7. 97
      README.md
  8. 228
      app/caldav_server.ml
  9. 71
      app/cohttp_lwt_unix_test.ml
  10. 1
      app/cohttp_lwt_unix_test.mli
  11. 43
      app/cohttp_test.ml
  12. 48
      app/cohttp_test.mli
  13. 3
      app/dune
  14. 54
      carddav.opam
  15. 13
      curl/change_acl.xml
  16. 2
      curl/create_user.xml
  17. 13
      curl/grant_read_acl.xml
  18. 23
      curl/notes
  19. 4
      curl/propfind.xml
  20. 8
      dune
  21. 2
      dune-project
  22. 91
      mirage/config.ml
  23. 0
      mirage/tls/.keep
  24. 161
      mirage/unikernel.ml
  25. 5
      src/dune
  26. 94
      src/privileges.ml
  27. 11
      src/privileges.mli
  28. 268
      src/properties.ml
  29. 51
      src/properties.mli
  30. 57
      src/test.sh
  31. 1289
      src/webdav_api.ml
  32. 55
      src/webdav_api.mli
  33. 36
      src/webdav_config.ml
  34. 347
      src/webdav_fs.ml
  35. 62
      src/webdav_fs.mli
  36. 556
      src/webdav_server.ml
  37. 788
      src/webdav_xml.ml
  38. 234
      test/appendix_b.ml
  39. 4
      test/dune
  40. 1844
      test/test.ml

19
.gitignore

@ -0,0 +1,19 @@
_build/
*.install
*/.merlin
checkseum/
decompress/
digestif/
irmin/
mirage-kv/
mirage/.mirage.config
mirage/Makefile
mirage/caldav
mirage/key_gen.ml
mirage/main.ml
mirage/main.native
mirage/*.opam
mirage/myocamlbuild.ml
mirage/static1.ml
mirage/static1.mli
ocaml-git/

6
.merlin

@ -0,0 +1,6 @@
S src
S test
B _build/**
B src/_build/**
PKG lwt alcotest xmlm tyxml rresult webmachine lwt ptime ptime.clock.os
PKG cohttp-lwt-unix mirage-fs-mem icalendar

15
.travis.yml

@ -0,0 +1,15 @@
language: c
install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
script: bash -ex .travis-opam.sh
sudo: required
env:
global:
- PACKAGE="caldav"
- POST_INSTALL_HOOK="make"
- PINS="webmachine:git+https://github.com/roburio/ocaml-webmachine.git#webdav"
matrix:
- OCAML_VERSION=4.05
- OCAML_VERSION=4.06
- OCAML_VERSION=4.07
notifications:
email: false

1
CHANGES.md

@ -0,0 +1 @@
### No release yet, need to patch webmachine first.

1
LICENSE.md

@ -0,0 +1 @@
Not sure yet.

28
Makefile

@ -0,0 +1,28 @@
all:
opam reinstall caldav
cd mirage; make
test: clean
dune runtest --no-buffer -j 1 test --profile=release
configure:
cd mirage; mirage configure
depend:
opam install -t --deps-only .
pin:
opam pin add caldav .
clean:
dune clean
utop:
dune utop src --profile=release
user:
curl -v -X PUT "http://root:toor@127.0.0.1:8080/user?name=user1&password=1"
acl:
curl -v -X PROPPATCH -d @curl/change-acl.xml "http://test:password@127.0.0.1:8080/calendars/test/calendar"

97
README.md

@ -0,0 +1,97 @@
## Compilation of CalDAV server unikernel
To begin the installation, you need to `ssh` into your server.
Then, you need to install [`opam`](https://opam.ocaml.org) via your package manager (e.g. `apt install opam`).
Make sure you have OCaml version `>=4.03.0`, and opam version `>=2.0.0` and mirage version `>=3.3.1` installed via your package manager.
You can use `ocaml --version`, `opam --version`, and `mirage --version` to find out.
Now we're ready to compile the CalDAV server. Let's get the code (don't worry that we already pinned caldav, we now need the source code of the unikernel):
git clone https://github.com/roburio/caldav.git
cd caldav/mirage
mirage configure
make depend
make
If the above commands fail while installing caldav, run `opam remove webmachine` and run `make depend` again.
The `make` command creates a `main.native` executable in `caldav/mirage`. This is the unikernel.
We can see all its options:
./main.native --help
## Running the unikernel
The following steps vary based on your desired server features.
### HTTPS preparations
If you're planning to use https you need to create a certificate:
opam install certify
selfsign -c server.pem -k server.key "calendar.example.com"
mv server.pem server.key caldav/mirage/tls/
You can also copy an existing one to that location.
### First start
To start the server, we need a data directory and an admin password, which will be used for the user `root` that always exists. The password needs to be set on first run only. It will then be hashed, salted and stored on disk in the data directory. The data directory persists on disk when the unikernel is not running. It's the part with your precious user data that you might want to back up.
Startup:
mkdir /tmp/calendar
### With HTTP
./main.native --data="/tmp/calendar" --admin-password="somecoolpassword" --host="calendar.example.com" --http=80
### With HTTPS
./main.native --data="/tmp/calendar" --admin-password="somecoolpassword" --host="calendar.example.com" --http=80 --https=443
### With HTTPS + trust on first use (tofu):
./main.native --data="/tmp/calendar" --admin-password="somecoolpassword" --host="calendar.example.com" --http=80 --https=443 --tofu
## Server administration
### Create user
If you don't use trust on first use, you might want to create a new user:
curl -v -u root:somecoolpassword -X PUT "https://calendar.example.com/users/somenewuser?password=theirpassword"
### Update password
If someone forgot their password, root can set a new one:
curl -v -u root:somecoolpassword -X PUT "https://calendar.example.com/users/somenewuser?password=theirpassword"
### Delete user
If someone wants to leave, root can delete their account:
curl -v -u root:somecoolpassword -X DELETE "https://calendar.example.com/users/somenewuser"
### Create group
You might want to create a new group. Members is an optional query parameter.
curl -v -u root:somecoolpassword -X PUT "https://calendar.example.com/groups/somenewgroup?members=ruth,viktor,carsten,else"
### Update group members
You might want to update the members of a group. The members parameter will overwrite the existing group members. Be careful not to lose your groups.
curl -v -u root:somecoolpassword -X PUT "https://calendar.example.com/groups/somenewgroup?members=ruth,viktor,carsten,else"
You might want to add a member to a group.
curl -v -u root:somecoolpassword -X PUT "https://calendar.example.com/groups/somenewgroup/users/ruth"
You might want to remove a member from a group.
curl -v -u root:somecoolpassword -X DELETE "https://calendar.example.com/groups/somenewgroup/users/ruth"
### Delete group
You might want to delete a group. Root can do this.
curl -v -u root:somecoolpassword -X DELETE "https://calendar.example.com/groups/somenewgroup"

228
app/caldav_server.ml

@ -0,0 +1,228 @@
(*
open Lwt.Infix
open Caldav.Webdav_config
module Fs = Caldav.Webdav_fs.Make(FS_unix)
module Webdav_server = Caldav.Webdav_server.Make(Clock)(Fs)
module G = Irmin_git.Mem
module Store = Irmin_mirage.Git.KV_RW(G)(Pclock)
module Fs = Caldav.Webdav_fs.Make(Store)
module Xml = Caldav.Webdav_xml
module Dav = Caldav.Webdav_api.Make(Fs)
module Http_server = Cohttp_lwt_unix.Server
module Conduit_mirage_tcp = Conduit_mirage.With_tcp(Tcpip_stack_socket)
let now = Ptime_clock.now
let generate_salt () = Nocrypto.Rng.generate 15
let init_users fs now config user_password =
Lwt_list.iter_p (fun (name, password) ->
let salt = generate_salt () in
Dav.make_user fs now config ~name ~password ~salt >|= fun _ -> ())
user_password >>= fun () ->
Dav.make_group fs now config "group" [ "root" ; "test" ]
let main () =
(* avoids ECONNRESET, see https://github.com/mirage/ocaml-cohttp/issues/511 *)
Lwt.async_exception_hook := (function
| Unix.Unix_error (error, func, arg) ->
Logs.warn (fun m -> m "Client connection error %s: %s(%S)"
(Unix.error_message error) func arg)
| exn -> Logs.err (fun m -> m "Unhandled exception: %a" Fmt.exn exn)
);
Logs.set_reporter (Logs_fmt.reporter ());
Logs.set_level (Some Logs.Debug);
let host = host () in
let do_trust_on_first_use = match Sys.getenv "CALDAV_TOFU" with
| exception Not_found -> false
| "yes" | "YES" | "1" | "true" | "TRUE" -> true
| _ -> false
in
let config = config ~do_trust_on_first_use host in
(* create the file system *)
G.v (Fpath.v "bla") >>= function
| Error _ -> assert false
| Ok git ->
Udpv4_socket.connect None >>= fun udp ->
Tcpv4_socket.connect None >>= fun tcp ->
Tcpip_stack_socket.connect [] udp tcp >>= fun stack ->
Conduit_mirage_tcp.connect stack Conduit_mirage.empty >>= fun conduit' ->
Conduit_mirage.with_tls conduit' >>= fun conduit ->
let resolver = Resolver_lwt_unix.system in
Store.connect git ~conduit ~author:"caldav" ~resolver ~msg:(fun _ -> "a calendar change") ()
"https://github.com/roburio/testcalendar.git" >>= fun fs ->
(* only for apple test suite *)
(* initialize_fs_for_apple_testsuite fs now config >>= fun () -> *)
Dav.initialize_fs fs (now ()) config >>= fun () ->
let user_password = [
("test", "password") ;
("root", "toor") ;
("nobody", "1")
] in
init_users fs (now ()) config user_password >>= fun _ ->
let callback (ch, conn) request body =
let open Cohttp in
(* Perform route dispatch. If [None] is returned, then the URI path did not
* match any of the route patterns. In this case the server should return a
* 404 [`Not_found]. *)
Logs.info (fun m -> m "REQUEST %s %s headers %s"
(Code.string_of_method (Request.meth request))
(Request.resource request)
(Header.to_string (Request.headers request)) );
Webdav_server.Wm.dispatch' (Webdav_server.routes config fs now generate_salt) ~body ~request
>|= begin function
| None -> (`Not_found, Header.init (), `String "Not found", [])
| Some result -> result
end
>>= fun (status, headers, body, path) ->
(* If you'd like to see the path that the request took through the
* decision diagram, then run this example with the [DEBUG_PATH]
* environment variable set. This should suffice:
*
* [$ DEBUG_PATH= ./crud_lwt.native]
*
*)
let path =
match Sys.getenv "DEBUG_PATH" with
| _ -> Printf.sprintf " - %s" (String.concat ", " path)
| exception Not_found -> ""
in
Logs.info (fun m -> m "\nRESPONSE %d - %s %s%s, body: %s"
(Code.code_of_status status)
(Code.string_of_method (Request.meth request))
(Uri.path (Request.uri request))
path
(match body with `String s -> s | `Empty -> "empty" | _ -> "unknown") ) ;
(* Finally, send the response to the client *)
Http_server.respond ~headers ~body ~status ()
in
(* create the server and handle requests with the function defined above *)
let conn_closed (ch, conn) =
Logs.info (fun m -> m "connection %s closed"
(Sexplib.Sexp.to_string_hum (Conduit_lwt_unix.sexp_of_flow ch)))
in
let port = match Uri.port config.host with None -> 80 | Some x -> x in
let http_config = Http_server.make ~callback ~conn_closed () in
Http_server.create ~mode:(`TCP(`Port port)) http_config
>>= (fun () -> Logs.app (fun m -> m "caldav_server.exe: listening on 0.0.0.0:%d%!" port);
Lwt.return_unit)
let () = Lwt_main.run (main ())
*)
open Lwt.Infix
open OUnit
open Cohttp
open Cohttp_lwt_unix_test
module Http_server = Cohttp_lwt_unix.Server
module Body = Cohttp_lwt.Body
module KV_mem = Mirage_kv_mem.Make(Pclock)
module Dav_fs = Caldav.Webdav_fs.Make(KV_mem)
module Webdav_server = Caldav.Webdav_server.Make(Mirage_random_test)(Pclock)(Dav_fs)(Http_server)
module Api = Caldav.Webdav_api.Make(Mirage_random_test)(Pclock)(Dav_fs)
let header, content, footer =
{|BEGIN:VCALENDAR
VERSION:2.0
PRODID:-//Example Corp.//CalDAV Client//EN
|},
{|BEGIN:VTIMEZONE
LAST-MODIFIED:20040110T032845Z
TZID:US/Eastern
BEGIN:DAYLIGHT
DTSTART:20000404T020000
RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4
TZNAME:EDT
TZOFFSETFROM:-0500
TZOFFSETTO:-0400
END:DAYLIGHT
BEGIN:STANDARD
DTSTART:20001026T020000
RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10
TZNAME:EST
TZOFFSETFROM:-0400
TZOFFSETTO:-0500
END:STANDARD
END:VTIMEZONE
BEGIN:VEVENT
UID:74855313FA803DA593CD579A@example.com
DTSTAMP:20060206T001102Z
DTSTART;TZID=US/Eastern:20060102T100000
DURATION:PT1H
SUMMARY:Event #1
Description:Go Steelers!
END:VEVENT
|},
{|END:VCALENDAR
|}
let data = header ^ content ^ footer
let rec repeat n s =
if n = 0 then "" else s ^ repeat (pred n) s
let convert_nl_to_cr_nl str =
let re = Re.compile ( Re.Perl.re "\n" ) in
Re.replace_string ~all:true re ~by:"\r\n" str
let expected =
convert_nl_to_cr_nl
({|BEGIN:VCALENDAR
PRODID:-//ROBUR.IO//EN
VERSION:2.0
X-WR-CALNAME:root
|} ^ repeat 1000 content ^ footer)
let config = Caldav.Webdav_config.config ~do_trust_on_first_use:true (Uri.of_string "localhost")
let server fs =
let headers =
let auth_header = "Basic " ^ Cstruct.to_string (Nocrypto.Base64.encode (Cstruct.of_string "root:foo")) in
Cohttp.Header.add (Cohttp.Header.init ()) "Authorization" auth_header
in
let request, body = Request.make ~headers ~meth:`GET (Uri.of_string "/calendars/root"), `Empty in
List.map const [ (* t *)
Webdav_server.dispatch config fs request body
(* Http_server.respond ~status:`OK ~body:(`String message) (); *)
] |> response_sequence
let ts fs =
Cohttp_lwt_unix_test.test_server_s (server fs) begin fun uri ->
let t () =
Cohttp_lwt_unix.Client.get uri >>= fun (_, body) ->
body |> Body.to_string >|= fun body ->
Logs.debug (fun m -> m "found %s" body) ;
assert_equal body expected in
[ "sanity test", t ]
end
let () =
ignore (Lwt_main.run (
Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) ;
Logs.set_level (Some Logs.Info);
KV_mem.connect () >>= fun fs ->
let now = Ptime.epoch in
Api.connect fs config (Some "foo") >>= fun _fs ->
let rec go = function
| 0 -> Lwt.return_unit
| n ->
let name = string_of_int n ^ ".ics" in
let filename = Dav_fs.create_file (`Dir ["calendars" ; "root"]) name in
let props = Caldav.Properties.create
~content_type:"text/calendar"
[(`All, `Grant [ `All ])] now (String.length data) name
in
Dav_fs.write fs filename data props >>= fun _ ->
go (pred n)
in
go 1000 >>= fun () ->
run_async_tests (ts fs)))

71
app/cohttp_lwt_unix_test.ml

@ -0,0 +1,71 @@
open Lwt
open OUnit
open Cohttp_lwt_unix
type 'a io = 'a Lwt.t
type ic = Lwt_io.input_channel
type oc = Lwt_io.output_channel
type body = Cohttp_lwt.Body.t
type response_action =
[ `Expert of Cohttp.Response.t
* (ic
-> oc
-> unit io)
| `Response of Cohttp.Response.t * body ]
type spec = Request.t -> body -> response_action io
type async_test = unit -> unit Lwt.t
let response rsp = `Response rsp
let expert ?(rsp=Cohttp.Response.make ()) f _req _body =
return (`Expert (rsp, f))
let const rsp _req _body = rsp >|= response
let response_sequence = Cohttp_test.response_sequence Lwt.fail_with
let () = Debug.activate_debug ()
let () = Logs.set_level (Some Info)
let temp_server ?port spec callback =
let port = match port with
| None -> Cohttp_test.next_port ()
| Some p -> p in
let server = Server.make_response_action ~callback:(fun _ req body -> spec req body) () in
let uri = Uri.of_string ("http://0.0.0.0:" ^ (string_of_int port)) in
let server_failed, server_failed_wake = Lwt.task () in
let server = Lwt.catch
(fun () -> Server.create ~mode:(`TCP (`Port port)) server)
(function
| Lwt.Canceled -> Lwt.return_unit
| x -> Lwt.wakeup_exn server_failed_wake x; Lwt.fail x)
in
Lwt.pick [ callback uri; server_failed ] >|= fun res ->
Lwt.cancel server;
res
let test_server_s ?port ?(name="Cohttp Server Test") spec f =
temp_server ?port spec begin fun uri ->
Logs.info (fun f -> f "Test %s running on %s" name (Uri.to_string uri));
let tests = f uri in
let results =
tests
|> Lwt_list.map_s (fun (name, test) ->
Logs.info (fun f -> f "Running %s" name);
let res = Lwt.try_bind test
(fun () -> return `Ok)
(fun exn -> return (`Exn exn)) in
res >|= (fun res -> (name, res))) in
results >|= (fun results ->
let ounit_tests =
results
|> List.map (fun (name, res) ->
name >:: fun () ->
match res with
| `Ok -> ()
| `Exn x -> raise x) in
name >::: ounit_tests)
end
let run_async_tests test = test >|= OUnit.run_test_tt_main

1
app/cohttp_lwt_unix_test.mli

@ -0,0 +1 @@
include Cohttp_test.S with type 'a io = 'a Lwt.t and type body = Cohttp_lwt.Body.t and type ic = Lwt_io.input_channel and type oc = Lwt_io.output_channel

43
app/cohttp_test.ml

@ -0,0 +1,43 @@
open Cohttp
module type S = sig
type 'a io
type ic
type oc
type body
type response_action =
[ `Expert of Cohttp.Response.t
* (ic
-> oc
-> unit io)
| `Response of Cohttp.Response.t * body ]
type spec = Request.t -> body -> response_action io
type async_test = unit -> unit io
val response : (Response.t * body) -> response_action
val expert : ?rsp:Cohttp.Response.t -> (ic -> oc -> unit io) -> spec
val const : (Response.t * body) io -> spec
val response_sequence : spec list -> spec
val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io
val test_server_s : ?port:int -> ?name:string -> spec
-> (Uri.t -> (string * async_test) list) -> OUnit.test io
val run_async_tests : OUnit.test io -> OUnit.test_results io
end
let port = ref 9193
let next_port () =
let current_port = !port in
incr port;
current_port
let response_sequence fail responses =
let xs = ref responses in
fun req body ->
match !xs with
| x::xs' ->
xs := xs';
x req body
| [] -> fail "response_sequence: Server exhausted responses"

48
app/cohttp_test.mli

@ -0,0 +1,48 @@
open Cohttp
module type S = sig
type 'a io
type ic
type oc
type body
type response_action =
[ `Expert of Cohttp.Response.t
* (ic
-> oc
-> unit io)
| `Response of Cohttp.Response.t * body ]
(** A server that is being tested must be defined by providing a spec *)
type spec = Request.t -> body -> response_action io
type async_test = unit -> unit io
val response : Response.t * body -> response_action
val expert : ?rsp:Response.t -> (ic -> oc -> unit io) -> spec
(** A constant handler that always returns its argument *)
val const : (Response.t * body) io -> spec
(** A server that process requests using the provided specs in sequence
and crashes on further reqeusts *)
val response_sequence : spec list -> spec
(** Create a temporary server according to spec that lives until the callback
thread is determined. The uri provided in the callback should be the base
uri for any requests made to the temp server *)
val temp_server : ?port:int -> spec -> (Uri.t -> 'a io) -> 'a io
(** Create a test suite against a server defined by spec. Tests
run sequentially. *)
val test_server_s : ?port:int -> ?name:string -> spec
-> (Uri.t -> (string * async_test) list) -> OUnit.test io
(** Run an async unit test and return and print the result *)
val run_async_tests : OUnit.test io -> OUnit.test_results io
end
(** Internal API. Subject to breakage *)
val next_port : unit -> int
val response_sequence : (string -> 'a) -> ('b -> 'c -> 'a) list
-> 'b -> 'c -> 'a

3
app/dune

@ -0,0 +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))

54
carddav.opam

@ -0,0 +1,54 @@
opam-version: "2.0"
maintainer: [
"Stefanie Schirmer @linse"
"Hannes Mehnert"
]
authors: [
"Stefanie Schirmer @linse"
"Hannes Mehnert"
]
homepage: "https://github.com/roburio/carddav"
bug-reports: "https://github.com/roburio/carddav/issues"
dev-repo: "git+https://github.com/roburio/carddav.git"
tags: ["org:mirage" "org:robur"]
doc: "https://roburio.github.io/carddav/"
license: "ISC"
build: [
["dune" "subst"] {pinned}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
pin-depends: [
["webmachine.dev" "git+https://github.com/roburio/ocaml-webmachine.git#webdav"]
["mirage-kv-mem.dev" "git+https://github.com/mirage/mirage-kv-mem.git"]
["mirage-kv.dev" "git+https://github.com/samoht/mirage-kv.git#rw"]
["mirage-kv-lwt.dev" "git+https://github.com/samoht/mirage-kv.git#rw"]
]
depends: [
"ocaml" {>= "4.05.0"}
"dune" {build}
"alcotest" {with-test}
"ounit" {with-test}
"mirage-random-test" {with-test}
"mirage-clock-unix" {with-test}
"mirage-kv-mem" {with-test}
"ppx_deriving" {build}
"webmachine"
"lwt"
"ptime"
"cohttp-lwt-unix"
"nocrypto"
"xmlm"
"tyxml"
"icalendar"
"rresult"
]
synopsis: "A CardDAV server"
description: """
A CardDAV server. Supports everything from the roburio/vcard library.
Also supports a bit of WebDAV.
"""

13
curl/change_acl.xml

@ -0,0 +1,13 @@
<?xml version="1.0" encoding="utf-8" ?>
<D:propertyupdate xmlns:D="DAV:">
<D:set>
<D:prop>
<D:acl>
<D:ace>
<D:principal><D:all/></D:principal>
<D:deny><D:privilege><D:all/></D:privilege></D:deny>
</D:ace>
</D:acl>
</D:prop>
</D:set>
</D:propertyupdate>

2
curl/create_user.xml

@ -0,0 +1,2 @@
<?xml version="1.0" encoding="utf-8" ?>
<A:mkcol xmlns:A="DAV:"><A:set><A:prop></A:prop></A:set></A:mkcol>

13
curl/grant_read_acl.xml

@ -0,0 +1,13 @@
<?xml version="1.0" encoding="utf-8" ?>
<D:propertyupdate xmlns:D="DAV:">
<D:set>
<D:prop>
<D:acl>
<D:ace>
<D:principal><D:href>http://127.0.0.1:8080/principals/test/</D:href></D:principal>
<D:grant><D:privilege><D:read/></D:privilege></D:grant>
</D:ace>
</D:acl>
</D:prop>
</D:set>
</D:propertyupdate>

23
curl/notes

@ -0,0 +1,23 @@
create user
IST ? /user ? name="username" & password = "pasword"
SOLL PUT /users/otto&password="password"
create or update group
IST PUT groups ? name = "meinegruppe" & members = [a, b, c]
SOLL PUT /groups/name &members=a,b,c => CREATED
delete user
IST DELETE /user ? name="username"
DELETE /users/otto
delete group
IST DELETE /group ? name = "name"
DELETE /groups/48
add user to group
IST not supported
SOLL PUT /groups/48/users/otto
remove user from group
IST not supported
SOLL DELETE /groups/48/users/otto

4
curl/propfind.xml

@ -0,0 +1,4 @@
<?xml version="1.0" encoding="utf-8" ?>
<propfind xmlns="DAV:">
<allprop/>
</propfind>

8
dune

@ -0,0 +1,8 @@
(env
(profile
(ocamlopt_flags (:standard -p -w -27-32-52-33-34-37-39))
(flags (:standard -w -27-32-52-33-34-37-39)))
(dev
(flags (:standard -w -27-32-52-33-34-37-39)))
(release
(flags (:standard -w -27-32-52-33-34-37-39))))

2
dune-project

@ -0,0 +1,2 @@
(lang dune 1.3)
(name caldav)

91
mirage/config.ml

@ -0,0 +1,91 @@
open Mirage
let net = generic_stackv4 default_network
(* set ~tls to false to get a plain-http server *)
let http_srv = http_server @@ conduit_direct ~tls:true net
(* TODO: make it possible to enable and disable schemes without providing a port *)
let http_port =
let doc = Key.Arg.info ~doc:"Listening HTTP port." ["http"] ~docv:"PORT" in
Key.(create "http_port" Arg.(opt (some int) None doc))
let https_port =
let doc = Key.Arg.info ~doc:"Listening HTTPS port." ["https"] ~docv:"PORT" in
Key.(create "https_port" Arg.(opt (some int) None doc))
let certs = generic_kv_ro ~key:Key.(value @@ kv_ro ()) "tls"
let admin_password =
let doc = Key.Arg.info ~doc:"Password for the administrator." ["admin-password"] ~docv:"STRING" in
Key.(create "admin_password" Arg.(opt (some string) None doc))
let fs_root =
let doc = Key.Arg.info ~doc:"Location of calendar data." [ "data" ] ~docv:"DIR" in
Key.(create "fs_root" Arg.(required string doc))
let tofu =
let doc = Key.Arg.info ~doc:"If a user does not exist, create them and give them a new calendar." [ "tofu" ] in
Key.(create "tofu" Arg.(flag doc))
let hostname =
let doc = Key.Arg.info ~doc:"Hostname to use." [ "host" ] ~docv:"STRING" in
Key.(create "hostname" Arg.(required string doc))
let monitor =
let doc = Key.Arg.info ~doc:"Hostname to use for monitoring." [ "monitor" ] ~docv:"STRING" in
Key.(create "monitor" Arg.(opt (some string) None doc))
let apple_testable =
let doc = Key.Arg.info ~doc:"Configure the server to use with Apple CCS CalDAVtester." [ "apple-testable" ] in
Key.(create "apple_testable" Arg.(flag doc))
(*
in the Mirage module (from the mirage package):
code: let keys = List.map Key.abstract [ http_port ; https_port ; admin_password ]
We get: Error: This expression has type
string option Mirage.Key.key = string option Functoria_key.key
but an expression was expected of type
int option Mirage.Key.key = int option Functoria_key.key
Type string is not compatible with type int
http_port and https_port are of type "int option Key.t", admin_password "string option Key.t".
How to prevent getting Key.abstract specialized to "int option Key.t"?
existential wrapper:
type any_key = Any : 'a Key.key -> any_key
let keys = List.map (fun (Any k) -> Key.abstract k) [Any http_port; Any https_port; Any admin_password]
*)
let main =
let direct_dependencies = [
package "uri" ;
package "mirage-kv-unix" ;
package ~pin:"git+https://github.com/roburio/caldav.git" "caldav" ;
package ~pin:"git+https://github.com/hannesm/ocaml-crunch.git#kv-ng" "crunch" ;
package ~pin:"git+https://github.com/mirage/mirage-kv-mem.git" "mirage-kv-mem" ;
package ~pin:"git+https://github.com/samoht/ocaml-tls.git#ro-ng" "tls" ;
package ~pin:"git+https://github.com/samoht/ocaml-dns.git#ro-ng" "mirage-dns" ;
package ~pin:"git+https://github.com/samoht/ocaml-cohttp.git#ro-ng" "cohttp-mirage" ;
package ~pin:"git+https://github.com/samoht/irmin.git#ro-ng" "irmin" ;
package ~pin:"git+https://github.com/samoht/irmin.git#ro-ng" "irmin-mirage" ;
package ~pin:"git+https://github.com/samoht/irmin.git#ro-ng" "irmin-git" ;
package ~pin:"git+https://github.com/samoht/irmin.git#ro-ng" "irmin-mem" ;
package ~max:"0.8.0" "graphql-cohttp" ;
package ~pin:"git+https://github.com/hannesm/mirage-fs.git#ro-ng" "mirage-fs-lwt" ;
(* package ~pin:"git+https://github.com/hannesm/metrics.git#influx-mirage" "metrics" ;
package ~pin:"git+https://github.com/hannesm/metrics.git#influx-mirage" "metrics-mirage" ;
package ~pin:"git+https://github.com/hannesm/metrics.git#influx-mirage" "metrics-influx" ;
*)
] in
let keys =
[ Key.abstract http_port ; Key.abstract https_port ;
Key.abstract admin_password ; Key.abstract fs_root ;
Key.abstract tofu ; Key.abstract hostname ;
Key.abstract monitor ; Key.abstract apple_testable ]
in
foreign
~packages:direct_dependencies ~keys
"Unikernel.Main" (random @-> pclock @-> mclock @-> kv_ro @-> http @-> resolver @-> conduit @-> job)
let () =
register "caldav" [main $ default_random $ default_posix_clock $ default_monotonic_clock $ certs $ http_srv $ resolver_dns net $ conduit_direct ~tls:true net ]

0
mirage/tls/.keep

161
mirage/unikernel.ml

@ -0,0 +1,161 @@
open Lwt.Infix
(** Common signature for http and https. *)
module type HTTP = Cohttp_lwt.S.Server
let server_src = Logs.Src.create "http.server" ~doc:"HTTP server"
module Server_log = (val Logs.src_log server_src : Logs.LOG)
let access_src = Logs.Src.create "http.access" ~doc:"HTTP server access log"
module Access_log = (val Logs.src_log access_src : Logs.LOG)
module Main (R : Mirage_random.C) (Clock: Mirage_clock.PCLOCK) (Mclock: Mirage_clock.MCLOCK) (KEYS: Mirage_types_lwt.KV_RO) (S: HTTP) (Resolver : Resolver_lwt.S) (Conduit : Conduit_mirage.S) = struct
module X509 = Tls_mirage.X509(KEYS)(Clock)
module Store = Irmin_mirage.Git.KV_RW(Irmin_git.Mem)(Clock)
module Dav_fs = Caldav.Webdav_fs.Make(Store)
module Dav = Caldav.Webdav_api.Make(R)(Clock)(Dav_fs)
module Webdav_server1 = Caldav.Webdav_server.Make(R)(Clock)(Dav_fs)(S)
module Dav_fs2 = Caldav.Webdav_fs.Make(Mirage_kv_unix)
module Dav2 = Caldav.Webdav_api.Make(R)(Clock)(Dav_fs2)
module Webdav_server2 = Caldav.Webdav_server.Make(R)(Clock)(Dav_fs2)(S)
module KV_mem = Mirage_kv_mem.Make(Clock)
module Dav_fs3 = Caldav.Webdav_fs.Make(KV_mem)
module Dav3 = Caldav.Webdav_api.Make(R)(Clock)(Dav_fs3)
module Webdav_server3 = Caldav.Webdav_server.Make(R)(Clock)(Dav_fs3)(S)
(*
module Metrics_reporter = Metrics_mirage.Influx(Mclock)(STACK)
*)
let tls_init kv =
Lwt.catch (fun () ->
X509.certificate kv `Default >|= fun cert ->
Tls.Config.server ~certificates:(`Single cert) ())
(function
| Failure _ -> Lwt.fail_with "Could not find server.pem and server.key in the <working directory>/tls."
| e -> Lwt.fail e)
(* Redirect to the same address, but in https. *)
let redirect port request _body =
let redirect_port = match port with 443 -> None | x -> Some x in
let uri = Cohttp.Request.uri request in
let new_uri = Uri.with_scheme uri (Some "https") in
let new_uri = Uri.with_port new_uri redirect_port in
Access_log.debug (fun f -> f "[%s] -> [%s]"
(Uri.to_string uri) (Uri.to_string new_uri));
let headers = Cohttp.Header.init_with "location" (Uri.to_string new_uri) in
S.respond ~headers ~status:`Moved_permanently ~body:`Empty ()
let serve callback =
let callback (_, cid) request body =
let cid = Cohttp.Connection.to_string cid in
let uri = Cohttp.Request.uri request in
Access_log.debug (fun f -> f "[%s] serving %s." cid (Uri.to_string uri));
callback request body
and conn_closed (_,cid) =
let cid = Cohttp.Connection.to_string cid in
Access_log.debug (fun f -> f "[%s] closing" cid);
in
S.make ~conn_closed ~callback ()
(*
let gc_quick_stat = Metrics.gc_quick_stat ~tags:Metrics.Tags.[]
let gc_stat = Metrics.gc_stat ~tags:Metrics.Tags.[]
let monitor_gc ?(quick = true) delay =
let id x = x in
let f () =
if quick then Metrics.add gc_quick_stat id (fun d -> d ())
else Metrics.add gc_stat id (fun d -> d ())
in
let rec loop () =
f ();
OS.Time.sleep_ns (Duration.of_f delay) >>= fun () -> loop ()
in
Lwt.async loop
*)
let start _random clock mclock tls_keys http resolver conduit =
(*
(match Key_gen.monitor () with
| None -> Lwt.return_unit
| Some monitor ->
Metrics.enable_all ();
monitor_gc 0.1;
let hostname = Key_gen.hostname () in
Metrics_reporter.create mclock net ~hostname (Ipaddr.V4.of_string_exn monitor) ()
>|= function
| Error () -> assert false
| Ok reporter -> Metrics.set_reporter reporter) >>= fun () ->
*)
(* TODO naming *)
let init_http port config fs =
Server_log.info (fun f -> f "listening on %d/HTTP" port);
http (`TCP port) @@ serve (match fs with
| `Unix fs -> Webdav_server2.dispatch config fs
| `Apple fs -> Webdav_server1.dispatch config fs
| `Mem fs -> Webdav_server3.dispatch config fs)
in
let init_https port config fs =
tls_init tls_keys >>= fun tls_config ->
Server_log.info (fun f -> f "listening on %d/HTTPS" port);
let tls = `TLS (tls_config, `TCP port) in
http tls @@ serve (match fs with
| `Unix fs -> Webdav_server2.dispatch config fs
| `Apple fs -> Webdav_server1.dispatch config fs
| `Mem fs -> Webdav_server3.dispatch config fs)
in
let config host =
let do_trust_on_first_use = Key_gen.tofu () in
Caldav.Webdav_config.config ~do_trust_on_first_use host
in
let init_fs_for_runtime config =
let dir = Key_gen.fs_root ()
and admin_pass = Key_gen.admin_password ()
and apple_testable = Key_gen.apple_testable ()
in
(*
Irmin_git.Mem.v (Fpath.v "bla") >>= function
| Error _ -> assert false
| Ok git ->
Store.connect git ~conduit ~author:"caldav" ~resolver
~msg:(fun _ -> "a calendar change") ()
"https://github.com/roburio/testcalendar.git" >>= fun fs ->
if not apple_testable then
Dav.connect fs config admin_pass >|= fun fs ->
`Unix fs
else
let now = Ptime.v (Clock.now_d_ps clock) in
Dav.initialize_fs_for_apple_testsuite fs now config >|= fun () ->
`Apple fs
KV_mem.connect () >>= fun fs ->
Dav3.connect fs config admin_pass >|= fun fs ->
`Mem fs
*)
Mirage_kv_unix.connect dir >>= fun fs ->
Dav2.connect fs config admin_pass >|= fun fs ->
`Unix fs
in
let hostname = Key_gen.hostname () in
match Key_gen.http_port (), Key_gen.https_port () with
| None, None ->
Logs.err (fun m -> m "no port provided for neither HTTP nor HTTPS, exiting") ;
Lwt.return_unit
| Some port, None ->
let config = config @@ Caldav.Webdav_config.host ~port ~hostname () in
init_fs_for_runtime config >>=
init_http port config
| None, Some port ->
let config = config @@ Caldav.Webdav_config.host ~scheme:"https" ~port ~hostname () in
init_fs_for_runtime config >>=
init_https port config
| Some http_port, Some https_port ->
Server_log.info (fun f -> f "redirecting on %d/HTTP to %d/HTTPS" http_port https_port);
let config = config @@ Caldav.Webdav_config.host ~scheme:"https" ~port:https_port ~hostname () in
init_fs_for_runtime config >>= fun fs ->
Lwt.pick [
http (`TCP http_port) @@ serve (redirect https_port) ;
init_https https_port config fs
]
end

5
src/dune

@ -0,0 +1,5 @@
(library
(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))

94
src/privileges.ml

@ -0,0 +1,94 @@
module Xml = Webdav_xml
let aces_for_identities ~identities aces =
let aces' = List.map Xml.xml_to_ace aces in
let aces'' = List.fold_left (fun acc -> function Ok ace -> ace :: acc | Error _ -> acc) [] aces' in (* TODO malformed ace? *)
List.filter (function
| `All, _, _ -> true
| `Href principal, _, _ -> List.exists (Uri.equal principal) identities
| _ -> assert false) aces''
let inherited_acls ~identities aces =
let aces' = aces_for_identities ~identities aces in
let get_inherited (_, _, c) = match c with
| None -> []
| Some (`Inherited url) -> [url]
in
List.flatten @@ List.map get_inherited aces'
(* user_privileges_for_resource: user properties and resource properties as input, output is the list of granted privileges *)
let list ~identities aces =
let aces' = aces_for_identities ~identities aces in
let get_grants (_, b, _) = match b with
| `Deny _ -> []
| `Grant ps -> ps
in
List.flatten @@ List.map get_grants aces'
(* TODO maybe move to own module *)
let is_met ~requirement privileges =
List.exists (fun privilege -> match requirement, privilege with
| _, `All -> true
| `Read, `Read -> true
| `Read_acl, `Read_acl -> true
| `Read_current_user_privilege_set, `Read_current_user_privilege_set -> true
| `Read_current_user_privilege_set, `Read_acl -> true
| `Write, `Write -> true
| `Write_content, `Write -> true
| `Write_properties, `Write -> true
| `Write_acl, `Write -> true
| `Bind, `Write -> true
| `Unbind, `Write -> true
| `Write_content, `Write_content -> true
| `Write_properties, `Write_properties -> true
| `Write_acl, `Write_acl -> true
| `Bind, `Bind -> true
| `Unbind, `Unbind -> true
| _ -> false ) privileges
(* checks privileges for "current-user-privilege-set" (`Read_current_user_privilege_set) and "acl" (`Read_acl) *)
let can_read_prop fqname privileges =
match fqname with
| ns, "current-user-privilege-set" when ns = Xml.dav_ns -> is_met ~requirement:`Read_current_user_privilege_set privileges
| ns, "acl" when ns = Xml.dav_ns -> is_met ~requirement:`Read_acl privileges
| ns, "password" when ns = Xml.robur_ns -> false
| _ -> true
let required verb ~target_exists = match verb with
| `GET -> `Read, `Target
| `HEAD -> `Read, `Target
| `OPTIONS -> `Read, `Target
| `PUT when target_exists -> `Write_content, `Target
| `PUT (* no target exists *) -> `Bind, `Parent
| `Other "PROPPATCH" -> `Write_properties, `Target
| `Other "ACL" -> `Write_acl, `Target
| `Other "PROPFIND" -> `Read, `Target (* plus <D:read-acl> and <D:read-current-user-privilege-set> as needed, see check in Properties.find_many *)
| `DELETE -> `Unbind, `Parent
| `Other "MKCOL" -> `Bind, `Parent
| `Other "MKCALENDAR" -> `Bind, `Parent
| `Other "REPORT" -> `Read, `Target (* referenced_resources body *)
| _ -> assert false
(* | COPY (target exists) | <D:read>, <D:write-content> and |
| | <D:write-properties> on target |
| | resource |
| COPY (no target exists) | <D:read>, <D:bind> on target |
| | collection |
| MOVE (no target exists) | <D:unbind> on source collection |
| | and <D:bind> on target |
| | collection |
| MOVE (target exists) | As above, plus <D:unbind> on |
| | the target collection |
| LOCK (target exists) | <D:write-content> |
| LOCK (no target exists) | <D:bind> on parent collection |
| UNLOCK | <D:unlock> |
| CHECKOUT | <D:write-properties> |
| CHECKIN | <D:write-properties> |
| VERSION-CONTROL | <D:write-properties> |
| MERGE | <D:write-content> |
| MKWORKSPACE | <D:write-content> on parent |
| | collection |
| BASELINE-CONTROL | <D:write-properties> and |
| | <D:write-content> |
| MKACTIVITY | <D:write-content> on parent |
| | collection | *)

11
src/privileges.mli

@ -0,0 +1,11 @@
module Xml = Webdav_xml
val list : identities:Uri.t list -> Xml.tree list -> Xml.privilege list
val inherited_acls : identities:Uri.t list -> Xml.tree list -> Uri.t list
val is_met : requirement:Xml.privilege -> Xml.privilege list -> bool
val can_read_prop : Xml.fqname -> Xml.privilege list -> bool
val required : Cohttp.Code.meth -> target_exists:bool -> Xml.privilege * [ `Parent | `Target ]

268
src/properties.ml

@ -0,0 +1,268 @@
module Xml = Webdav_xml
let prop_version = [ Xml.pcdata "0" ]
module PairMap = Map.Make (struct
type t = string * string
let compare (a1, a2) (b1, b2) = match String.compare a1 b1 with
| 0 -> String.compare a2 b2
| x -> x
end)
open Sexplib.Conv
type property = Xml.attribute list * Xml.tree list [@@deriving sexp]
type t = property PairMap.t
type property_list = ((string * string) * property) list [@@deriving sexp]
let to_sexp t =
let bindings = PairMap.bindings t in
sexp_of_property_list bindings
let of_sexp s =
let bindings = property_list_of_sexp s in
List.fold_left (fun map (k, v) ->
PairMap.add k v map) PairMap.empty bindings
(* not safe *)
let unsafe_find = PairMap.find_opt
(* not safe *)
let unsafe_add = PairMap.add
(* not safe, not public *)
let remove = PairMap.remove
(* public and ok *)
let empty = PairMap.empty
(* internal *)
let keys m = List.map fst (PairMap.bindings m)
(* public and ok *)
let count = PairMap.cardinal
let not_returned_by_allprop = [
(Xml.robur_ns, "prop_version");
(Xml.dav_ns, "owner");
(Xml.dav_ns, "group");
(Xml.dav_ns, "supported-privilege-set");
(Xml.dav_ns, "current-user-privilege-set");
(Xml.dav_ns, "acl");
(Xml.dav_ns, "acl-restrictions");
(Xml.dav_ns, "inherited-acl-set");
(Xml.dav_ns, "principal-collection-set");
(Xml.caldav_ns, "calendar-description");
(Xml.caldav_ns, "calendar-timezone");
(Xml.caldav_ns, "supported-calendar-component-set");
(Xml.caldav_ns, "supported-calendar-data");
(Xml.caldav_ns, "max-resource-size");
(Xml.caldav_ns, "min-date-time");
(Xml.caldav_ns, "max-date-time");
(Xml.caldav_ns, "max-instances");
(Xml.caldav_ns, "max-attendees-per-instance");
(Xml.caldav_ns, "calendar-home-set");
(Xml.caldav_ns, "supported-collation-set");
(Xml.robur_ns, "password");
(Xml.robur_ns, "salt");
]
let write_protected = [
(Xml.robur_ns, "prop_version");
(Xml.dav_ns, "principal-URL");
(Xml.dav_ns, "group-membership");
(Xml.dav_ns, "resourcetype");
(Xml.dav_ns, "current-user-principal");
(Xml.dav_ns, "current-user-privilege-set");
(Xml.dav_ns, "content-length");
(Xml.dav_ns, "etag");
]
let computed_properties = [
(Xml.dav_ns, "current-user-privilege-set") ;
(Xml.dav_ns, "current-user-principal")
]
(* assume that it is safe, should call can_write_prop *)
(* TODO check `Write_acl if writing an ACL property *)
let patch ?(is_mkcol = false) props_for_resource updates =
(* if an update did not apply, m will be None! *)
let xml (ns, n) = [ Xml.node ~ns n [] ] in
let apply (props_for_resource, propstats) update = match props_for_resource, update with
| None, `Set (_, k, _) -> None, (`Failed_dependency, xml k) :: propstats
| None, `Remove k -> None, (`Failed_dependency, xml k) :: propstats
| Some props_for_resource', `Set (a, k, v) ->
if List.mem k write_protected && not (is_mkcol && k = (Xml.dav_ns, "resourcetype"))
then None, (`Forbidden, xml k) :: propstats
else
let props_for_resource'' = unsafe_add k (a, v) props_for_resource' in
(Some props_for_resource'', (`OK, xml k) :: propstats)
| Some props_for_resource', `Remove k ->
if List.mem k write_protected
then None, (`Forbidden, xml k) :: propstats
else
let props_for_resource'' = remove k props_for_resource' in
Some props_for_resource'', (`OK, xml k) :: propstats
in
match List.fold_left apply (Some props_for_resource, []) updates with
| Some props_for_resource', xs -> Some props_for_resource', xs
| None, xs ->
(* some update did not apply -> tree: None *)
let ok_to_failed (s, k) =
((match s with
| `OK -> `Failed_dependency
| x -> x), k)
in
None, List.map ok_to_failed xs
(* housekeeping *)
let to_trees m =
PairMap.fold (fun (ns, k) (a, v) acc ->
Xml.node ~ns ~a k v :: acc) m []
(* housekeeping *)
let to_string m =
let c = to_trees m in
Xml.tree_to_string (Xml.dav_node "prop" c)
(* housekeeping *)
let pp ppf t = Fmt.string ppf @@ to_string t
(* housekeeping *)
let equal a b = String.equal (to_string a) (to_string b)
(* creates property map for file, only needs to check `Bind in parent, done by webmachine *)
let create ?(initial_props = []) ?(content_type = "text/html") ?(language = "en") ?etag ?(resourcetype = []) acl timestamp length filename =
let filename = if filename = "" then "hinz und kunz" else filename in
let etag' m = match etag with None -> m | Some e -> unsafe_add (Xml.dav_ns, "getetag") ([], [ Xml.Pcdata e ]) m in
let timestamp' = Ptime.to_rfc3339 timestamp in
let propmap = etag' @@
unsafe_add (Xml.robur_ns, "prop_version") ([], prop_version) @@
unsafe_add (Xml.dav_ns, "acl") ([], List.map Xml.ace_to_xml acl) @@
unsafe_add (Xml.dav_ns, "creationdate") ([], [ Xml.Pcdata timestamp' ]) @@
unsafe_add (Xml.dav_ns, "displayname") ([], [ Xml.Pcdata filename ]) @@
unsafe_add (Xml.dav_ns, "getcontentlanguage") ([], [ Xml.Pcdata language ]) @@
unsafe_add (Xml.dav_ns, "getcontenttype") ([], [ Xml.Pcdata content_type ]) @@
unsafe_add (Xml.dav_ns, "getcontentlength") ([], [ Xml.Pcdata (string_of_int length) ]) @@
unsafe_add (Xml.dav_ns, "getlastmodified") ([], [ Xml.Pcdata timestamp' ]) @@
(* unsafe_add "lockdiscovery" *)
unsafe_add (Xml.dav_ns, "resourcetype") ([], resourcetype) empty
(* unsafe_add "supportedlock" *)
in
List.fold_left (fun p (k, v) -> unsafe_add k v p) propmap initial_props
(* creates property map for directory *)
let create_dir ?initial_props ?(resourcetype = []) acl timestamp dirname =
create ?initial_props ~content_type:"text/directory"
~resourcetype:(Xml.dav_node "collection" [] :: resourcetype)
acl timestamp 0 dirname
(* housekeeping *)
let from_tree = function
| Xml.Node (_, "prop", _, children) ->
List.fold_left (fun m c -> match c with
| Xml.Node (ns, k, a, v) -> unsafe_add (ns, k) (a, v) m
| Xml.Pcdata _ -> assert false)
empty children
| _ -> assert false
(* TODO groups only one level deep right now *)
(* TODO belongs elsewhere? *)
(* outputs identities for a single user *)
let identities userprops =
let url = function
| Xml.Node (_, "href", _, [ Xml.Pcdata url ]) -> [ Uri.of_string url ]
| _ -> []
in
let urls n = List.flatten (List.map url n) in
match
unsafe_find (Xml.dav_ns, "principal-URL") userprops,
unsafe_find (Xml.dav_ns, "group-membership") userprops
with
| None, _ -> []
| Some (_, principal), Some (_, groups) -> urls principal @ urls groups
| Some (_, principal), None -> urls principal
let privileges ~auth_user_props resource_props =
let aces = match unsafe_find (Xml.dav_ns, "acl") resource_props with
| None -> []
| Some (_, aces) -> aces
in
Privileges.list ~identities:(identities auth_user_props) aces
let inherited_acls ~auth_user_props resource_props =
let aces = match unsafe_find (Xml.dav_ns, "acl") resource_props with
| None -> []
| Some (_, aces) -> aces
in
Privileges.inherited_acls ~identities:(identities auth_user_props) aces
(* 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 uniq =
(* workaround for Firefox OS which doesn't understand <privilege><all/></privilege> *)
if List.mem `All privileges
then [ `Read ; `Write ; `Read_current_user_privilege_set ; `Write_content ; `Write_properties ; `Bind ; `Unbind ; `All ]
else List.sort_uniq compare privileges
in
Some ([], (List.map make_node uniq))
(* checks nothing, computes current-user-principal, helper function *)
let current_user_principal props =
match unsafe_find (Xml.dav_ns, "principal-URL") props with
| None -> Some ([], [ Xml.dav_node "unauthenticated" [] ])
| Some url -> Some url
(* checks nothing, computes properties, should be visible? but requires auth_user_props *)
let get_prop auth_user_props m = function
| ns, "current-user-privilege-set" when ns = Xml.dav_ns -> current_user_privilege_set ~auth_user_props m
| ns, "current-user-principal" when ns = Xml.dav_ns -> current_user_principal auth_user_props
| fqname -> unsafe_find fqname m
let authorized_properties_for_resource ~auth_user_props requested_props propmap_for_resource =
let privileges = privileges ~auth_user_props propmap_for_resource in
let requested_allowed, requested_forbidden =
List.partition (fun prop -> Privileges.can_read_prop prop privileges) requested_props
in
(requested_allowed, requested_forbidden)
let find ~auth_user_props ~resource_props property_fqname =
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
| Some v -> Ok v
else Error `Forbidden
let transform_lastmodified = function
| None -> None
| Some (attrs, [ Xml.Pcdata str ]) ->
Some (attrs, [ Xml.Pcdata (Xml.rfc3339_date_to_http_date str) ])
| Some _ -> assert false
(* checks sufficient privileges for "current-user-privilege-set" and "read-acl" via can_read_prop *)
let find_many ~auth_user_props ~resource_props property_names =
let resource_props = PairMap.update (Xml.dav_ns, "getlastmodified") transform_lastmodified resource_props in
let props = List.map (find ~auth_user_props ~resource_props) property_names in
let results = List.map2 (fun (ns, name) p -> p, match p with
| Ok (a, c) -> Xml.node ~ns ~a name c
| Error _ -> Xml.node ~ns name []) property_names props
in
(* group by return code *)
let found, rest = List.partition (function | Ok _, _ -> true | _ -> false) results in
let not_found, forbidden = List.partition (function | Error `Not_found, _ -> true | Error `Forbidden, _ -> false | Ok _, _ -> assert false) rest in
let apply_tag tag l = if l = [] then [] else [ tag, List.map snd l ] in
apply_tag `OK found @ apply_tag `Not_found not_found @ apply_tag `Forbidden forbidden
(* not safe, exposed, returns property names *)
let names m =
List.map (fun (ns, k) -> Xml.node ~ns k []) @@
computed_properties @ keys m
(* not really safe, but excludes from the not-returned-by-allprop list *)
let all m =
let m' = PairMap.update (Xml.dav_ns, "getlastmodified") transform_lastmodified m in
to_trees (List.fold_right remove not_returned_by_allprop m')

51
src/properties.mli

@ -0,0 +1,51 @@
module Xml = Webdav_xml
(* web machine already verified the _resource_ ACL *)
type t
type property = Xml.attribute list * Xml.tree list
val to_sexp : t -> Sexplib.Sexp.t
val of_sexp : Sexplib.Sexp.t -> t
val pp : t Fmt.t
val equal : t -> t -> bool
val empty : t
val count : t -> int
val to_string : t -> string
val from_tree : Xml.tree -> t
val privileges : auth_user_props:t -> t -> Xml.privilege list
val inherited_acls : auth_user_props:t -> t -> Uri.t list
(* unsafe methods *)
val unsafe_add : Xml.fqname -> property -> t -> t
val unsafe_find : Xml.fqname -> t -> property option
(* safe methods: ACL is verified for property, property is checked to be not in any exclusion list *)
val create : ?initial_props:(Xml.fqname * property) list ->
?content_type:string -> ?language:string -> ?etag:string ->
?resourcetype:Xml.tree list -> Xml.ace list -> Ptime.t -> int -> string -> t
val create_dir : ?initial_props:(Xml.fqname * property) list ->
?resourcetype:Xml.tree list -> Xml.ace list -> Ptime.t -> string -> t
val find : auth_user_props:t -> resource_props:t -> Xml.fqname ->
(property, [> `Forbidden | `Not_found]) result
val find_many : auth_user_props:t -> resource_props:t -> Xml.fqname list ->
(Cohttp.Code.status_code * Xml.tree list) list
val all : t -> Xml.tree list
val names : t -> Xml.tree list
val patch : ?is_mkcol:bool -> t -> Xml.propupdate list ->
t option * (Cohttp.Code.status_code * Xml.tree list) list

57
src/test.sh

@ -0,0 +1,57 @@
#!/bin/sh
pidfile="/tmp/webdav_lwt.pid"
#/bin/sh -c "echo \$\$ > $pidfile && exec ./webdav_lwt.native > /dev/null" &
/bin/sh -c "echo \$\$ > $pidfile && exec ./webdav_lwt.native " &
sleep 0.3
cleanup () {
cat $pidfile | xargs kill
rm $pidfile
}
curl="curl -f -s -X"
check_exit () {
if [ $? -eq 0 ]; then
echo "success $1"
else
cleanup
echo "failed $1"
exit 1
fi
}
testone () {
echo "executing: $curl $1"
$curl $1
check_exit "$1"
}
#testone "GET http://localhost:8080/calendars/1"
#testone "POST -d '{\"name\":\"new item\"}' http://localhost:8080/calendars"
#testone "PUT -H 'Content-Type: application/json' -d '{\"name\":\"modified item\"}' http://localhost:8080/calendars/1"
#testone "PROPFIND -H 'Content-type: application/xml; charset=\"utf-8\"' -d '<?xml version=\"1.0\" encoding=\"utf-8\" ?><propfind xmlns=\"DAV:\"><propname/></propfind>' http://localhost:8080/calendars/1"
#testone "DELETE http://localhost:8080/calendars/1"
#curl -f -s -X PUT -H 'Content-Type: application/json' -d '{"name":"modified item"}' http://localhost:8080/calendars/1
#check_exit "PUT -H 'Content-Type: application/json' -d '{\"name\":\"modified item\"}' http://localhost:8080/calendars/1"
#curl -f -s -X PROPFIND -H 'Content-type: application/xml; charset="utf-8"' -d '<?xml version="1.0" encoding="utf-8" ?><propfind xmlns="DAV:"><propname/></propfind>' http://localhost:8080/calendars/1
#check_exit "PROPFIND -H 'Content-type: application/xml; charset=\"utf-8\"' -d '<?xml version=\"1.0\" encoding=\"utf-8\" ?><propfind xmlns=\"DAV:\"><propname/></propfind>' http://localhost:8080/calendars/1"
#curl -f -s -X PROPFIND -H 'Content-type: applicationgxml; charset="utf-8"' -d '<?xml version="1.0" encoding="utf-8" ?><D:propfind xmlns:D="DAV:"><D:prop xmlns:R="http://ns.example.com/boxschema/"><R:bigbox/><R:author/><R:DingALing/><R:Random/></D:prop></D:propfind>' http://localhost:8080/calendars/1
#check_exit "<?xml version=\"1.0\" encoding=\"utf-8\" ?><D:propfind xmlns:D=\"DAV:\"><D:prop xmlns:R=\"http://ns.example.com/boxschema/\"><R:bigbox/><R:author/><R:DingALing/><R:Random/></D:prop></D:propfind>"
#curl -f -s -X PROPFIND -H 'Content-type: application/xml; charset="utf-8"' -d '<?xml version="1.0" encoding="utf-8" ?><D:propfind xmlns:D="DAV:"><D:allprop/></D:propfind>' http://localhost:8080/calendars/1
#check_exit "<?xml version=\"1.0\" encoding=\"utf-8\" ?><D:propfind xmlns:D=\"DAV:\"><D:allprop/></D:propfind>"
#curl -f -s -X PROPFIND -H 'Content-type: application/xml; charset="utf-8"' -d '<?xml version="1.0" encoding="utf-8" ?><D:propfind xmlns:D="DAV:"><D:allprop/><D:include><D:supported-live-property-set/><D:supported-report-set/></D:include></D:propfind>' http://localhost:8080/calendars/1
#check_exit "<?xml version=\"1.0\" encoding=\"utf-8\" ?><D:propfind xmlns:D=\"DAV:\"><D:allprop/><D:include><D:supported-live-property-set/><D:supported-report-set/></D:include></D:propfind>"
curl -f -i -X PROPFIND -H 'Content-type: application/xml; charset="utf-8"' -d '<?xml version="1.0" encoding="utf-8" ?><D:propfind xmlns:D="DAV:"><D:prop><D:getcontentlength/><D:getcontenttype/> <D:getlastmodified/><D:creationdate/><D:resourcetype/><D:getetag/><D:displayname/></D:prop></D:propfind>' http://localhost:8080/calendars/__uids__/10000000-0000-0000-0000-000000000001/
check_exit '<?xml version="1.0" encoding="utf-8" ?><D:propfind xmlns:D="DAV:"><D:prop><D:getcontentlength/><D:getcontenttype/> <D:getlastmodified/><D:creationdate/><D:resourcetype/><D:getetag/><D:displayname/></D:prop></D:propfind>'
cleanup

1289
src/webdav_api.ml

File diff suppressed because it is too large

55
src/webdav_api.mli

@ -0,0 +1,55 @@
type tree = Webdav_xml.tree
type content_type = string
open Webdav_config
module type S =
sig
type state
val mkcol : state -> config -> path:string -> user:string -> Cohttp.Code.meth -> Ptime.t -> data:string ->
(unit, [ `Bad_request | `Conflict | `Forbidden of string ]) result Lwt.t
val propfind : state -> config -> path:string -> user:string -> depth:string option -> data:string ->
(string, [> `Bad_request | `Forbidden of string | `Property_not_found ]) result Lwt.t
val proppatch : state -> config -> path:string -> user:string -> data:string ->
(string, [> `Bad_request ]) result Lwt.t
val report : state -> config -> path:string -> user:string -> data:string ->
(string, [> `Bad_request ]) result Lwt.t
val write_component : state -> config -> path:string -> user:string ->