diff options
Diffstat (limited to 'module/calp')
-rw-r--r-- | module/calp/html/view/calendar.scm | 14 | ||||
-rw-r--r-- | module/calp/html/view/search.scm | 2 | ||||
-rw-r--r-- | module/calp/namespaces.scm | 14 | ||||
-rw-r--r-- | module/calp/server/routes.scm | 44 | ||||
-rw-r--r-- | module/calp/server/server.scm | 19 | ||||
-rw-r--r-- | module/calp/server/socket.scm | 48 | ||||
-rw-r--r-- | module/calp/server/webdav.scm | 768 | ||||
-rw-r--r-- | module/calp/terminal.scm | 12 | ||||
-rw-r--r-- | module/calp/webdav/property.scm | 91 | ||||
-rw-r--r-- | module/calp/webdav/propfind.scm | 99 | ||||
-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 | 598 | ||||
-rw-r--r-- | module/calp/webdav/resource/calendar.scm | 27 | ||||
-rw-r--r-- | module/calp/webdav/resource/calendar/collection.scm | 295 | ||||
-rw-r--r-- | module/calp/webdav/resource/calendar/object.scm | 76 | ||||
-rw-r--r-- | module/calp/webdav/resource/file.scm | 192 | ||||
-rw-r--r-- | module/calp/webdav/resource/virtual.scm | 71 |
18 files changed, 2401 insertions, 51 deletions
diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index a240d00c..070d1c3f 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -171,7 +171,7 @@ window.default_calendar='~a';" ;; Button to view week (G_ "Week")) - ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html") + ,(btn href: (date->string (day start-date 1) "/month/~1.html") ;; button to view month (G_ "Month")) @@ -381,13 +381,11 @@ window.default_calendar='~a';" (repeating% regular (partition repeating? flat-events)) (repeating (for ev in repeating% - (define instance (copy-vcomponent ev)) - - (set! (prop instance 'UID) (output-uid instance)) - (delete-parameter! (prop* instance 'DTSTART) '-X-HNH-ORIGINAL) - (delete-parameter! (prop* instance 'DTEND) '-X-HNH-ORIGINAL) - - instance))) + ;; TODO + (-> (set-properties ev 'UID (output-uid ev)) + ;; (focus (prop* instance 'DTSTART) (lambda (vline) (remove-parameter vline key))) + ;; (focus (prop* instance 'DTEND) (lambda (vline) (remove-parameter vline key))) + )))) `( ;; Mapping showing which events belongs to which calendar, diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index 7b991104..e400c1ba 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -31,6 +31,8 @@ (body (a (@ (href ("/today"))) ,(G_ "Show today")) (h2 ,(G_ "Search term")) + ;; TODO add blurb documenting available variables here, + ;; and link to full documentation page (form (pre (textarea (@ (name "q") (rows 5) (spellcheck false) (style "width:100%")) 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/routes.scm b/module/calp/server/routes.scm index b4901900..3383f7a6 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -294,11 +294,11 @@ str))))) (return '((content-type application/xml)) - (with-output-to-string - (lambda () - (sxml->xml - `(properties - (uid (text ,(prop event 'UID))))))))))) + (lambda (port) + (sxml->xml + `(properties + (uid (text ,(prop event 'UID)))) + port)))))) ;; Get specific page by query string instead of by path. ;; Useful for <form>'s, since they always submit in this form, but also @@ -332,16 +332,16 @@ (GET "/calendar/:uid{.*}.xcs" (uid) (aif (get-event-by-uid global-event-object uid) (return '((content-type application/calendar+xml)) - ;; TODO sxml->xml takes a port, would be better - ;; to give it the return port imidiately. - (with-output-to-string - ;; TODO this is just the vevent part. - ;; A surounding vcalendar is required, as well as - ;; a doctype. - ;; Look into changing how events carry around their - ;; parent information, possibly splitting "source parent" - ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) it))))) + ;; TODO this is just the vevent part. + ;; A surounding vcalendar is required, as well as + ;; a doctype. + ;; Look into changing how events carry around their + ;; parent information, possibly splitting "source parent" + ;; and "program parent" into different fields. + (lambda (port) + (sxml->xml + ((@ (vcomponent formats xcal output) vcomponent->sxcal) it) + port))) (return (build-response code: 404) (format #f (G_ "No component with UID=~a found.") uid)))) @@ -414,13 +414,13 @@ (format #f "~?~%" fmt arg)))))) (return `((content-type ,(content-type html))) - (with-output-to-string - (lambda () - ((sxml->output html) - (search-result-page - error - (and=> q (negate string-null?)) - search-term search-result page paginator)))))) + (lambda (port) + ((sxml->output html) + (search-result-page + error + (and=> q (negate string-null?)) + search-term search-result page paginator) + port)))) ;; NOTE this only handles files with extensions. Limited, but since this ;; is mostly for development, and something like nginx should be used in diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index f2d58337..4c5a0886 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -4,28 +4,13 @@ :use-module ((calp server routes) :select (make-make-routes)) :use-module (ice-9 threads) :use-module (srfi srfi-88) + :use-module (calp server socket) :export (start-server)) +;;; TODO Do I really want this hardcoded here? (define handler (make-make-routes)) -;; NOTE The default make-default-socket is broken for IPv6. -;; A patch has been submitted to the mailing list. 2020-03-31 -;; -;; This sets up the socket manually, and sends that to @code{http-open}. -(define* (make-default-socket/fixed family addr port) - (let ((sock (socket family SOCK_STREAM 0))) - (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - (bind sock family addr port) - sock)) - -(define* (setup-socket key: - (host #f) - (family AF_INET) - (addr (if host (inet-pton family host) - INADDR_LOOPBACK)) - (port 8080)) - (make-default-socket/fixed family addr port)) (define (start-server open-params) (run-server handler diff --git a/module/calp/server/socket.scm b/module/calp/server/socket.scm new file mode 100644 index 00000000..990adfa6 --- /dev/null +++ b/module/calp/server/socket.scm @@ -0,0 +1,48 @@ +(define-module (calp server socket) + :use-module (srfi srfi-88) + :use-module (web server) + :export (setup-socket + run-at-any-port) + ) + +;; NOTE The default make-default-socket is broken for IPv6. +;; A patch has been submitted to the mailing list. 2020-03-31 +;; +;; This sets up the socket manually, and sends that to @code{http-open}. +(define* (make-default-socket/fixed family addr port) + (let ((sock (socket family SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock)) + +(define* (setup-socket key: + (host #f) + (family AF_INET) + (addr (if host (inet-pton family host) + INADDR_LOOPBACK)) + (port 8080)) + (make-default-socket/fixed family addr port)) + + +(define* (run-at-any-port handler key: + (min-port 8081) + msg-port) + (unless msg-port + (scm-error 'misc-error "run-at-any-port" + "msg-port required" + '() #f)) + (let loop ((port min-port)) + (catch 'system-error + (lambda () + (let ((socket (setup-socket port: port))) + (let ((addr (format #f "http://localhost:~a~%" port))) + (display addr msg-port) + (force-output msg-port) + (format #t "Server started at ~s~%" addr) + (run-server handler 'http + `(socket: ,socket)) + (format #t "Server closed~%")))) + (lambda (err proc fmt args data) + (if (= EADDRINUSE (car data)) + (loop (1+ port)) + (apply throw err proc fmt args data)))))) diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm new file mode 100644 index 00000000..781a85d9 --- /dev/null +++ b/module/calp/server/webdav.scm @@ -0,0 +1,768 @@ +(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) +(declare-method! "MKCALENDAR" 'REPORT) + + + +(define (root-element sxml) + (sxml-match sxml + [(*TOP* (*PI* . ,args) ,root) root] + [(*TOP* ,root) root] + [,root root])) + +(define (root-element/namespaced sxml) + (cond ((not (list? sxml)) (scm-error 'misc-error "root-element/namespaced" + "Argument is invalid sxml: ~s" + (list sxml) #f)) + ((null? (car sxml)) (scm-error 'misc-error "root-element/namespaced" + "No root in an empty list" + '() #f)) + ((eq? '*TOP* (car sxml)) + (let ((children (cdr sxml))) + (cond ((null? children) #f) + ((pi-element? (car children)) + (cadr children)) + (else (car children))))) + (else sxml))) + + +(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 property-request + (cond ((string? body) + (xml->namespaced-sxml body)) + ((bytevector? body) + (-> body + (bytevector->string + (make-transcoder (utf-8-codec))) + xml->namespaced-sxml)) + (else `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)))))) + + + (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/namespaced property-request) + 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"))))) + + (case (copy-to-location! source-resource destination-parent-resource + new-name: dest-name + include-children?: (case depth + ((0) #f) + ((infinity) #t) + (else (throw 'invalid-requeqst))) + overwrite?: 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) ""))))) + + +(define (run-move href request) + ;; TODO href="/" + (define headers (request-headers request)) + (call/ec + (lambda (return) + (define-values (path name) (init+last href)) + (define parent (or (lookup-resource (root-resource) path) + (return (build-response code: 404) + "Source Parent not found"))) + (define child (or (lookup-resource parent (list name)) + (return (build-response code: 404) + "Source not found"))) + (define-values (dest-path dest-name) + (-> headers (assoc-ref 'destination) + uri-path string->href init+last)) + (define dest-parent (or (lookup-resource (root-resource) dest-path) + (return (build-response code: 404) + "Dest Parent not found"))) + (define overwrite? (cond ((assoc 'overwrite headers) => cdr) + (else #t))) + (define status (move-to-location! parent child + dest-parent + new-name: dest-name + overwrite?: overwrite?)) + + (case status + ((created) + (values (build-response code: 201) "")) + ((replaced) + (values (build-response code: 204) "")) + ((collision) + (values (build-response code: 412) "")))))) + + + +;; (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* + (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)))) + + (parser-error + (lambda (err port msg . args) + (define head (build-response code: 400 + headers: '((content-type . (text/plain))))) + (define errmsg + (with-output-to-string + (lambda () + (display msg) + (for-each display args)))) + (log-table-add! 'response head + 'response-code 400 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + + (#t + (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/terminal.scm b/module/calp/terminal.scm index 04effd68..316421eb 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -162,11 +162,11 @@ (date->string start)))) (format #t "\x1b[1m~a:\x1b[m ~a~%~%" (G_ "End") - (let ((start (prop ev 'DTSTART))) - (if (datetime? start) - (datetime->string (prop ev 'DTSTART) + (let ((end (prop ev 'DTEND))) + (if (datetime? end) + (datetime->string (prop ev 'DTEND) (G_ "~Y-~m-~d ~H:~M:~S")) - (date->string start)))) + (date->string end)))) (format #t "~a~%" (unlines (take-to (flow-text (or (prop ev 'DESCRIPTION) "") width: (min 70 width)) @@ -290,6 +290,7 @@ ">"))) (newline)) +;;; TODO what is this view? (define-method (input (this <view>) char) (case char ((#\j #\J down) (unless (= (active-element this) (1- (page-length this))) @@ -300,6 +301,9 @@ ((#\g) (set! (active-element this) 0)) ((#\G) (set! (active-element this) (1- (page-length this)))) + ;; TODO Launch edit mode! + ;; TODO should edit mode be here? + ((#\e) 'NOOP) ((#\q) '(pop))) 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..83725825 --- /dev/null +++ b/module/calp/webdav/propfind.scm @@ -0,0 +1,99 @@ +(define-module (calp webdav propfind) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (calp namespaces) + :use-module (srfi srfi-1) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :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))) + + + + + +(define (find-element target list) + (define target* (xml-element-hash-key target)) + (find (lambda (x) (and (list? x) + (not (null? x)) + (xml-element? (car x)) + (equal? target* (xml-element-hash-key (car x))))) + list)) + +;; Takes a propfind xml element (tree), and a webdav resource object. +;; Returns a list of <propstat> objects. +(define (parse-propfind sxml resource) + ;; (assert (list? sxml)) + ;; (assert (not (null? sxml))) + ;; (assert eq? 'd:propfid (car sxml)) + (let ((propname (find-element (xml webdav 'propname) (cdr sxml))) + (allprop (find-element (xml webdav 'allprop) (cdr sxml))) + (include (find-element (xml webdav 'include) (cdr sxml))) + (prop (find-element (xml webdav 'prop) (cdr sxml)))) + (merge-propstats + (cond ((and allprop include) + ;; Return "all" properties + those noted by <include/> + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource) + (propfind-selected-properties + resource + (map car (cdr include))))) + (allprop + ;; Return "all" properties + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (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)))))) + (prop + ;; Return the properties listed + (propfind-selected-properties + resource + (map car (cdr prop)))) + (else + (scm-error 'bad-request "parse-propfind" + "Invalid search query ~s" (list sxml) (list sxml))))))) 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..500aef90 --- /dev/null +++ b/module/calp/webdav/resource/base.scm @@ -0,0 +1,598 @@ +(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 (sxml namespaced util) + :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 + href-relative + ;; local-path + name + dead-properties + ;; resource-children + resource? + children + + + + 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! + + + setup-new-resource! + setup-new-collection! + + + + live-properties + add-child! + add-resource! + add-collection! + is-collection? + + content + set-content! + + copy-resource + copy-to-location! + move-to-location! + cleanup-resource + delete-child! + 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 #\/))) + +;; parent must be the head of child, elements in child after that is "free range" +(define (href-relative parent child) + (cond ((null? parent) child) + ((null? child) (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)) + ((equal? (car parent) (car child)) + (href-relative (cdr parent) (cdr child))) + (else (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)))) + +(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) + (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)))))) + + +(define (add-resource! self new-name content) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (add-child! self resource collection?: #f) + (set-content! resource content) + resource))) + +(define (add-collection! self 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 collection?: #t) + resource))) + +(define (initialize-copied-resource! source copy) + (for-each (lambda (tag) (set-dead-property! copy tag)) + (dead-properties source)) + (set! (displayname* copy) (displayname* source) + (contentlanguage copy) (contentlanguage source)) + ;; (format (current-error-port) "Setting content! ~s (~s)~%" copy source) + (when (content source) + (set-content! copy (content source))) + ;; resource-cache should never be copied + ) + +(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))))) + (initialize-copied-resource! self resource) + (when include-children? + (for-each (lambda (c) (add-child! resource c)) + (map (lambda (c) (copy-resource c #t)) + (children self)))) + resource)) + +;; source and target-parent should be resource instances +;; new-name a string +;; include-children? and overwrite? booleans +(define* (copy-to-location! source target-parent + key: + (new-name (name source)) + include-children? + overwrite? + ) + (let ((copy (make (class-of source) name: new-name)) + ;; Take copy if child list. If we run `cp -r / /c` then; + ;; (at least when /c already exists) our child list gets + ;; updated, leading to an infinite loop if we use + ;; `(children source)` directly below. + (children-before (children source))) + (let ((status (add-child! target-parent copy + ;; (is-collection? copy) doesn't work for + ;; all types, since it's not quite yet + ;; added (for example: <file-resoure> + ;; checks if the target resource is a + ;; directory on the file system). + collection?: (is-collection? source) + overwrite?: overwrite?))) + (case status + ((created replaced) + (initialize-copied-resource! source copy) + (when include-children? + (for-each (lambda (c) (copy-to-location! + c copy + include-children?: #t)) + children-before)) + status) + ((collision) 'collision))))) + +(define* (move-to-location! source-parent source target-parent + key: + (new-name (name source)) + overwrite?) + (let ((status (copy-to-location! source target-parent + new-name: new-name + include-children?: #t + overwrite?: overwrite?))) + (case status + ((created replaced) + (delete-child! source-parent source) + status) + ((collision) 'collision)))) + + +;; 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 (setup-new-collection! (this <resource>) (parent <resource>)) + 'noop) + +(define (add-child* this child collection?) + (setup-new-resource! child this) + (when collection? + (setup-new-collection! child this)) + (set! (resource-children this) + (cons child (resource-children this)))) + +(define* (add-child! this child + key: + overwrite? + (collection? (is-collection? child))) + (let ((existing (lookup-resource this (list (name child))))) + (cond ((and overwrite? existing) + (delete-child! this existing) + (add-child* this child collection?) + 'replaced) + (existing 'collision) + (else + (add-child* this child collection?) + '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)) + + + +;;; 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..314d66aa --- /dev/null +++ b/module/calp/webdav/resource/calendar.scm @@ -0,0 +1,27 @@ +(define-module (calp webdav resource calendar) + ;; :use-module (hnh util) + ;; :use-module (datetime) + ;; :use-module (sxml namespaced util) + ;; :use-module (calp webdav property) + ;; :use-module (ice-9 hash-table) + :use-module (calp webdav resource calendar collection) + :use-module (calp webdav resource calendar object) + :export ( + calendar-resource? +) + ) + +(define cm (module-public-interface (current-module))) +(module-use! cm (resolve-interface '(calp webdav resource calendar collection))) +(module-use! cm (resolve-interface '(calp webdav resource calendar object))) + +(define (calendar-resource? x) + (or (calendar-collection-resource? x) + (calendar-object-resource? x))) + + + + + + + diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm new file mode 100644 index 00000000..e1bf73fd --- /dev/null +++ b/module/calp/webdav/resource/calendar/collection.scm @@ -0,0 +1,295 @@ +(define-module (calp webdav resource calendar collection) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :use-module ((vcomponent) :prefix vcs-) + :use-module ((vcomponent base) + :select (type prop vcomponent)) + + :use-module (web request) + :use-module (web uri) + + :use-module ((calp namespaces) :select (webdav caldav)) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (ice-9 hash-table) + + :use-module (hnh util) + + :use-module (calp webdav resource calendar object) + ;; propfind-most-live-properties propfind-all-dead-properties propname uri-path request-uri type + :export (<calendar-collection-resource> + caldav-properties + calendar-collection-resource?) + ) + +;;; Resoruces containing calendar components +(define-class <calendar-collection-resource> (<resource>) + (description init-value: #f + accessor: description) + (data-store getter: data-store + init-keyword: store:)) + + +(define-method (is-collection? (_ <calendar-collection-resource>)) + #t) + + + +(define-method (children (this <calendar-collection-resource>)) + (map (lambda (ev) + (make <calendar-object-resource> + name: (prop ev 'UID) + component: ev)) + (vcs-children this))) + +(define (calendar-collection-resource? x) + (is-a? x <calendar-collection-resource>)) + + +(define-method (base-timezone <calendar-collection-resource>) + ;; (zoneinfo->vtimezone '() "Europe/Stockholm" 'ev) + (vcomponent type: 'VTIMEZONE) + ) + + + +(define-method (live-properties (self <calendar-collection-resource>)) + (append (next-method) + (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair))) + caldav-properties))) + + + + +(define-method (displayname (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml webdav 'displayname) + ,(prop (content self) 'displayname))))) + + +(define-method (resourcetype (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml webdav 'resourcetype) + (,(xml caldav 'calendar)))))) + +;;; CALDAV Properties + +(define-method (calendar-description (self <calendar-collection-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))))))) + +(define-method (calendar-timezone (self <calendar-collection-resource>)) + (propstat 200 + (list + (list (xml caldav 'calendar-description) + (call-with-output-string + (lambda (port) + (ics:serialize (base-timezone self) port))))))) + +(define-method (supported-calendar-component-set (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml caldav 'supported-calendar-component-set) + (,(xml caldav 'comp + (alist->hashq-table '((name . "VEVENT"))))))))) + +(define-method (supported-calendar-data (self <calendar-collection-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-collection-resource>)) +;; ) + +;; (define-method (min-date-time )) +;; (define-method (max-date-time )) +;; (define-method (max-instances )) +;; (define-method (max-attendees-per-instance )) + +(define-method (supported-collation-set (self <calendar-collection-resource>)) + (propstat 200 + (list `(,(xml caldav 'supported-collation-set) + ,@(map (lambda (cs) `(,(xml caldav 'supported-collation) ,cs)) + `(;; Required by CalDAV + "i;ascii-casemap" + "i;octet" + ;; Added (RFC 5051)) + "i;unicode-casemap")))))) + + + +(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) + (supported-collation-set . ,supported-collation-set) + ;; (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) + )) + +;;; Reports + +(define-method (supported-reports* (this <calendar-collection-resource>)) + (append (next-method) + (list + ;; Required for ACL, but not for CalDAV + ;; (xml webdav 'version-tree) + ;; Optional for ACL, but REQUIRED for CalDAV + (cons (xml webdav 'expand-property) expand-property) + ;; REQUIRED by CalDAV + (cons (xml caldav 'calendar-query) calendar-query) + (cons (xml caldav 'calendar-multiget) calendar-multiget) + (cons (xml caldav 'free-busy-report) free-busy-report) + ))) + + +(define-method (calendar-query (this <calendar-collection-resource>) headers body) + ;; Request body MUST be a caldav:calendar-query + ;; Request MAY include a depth header, default = 0 + ;; Respnose-body MUST be a dav:multistatus + ;; Responseb body MUST contain DAV:respons element for each iCalendar object that matched the search filter + + (let ((allprop (find-element (xml webdav 'allprop) (cdr body))) + (propname (find-element (xml webdav 'propname) (cdr body))) + (prop (find-element (xml webdav 'prop) (cdr body))) + (filter (find-element (xml caldav 'filter) (cdr body))) + (timezone (find-element (xml caldav 'timezone) (cdr body)))) + (when (< 1 (count identity (list allprop propname prop))) + (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive")) + + (unless filter + (throw 'bad-request 400 "filter required")) + + + #; + (when timezone + (case (assoc-ref (attributes timezone) 'content-type) + ((application/calendar+xml) + (xcs:serialize default-timezone)) + ;; ((application/calendar+json)) + (else ; includes text/calendar + (ics:serialieze default-timezone) + ))) + + (let ((resources (select-components-by-comp-filter this comp-filter))) + `(,(xml webdav 'multistatus) + ,@(for (href . resource) in resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (merge-propstats + (cond (allprop + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + (list (propstat + 200 + (map (compose list car) + (append (dead-properties resource) + (live-properties resource)))))) + (prop + (map (lambda (prop) (get-property resource prop)) + prop))))))))))) + + + + +(define-method (expand-property (this <calendar-collection-resource>) request body)) + +(define-method (free-busy-report (this <calendar-collection-resource>) request body)) + +(define-method (calendar-multiget (this <calendar-collection-resource>) request body) + (define base-href (-> request request-uri uri-path href->string)) + (let ((allprop (find-element (xml webdav 'allprop) (cdr body))) + (propname (find-element (xml webdav 'propname) (cdr body))) + (prop (find-element (xml webdav 'prop) (cdr body))) + (hrefs (find-elements (xml webdav 'href) (cdr body)))) + (when (< 1 (count identity (list allprop propname prop))) + (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive")) + (when (null? hrefs) + (throw 'bad-request 400 "At least one href is required")) + + ;; (assert (memv href hrefs)) + + (let ((resources + (for href in hrefs + (cons href + (lookup-resource + this + (href-relative base-href href)))))) + `(,(xml webdav 'multistatus) + (for (href . resource) in resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(cond (resource + (cond (allprop + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + (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)))))) + (prop + (propfind-selected-properties + resource + (map car (cdr prop)))))) + (else + `(,(xml webdav 'status) + ,(http-status-line 404)))))))))) + + + + +(define-method (select-components-by-comp-filter (this <calendar-collection-resource>) comp-filter) + ) + + +;;; TODO +(define (overlaps? a b) + #t) + +(define (comp-filter scope filter) + ;; CaldDAV 9.7.1 + (or (and (null? (children filter)) + (eq? (attribute filter 'name) + (type scope))) + (and (find-element (xml caldav 'is-not-defined) + (children filter)) + (not + (find (lambda (el) (eq? (type el) (attribute filter 'name))) + (children scope)))) + (and (cond ((find-element (xml caldav 'time-range) + (children filter)) + => (lambda (range) + (overlaps? scope range))) + (else #f)) + (every (lambda (filt) (comp-filter scope filt)) (children filter))) + (every (lambda (filt) (comp-filter scope filt)) (children filter)))) diff --git a/module/calp/webdav/resource/calendar/object.scm b/module/calp/webdav/resource/calendar/object.scm new file mode 100644 index 00000000..82a8c18e --- /dev/null +++ b/module/calp/webdav/resource/calendar/object.scm @@ -0,0 +1,76 @@ +(define-module (calp webdav resource calendar object) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :use-module ((vcomponent formats xcal) :prefix #{xcs:}#) + :use-module ((vcomponent) :prefix vcs-) + :use-module ((calp namespaces) :select (webdav)) + :use-module (calp webdav property) + :use-module (sxml namespaced) + + :export (<calendar-object-resource> + calendar-object-resource? + component) + ) + +;;; content% + +(define-class <calendar-object-resource> (<resource>) + (component getter: component + init-keyword: component:)) + + + +(define-method (is-collection? (_ <calendar-object-resource>)) + #f) + + + +(define-method (children (_ <calendar-object-resource>)) + '()) + +(define (calendar-object-resource? x) + (is-a? x <calendar-object-resource>)) + +(define-method (content (self <calendar-object-resource>) content-type) + (case content-type + ((text/calendar) + (call-with-output-string (lambda (port) (ics:serialize (content% self) port)))) + ((application/calendar+xml) + (call-with-output-string (lambda (port) (xcs:serialize (content% self) port)))) + ;; ((text/html)) + ;; ((application/xhtml+xml)) + ;; ((application/calendar+json)) + (else (content self 'text/calendar)) + ) + ) + +(define-method (creationdate (self <calendar-object-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + (-> (content self) + (prop 'CREATED) + ;; TODO timezone + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + + +(define-method (getcontentlength (self <calendar-object-resource>)) + ;; TODO which representation should be choosen to calculate length? + (propstat 501 `((,(xml webdav 'getcontentlength))))) + + + +(define-method (getcontenttyype (self <calendar-object-resource>)) + ;; TODO different representations + (propstat 200 `((,(xml webdav 'getcontentlength) + "text/calendar")))) + + +(define-method (getlastmodified (self <calendar-object-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + (string->datetime (prop (content self) 'LAST-MODIFIED) + "~Y~m~dT~H~M~S"))))) diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm new file mode 100644 index 00000000..e2fec9a5 --- /dev/null +++ b/module/calp/webdav/resource/file.scm @@ -0,0 +1,192 @@ +(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-method (write (self <file-resource>) port) + (display + (format #f "#<<file-resource> name=~s, root=~s, path=~s>" + (name self) + (root self) + (path self)) + port)) + +(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)))) + + +(define-method (setup-new-resource! (self <file-resource>) + (parent <file-resource>)) + (next-method) + (set-root! self (root parent)) + (set-path! self (path-append (path parent) (name self)))) + +(define-method (setup-new-collection! (self <file-resource>) + (parent <file-resource>)) + (next-method) + (mkdir (filepath self))) + +(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..1d2d5d31 --- /dev/null +++ b/module/calp/webdav/resource/virtual.scm @@ -0,0 +1,71 @@ +(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 (sxml namespaced util) + :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")) |