diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/calp/namespaces.scm | 14 | ||||
-rw-r--r-- | module/calp/server/webdav.scm | 736 | ||||
-rw-r--r-- | module/calp/webdav/property.scm | 91 | ||||
-rw-r--r-- | module/calp/webdav/propfind.scm | 93 | ||||
-rw-r--r-- | module/calp/webdav/proppatch.scm | 67 | ||||
-rw-r--r-- | module/calp/webdav/resource.scm | 15 | ||||
-rw-r--r-- | module/calp/webdav/resource/base.scm | 572 | ||||
-rw-r--r-- | module/calp/webdav/resource/calendar.scm | 129 | ||||
-rw-r--r-- | module/calp/webdav/resource/file.scm | 188 | ||||
-rw-r--r-- | module/calp/webdav/resource/virtual.scm | 70 |
10 files changed, 1975 insertions, 0 deletions
diff --git a/module/calp/namespaces.scm b/module/calp/namespaces.scm new file mode 100644 index 00000000..09a642da --- /dev/null +++ b/module/calp/namespaces.scm @@ -0,0 +1,14 @@ +(define-module (calp namespaces)) + +;;; Commentary: +;;; (XML) Namespaces used by different parts of the program. +;;; Code: + +(define-public webdav (string->symbol "DAV:")) +(define-public caldav (string->symbol "urn:ietf:params:xml:ns:caldav")) +(define-public xcal (string->symbol "urn:ietf:params:xml:ns:icalendar-2.0")) + +(define-public namespaces + `((d . ,webdav) + (c . ,caldav) + (x . ,xcal))) diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm new file mode 100644 index 00000000..97d5c56d --- /dev/null +++ b/module/calp/server/webdav.scm @@ -0,0 +1,736 @@ +(define-module (calp server webdav) + :use-module ((hnh util) :select (for group -> ->> init+last catch*)) + :use-module (ice-9 match) + :use-module (ice-9 regex) + :use-module (ice-9 format) + :use-module (ice-9 control) + :use-module (web request) + :use-module (web response) + :use-module (web uri) + :use-module (web server) + :use-module ((web http) :select (declare-method! + declare-header!)) + :use-module (web http status-codes) + :use-module (datetime) + :use-module (sxml match) + :use-module (sxml namespaced) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module (calp namespaces) + :use-module (calp webdav resource) + :use-module (calp webdav resource virtual) + :use-module (calp webdav resource file) + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module (calp webdav proppatch) + :use-module (oop goops) + :export (; run-run + run-propfind + run-proppatch + run-options + run-get + run-put + run-delete + run-mkcol + run-copy + run-move + run-report + + root-resource + webdav-handler + )) + +;; (define* (my-build-response . kvs) +;; (define dt (datetime->string (current-datetime) "~a, ~d ~b ~Y ~H:~M:~S GMT")) +;; (define server (format #f "calp/~a" (@ (calp) version))) +;; (let ((as (kvlist->assq kvs))) +;; (append kvs +;; (list +;; reason-phrase: (http-status-phrase (assq-ref as code:)) +;; headers: (append (or (assq-ref kvs headers:) '()) +;; (list +;; server: server +;; date: dt +;; connection: 'keep-alive)))))) + +(define (swap p) + (xcons (car p) (cdr p))) + + +(define output-namespaces + (map (lambda (pair) (call-with-values (lambda () (car+cdr pair)) + xcons)) + namespaces)) + +;; (define (run-filter context filter-spec) +;; (sxml-match filter-spec +;; [(c:comp-filter (@ (name ,name)) . ,rest) +;; ;; TODO +;; (filter (lambda (child) (string=? name (type child))) +;; (children context))] +;; [(c:prop-filter (@ (name ,name))) +;; (prop context name) +;; ] +;; [(c:prop-filter (@ (name ,name)) . ,rest) +;; ] +;; [(c:param-filter (@ (name ,name)) . ,rest)] +;; [(c:is-not-defined)] +;; [(c:text-match (@ . ,attrs) . ,data)] +;; [(c:time-range (@ . ,attrs))])) + + + +;; Requests can content-type be both both application/xml and text/xml, server MUST accept both (RFC 4918 8.2) + +;; ;; RFC 4918 8.2 +;; (catch 'parser-error +;; (lambda () (xml->sxml body)) +;; (lambda (err input-port . msg) +;; (define err-msg +;; (with-output-to-string +;; (lambda () (for-each display msg)))) +;; (return (build-response code: 400 +;; headers: ((content-type . (text/plain)))) +;; err-msg))) + +;; ;; If a body is sent by the client when not expected, the server MUST repspond +;; ;; with 415 (RFC 4918 8.4) + +;; PROPPATCH +;; SHOULD support setting of arbitrary dead properties (RFC4918 9.2) +;; Fruux supports this +;; NOTE this means that user quotas must include dead properties + + +;; A caldav server MUST support +;; - RFC4918 (WebDAV) Class 1 +;; - RFC3744 WebDAV ACL including additional privilege defined in 6.1 +;; - HTTPS +;; - ETags from RFC2616 (http) + +;; MKCALENDAR NOT required + + + + +;; getcontentlanguage, "dead" property + +(declare-method! "PROPFIND" 'PROPFIND) +(declare-method! "PROPPATCH" 'PROPPATCH) +(declare-method! "MKCOL" 'MKCOL) +(declare-method! "COPY" 'COPY) +(declare-method! "MOVE" 'MOVE) +(declare-method! "LOCK" 'LOCK) +(declare-method! "UNLOCK" 'UNLOCK) +(declare-method! "REPORT" 'REPORT) + + + +(define (root-element sxml) + (sxml-match sxml + [(*TOP* (*PI* . ,args) ,root) root] + [(*TOP* ,root) root] + [,root root])) + + +(define root-resource (make-parameter #f)) + + + +(define (parse-dav-line str) + (map (lambda (item) + (cond ((string-match "^[0-9]+$" item) + => (lambda (m) (number->string (match:substring m)))) + ((string-match "^<(.*)>$" item) + => (lambda (m) (string->uri (match:substring m 1)))) + (else (string->symbol item)))) + (map string-trim-both (string-split str #\,)))) + +(define (validate-dav-line lst) + (every (lambda (item) + (or (and (number? item) (<= 1 item 3)) + (uri? item) + ;; Possibly check against list of valid tokens + (symbol? item))) + lst)) + +(define (write-dav-line lst port) + (display + (string-join (map (lambda (item) + (cond ((number? item) (number->string item)) + ((uri? item) (string-append "<" (uri->string item) ">")) + (else (symbol->string item)))) + lst) + ", " 'infix) + port)) + +(declare-header! "DAV" + parse-dav-line + validate-dav-line + write-dav-line) + +(declare-header! "Depth" + (lambda (str) + (if (string-ci=? str "Infinity") + 'infinity + (string->number str))) + (lambda (value) + (memv value '(0 1 infinity))) + (lambda (value port) + (display value port))) + +(declare-header! "Destination" + string->uri + uri? + (lambda (uri port) + (display (uri->string uri) port))) + +;;; TODO +;; (declare-header! "If") + +;;; TODO +;; (declare-header! "Lock-Token") + +(declare-header! "Overwrite" + (lambda (str) + ;; TODO assert isn't a thing + ;; (assert (= 1 (string-length str))) + (case (string-ref str 0) + ((#\F) #f) + ((#\T) #t) + (else (throw 'error)))) + boolean? + (lambda (b port) + (display (if b "T" "F") + port))) + +;;; TODO +;; (declare-header! "Timeout") + + + +(define (run-propfind href request body) + (define headers (request-headers request)) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + (define requested-resources + (case (or (assoc-ref headers 'depth) 'infinity) + ((0) (list (cons href resource))) + ((1) (cons (cons href resource) + (map (lambda (child) + (cons (append href (list (name child))) + child)) + (children resource)))) + ((infinity) (all-resources-under resource href)))) + + ;; Body, if it exists, MUST have be a DAV::propfind object + (define-values (property-request namespaces*) + (cond ((string? body) + (-> body + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces (map swap namespaces)))) + ((bytevector? body) + (-> body + (bytevector->string (make-transcoder (utf-8-codec))) + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces (map swap namespaces)))) + (else (values '(d:propfind (d:allprop)) + `((d . ,webdav)))))) + + + (catch 'bad-request + (lambda () + (values (build-response + code: 207 + reason-phrase: (http-status-phrase 207) + headers: '((content-type . (application/xml)))) + (lambda (port) + (namespaced-sxml->xml + `(,(xml webdav 'multistatus) + ,@(for (href . resource) in requested-resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (parse-propfind (root-element property-request) + (map swap namespaces*) + resource))))) + namespaces: output-namespaces + port: port) + (newline port)))) + (lambda (err proc fmt args data) + (values (build-response + code: 400 + headers: '((content-type . (text/plain)))) + (lambda (port) + (apply format port fmt args))))))) + (else (values (build-response code: 404) "")))) + + + +(define (run-proppatch href request body) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + ;; Body MUST exist, and be a DAV::propertyupdate element + (catch 'bad-request + (lambda () + (values (build-response + code: 207 + reason-phrase: (http-status-phrase 207) + headers: '((content-type . (application/xml)))) + (lambda (port) + (define-values (request namespaces*) + (cond ((string? body) + (-> body + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces + (map swap namespaces)))) + ((bytevector? body) + (-> body + (bytevector->string (make-transcoder (utf-8-codec))) + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces + (map swap namespaces)))) + (else (throw 'body-required)))) + + (namespaced-sxml->xml + `(,(xml webdav 'multistatus) + (,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (parse-propertyupdate + (root-element request) + (map swap namespaces*) + resource)))) + port: port)))) + (lambda (err proc fmt args data) + (values (build-response + code: 400 + headers: '((content-type . (text/plain)))) + (lambda (port) + (apply format port fmt args))))))) + (else (values (build-response code: 404) "")))) + + +(define (run-options href request) + (values + (build-response code: 200 + headers: `((dav . (1)) + ;; (DAV . "calendar-access") + ;; TODO collecting this set dynamically would be fancy! + (allow . (GET HEAD PUT + MKCOL PROPFIND OPTIONS + DELETE + COPY + MOVE + ;; LOCK + ;; UNLOCK + ;; REPORT + )))) + "")) + +(define (run-get href request mode) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + ;; "/calendar/:user/:calendar/:filename" + ;; headers: `((content-type ,content-type)) + (values (build-response code: 200) + (case mode + ((HEAD) "") + ((GET) (content resource)) + (else (scm-error 'misc-error "run-get" + "Unknown mode: ~s" + (list mode) #f)))))) + (else (values (build-response code: 404) "")))) + +(define (run-put href request request-body) + (cond ((null? href) + (values (build-response code: 405 headers: '((content-type . (text/plain)))) + "Can't PUT on root resource")) + ((lookup-resource (root-resource) (drop-right href 1)) + => (lambda (parent) + (cond ((lookup-resource parent (list (last href))) + => (lambda (child) + (if (is-collection? child) + (values (build-response code: 405) "") + (begin + (set-content! child request-body) + (values (build-response code: 204) ""))))) + (else + (add-resource! parent (last href) + request-body) + (values (build-response code: 201) ""))))) + ;; No parent collection, fail per [WEBDAV] 9.7.1. + (else (values (build-response code: 409))))) + +(define (run-mkcol href request _) + ;; TODO href="/" + (if (assoc-ref (request-headers request) 'content-type) + (values (build-response code: 415) + "") + (let ((path name (init+last href))) + (cond ((lookup-resource (root-resource) path) + => (lambda (parent) + (catch 'resource-exists + (lambda () + (add-collection! parent name) + (values (build-response code: 201) "")) + (lambda _ (values (build-response code: 405) ""))))) + (else + (values (build-response code: 409) "")))))) + + + +;;; TODO completely rewrite error handling here +;;; TODO what happens on copy between sub-trees of different types? +;;; Like from a <calendar-resource> tree to a <file-tree>. +(define (run-copy source-href request) + (define headers (request-headers request)) + (call/ec + (lambda (return) + (let* ((depth (or (assoc-ref headers 'depth) 'infinity)) + (destination-uri (assoc-ref headers 'destination)) + (dest-href (-> headers (assoc-ref 'destination) + uri-path string->href)) + (overwrite? + (cond ((assoc 'overwrite headers) => cdr) + (else #t)))) + + ;; (assert (memv depth '(0 infinity))) + ;; (unless (string=? (listen-uri) (uri-host destination-uri)) + ;; (throw 'cross-domain-copy-not-supported)) + + (let ((dest-path dest-name (init+last dest-href))) + (let ((source-resource + (cond ((lookup-resource (root-resource) source-href) => identity) + (else (return (build-response code: 404) "")))) + (destination-parent-resource + (cond ((lookup-resource (root-resource) dest-path) => identity) + (else (return (build-response + code: 409 + reason-phrase: (http-status-phrase 409) + headers: '((content-type . (text/plain)))) + "One or more parent components of destination are missing"))))) + + (let ((copy (copy-resource source-resource + (case depth + ((0) #f) + ((infinity) #t) + (else (throw 'invalid-request))) + dest-name))) + (case (add-child! destination-parent-resource + copy + overwrite?) + ((created) + (values (build-response code: 201) "")) + ((replaced) + (values (build-response code: 204) "")) + ((collision) + (values (build-response code: 412) "")))))))))) + + +(define (run-delete href request) + ;; TODO href="/" + (let ((path name (init+last href))) + (cond ((lookup-resource (root-resource) path) + => (lambda (parent) + (cond ((lookup-resource parent (list name)) + => (lambda (child) + (delete-child! parent child) + (values (build-response code: 202) + ""))) + (else + (values (build-response code: 404) ""))))) + (else + (values (build-response code: 404) ""))))) + + +;;; TODO read spec +(define (run-move href request) + ;; TODO href="/" + ;; (format (current-error-port) + ;; "MOVE ~s: ~s~%" href request) + (catch* + (lambda () + (let ((to (-> (request-headers request) + (assoc-ref 'destination) + uri-path + string->href)) + (overwrite? (cond ((assoc 'overwrite request) => cdr) + (else #t)))) + (case (move-resource! (root-resource) href to overwrite?) + ((created) (values (build-response code: 201) "")) + ((replaced) (values (build-response code: 204) "")) + ((collision) (values (build-response code: 412 + headers: '((content-type . (text/plain)))) + "Something already exists there"))) + )) + (source-not-found + (lambda _ (values (build-response code: 404)))) + (target-parent-not-found + (lambda _ (values (build-response code: 409)))))) + + + +;; (define (run-report href request request-body)) + + + + + + +(define log-table (make-parameter #f)) +(define (init-log-table!) (log-table '())) +(define (log-table-add! . args) + (for (key value) in (group args 2) + (log-table (acons key value (log-table))))) +(define* (log-table-get key optional: dflt) + (or (assoc-ref (log-table) key) + dflt)) + +(define (log-table-format . args) + (for-each (lambda (arg) + (cond ((string? arg) (display arg)) + ((symbol? arg) (cond ((log-table-get arg) + => display))) + ((pair? arg) (cond ((log-table-get (car arg)) + => (compose display (cdr arg))))) + (else #f))) + args)) + +(define (emit-log!) + ;; (write (log-table) (current-error-port)) + ;; (newline (current-error-port)) + (display + (with-output-to-string + (lambda () + (log-table-format (cons 'now (lambda (n) (datetime->string n "~H:~M:~S"))) + " " 'method " " + (cons 'uri uri->string) + " ") + (case (request-method (log-table-get 'request)) + ((COPY MOVE) (log-table-format + (cons 'headers (lambda (h) (and=> (assoc-ref h 'destination) uri->string))) + " ")) + (else "")) + ;; Nginx uses + ;; <ip> - - [<date>] "<request-line>" <request-status> <content-length> "<referer-url>" "<user-agent>" + (log-table-format 'response-code " " + 'response-phrase + " " + (cons 'headers (lambda (h) (assoc-ref h 'x-litmus))) + "\n") + + (cond ((log-table-get 'msg) + => (lambda (it) + (display it) + (newline)))))) + + (current-error-port)) + ) + + + + +;; For all headers: +;; `((server ,(format #f "calp/~a" (@ (calp) version))) +;; (date ,(datetime->string (current-datetime) +;; "~a, ~d ~b ~Y ~H:~M:~S GMT")) +;; (connection keep-alive)) + +;; Already fixed by server +;; (content-length ,(format #f (bytevector->length data))) + + +(define (webdav-handler request request-body) + (define href (-> request request-uri uri-path string->href)) + (init-log-table!) + (log-table-add! 'now (current-datetime) + 'method (request-method request) + 'uri (request-uri request) + 'headers (request-headers request) + 'request request) + + (catch #t + (lambda () + ;; TODO also log result of execution + (call-with-values + (lambda () + (case (request-method request) + ((OPTIONS) (run-options href request)) + + ((PROPFIND) (run-propfind href request request-body)) + ((PROPPATCH) (run-proppatch href request request-body)) + + ((GET HEAD) (run-get href request (request-method request))) + + ((PUT) (run-put href request request-body)) + + ((DELETE) (run-delete href request)) + + ((MKCOL) (run-mkcol href request request-body)) + + ((COPY) (run-copy href request)) + ((MOVE) (run-move href request)) + + ;; ((REPORT)) + + (else (values (build-response code: 400) "")))) + (lambda (head body) + (log-table-add! + 'response head + 'response-code (response-code head) + 'response-phrase (response-reason-phrase head)) + (emit-log!) + (values head body)))) + + (case-lambda ((err proc fmt args data) + (let ((head (build-response + code: 500 + headers: '((content-type . (text/plain))))) + (errmsg (if proc + (format #f "Error in ~a: ~?~%" proc fmt args) + (format #f "~?~%" fmt args)))) + (log-table-add! 'response head + 'response-code 500 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + (err + (let ((errmsg (format #f "General error: ~s~%" err))) + (log-table-add! 'response-code 500 + 'msg errmsg) + (emit-log!) + (values (build-response code: 500) + errmsg)))))) + + + +;;; TODO shouldn't this default to #f +(root-resource + (let () + (define root-resource (make <virtual-resource> name: "*root*")) + + (define virtual-resource (make <virtual-resource> + name: "virtual" + content: (string->bytevector "Hello, World\n" (native-transcoder)))) + + (define file-tree (make <file-resource> + root: "/home/hugo/tmp" + name: "files")) + + (mount-resource! root-resource file-tree) + (mount-resource! root-resource virtual-resource) + root-resource)) + + +(define (run-run) + (unless (root-resource) + (throw 'misc-error "run-run" + "root-resource parameter must be set before running" + (list) #f)) + (run-server webdav-handler + 'http + `(#:port 8102))) + +;; "/principals/uid/:uid" + +#; + +(define (make-make-routes) + (make-routes + + + ;; A file extension could be added, but + ;; text/calendar ⇒ .ics + ;; application/calendar+xml ⇒ .xcs + ;; application/calendar+json ⇒ UNKNOWN + (GET "/caldav/:user/:calendar/:filename" (user calendar filename) + (define requested-types + (cond ((assoc-ref r:headers 'accept) + => (lambda (accept) + (sort* accept < + (lambda (type) + (or (assoc-ref (cdr type) 'q) + 1000))))) + (else '(text/calendar)))) + (define available-types + '(text/calendar application/calendar+xml)) + + (define content-type (find (lambda (type) (memv type available-types)) requested-types)) + (define serializer + (case content-type + ((text/calendar) ical:serialize) + ((application/calendar+xml) xcal:serialize) + ((application/calendar+sexp) sxcal:serialize) + (else (return (build-response code: 415) + "Bad content type")))) + + (define event + (copy-as-orphan + (get-by-uid (get-store-by-name calendar) filename))) + + ;; TODO where is the event split into multiple VEVENT objects in the + ;; serialized form? Should be in the serializer, right? + + (define component + (vcalendar prodid: ((@ (calp) prodid)) + version: "2.0" + (list event))) + + (values `((content-type ,content-type)) + (call-with-output-string + (lambda (p) (serializer component p))))) + + (PUT "/caldav/:user/:calendar/:filename" (user calendar filename) + ;; Request Headers: + ;; If-None-Match + ;; Content-Type: text/calendar + ;; application/calendar+xml + + ;; TODO change -X-HNH to X-HNH-PRIVATE, see RFC4791 5.3.3 + + (define component + (let ((type args (car+cdr (assoc-ref r:headers 'content-type)))) + ;; Valid args: charset component optinfo + ;; Invalid args: method (see RFC4791 4.1) + ;; Component is for redundancy? + ;; optinfo is implementation dependant? + ;; Charset already handled by HTTP server + (case type + ((text/calendar) (ical:deserialize body)) + ((application/calendar+xml) (xcal:deserialize body)) + (else (return (build-response code: 415) + "Can't handle that content type"))))) + + (unless (eq? 'VCALENDAR (type component)) + ;; Top level object must be a VCALENDAR + ) + + ;; Must all children be VEVENT? + (children component) + + ;; All VEVENT component must be the the same event, so they should be merged into a single event + (define event (handle-events component)) + + ;; RFC4791 5.3.2: + ;; > The URL for each calendar object resource is entirely arbitrary and + ;; > does not need to bear a specific relationship to the calendar object + ;; > resource's iCalendar properties or other metadata. New calendar + ;; But requiring that UID and filename match makes things easier for us, at least for now + (unless (string=? filename (prop component 'UID)) + (return (build-response code: 400) + "UID and filename must match")) + + (let ((cal (get-calendar-by-name global-event-object calendar))) + ;; (add-and-save-event global-event-object cal component) + + (reparent! cal event) + (queue-write (get-store-for-calendar cal) event) + + ) + + ) + )) diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm new file mode 100644 index 00000000..092d270a --- /dev/null +++ b/module/calp/webdav/property.scm @@ -0,0 +1,91 @@ +(define-module (calp webdav property) + :use-module (sxml namespaced) + :use-module (web http status-codes) + :use-module ((srfi srfi-1) :select (concatenate find)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util) + :use-module (calp namespaces) + :export (make-propstat + propstat? + propstat-status-code + propstat-property + propstat-error + propstat-response-description + + propstat + + merge-propstats + propstat-200? + ;; propstat->sxml + propstat->namespaced-sxml + )) + +;;; Commentary: +;;; Code: + + +;; Maps directly to [WEBDAV]'s propstat objects. This is just a simpler interface in the code. + +(define-record-type <propstat> + (make-propstat status prop error responsedescription) + propstat? + ;; An http status code indicating if this property is present + (status propstat-status-code) + ;; A list of namespaced sxml elements, such that they could all be + ;; directly inserted as the children of <DAV::prop/> + ;; @example + ;; `((,(xml ns tag) "Content")) + ;; @end example + (prop propstat-property) + + ;; See [WEBCAL] propstat XML element + (error propstat-error) + (responsedescription propstat-response-description)) + +(define* (propstat code prop key: error responsedescription) + (make-propstat code prop error responsedescription)) + +;; Query a given dead property from the given resource +;; property should be a xml-element item +;; (define (propfind-selected-property resource property) +;; (cond ((get-dead-property resource property) +;; => (lambda (it) (propstat 200 (list it)))) +;; (else (propstat 404 (list (list property)))))) +;; Takes a list of <propstat> items, finds all where status, error, and +;; responsedescription are all equal, and merges the prop tags of all those. +;; Returns a new list of <propstat> items +(define (merge-propstats propstats) + (map (lambda (group) + (define-values (code error desc) (unlist (car group))) + (make-propstat code + (concatenate + (map propstat-property (cdr group))) + error desc)) + (group-by (lambda (propstat) + (list (propstat-status-code propstat) + (propstat-error propstat ) + (propstat-response-description propstat))) + propstats))) + +(define (propstat-200? prop) + (= 200 (propstat-status-code prop))) + + +;; (define (propstat->sxml propstat) +;; `(d:propstat (d:prop ,(propstat-property propstat)) +;; (d:status ,(http-status-line (propstat-status-code propstat))) +;; ,@(awhen (propstat-error propstat) +;; `((d:error ,it))) +;; ,@(awhen (propstat-response-description propstat) +;; `((d:responsedescription ,it))))) + +(define (propstat->namespaced-sxml propstat) + `(,(xml webdav 'propstat) + (,(xml webdav 'prop) ,@(propstat-property propstat)) + (,(xml webdav 'status) ,(http-status-line (propstat-status-code propstat))) + ,@(awhen (propstat-error propstat) + `((,(xml webdav 'error) ,it))) + ,@(awhen (propstat-response-description propstat) + `((,(xml webdav 'responsedescription) ,it))))) diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm new file mode 100644 index 00000000..e6becafd --- /dev/null +++ b/module/calp/webdav/propfind.scm @@ -0,0 +1,93 @@ +(define-module (calp webdav propfind) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (sxml match) + :use-module (sxml namespaced) + :export (propfind-selected-properties + propfind-all-live-properties + propfind-most-live-properties + propfind-all-dead-properties + + parse-propfind + )) + +;;; Commentary: +;;; Procedures for the WebDav PROPFIND method +;;; Code: + +;; Properties should be a list of xml-tag-elements +;; return a list of propstat elements +;; work for both dead and alive objects +(define (propfind-selected-properties resource properties) + (map (lambda (el) (get-property resource el)) + properties)) + + +;; (define-method (supported-properties (self <resource>)) +;; (map (lambda (v) (cons webdav v)) +;; `())) + +;; Returns a list of <propstat> objects. +(define (propfind-all-live-properties resource) + (map (lambda (p) ((cdr p) resource)) + (live-properties resource))) + +;; Returns a list of <propstat> objects. +;; The list being the live properties defined by [WEBDAV] +(define (propfind-most-live-properties resource) + (map (lambda (p) ((property-getter (cdr p)) resource)) + webdav-properties)) + +;; Returns a list of <propstat> objects. +;; All "dead" properties on resource. +(define (propfind-all-dead-properties resource) + (map (lambda (v) (propstat 200 (list v))) + (dead-properties resource))) + + + + + + +;; Takes a propfind xml element (tree), and a webdav resource object. +;; Returns a list of <propstat> objects. +(define (parse-propfind sxml namespaces resource) + (merge-propstats + ;; TODO Allow *TOP* and *PI*? + (sxml-match sxml + ((d:propfind (d:propname)) + ;; Return the list of available properties + (list (propstat + 200 + ;; car to get tagname, list to construct a valid xml element + (map (compose list car) + (append + (dead-properties resource) + (live-properties resource)))))) + + ((d:propfind (d:allprop)) + ;; Return "all" properties + (append + (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + + ((d:propfind (d:allprop) (d:include ,properties ...)) + ;; Return "all" properties + those noted by <include/> + (append + (propfind-most-live-properties resource) + (propfind-all-dead-properties resource) + (propfind-selected-properties + resource + (map (lambda (prop) (car (sxml->namespaced-sxml prop namespaces))) + properties)))) + + ((d:propfind (d:prop ,properties ...)) + ;; Return the properties listed + (propfind-selected-properties + resource + (map (lambda (prop) (car (sxml->namespaced-sxml prop namespaces))) + properties))) + + (,default (scm-error 'bad-request "parse-propfind" + "Invalid search query ~s" (list default) (list default))) + ))) diff --git a/module/calp/webdav/proppatch.scm b/module/calp/webdav/proppatch.scm new file mode 100644 index 00000000..db7f5f95 --- /dev/null +++ b/module/calp/webdav/proppatch.scm @@ -0,0 +1,67 @@ +(define-module (calp webdav proppatch) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (sxml match) + :use-module (sxml namespaced) + :use-module ((hnh util) :select (for)) + :export (parse-propertyupdate) + ) + + +(define (parse-propertyupdate body namespaces resource) + (merge-propstats + (sxml-match body + [(d:propertyupdate . ,changes) + (define continuations + (concatenate + (for change in changes + (sxml-match change + [(d:remove (d:prop . ,properties)) + (map (lambda (prop) (cons prop + (remove-property + resource + (car + (sxml->namespaced-sxml prop namespaces))))) + properties)] + + ;; TODO handle xmllang correctly + [(d:set (d:prop . ,properties)) + (map (lambda (prop) (cons prop + (set-property resource + (sxml->namespaced-sxml prop namespaces)))) + properties)] + + [,else (scm-error 'bad-request "" + "Invalid propertyupdate: ~s" + (list body) + (list body))])))) + + ;; (format (current-error-port) "~s~%" continuations) + (let loop ((continuations continuations)) + (if (null? continuations) + '() + (let ((tag proc (car+cdr (car continuations)))) + (set! tag (sxml->namespaced-sxml tag namespaces)) + ;; (format (current-error-port) "tag: ~s~%" tag) + (catch #t (lambda () + ;; This is expected to throw quite often + (proc) + (cons (propstat 200 (list tag)) + (loop (cdr continuations)))) + (lambda err + (cons (propstat 409 (list tag)) + (mark-remaining-as-failed-dependency (cdr continuations))))))))] + + [,else (scm-error 'bad-request "" + "Invalid root element: ~s" + (list else) + (list else))]))) + + +(define (mark-remaining-as-failed-dependency pairs) + (map (lambda (item) + (propstat 424 (list (car item)))) + pairs)) diff --git a/module/calp/webdav/resource.scm b/module/calp/webdav/resource.scm new file mode 100644 index 00000000..47c5aded --- /dev/null +++ b/module/calp/webdav/resource.scm @@ -0,0 +1,15 @@ +(define-module (calp webdav resource) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource base) + :export (mount-resource!)) + +(define cm (module-public-interface (current-module))) +(module-use! cm (resolve-interface '(calp webdav resource base))) + +;;; TODO mount-resource! vs add-child! +;;; Would a good idea be that add-resource! adds directly, and should +;;; be considered internal, while mount-resource! also runs post-add +;;; hooks, and could thereby be exported +(define-method (mount-resource! (this <resource>) (child <resource>)) + (add-child! this child)) diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm new file mode 100644 index 00000000..0b1d4ace --- /dev/null +++ b/module/calp/webdav/resource/base.scm @@ -0,0 +1,572 @@ +(define-module (calp webdav resource base) + :use-module ((srfi srfi-1) :select (find remove last append-map drop-while)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (sxml namespaced) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module ((hnh util) :select (unless)) + :use-module (rnrs bytevectors) + :use-module (hnh util) + :use-module (hnh util env) + :use-module (datetime) + :export (<resource> + ;; href + href->string + string->href + ;; local-path + name + dead-properties + ;; resource-children + resource? + children + xml-element-hash-key + + + + get-live-property + get-dead-property + get-property + + set-dead-property + set-dead-property! + set-live-property + set-live-property! + set-property + set-property! + + remove-dead-property + remove-dead-property! + remove-live-property + remove-live-property! + remove-property + remove-property! + + + + + live-properties + add-child! + add-resource! + add-collection! + is-collection? + + content + set-content! + + copy-resource + cleanup-resource + delete-child! + move-resource! + setup-new-resource! + ;; prepare-for-add! + + creationdate + displayname + getcontentlanguage + getcontentlength + getcontenttype + getetag + getlastmodified + lockdiscovery + resourcetype + supportedlock + + webdav-properties + + ;; absolute-path + ;; find-resource + lookup-resource + all-resources-under + + ;; dereference + + make-live-property + live-property? + property-getter + property-setter-generator + property-remover-generator + + prepare-update-properties + + )) + + +(define-record-type <live-property> + (make-live-property% getter setter-generator remover-generator) + live-property? + (getter property-getter) + (setter-generator property-setter-generator) + (remover-generator property-remover-generator)) + +(define* (make-live-property getter setter-generator optional: remover-generator) + (make-live-property% getter setter-generator remover-generator)) + + + +;; Collections are also resources, this is non-collection resources +(define-class <resource> () + ;; (href init-keyword: href: getter: href init-value: #f) + ;; (local-path init-keyword: local-path: getter: local-path) + + ;; name is a part of its search path. + ;; For example: the component located at /a/b + ;; would have name="a", its parent name="b", and the root element + ;; would have an unspecified name (probably the empty string, or "*root*") + (name init-keyword: name: getter: name) + + (dead-properties + ;; Map from (namespace . tagname) pairs to namespaced xml element + init-form: (make-hash-table) + getter: dead-properties%) + + ;; Attributes on data + (displayname accessor: displayname* init-value: #f) + (contentlanguage accessor: contentlanguage init-value: #f) + + ;; Direct children, used by @code{children} if not overwritten by child + (resource-children init-value: '() + accessor: resource-children) + + ;; Table containing href -> resource mappings, saves us from recursivly searching children each time. + (resource-cache init-value: (make-hash-table 0) + getter: resource-cache)) + +(define (resource? x) + (is-a? x <resource>)) + + +(define (href->string href) + (if (null? href) + "/" (string-join href "/" 'prefix))) + +(define (string->href s) + (remove string-null? + (string-split s #\/))) + +(define-method (children (self <resource>)) + (resource-children self)) + +;;; TODO merge content and set-content! into an accessor? +(define-method (content (self <resource>)) + (throw 'misc-error "content<resource>" + "Base <resource> doesn't implement (getting) content, please override this method" + '() #f)) + +(define-method (set-content! (self <resource>) content) + (throw 'msic-error "set-content!<resource>" + "Base <resource> doesn't implement (setting) content, please override this method" + '() #f)) + +(define-method (content-length (self <resource>)) + (if (is-collection? self) + 0 + (let ((c (content self))) + (cond ((bytevector? c) (bytevector-length c)) + ((string? c) (string-length c)) + (else -1))))) + +(define-method (write (self <resource>) port) + (catch #t + (lambda () + (display ; Make output atomic + (call-with-output-string + (lambda (port) + ;; (define o (dereference self)) + (format port "#<~a name=~s" + (class-name (class-of self)) + (name self)) + (cond ((displayname self) + propstat-200? + (lambda (name) (format port ", displayname=~s" name)))) + (format port ">"))) + port)) + (lambda _ + (format port "#<~a>" (class-name (class-of self)))))) + + +;;; TODO should add-resource! be kept? It would probably be better to merge it +;;; with add-child! + + + +;; Possibly change this to a fixed procedure +(define-method (add-resource! (self <resource>) + (new-name <string>) + content) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (setup-new-resource! resource self) + (add-child! self resource) + (set-content! resource content) + resource))) + +;; Possibly change this to a fixed procedure, +;; adding a setup method instead +(define-method (add-collection! (self <resource>) new-name) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (add-child! self resource) + resource))) + +(define-method (copy-resource (self <resource>) include-children?) + (copy-resource self include-children? #f)) + +(define-method (copy-resource (self <resource>) include-children? new-name) + (let ((resource (make (class-of self) name: (or new-name (name self))))) + (for-each (lambda (tag) (set-dead-property! resource tag)) + (dead-properties self)) + (set! (displayname* resource) (displayname* self) + (contentlanguage resource) (contentlanguage self)) + (set-content! resource (content self)) + (when include-children? + (for-each (lambda (c) (add-child! resource c)) + (map (lambda (c) (copy-resource c #t)) + (children self)))) + ;; resource-cache should never be copied + resource)) + +(define (xml-element-hash-key tag) + "Returns a value suitable as a key to hash-ref (and family)" + (cons (xml-element-namespace tag) + (xml-element-tagname tag))) + +;; Only tagname and namespaces are checked on the <xml-element> for the {get,set}-property + + +;;; All get-*-property methods return propstat elements + +(define (lookup-live-property resource xml-el) + (assoc-ref (live-properties resource) (xml-element-hash-key xml-el))) + +;;; TODO should {get,set}{,-{dead,live}}-property really be methods? +;;; - Live properties are defined by lookup-live-property, which isn't a +;;; method, which in turn calls live-properties, which MUST be a method. +;;; - Dead properties may have a reason. For example, file resources might +;;; want to store them directly in xattrs, ignoring its built in hash-table. +;;; - The combined should always just dispatch to either one + +(define-method (get-live-property (resource <resource>) xml-el) + (cond ((lookup-live-property resource xml-el) + => (lambda (pair) ((property-getter pair) resource))) + (else (propstat 404 (list (list xml-el)))))) + +(define-method (get-dead-property (resource <resource>) xml-el) + (cond ((hash-ref (dead-properties% resource) + (xml-element-hash-key xml-el)) + => (lambda (it) (propstat 200 (list it)))) + (else (propstat 404 (list (list xml-el)))))) + +;;; Return a list xml tags (including containing list) +(define-method (dead-properties (resource <resource>)) + (hash-map->list (lambda (_ v) v) + (dead-properties% resource))) + +;; Value should be a list with an <xml-element> in it's car +(define-method (set-dead-property (resource <resource>) value) + (unless (and (list? value) + (xml-element? (car value))) + (scm-error 'misc-error "set-dead-property" + "Invalid value, expected namespaced sxml" + '() #f)) + (lambda () + (hash-set! (dead-properties% resource) + (xml-element-hash-key (car value)) + value))) + +(define-method (set-live-property (resource <resource>) value) + (unless (and (list? value) + (xml-element? (car value))) + (scm-error 'misc-error "set-live-property" + "Invalid value, expected namespaced sxml" + '() #f)) + (cond ((lookup-live-property resource (car value)) + => (lambda (prop) (apply (property-setter-generator prop) + resource (cdr value)))) + (else #f))) + +(define (set-dead-property! resource value) + ((set-dead-property resource value))) + +(define (set-live-property! resource value) + ((set-live-property resource value))) + +(define (set-property resource value) + (or (set-live-property resource value) + (set-dead-property resource value))) + +(define (set-property! resource value) + ((set-property resource value))) + +;;; The remove-* procedures still take "correct" namespaced sxml (so an +;;; xml-element object inside a list). These extra lists are a bit of a waste, +;;; But allows remove-* to have the same signature as set-* + +(define-method (remove-dead-property (resource <resource>) xml-tag) + (unless (xml-element? xml-tag) + (scm-error 'misc-error "remove-dead-property" + "Bad property element" + '() #f)) + (lambda () + (hash-remove! (dead-properties% resource) + (xml-element-hash-key xml-tag)))) + +(define-method (remove-live-property (resource <resource>) xml-tag) + (unless (xml-element? xml-tag) + (scm-error 'misc-error "remove-live-property" + "Bad property element" + '() #f)) + + (cond ((lookup-live-property resource xml-tag) + => (lambda (prop) + (cond ((property-remover-generator prop) + => (lambda (f) (f resource))) + (else (throw 'irremovable-live-property))))) + (else #f))) + +(define (remove-dead-property! resource xml-tag) + ((remove-dead-property resource xml-tag))) + +(define (remove-live-property! resource xml-tag) + ((remove-live-property resource xml-tag))) + +(define-method (remove-property (resource <resource>) xml-tag) + (or (remove-live-property resource xml-tag) + (remove-dead-property resource xml-tag))) + +(define (remove-property! resource xml-tag) + ((remove-property resource xml-tag))) + + + +;; xml-tag should be just the tag element, without a surounding list +(define-method (get-property (resource <resource>) xml-tag) + (cond ((get-dead-property resource xml-tag) + propstat-200? => identity) + (else (get-live-property resource xml-tag)))) + +;; Return an alist from xml-element tags (but not full elements with surrounding list) +;; to generic procedures returning that value. +;; SHOULD be extended by children, which append their result to this result +;; @example +;; (define-method (live-properties (self <specific-resource>) +;; (append (next-method) +;; specific-resource-properties)) +;; @end example +(define-method (live-properties (self <resource>)) + (map (lambda (pair) (cons (xml-element-hash-key (xml webdav (car pair))) (cdr pair))) + webdav-properties)) + +(define-method (setup-new-resource! (this <resource>) (parent <resource>)) + 'noop) + +(define-method (add-child! (this <resource>) (child <resource>)) + ;; TODO this should call a method on child, allowing it to be updated + ;; with aditional context + ;; (prepare-for-add! child this) + (set! (resource-children this) + (cons child (resource-children this))) + 'created) + +(define-method (add-child! (this <resource>) (child <resource>) (overwrite? <boolean>)) + (let ((existing (lookup-resource this (list (name child))))) + (cond ((and overwrite? existing) + (set! (resource-children this) + ;; TODO properly remove the old node, similar to mov DELETE + ;; will do it (calling cleanup, and so on). + (cons child (delete existing (children this)))) + 'replaced) + (existing 'collision) + (else + (add-child! this child) + 'created)))) + +;; Free any aditional system resources held by this object. +;; For example, file resources will remove the underlying file here. +(define-method (cleanup-resource (this <resource>)) + 'noop) + +(define-method (delete-child! (this <resource>) (child <resource>)) + (set! (resource-children this) + (delq1! child (children this))) + (for-each (lambda (grandchild) + (delete-child! child grandchild)) + (children child)) + (cleanup-resource child)) + + +(define-method (move-resource! (root <resource>) + from to + (overwrite? <boolean>)) + (let* ((dest-path dest-name (init+last to)) + (from-path from-name (init+last from)) + (dest-parent (or (lookup-resource root dest-path) + (throw 'target-parent-not-found))) + (from-parent (or (lookup-resource root from-path) + (throw 'source-not-found))) + (source (or (lookup-resource from-parent (list from-name)) + (throw 'source-not-found)))) + (if (and (is-collection? source) + (not overwrite?)) + 'collision + ;; run move by running a copy followed by a delete. + ;; [RFC4918] 9.9.3 specifies that the server MUST run a DELETE + ;; on the target if overwrite is true, but I actually don't + ;; see the difference between that and a propper move... + (let ((status (add-child! dest-parent (copy-resource source #t dest-name) + overwrite?))) + (case status + ((created replaced) + (delete-child! from-parent source) + status) + (else status)))))) + + + + + +;;; TODO rename to simply @code{collection?} +(define-method (is-collection? (self <resource>)) + (not (null? (resource-children self)))) + + + + +(define-method (creationdate (self <resource>)) + (propstat 501 `((,(xml webdav 'creationdate))))) + +(define-method (set-creationdate! (self <resource>) _) + (throw 'protected-resource "creationdate")) + +(define-method (displayname (self <resource>)) + (cond ((displayname* self) + => (lambda (name) + (propstat 200 `((,(xml webdav 'displayname) + ,name))))) + (else + (propstat 404 `((,(xml webdav 'displayname))))))) + +(define-method (set-displayname! (self <resource>) value) + (lambda () (set! (displayname* self) value))) + +(define-method (getcontentlanguage (self <resource>)) + (cond ((contentlanguage self) + => (lambda (lang) (propstat 200 `((,(xml webdav 'getcontentlanguage) ,lang))))) + (else (propstat 404 `((,(xml webdav 'getcontentlanguage))))))) + +(define-method (set-getcontentlanguage! (self <resource>) value) + (lambda () (set! (contentlanguage self) value))) + +(define-method (getcontentlength (self <resource>)) + (propstat 501 `((,(xml webdav 'getcontentlength))))) + +(define-method (getcontentlength (self <resource>)) + (propstat 200 + (list + (list (xml webdav 'getcontentlength) + (content-length self))))) + +(define-method (set-getcontentlength! (self <resource>) _) + (throw 'protected-resource "getcontentlength")) + +(define-method (getcontenttype (self <resource>)) + (propstat 501 `((,(xml webdav 'getcontenttype))))) + +(define-method (set-getcontenttype! (self <resource>) _) + (throw 'protected-resource "getcontenttype")) + +(define-method (getetag (self <resource>)) + ;; TODO + (propstat 501 `((,(xml webdav 'getetag))))) + +(define-method (set-getetag! (self <resource>) _) + (throw 'protected-resource "getetag")) + +(define-method (getlastmodified (self <resource>)) + (propstat 200 `((,(xml webdav 'getlastmodified) + ,(with-locale1 + LC_TIME "C" + (lambda () + (datetime->string (unix-time->datetime 0) "~a, ~d ~b ~Y ~H:~M:~S GMT"))))))) + +(define-method (set-getlastmodified! (self <resource>) _) + (throw 'protected-resource "getlastmodified")) + +(define-method (lockdiscovery (self <resource>)) + (propstat 200 `((,(xml webdav 'lockdiscovery) + ())))) + +(define-method (set-lockdiscovery! (self <resource>) _) + (throw 'protected-resource "lockdiscovery")) + +(define-method (resourcetype (self <resource>)) + (propstat 200 `((,(xml webdav 'resourcetype) + ,@(when (is-collection? self) + `((,(xml webdav 'collection)))))))) + +(define-method (set-resourcetype! (self <resource>) _) + (throw 'protected-resource "resourcetype")) + +(define-method (supportedlock (self <resource>)) + (propstat 200 `((,(xml webdav 'supportedlock) ())))) + +(define-method (set-supportedlock! (self <resource>) _) + (throw 'protected-resource "supportedlock")) + +(define webdav-properties + `((creationdate . ,(make-live-property creationdate set-creationdate!)) + (displayname . ,(make-live-property displayname set-displayname!)) + (getcontentlanguage . ,(make-live-property getcontentlanguage set-getcontentlanguage!)) + (getcontentlength . ,(make-live-property getcontentlength set-getcontentlength!)) + (getcontenttype . ,(make-live-property getcontenttype set-getcontenttype!)) + (getetag . ,(make-live-property getetag set-getetag!)) + (getlastmodified . ,(make-live-property getlastmodified set-getlastmodified!)) + (lockdiscovery . ,(make-live-property lockdiscovery set-lockdiscovery!)) + (resourcetype . ,(make-live-property resourcetype set-resourcetype!)) + (supportedlock . ,(make-live-property supportedlock set-supportedlock!)))) + + + +;;; TODO remove! This is a remnant of the old mount system +;; (define-method (dereference (self <resource>)) +;; self) + +(define (find-resource resource path) + ;; Resource should be a <resource> (or something descended from it) + ;; path should be a list of strings + (cond ((null? path) resource) + ((string-null? (car path)) + ;; resource + (find-resource resource (cdr path))) + ((find (lambda (r) (string=? (car path) (name r))) + (children resource)) + => (lambda (r) (find-resource r (cdr path)))) + (else #f))) + +;; Lookup up a given resource first in the cache, +;; Then in the tree +;; and finaly fails and returns #f +(define (lookup-resource root-resource path) + (find-resource root-resource path) + #; + (or (hash-ref (resource-cache root-resource) path) + (and=> (find-resource root-resource path) + (lambda (resource) + (hash-set! (resource-cache root-resource) path resource) + resource)))) + +(define* (all-resources-under* resource optional: (prefix '())) + (define s (append prefix (list (name resource)))) + (cons (cons s resource) + (append-map (lambda (c) (all-resources-under* c s)) + (children resource)))) + +;; Returns a flat list of this resource, and all its decendants +(define* (all-resources-under resource optional: (prefix '())) + (cons (cons prefix resource) + (append-map (lambda (c) (all-resources-under* c prefix)) + (children resource)))) diff --git a/module/calp/webdav/resource/calendar.scm b/module/calp/webdav/resource/calendar.scm new file mode 100644 index 00000000..6c20df31 --- /dev/null +++ b/module/calp/webdav/resource/calendar.scm @@ -0,0 +1,129 @@ +(define-module (calp webdav resource calendar) + :use-module (srfi srfi-88) + :use-module (hnh util) + :use-module (oop goops) + :use-module (vcomponent) + :use-module (datetime) + :use-module (sxml namespaced) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module (ice-9 hash-table) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :export (<calendar-resource> + calendar-resource? + content + caldav-properties) + ) + +;;; Resoruces containing calendar components +(define-class <calendar-resoruce> (<resource>) + (description init-value: #f + accessor: description) + (content init-value: (make-vcomponent 'VIRTUAL) + accessor: content)) + +(define (calendar-resource? x) + (is-a? x <calendar-resource>)) + +(define-method (live-properties (self <calendar-resource>)) + (append (next-method) + (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair))) + caldav-properties))) + +(define-method (creationdate (self <calendar-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + (-> (content self) + (prop 'CREATED) + ;; TODO timezone + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + +(define-method (displayname (self <calendar-resource>)) + (propstat 200 + `((,(xml webdav 'displayname) + ,(prop (content self) 'displayname))))) + + +(define-method (getcontentlength (self <calendar-resoruce>)) + ;; TODO which representation should be choosen to calculate length? + (propstat 501 `((,(xml webdav 'getcontentlength))))) + +(define-method (getcontenttyype (self <calendar-resource>)) + ;; TODO different representations + (propstat 200 `((,(xml webdav 'getcontentlength) + "text/calendar")))) + + +(define-method (getlastmodified (self <calendar-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + (string->datetime (prop (content self) 'LAST-MODIFIED) + "~Y~m~dT~H~M~S"))))) + + +(define-method (resourcetype (self <calendar-resource>)) + (propstat 200 + `((,(xml webdav 'resourcetype) + (,(xml caldav 'calendar)))))) + +;;; CALDAV Properties + +;; NOT in allprop +(define-method (calendar-description (self <calendar-resource>)) + (cond ((description self) + => (lambda (it) + (propstat 200 + (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en")))) + it))))) + (else + (propstat 404 (list (list (xml caldav 'calendar-description))))))) + +;; NOT in allprop +(define-method (calendar-timezone (self <calendar-resource>)) + (propstat 200 + (list + (list (xml caldav 'calendar-description) + ;; TODO serialize, base-timezone + (ics:serialize (base-timezone (content self))))))) + +;; NOT in allprop +(define-method (supported-calendar-component-set (self <calendar-resource>)) + (propstat 200 + `((,(xml caldav 'supported-calendar-component-set) + (,(xml caldav 'comp + (alist->hashq-table '((name . "VEVENT"))))))))) + +(define-method (supported-calendar-data (self <calendar-resource>)) + (propstat 200 + (list + (list + (xml caldav 'supported-calendar-data) + (map (lambda (content-type) + (list (xml caldav 'calendar-data + (alist->hashq-table + '((content-type . ,content-type) + (version . "2.0")))))) + '("text/calendar" "application/calendar+xml")))))) + +;; (define-method (max-resource-size (self <calendar-resource>)) +;; ) + +;; (define-method (min-date-time )) +;; (define-method (max-date-time )) +;; (define-method (max-instances )) +;; (define-method (max-attendees-per-instance )) + +(define caldav-properties + `((calendar-description . ,calendar-description) + (calendar-timezone . ,calendar-timezone) + (supported-calendar-component-set . ,supported-calendar-component-set) + (supported-calendar-data . ,supported-calendar-data) + ;; (max-resource-size . ,max-resource-size) + ;; (min-date-time . ,min-date-time) + ;; (max-date-time . ,max-date-time) + ;; (max-instances . ,max-instances) + ;; (max-attendees-per-instance . ,max-attendees-per-instance) + )) + + diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm new file mode 100644 index 00000000..58e71e2c --- /dev/null +++ b/module/calp/webdav/resource/file.scm @@ -0,0 +1,188 @@ +(define-module (calp webdav resource file) + :use-module (srfi srfi-1) + :use-module (oop goops) + :use-module (hnh util) + :use-module (hnh util env) + :use-module (hnh util path) + :use-module (datetime) + :use-module (ice-9 popen) + :use-module (ice-9 rdelim) + :use-module (ice-9 ftw) + :use-module (sxml namespaced) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors) + :export (<file-resource> file-resource? root ; path + )) + +;;; Resources backed by the filesystem +(define-class <file-resource> (<resource>) + ;; Directory to act as root for this file tree. + ;; Should be inherited by all children + + ;; DO NOT export the setters. These fields needs to be carefully managed to + ;; ensure that they stay consistant with the @var{name} trail. + (root getter: root setter: set-root! init-value: "/" init-keyword: root:) + (path getter: path setter: set-path! init-value: "/" init-keyword: path:)) + +(define (file-resource? x) + (is-a? x <file-resource>)) + +;; TODO this is global, so most certanly leaks info between different +;; <file-resource> trees. +(define *realized-resource* (make-hash-table)) + +(define (file-resource-for-path root path) + (or (hash-ref *realized-resource* path) + (let ((resource (make <file-resource> + ;; href: + root: root + ; local-path: path + name: (basename path) + path: path + ))) + (hash-set! *realized-resource* path resource) + resource))) + +(define (filepath self) + (path-append (root self) + (path self))) + +(define-method (children (self <file-resource>)) + ;; (format (current-error-port) "root=~s, path=~s~%" + ;; (root self) + ;; (local-path self)) + (when (is-collection? self) + (map (lambda (p) (file-resource-for-path (root self) + (path-append (path self) + p))) + (remove (lambda (p) (member p '("." ".."))) + (scandir (filepath self)))))) + +(define-method (is-collection? (self <file-resource>)) + (eq? 'directory (stat:type (stat (filepath self))))) + +(define (file-creation-date path) + (let ((pipe (open-pipe* OPEN_READ "stat" "-c" "%W" path))) + (begin1 (unix-time->datetime (read pipe)) + (close-pipe pipe)))) + +(define (mimetype path) + (let ((pipe (open-pipe* OPEN_READ "file" "--brief" "--mime-type" + path))) + (begin1 (read-line pipe) + (close-pipe pipe)))) + +(define-method (creationdate (self <file-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + ,(with-locale1 + LC_TIME "C" + (lambda () + (-> (file-creation-date (filepath self)) + (datetime->string "~Y-~m-~dT~H:~M:~S~Z")))))))) + +(define-method (content (self <file-resource>)) + (if (is-collection? self) + #f + (call-with-input-file (filepath self) + get-bytevector-all binary: #t))) + +(define-method (set-content! (self <file-resource>) data) + (cond ((bytevector? data) + (call-with-output-file (filepath self) + (lambda (port) (put-bytevector port data)))) + ((string? data) + (call-with-output-file (filepath self) + (lambda (port) (put-string port data)))) + (else (scm-error 'misc-error "set-content!<file-resource>" + "Content must be bytevector or string: ~s" + (list data) #f)))) + + +;; This is currently ONLY called from add-resource! which creates a +;; child from the type of the parent. +(define-method (setup-new-resource! (self <file-resource>) + (parent <file-resource>)) + (set-root! self (root parent)) + (set-path! self (path-append (path parent) (name self)))) + + +(define-method (add-collection! (self <file-resource>) new-name) + (let ((resource (next-method))) + (set-root! resource (root self)) + (set-path! resource (path-append (path self) new-name)) + (mkdir (path-append (root resource) (path resource))) + resource)) + +(define-method (cleanup-resource (self <file-resource>)) + ((if (is-collection? self) + rmdir + delete-file) + (filepath self))) + +(define-method (content-length (self <file-resource>)) + (-> (filepath self) stat stat:size)) + + +(define-method (getcontenttype (self <file-resource>)) + ;; TODO 404 if collection + ;; Or just omit it? + (propstat 200 `((,(xml webdav 'getcontenttype) + ,(mimetype (filepath self)))))) + +(define-method (getlastmodified (self <file-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + ,(with-locale1 + LC_TIME "C" + (lambda () + (-> (filepath self) + stat + stat:mtime + unix-time->datetime + (datetime->string "~a, ~d ~b ~Y ~H:~M:~S GMT")))))))) + +;; (define (xattr-key xml-el) +;; (format #f "caldav.~a" +;; (base64-encode +;; (format #f "~a:~a" +;; (xml-element-namespace xml-el) +;; (xml-element-tagname xml-el))))) + + +;; (define-method (set-dead-property (self <file-resource>) value) +;; (unless (and (list? value) +;; (xml-element? (car value))) +;; (scm-error 'misc-error "set-dead-property" +;; "Invalid value, expected namespaced sxml" +;; '() #f)) +;; (catch #t +;; (lambda () +;; (lambda () +;; (xattr-set! +;; (filename self) +;; (xattr-key (car value)) +;; (with-output-to-string +;; (lambda () (namespaced-sxml->xml value)))))) +;; (lambda _ (next-method)))) + + +;; (define-method (get-dead-property (self <file-resource>) +;; xml-el) +;; (catch #t +;; (lambda () +;; (propstat 200 +;; (list +;; (xattr-ref (filepath self) +;; (xattr-key el))))) +;; (lambda _ (next-method)))) + + +;; (define-method (remove-dead-property (self <file-resource>) +;; xml-el) +;; (catch #t +;; (lambda () (xattr-remove! (filepath self) xml-el)) +;; (lambda _ (next-method)))) diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm new file mode 100644 index 00000000..2fcaa76a --- /dev/null +++ b/module/calp/webdav/resource/virtual.scm @@ -0,0 +1,70 @@ +(define-module (calp webdav resource virtual) + :use-module (oop goops) + :use-module (datetime) + :use-module (rnrs bytevectors) + :use-module (hnh util) + :use-module (sxml namespaced) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :export (<virtual-resource> + virtual-resource? + virtual-ns + ;; content + isvirtual + ) + ) + +(define virtual-ns (string->symbol "http://example.com/virtual")) + +(define-class <virtual-resource> (<resource>) + (content* init-value: #vu8() + init-keyword: content: + accessor: content*) + (creation-time init-form: (current-datetime) + init-keyword: creation-time: + getter: creation-time)) + +(define (virtual-resource? x) + (is-a? x <virtual-resource>)) + +(define-method (write (self <virtual-resource>) port) + (format port "#<<virtual-resource> name=~s, creation-time=~s, content=~s>" + (name self) + (creation-time self) + (content self))) + +(define-method (live-properties (self <virtual-resource>)) + (append + (next-method) + (list (cons (xml-element-hash-key (xml virtual-ns 'isvirtual)) (make-live-property isvirtual set-isvirtual!))))) + +(define-method (content (self <virtual-resource>)) + (content* self)) + +(define-method (set-content! (self <virtual-resource>) data) + (set! (content* self) data)) + +(define-method (creationdate (self <virtual-resource>)) + (propstat 200 + (list + (list (xml webdav 'creationdate) + (-> (creation-time self) + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + + +(define-method (getcontenttype (self <resource>)) + (propstat 200 + (list + (list (xml webdav 'getcontenttype) + "application/binary")))) + +(define-method (isvirtual (self <virtual-resource>)) + (propstat 200 + (list + (list (xml virtual-ns 'isvirtual) + "true")))) + + +(define-method (set-isvirtual! (self <virtual-resource>) _) + (throw 'protected-resource "isvirtual")) |