diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/calp.scm | 9 | ||||
-rw-r--r-- | module/vcomponent/base.scm | 27 | ||||
-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 | ||||
-rw-r--r-- | module/vcomponent/formats/ical.scm | 7 | ||||
-rw-r--r-- | module/vcomponent/formats/ical/output.scm | 5 | ||||
-rw-r--r-- | module/vcomponent/formats/sxcal.scm | 13 | ||||
-rw-r--r-- | module/vcomponent/formats/xcal.scm | 3 | ||||
-rw-r--r-- | module/web/http/dav.scm | 144 |
12 files changed, 589 insertions, 36 deletions
diff --git a/module/calp.scm b/module/calp.scm index 81268cbb..b1952547 100644 --- a/module/calp.scm +++ b/module/calp.scm @@ -1,4 +1,9 @@ -(define-module (calp)) +(define-module (calp) + :export (version prodid)) ;; Update me on new release -(define-public version "0.6.1") +(define version "0.6.1") + +(define (prodid) + (format #f "-//hugo//calp ~a//EN" + (@ (calp) version))) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index e4982336..472c5074 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -30,6 +30,7 @@ parameters properties + copy-as-orphan copy-vcomponent x-property? internal-field? @@ -198,23 +199,25 @@ ;; TODO deep-copy on parameters? (get-vline-parameters vline))) +(define (copy-as-orphan component) + (make-vcomponent% + (type component) + (children component) + ;; properties + (alist->hashq-table + (hash-map->list (lambda (key value) + (cons key (if (list? value) + (map copy-vline value) + (copy-vline value)))) + (get-component-properties component))))) + + (define (copy-vcomponent component) - (let ((ev - (make-vcomponent% - (type component) - (children component) - ;; properties - (alist->hashq-table - (hash-map->list (lambda (key value) - (cons key (if (list? value) - (map copy-vline value) - (copy-vline value)))) - (get-component-properties component)))))) + (let ((ev (copy-as-orphan component))) (when (parent component) (reparent! (parent component) ev)) ev)) - (define (extract field) (lambda (e) (prop e field))) 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 )) diff --git a/module/vcomponent/formats/ical.scm b/module/vcomponent/formats/ical.scm index 294642de..dddca946 100644 --- a/module/vcomponent/formats/ical.scm +++ b/module/vcomponent/formats/ical.scm @@ -10,9 +10,8 @@ (define (serialize component port) - (display (component->ical-string component) - port)) + (with-output-to-port port + (lambda () (component->ical-string component)))) (define (deserialize port) - (parse-calendar port) - ) + (parse-calendar port)) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index 4d37dff6..57860d2a 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -16,6 +16,7 @@ :use-module (vcomponent geo) :use-module (vcomponent formats ical types) :use-module (vcomponent recurrence) + :use-module ((calp) :select (prodid)) :use-module (calp translation) :autoload (vcomponent util instance) (global-event-object) :export (component->ical-string @@ -24,10 +25,6 @@ print-events-in-interval )) -(define (prodid) - (format #f "-//hugo//calp ~a//EN" - (@ (calp) version))) - ;; Format value depending on key type. ;; Should NOT emit the key. diff --git a/module/vcomponent/formats/sxcal.scm b/module/vcomponent/formats/sxcal.scm index caf453ec..c02dbada 100644 --- a/module/vcomponent/formats/sxcal.scm +++ b/module/vcomponent/formats/sxcal.scm @@ -1,11 +1,16 @@ (define-module (vcomponent formats sxcal) - :export (serialize deserialize) - ) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :export (serialize deserialize) + ) (define (serialize component port) - 'TODO - ) + (write (serialize/object component) port)) + +(define (serialize/object component) + ;; TODO where is this defined? + (vcomponent->sxcal component)) (define (deserialize port) (sxcal->vcomponent port)) diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm index 2732a5a7..cfc70a92 100644 --- a/module/vcomponent/formats/xcal.scm +++ b/module/vcomponent/formats/xcal.scm @@ -14,6 +14,9 @@ (sxml->xml port) )) +(define (serialize/object component) + (call-with-output-string (lambda (p) (serialize component p)))) + (define (deserialize port) (-> (xml->sxml port) diff --git a/module/web/http/dav.scm b/module/web/http/dav.scm new file mode 100644 index 00000000..9adc8b87 --- /dev/null +++ b/module/web/http/dav.scm @@ -0,0 +1,144 @@ +(define-module (web http dav) + :use-module (srfi srfi-9) + :use-module (srfi srfi-88) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module ((ice-9 binary-ports) :select (call-with-output-bytevector)) + :use-module (web request) + :use-module (web response) + :use-module (web client) + :use-module (web uri) + :use-module (sxml simple) + :use-module (sxml xpath) + :use-module ((hnh util) :select (->)) + :export (caldav + user-agent dav + propfind + get-principal + get-calendar-home-set + get-calendar-paths + get-calendar-name + ) + ) + +(define caldav "urn:ietf:params:xml:ns:caldav") +(define user-agent (make-parameter "")) +(user-agent "calp/0.1") + +(define-record-type <info> + (make-info uri-creator password) + info? + (uri-creator uri-creator) + (password info-password) + ) + +(define (with-output-to-bytevector thunk) + (call-with-output-bytevector + (lambda (port) + (with-output-to-port port thunk)))) + +;; Make a webdav HTTP request, body should be a sxml tree without the *TOP* or +;; *PI* element. +(define* (dav uri key: method authorization body (depth 1)) + (define request-body + (if body + (with-output-to-bytevector + (lambda () + (sxml->xml + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + ,body)))) + #f)) + + (define headers + `((user-agent . ,(user-agent)) + (depth . ,(cond (depth number? => number->string) + (else depth))) + ;; (accept . ((*/*))) + (authorization . ,authorization) + ,@(if body + `((content-type . (application/xml (charset . "UTF-8"))) + (content-length . ,(bytevector-length request-body))) + '()))) + + (http-request uri + method: method + body: request-body + headers: headers + keep-alive?: #t + decode-body?: #f + streaming?: #t)) + +(define* (propfind uri resource key: (depth 1) password) + (define authorization + (if password + `(Basic ,password) + #f)) + (define-values (response port) + (dav uri + method: 'PROPFIND + authorization: authorization + depth: depth + body: `(propfind (@ (xmlns "DAV:") + (xmlns:d "DAV:") + (xmlns:c ,caldav)) + (prop (,resource))))) + (unless (= 207 (response-code response)) + (scm-error 'dav-error "propfind" + "HTTP error ~a: ~a" + (list + (response-code response) + (response-reason-phrase response)) + (list response))) + (xml->sxml port + declare-namespaces?: #t + trim-whitespace?: #t + namespaces: `((d . "DAV:") + (c . ,caldav)))) + + +;; (define (get-collections) +;; (-> (propfind "/" 'resourcetype) +;; ((sxpath '(// (d:response (// d:resourcetype d:collection)) +;; d:href *text*))))) + +;; => ((d:resourcetype (d:collection))) + +(define* (get-principal uri key: password) + (-> (propfind uri 'current-user-principal + depth: 0 + password: password) + ((sxpath '(// (d:response (d:href (equal? "/"))) + // + d:prop d:current-user-principal + d:href *text*))) + car)) + +(define* (get-calendar-home-set principal-uri key: password) + (-> (propfind principal-uri + 'c:calendar-home-set + password: password) + ((sxpath `(// (d:response (d:href + (equal? ,(uri-path principal-uri)))) + // d:prop c:calendar-home-set + d:href *text* + ))) + car)) + +(define* (get-calendar-paths calendar-home-set-uri key: password) + (-> (propfind calendar-home-set-uri + 'resourcetype + depth: "infinity" + password: password) + ((sxpath '(// (d:response (// d:resourcetype c:calendar)) + d:href *text*))))) + +;; => ("Calendar") +(define* (get-calendar-name calendar-path + key: password) + (-> (propfind calendar-path 'displayname + depth: 0 + password: password) + ((sxpath '(// d:response // d:prop d:displayname *text*))) + car)) + + |