diff options
Diffstat (limited to '')
-rw-r--r-- | module/vcomponent/data-stores/caldav.scm | 270 | ||||
-rw-r--r-- | module/vcomponent/data-stores/common.scm | 27 | ||||
-rw-r--r-- | module/vcomponent/data-stores/file.scm | 28 | ||||
-rw-r--r-- | module/vcomponent/data-stores/meta.scm | 16 | ||||
-rw-r--r-- | module/vcomponent/data-stores/vdir.scm | 76 |
5 files changed, 407 insertions, 10 deletions
diff --git a/module/vcomponent/data-stores/caldav.scm b/module/vcomponent/data-stores/caldav.scm new file mode 100644 index 00000000..f9ba61c1 --- /dev/null +++ b/module/vcomponent/data-stores/caldav.scm @@ -0,0 +1,270 @@ +(define-module (vcomponent data-stores caldav) + ) + +(use-modules (srfi srfi-71) + (srfi srfi-88) + (rnrs bytevectors) + (rnrs io ports) + ((ice-9 binary-ports) :select (call-with-output-bytevector)) + (web request) + (web response) + (web client) + (web uri) + ;; (web http) ; + (sxml simple) + (oop goops) + (vcomponent data-stores common) + ((hnh util) :select (->)) + (web http dav) + ) + + + +(define-class <caldav-data-store> (<calendar-data-store>) + (host init-keyword: host: + getter: host) + (user init-keyword: user: + getter: user) + (calendar-path init-keyword: calendar-path: + accessor: calendar-path) + (password init-keyword: password: + getter: store-password)) + + +(define local-uri + (case-lambda ((this path) + (build-uri 'https + host: (host this) + path: path)) + ((this) + (build-uri 'https + host: (host this) + path: (calendar-path this))))) + + +(define* (make-caldav-store key: host user path password) + (define store + (make <caldav-data-store> + host: host + user: user + password: (string->symbol password) + calendar-path: path)) + + + (let* ((principal-path + (get-principal (local-uri store "/") + password: (store-password store))) + (calendar-home-set + (get-calendar-home-set (local-uri store principal-path) + password: (store-password store))) + (calendar-paths + (get-calendar-paths (local-uri store calendar-home-set) + password: (store-password store)))) + (set! (calendar-path store) + (car calendar-paths))) + + store) + +(define-method (write (this <caldav-data-store>) port) + (write `(make-caldav-store host: ,(host this) + user: ,(user this) + calendar-path: ,(calendar-path this) + password: ,(store-password this)) + port)) + +(define store + (make-caldav-store host: "dav.fruux.com" + user: "a3298201184" + password: "YjMyOTc0NjUwMDk6YXRhc3llanY2MGtu")) + +#; +(define-method (calendar-base (this <caldav-data-store>)) + (build-uri 'https + host: (host this) + path: (calendar-path this))) + + +;; (define-method (get-all (this <caldav-data-store>)) +;; ) + +(define-method (get-by-uid (this <caldav-data-store>) + (uid <string>)) + (let ((uids + (dav (local-uri this) + method: 'REPORT + authorization: `(Basic ,(store-password this)) + depth: 1 + body: + `(c:calendar-query + (@ (xmlns:c ,caldav)) + (d:prop (@ (xmlns:d "DAV:")) + (d:getetag) + #; (c:calendar-data) + ) + (c:filter + (c:comp-filter + (@ (name "VCALENDAR")) + (c:comp-filter + (@ (name "VEVENT")) + (c:prop-filter + (@ (name "UID")) + (c:text-match (@ (collation "i;octet")) + ,uid))))))))) + uids)) + + +(define-method (search (this <caldav-data-store>) + (filter <pair>)) + (let ((uids + (dav (local-uri this) + method: 'REPORT + authorization: `(Basic ,(store-password this)) + depth: 1 + body: + `(c:calendar-query + (@ (xmlns:c ,caldav)) + (d:prop (@ (xmlns:d "DAV:")) + (d:getetag) + (c:calendar-data + (c:comp (@ (name "VCALENDAR")) + (c:prop (@ (name "PRODID"))))) + #; (c:calendar-data) + ) + ,filter)))) + uids)) + +(define-method (search (this <caldav-data-store>) + (filter <string>) + (field <string>)) + (search store + `(c:filter + (c:comp-filter + (@ (name "VCALENDAR")) + (c:comp-filter + (@ (name "VEVENT")) + (c:prop-filter + (@ (name ,field)) + (c:text-match (@ (collation "i;octet")) + ,filter))))))) + + + +(define-method (list-calendars (this <caldav-data-store>)) + ) + + + + +(get-principal) ; => "/principals/uid/a3298201184/" + +(get-calendar-home-set "/principals/uid/a3298201184/") +;; => "/calendars/a3298201184/" + +(get-calendar-paths "/calendars/a3298201184/") +;; => ("/calendars/a3298201184/b85ba2e9-18aa-4451-91bb-b52da930e977/") + + + +(define user "a3298201184") +(define calendar "b85ba2e9-18aa-4451-91bb-b52da930e977") +(define password (string->symbol "YjMyOTc0NjUwMDk6YXRhc3llanY2MGtu")) +(define auth `(Basic ,password)) + + + + + + +(define uri + (build-uri 'https + host: "dav.fruux.com" + path: "/calendars/a3298201184/b85ba2e9-18aa-4451-91bb-b52da930e977/ff95c36c-6ae9-4aa0-b08f-c52d84bf4f26.ics")) + +(define-values (response body) + (dav uri + method: 'GET + authorization: auth)) + + + + +(define-values (response body) + (dav uri + method: 'PROPFIND + authorization: auth + body: + `(C:supported-collation-set (@ (xmlns:C ,caldav))))) + +(define-values (response body) + (dav uri + method: 'REPORT + authorization: auth + body: + `(C:calendar-query + (@ (xmlns:C ,caldav)) + (D:prop (@ (xmlns:D "DAV:")) + (D:getetac) + (C:calendar-data)) + (C:filter + (C:comp-filter (@ (name "VCALENDAR")) + (C:comp-filter (@ (name "VEVENT")) + (C:prop-filter (@ (name "UID")) + (C:text-match (@ (collation "i;utf-8")) + "Admittansen")))))))) + + + + + + +(define (add) + ;; add new event + (http-request 'PUT + path: "/path-on-server/<filename>.ics" + headers: + ((if-none-match "*") + (content-type "text/calendar")) + body: (ics:serialize event-with-wrapping-calendar) + )) + + +(define (get-by-time-range) + (http-request 'REPORT + path: "/calendar/<calendar-name>" + body: + ;; See RFC 4791 7.8.1 + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (C:calendar-query + (@ (xmlns:D "DAV:") + (xmlns:C "urn:ietf:params:xml:ns:caldav")) + (D:prop + (D:getetag) + (C:calendar-data + (C:comp + (@ (name "VCALENDAR")) + (C:prop (@ (name "VERSION"))) + (C:prop (@ name "VEVENT") + (C:prop (@ (name "SUMMARY"))) + ...)))) + (C:filter + (C:comp-filter + (@ (name "VCALENDAR")) + (C:comp-filter + (@ (name "VEVENT")) + (C:time-range + (@ (start ,(datetime->string + start + "~Y~m~dT~H~M~S~Z")) + (end ,(datetime->string + end + "~Y~m~dT~H~M~S~Z"))))))))))) + + + + + +;; (use-modules (curl)) +;; (define c (curl-easy-init)) +;; (curl-easy-setopt c 'url "https://hornquist.se") + +;; (curl-easy-perform handle) diff --git a/module/vcomponent/data-stores/common.scm b/module/vcomponent/data-stores/common.scm index d6775141..2fb4422a 100644 --- a/module/vcomponent/data-stores/common.scm +++ b/module/vcomponent/data-stores/common.scm @@ -2,25 +2,42 @@ :use-module ((srfi srfi-88) :select ()) :use-module (oop goops) :export (<calendar-data-store> - path + ;; path get-all get-by-uid)) (define-class <calendar-data-store> () - (path init-keyword: path: - getter: path) + ;; (path init-keyword: path: + ;; getter: path) ) + +;;; In (calp server routes) + + + + +;;; Load - Load store into memero +;;; Dump - Save store into "disk" + (define-method (get-all (this <calendar-data-store>)) (scm-error 'not-implemented "get-all" "Get-all is not implemented for ~s" - (list (class-of this)) + (class-of this) #f)) (define-method (get-by-uid (this <calendar-data-store>) (uid <string>)) (scm-error 'not-implemented "get-by-uid" "Get-by-uid is not implemented for ~s" - (list (class-of this)) + (class-of this) #f)) + + +(define-method (color (this <calendar-data-store>)) + "") + + +(define-method (displayname (this <calendar-data-store>)) + "") diff --git a/module/vcomponent/data-stores/file.scm b/module/vcomponent/data-stores/file.scm index 0f09d81c..54676224 100644 --- a/module/vcomponent/data-stores/file.scm +++ b/module/vcomponent/data-stores/file.scm @@ -1,4 +1,32 @@ (define-module (vcomponent data-stores file) :use-module (oop goops) + :use-module ((srfi srfi-88) :select ()) + :use-module ((calp) :select (prodid)) :use-module (vcomponent data-stores common) + :use-module ((vcomponent formats ical) :select (serialize deserialize)) + ) + +(define-class <file-data-store> (<calendar-data-store>) + (path getter: path + init-keyword: path:)) + +(define (make-file-store path) + (make <file-store> path: path)) + +(define-method (get-all (this <file-data-store>)) + ;; X-WR-CALNAME ⇒ NAME + ;; X-WR-CALDESC + (call-with-input-file (path this) + deserialize)) + +(define-method (get-by-uid (this <file-data-store>) (uid <string>)) + #f + ) + +(define-method (queue-write (this <file-data-store>) vcomponent) + ) + +(define-method (flush (this <file-data-store>)) + (with-atomic-output-to-file (path this) + (lambda () (serialize (data this) (current-output-port)))) ) diff --git a/module/vcomponent/data-stores/meta.scm b/module/vcomponent/data-stores/meta.scm index c670d692..8ec5f7fd 100644 --- a/module/vcomponent/data-stores/meta.scm +++ b/module/vcomponent/data-stores/meta.scm @@ -6,12 +6,24 @@ (define-module (vcomponent data-stores meta) :use-module (oop goops) :use-module (vcomponent data-stores common) + :use-module (srfi srfi-41) :use-module ((srfi srfi-88) :select ()) :export () ) (define-class <meta-data-store> (<calendar-data-store>) (stores accessor: stores - init-value: '())) + init-value: '() + init-keyword: stores:)) -(define-method (get-calendar )) + + +(define-method (get-all (this <meta-data-store>)) + (map get-all (stores this))) + +(define-method (get-by-uid (this <meta-data-store>) (uid <string>)) + (stream-car + (stream-append + (steam-map (lambda (store) (get-by-uid store uid)) + (list->stream (stores this))) + (stream #f)))) diff --git a/module/vcomponent/data-stores/vdir.scm b/module/vcomponent/data-stores/vdir.scm index fca59092..f0ed0fdc 100644 --- a/module/vcomponent/data-stores/vdir.scm +++ b/module/vcomponent/data-stores/vdir.scm @@ -1,17 +1,87 @@ (define-module (vcomponent data-stores vdir) + :use-module (hnh util) :use-module (oop goops) :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) :use-module ((srfi srfi-88) :select ()) + :use-module (hnh util path) + :use-module ((vcomponent formats ical) :select (serialize deserialize)) + :use-module ((ice-9 ftw) :select (scandir)) :export ()) (define-class <vdir-data-store> (<calendar-data-store>) + (path getter: path + init-keyword: path:) + (loaded-calendar accessor: loaded-calendar + init-value: #f) + (uid-map accessor: uid-map + init-value: #f) ) +(define (make-vdir-store path) + (make <vdir-data-store> path: path)) + +(define* (get-attribute path key key: dflt) + (catch 'system-error + (lambda () (call-with-input-file (path-append path key) read-line)) + (const dflt))) + + (define-method (get-all (this <vdir-data-store>)) - '()) + (let ((files (scandir (path this) (lambda (item) (string-ci=? "ics" (filename-extension item))))) + (calendar (make-vcomponent 'VCALENDAR))) + (set! (prop calendar 'NAME) (get-attribute (path this) "displayname") + (prop calendar 'COLOR) (get-attribute (path this) "color" "#FFFFFF")) + (for-each (lambda (item) (reparent! calendar item)) + (append-map (lambda (file) + (define cal + (call-with-input-file (path-append (path this) file) + deserialize)) + (unless (eq? 'VCALENDAR (type cal)) + (scm-error 'misc-error "get-all<vdir-data-store>" + "Unexpected top level component. Expected VCALENDAR, got ~a. In file ~s" + (list (type cal) file))) + (for-each (lambda (child) + (set! (prop child '-X-HNH-FILENAME) file)) + (children cal)) + ) + files)) + (set! (loaded-calendar this) calendar) + calendar)) + (define-method (get-by-uid (this <vdir-data-store>) (uid <string>)) - #f - ) + (unless (uid-map this) + (let ((cal + (or (loaded-calendar this) + (get-all this)))) + (define ht (make-hash-table)) + (for-each (lambda (ev) (hash-set! ht (uid ev) ev)) + (children cal)) + (set! (uid-map this) ht))) + (hash-ref m uid #f)) + + +(define (wrap-for-output . vcomponents) + (let ((calendar (make-vcomponent 'VCALENDAR))) + (set! (prop calendar 'VERSION) "2.0" + (prop calendar 'PRODID) (prodid) + (prop calendar 'CALSCALE) "GREGORIAN") + (for-each (lambda (vcomponent) (reparent! calendar vcomponent)) + vcomponents) + calendar)) + +(define-method (queue-write (this <vdir-data-store>) vcomponent) + ;; TODO Multiple components + (let ((filename + (cond ((prop vcomponent '-X-HNH-FILENAME) + => identity) + (else + (format #f "~a.ics" (prop vcomponent 'UID)))))) + (with-atomic-output-to-file (path-append (path this) filename) + (lambda () (serialize (wrap-for-output vcomponent) (current-output-port)))))) + +(define-method (flush (this <vdir-data-store>)) + (sync)) ;; (define (get-in-date-interval )) |