diff options
Diffstat (limited to 'module/vcomponent')
25 files changed, 1356 insertions, 531 deletions
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index df452f62..ff2382bf 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,38 +1,39 @@ (define-module (vcomponent base) :use-module (hnh util) :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-9 gnu) :use-module (srfi srfi-17) :use-module (srfi srfi-88) - :use-module (ice-9 hash-table) - :export (make-vline + :use-module (hnh util object) + :use-module (hnh util lens) + :use-module (hnh util table) + :use-module (hnh util uuid) + :export (vline vline? - vline-key + vline-value + key + vline-parameters vline-source - make-vcomponent + vcomponent vcomponent? children type parent + add-child - add-child! remove-child! - - delete-property! + remove-property prop* prop extract extract* - delete-parameter! - value + set-properties + + remove-parameter + ;; value param parameters properties - copy-vcomponent x-property? internal-field? - - ) ) @@ -50,163 +51,95 @@ ;;; </vcomponent> ;;; -(define-record-type <vline> - (make-vline% key value parameters) - vline? - (key vline-key) - (value get-vline-value set-vline-value!) - (parameters get-vline-parameters) - (source get-source set-source!) - ) - -(set-record-type-printer! - <vline> - (lambda (v p) - (format p "#<<vline> key: ~s value: ~s parameters: ~s>" - (vline-key v) - (get-vline-value v) - (hash-map->list list (get-vline-parameters v))))) - -(define vline-source - (make-procedure-with-setter - get-source set-source!)) - -(define* (make-vline key value optional: (ht (make-hash-table))) - (make-vline% key value ht)) - -(define-record-type <vcomponent> - (make-vcomponent% type children parent properties) - vcomponent? - (type type) - (children children set-component-children!) - (parent get-component-parent set-component-parent!) - (properties get-component-properties)) - -((@ (srfi srfi-9 gnu) set-record-type-printer!) - <vcomponent> - (lambda (c p) - (format p "#<<vcomponent> ~a, len(child)=~a, parent=~a>" - (type c) - (length (children c)) - (and=> (get-component-parent c) type)))) - -;; TODO should this also update the parent -(define parent - (make-procedure-with-setter - get-component-parent set-component-parent!)) - -(define* (make-vcomponent optional: (type 'VIRTUAL)) - (make-vcomponent% type '() #f (make-hash-table))) - -(define (add-child! parent child) - (set-component-children! parent (cons child (children parent))) - (set-component-parent! child parent)) - -(define (remove-child! parent-component child) - (unless (eq? parent-component (parent child)) - (scm-error - 'wrong-type-arg "remove-child!" "Child doesn't belong to parent" - (list parent-component child) #f)) - (set-component-children! parent-component (delq1! child (children parent-component))) - (set-component-parent! child #f)) - -;;; TODO key=DTSTART, (date? value) => #t -;;; KRÄVER att (props vline 'VALUE) <- "DATE" -(define (set-property! component key value) - (let ((ht (get-component-properties component))) - (cond [(hashq-ref ht key #f) - => (lambda (vline) (set-vline-value! vline value))] - [else (hashq-set! ht key (make-vline key value))]))) +(define (print-vline v p) + (format p "#<<vline> key: ~s value: ~s parameters: ~s>" + (key v) + (vline-value v) + #f + ;; (hash-map->list list (get-vline-parameters v)) + )) +(define-type (vline printer: print-vline) + (key type: symbol?) + (vline-value) + (vline-parameters default: (table) type: table?) + (vline-source default: "" type: string?)) - +(define (print-vcomponent c p) + (format p "#<<vcomponent> ~a>" + (type c))) -;; vline → value -(define value - (make-procedure-with-setter - get-vline-value set-vline-value!)) -;; vcomponent x (or str symb) → vline -(define (get-prop* component prop) - (hashq-ref (get-component-properties component) - (as-symb prop))) +(define false? not) -(define (set-prop*! component key value) - (hashq-set! (get-component-properties component) - (as-symb key) value)) +(define-type (vcomponent printer: print-vcomponent) + (type type: symbol?) + (vcomponent-children + default: (table) type: table?) + (component-properties + default: (table) type: table?) + (parent default: #f type: (or false? vcomponent?))) (define prop* - (make-procedure-with-setter - get-prop* - set-prop*!)) - -(define (delete-property! component key) - (hashq-remove! (get-component-properties component) - (as-symb key))) + (case-lambda + ((object key) + (table-get (component-properties object) key)) + ((object key value) + (component-properties object + (table-put (component-properties object) key value))))) + +(define (children c) + (map cdr (table->list (vcomponent-children c)))) + +(define (add-child parent* child) + (modify parent* vcomponent-children + (lambda (table) + (let ((child + (if (prop child 'UID) + child + (prop child 'UID (uuid))))) + (table-put table + (as-symb (prop child 'UID)) + (parent child parent*)))))) + -;; vcomponent x (or str symb) → value -(define (get-prop component key) - (let ((props (get-prop* component key))) - (cond [(not props) #f] - [(list? props) (map value props)] - [else (value props)]))) - -;; TODO do something sensible here -(define (set-prop! component key value) - (set-property! component (as-symb key) value)) - +;; (define prop (compose-lens vline-value prop*)) (define prop - (make-procedure-with-setter - get-prop - set-prop!)) - + (case-lambda + ((comp key) (and=> (prop* comp key) vline-value)) + ((comp k v) + (cond ((prop* comp k) + => (lambda (vline) + (prop* comp k (vline-value vline v)))) + (else + (prop* comp k (vline key: k vline-value: v))))))) + +(define (remove-property component key) + (component-properties component + (table-remove (component-properties component) key))) (define param - (make-procedure-with-setter - (lambda (vline parameter-key) - ;; TODO `list' is a hack since a bit to much code depends - ;; on prop always returning a list of values. - (and=> (hashq-ref (get-vline-parameters vline) - (as-symb parameter-key)) - list)) - (lambda (vline parameter-key val) - (hashq-set! (get-vline-parameters vline) - (as-symb parameter-key) val)))) + ;; TODO list? + (case-lambda ((vline key) (and=> (table-get (vline-parameters vline) key) list)) + ((vline k v) (vline-parameters + vline + (table-put (vline-parameters vline) k v))))) - -(define (delete-parameter! vline parameter-key) - (hashq-remove! (get-vline-parameters vline) - (as-symb parameter-key))) +(define (remove-parameter vline key) + (vline-parameters vline + (table-remove (vline-parameters vline) key))) ;; Returns the parameters of a property as an assoc list. ;; @code{(map car <>)} leads to available parameters. (define (parameters vline) - (hash-map->list list (get-vline-parameters vline))) + (map (compose list car+cdr) + (table->list (vline-parameters vline)))) (define (properties component) - (hash-map->list cons (get-component-properties component))) - -(define (copy-vline vline) - (make-vline (vline-key vline) - (get-vline-value vline) - ;; TODO deep-copy on parameters? - (get-vline-parameters vline))) - -(define (copy-vcomponent component) - (make-vcomponent% - (type component) - ;; TODO deep copy? - (children component) - (parent 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))))) + (map (compose list car+cdr) + (table->list (component-properties component)))) (define (extract field) (lambda (e) (prop e field))) @@ -221,3 +154,10 @@ (string=? prefix (string-take-to (symbol->string symbol) (string-length prefix)))) + + +(define (set-properties component . pairs) + ;; (format (current-error-port) "component: ~s, pairs: ~s~%" component pairs) + (fold (lambda (pair component) (prop component (car pair) (cdr pair))) + component + pairs)) diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm new file mode 100644 index 00000000..5704b0f1 --- /dev/null +++ b/module/vcomponent/create.scm @@ -0,0 +1,104 @@ +(define-module (vcomponent create) + :use-module ((vcomponent base) :prefix vcs-) + :use-module ((vcomponent base) + :select (vline key add-child prop* vline?)) + :use-module ((srfi srfi-1) :select (fold last drop-right car+cdr)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-17) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((hnh util table) :select (alist->table)) + :use-module ((hnh util) :select (swap init+last kvlist->assq ->)) + :export (with-parameters + as-list + vcomponent + vcalendar vevent + vtimezone standard daylight + )) + +;; TODO allow parameters and list values at same time + + + +;; Convert a scheme keyword to a symbol suitable for us +(define (keyword->key keyword) + (-> keyword + keyword->string + string-upcase + string->symbol)) + +(define (symbol-upcase symbol) + (-> symbol + symbol->string + string-upcase + string->symbol)) + +;; Upcase the keys in an association list. Keys must be symbols. +(define (upcase-keys alist) + (map (lambda (pair) (cons (symbol-upcase (car pair)) + (cdr pair))) + alist)) + + + +(define (with-parameters . args) + (define-values (parameters value) + (init+last args)) + (vline + key: 'PLACEHOLDER + vline-value: value + vline-parameters: + (-> parameters + kvlist->assq + upcase-keys + alist->table))) + + + +(define-immutable-record-type <list-value> + (make-list-value value) + list-value? + (value list-value-value)) + +(define (as-list arg) + (make-list-value arg)) + + + +(define (vcomponent type . attrs*) + (define-values (attrs children) + (cond ((null? attrs*) (values '() '())) + ((even? (length attrs*)) (values attrs* '())) + (else (init+last attrs*)))) + ;; TODO add-child requires a UID on the child + ;; Possibly just genenerate one here if missing + (fold (swap add-child) + (fold (lambda (pair component) + (let ((k value (car+cdr pair))) + (prop* component k + (cond ((vline? value) + (key value k)) + ((list-value? value) + (map (lambda (value) (vline key: k vline-value: value)) + (list-value-value value))) + (else (vline key: k vline-value: value)))))) + (vcs-vcomponent + type: type) + (upcase-keys (kvlist->assq attrs))) + children)) + +(define (vcalendar . attrs) + (apply vcomponent 'VCALENDAR attrs)) + +(define (vevent . attrs) + (apply vcomponent 'VEVENT attrs)) + +(define (vtimezone . attrs) + (apply vcomponent 'VTIMEZONE attrs)) + +(define (standard . attrs) + (apply vcomponent 'STANDARD attrs)) + +(define (daylight . attrs) + (apply vcomponent 'DAYLIGHT attrs)) 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 new file mode 100644 index 00000000..2fb4422a --- /dev/null +++ b/module/vcomponent/data-stores/common.scm @@ -0,0 +1,43 @@ +(define-module (vcomponent data-stores common) + :use-module ((srfi srfi-88) :select ()) + :use-module (oop goops) + :export (<calendar-data-store> + ;; path + get-all + get-by-uid)) + + +(define-class <calendar-data-store> () + ;; (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" + (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" + (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 new file mode 100644 index 00000000..54676224 --- /dev/null +++ b/module/vcomponent/data-stores/file.scm @@ -0,0 +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 new file mode 100644 index 00000000..8ec5f7fd --- /dev/null +++ b/module/vcomponent/data-stores/meta.scm @@ -0,0 +1,29 @@ +;;; Commentary: +;;; A virtual data store which uses other data stores for its storage. +;;; Used to merge stores into larger stores +;;; Code: + +(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-keyword: stores:)) + + + +(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/sqlite.scm b/module/vcomponent/data-stores/sqlite.scm new file mode 100644 index 00000000..5d487028 --- /dev/null +++ b/module/vcomponent/data-stores/sqlite.scm @@ -0,0 +1,186 @@ +(define-module (vcomponent data-stores sqlite) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) + :use-module ((srfi srfi-88) :select ()) + :use-module (vcomponent) + :use-module ((vcomponent formats ical) :prefix #{ical:}#) + :use-module ((hnh util) :select (aif)) + ) + + +(catch 'misc-error + (lambda () + (use-modules (sqlite3)) + (provide 'data-store-sqlite)) + (lambda args 'no-op)) + +;; (define (sqlite-exec db str) +;; (display str) +;; ((@ (sqlite3) sqlite-exec) db str)) + +(define-class <sqlite-data-store> (<calendar-data-store>) + (database accessor: database) + (name init-keyword: name: getter: calendar-name) + ) + +(define (initialize-database db) + ;;; Setup Content type + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS content_type +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (let ((stmt (sqlite-prepare db " +INSERT OR IGNORE INTO content_type +( name ) VALUES ( ? )"))) + (for-each (lambda (content-type) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt ) + (sqlite-step stmt)) + '("ical" + "xcal" + "jcal"))) + + ;;; Setup calendar + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar_properties +( id INTEGER PRIMARY KEY AUTOINCREMENT +, calendar INTEGER NOT NULL +, key TEXT NOT NULL +, value TEXT NOT NULL +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + ;; INSERT INTO calendar_properties (id, key, value) + ;; VALUES ( (SELECT id FROM calendar WHERE name = 'Calendar') + ;; , 'color' + ;; , '#1E90FF') + + ;;; Setup event + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event +( uid TEXT PRIMARY KEY +, content_type INTEGER NOT NULL +, content TEXT NOT NULL +, calendar INTEGER NOT NULL +, FOREIGN KEY (content_type) REFERENCES content_type(id) +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances +( id INTEGER PRIMARY KEY AUTOINCREMENT +, event TEXT NOT NULL +, start DATETIME NOT NULL +, end DATETIME +, FOREIGN KEY (event) REFERENCES event(uid) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances_valid_range +( start DATETIME NOT NULL +, end DATETIME NOT NULL +)") + ) + +(define-method (initialize (this <sqlite-data-store>) args) + (next-method) + (if (calendar-name this) + (set! (database this) (sqlite-open (path this))) + (let ((path db-name + (aif (string-rindex (path this) #\#) + (values (substring (path this) 0 it) + (substring (path this) (1+ it))) + (scm-error 'misc-error "(initialize <sqlite-data-store>)" + "Target calendar name not specified" + '() #f)))) + (set! (database this) (sqlite-open path)) + (slot-set! this 'name db-name))) + + (initialize-database (database this))) + + +(define-method (get-calendar (this <sqlite-data-store>)) + (let ((db (database this)) + (calendar (vcomponent type: 'VCALENDAR))) + (let ((stmt (sqlite-prepare db " +SELECT key, value FROM calendar_properties cp +LEFT JOIN calendar c ON cp.calendar = c.id +WHERE c.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (let ((key (vector-ref row 0)) + (value (vector-ref row 1))) + (set-property! calendar + (string->symbol key) + value)) + calendar) + calendar + stmt)) + + (let ((stmt (sqlite-prepare db " +SELECT content_type.name, content +FROM event +LEFT JOIN calendar ON event.calendar = calendar.id +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE calendar.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (case (string->symbol (vector-ref row 0)) + ((ical) + (add-child! calendar + (call-with-input-string (vector-ref row 1) + ics:deserialize)) + calendar) + (else + (scm-error 'misc-error "(get-calendar <sqlite-data-store>)" + "Only iCal data supported, got ~a" + (list (vector-ref row 0)) #f) + )) + ) + calendar + stmt)) + + calendar)) + + +#; +(define-method (get-by-uid (this <sqlite-data-store>) (uid <string>)) + (let ((stmt (sqlite-prepare db " +SELECT name, content +FROM event +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE event.uid = ?"))) + (sqlite-bind-arguments stmt uid) + (cond ((sqlite-step stmt) + => (lambda (record) + (case (string->symbol (vector-ref content 0)) + ((ics) + ;; TODO dispatch to higher instance + ) + (else + (scm-error 'value-error "get-by-uid" + "Can only deserialize ics (uid=~s)" + (list uid) #f))) + + )) + (else + ;; TODO possibly throw no-such-value + #f + )) + + ) + ) diff --git a/module/vcomponent/data-stores/vdir.scm b/module/vcomponent/data-stores/vdir.scm new file mode 100644 index 00000000..9320c44e --- /dev/null +++ b/module/vcomponent/data-stores/vdir.scm @@ -0,0 +1,89 @@ +(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)) + :use-module (ice-9 rdelim) + :use-module (srfi srfi-1) + :use-module (vcomponent base) + :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 + (fold (swap add-child) + (set-properties (vcomponent type: 'VCALENDAR) + (cons 'NAME (get-attribute (path this) "displayname")) + (cons 'COLOR (get-attribute (path this) "color" "#FFFFFF"))) + (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))) + (each cal children + (lambda (child) + (prop child '-X-HNH-FILENAME file)))) + files)))) + (set! (loaded-calendar this) calendar) + calendar)) + + +(define-method (get-by-uid (this <vdir-data-store>) (uid <string>)) + (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) + (fold (swap add-child) + (set-properties (vcomponent type: 'VCALENDAR) + (cons 'VERSION "2.0") + (cons 'PRODID (prodid)) + (cons 'CALSCALE "GREGORIAN")) + vcomponents)) + +(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/data-stores/virtual.scm b/module/vcomponent/data-stores/virtual.scm new file mode 100644 index 00000000..03c115f5 --- /dev/null +++ b/module/vcomponent/data-stores/virtual.scm @@ -0,0 +1,22 @@ +(define-module (vcomponent data-stores virtual) + :use-module (oop goops) + :use-module ((srfi srfi-88) :select ()) + :use-module (vcomponent data-stores common) + :export (make-file-store)) + +(define-class <virtual-data-store> (<calendar-data-store>) + ) + +(define-method (get-all (this <virtual-data-store>)) + #f) + +(define-method (get-by-uid (this <virtual-data-store>) + (uid <string>)) + #f) + + +(define-method (color (this <virtual-data-store>)) + "") + +(define-method (displayname (this <virtual-data-store>)) + "Virtual Calendar") diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 440ec5fd..5aa6f4ab 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -227,75 +227,89 @@ Event must have the DTSTART and DTEND protperty set." ;; event is for limiter (define (zoneinfo->vtimezone zoneinfo zone-name event) - (define vtimezone (make-vcomponent 'VTIMEZONE)) (define last-until (datetime date: (date month: 1 day: 1))) (define last-offset (timespec-zero)) - (set! (prop vtimezone 'TZID) zone-name) - - (for zone-entry in (filter (relevant-zone-entry? event) (get-zone zoneinfo zone-name)) - (cond [(zone-entry-rule zone-entry) timespec? - => (lambda (inline-rule) - (let ((component (make-vcomponent 'DAYLIGHT)) - (new-timespec (timespec-add - (zone-entry-stdoff zone-entry) - inline-rule))) - (set! (prop component 'DTSTART) last-until - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) new-timespec - (prop component 'TZNAME) (zone-entry-format zone-entry) - last-until (zone-entry-until zone-entry) - last-offset new-timespec) - (add-child! vtimezone component)))] - - [(zone-entry-rule zone-entry) - => (lambda (rule-name) - (map (lambda (rule) - (let ((component (make-vcomponent - ;; NOTE the zoneinfo database doesn't - ;; come with information if a given - ;; rule is in standard or daylight time, - ;; since that's mostly nonsencical - ;; (e.g. war- and peacetime). - ;; But the ical standard requires that, - ;; so this is a fair compromize. - (if (string-null? (rule-letters rule)) - 'STANDARD 'DAYLIGHT))) - (new-timespec (timespec-add - (zone-entry-stdoff zone-entry) - (rule-save rule)))) - - (set! (prop component 'DTSTART) (rule->dtstart rule) - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) new-timespec - (prop component 'TZNAME) (zone-format - (zone-entry-format zone-entry) - (rule-letters rule)) - ;; NOTE this can both be a number or the - ;; symbol 'maximum - last-until (zone-entry-until zone-entry) - last-offset new-timespec) - - (awhen (rule->rrule rule) - (set! (prop component 'RRULE) it)) - - (add-child! vtimezone component))) - ;; some of the rules might not apply to us since we only - ;; started using that rule set later. It's also possible - ;; that we stopped using a ruleset which continues existing. - ;; - ;; Both these are filtered here. - (filter - (relevant-zone-rule? event) - (get-rule zoneinfo rule-name))))] - - [else ; no rule - (let ((component (make-vcomponent 'STANDARD))) - ;; DTSTART MUST be a datetime in local time - (set! (prop component 'DTSTART) last-until - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) (zone-entry-stdoff zone-entry) - (prop component 'TZNAME) (zone-entry-format zone-entry) - last-until (zone-entry-until zone-entry) - last-offset (zone-entry-stdoff zone-entry)) - (add-child! vtimezone component))])) - vtimezone) + + (fold (lambda (zone-entry vtimezone) + (cond [(zone-entry-rule zone-entry) timespec? + => (lambda (inline-rule) + (let ((component (vcomponent type: 'DAYLIGHT)) + (new-timespec (timespec-add + (zone-entry-stdoff zone-entry) + inline-rule))) + (let ((component + (set-properties + component + (cons 'DTSTART last-until) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO new-timespec) + (cons 'TZNAME (zone-entry-format zone-entry))))) + (set! last-until (zone-entry-until zone-entry) + last-offset new-timespec) + (add-child vtimezone component))))] + + [(zone-entry-rule zone-entry) + => (lambda (rule-name) + (fold (lambda (rule vtimezone) + (let ((component (vcomponent + type: + ;; NOTE the zoneinfo database doesn't + ;; come with information if a given + ;; rule is in standard or daylight time, + ;; since that's mostly nonsencical + ;; (e.g. war- and peacetime). + ;; But the ical standard requires that, + ;; so this is a fair compromize. + (if (string-null? (rule-letters rule)) + 'STANDARD 'DAYLIGHT))) + (new-timespec (timespec-add + (zone-entry-stdoff zone-entry) + (rule-save rule)))) + + (let ((component + (set-properties + component + (cons 'DTSTART (rule->dtstart rule)) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO new-timespec) + (cons 'TZNAME (zone-format + (zone-entry-format zone-entry) + (rule-letters rule)))))) + + (set! ;; NOTE this can both be a number or the + ;; symbol 'maximum + last-until (zone-entry-until zone-entry) + last-offset new-timespec) + + (add-child + vtimezone + (cond ((rule->rrule rule) + => (lambda (it) (prop component 'RRULE it))) + (else component)))))) + vtimezone + ;; some of the rules might not apply to us since we only + ;; started using that rule set later. It's also possible + ;; that we stopped using a ruleset which continues existing. + ;; + ;; Both these are filtered here. + (filter + (relevant-zone-rule? event) + (get-rule zoneinfo rule-name))))] + + [else ; no rule + ;; DTSTART MUST be a datetime in local time + (let ((component + (set-properties + (vcomponent type: 'STANDARD) + (cons 'DTSTART last-until) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO (zone-entry-stdoff zone-entry)) + (cons 'TZNAME (zone-entry-format zone-entry))))) + (set! last-until (zone-entry-until zone-entry) + last-offset (zone-entry-stdoff zone-entry)) + (add-child vtimezone component)) + ]) + ) + (prop (vcomponent type: 'VTIMEZONE) 'TZID zone-name) + (filter (relevant-zone-entry? event) (get-zone zoneinfo zone-name)) + )) diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index 736db0a4..1226fc44 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -73,7 +73,7 @@ (let ((s (prop ev 'DTSTART)) (e (prop ev 'DTEND))) (if e - (let ((fmt-str (if (date= (get-date s) (get-date e)) + (let ((fmt-str (if (date= (datetime-date s) (datetime-date e)) (G_ "~H:~M") ;; Note the non-breaking space (G_ "~Y-~m-~d ~H:~M")))) diff --git a/module/vcomponent/formats/ical.scm b/module/vcomponent/formats/ical.scm new file mode 100644 index 00000000..dddca946 --- /dev/null +++ b/module/vcomponent/formats/ical.scm @@ -0,0 +1,17 @@ +(define-module (vcomponent formats ical) + :use-module ((vcomponent formats ical output) + :select (component->ical-string)) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar)) + :export (serialize + deserialize + ) + ) + + +(define (serialize component port) + (with-output-to-port port + (lambda () (component->ical-string component)))) + +(define (deserialize port) + (parse-calendar port)) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index 4d37dff6..5fa004bb 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -14,8 +14,10 @@ :use-module (vcomponent) :use-module (vcomponent datetime) :use-module (vcomponent geo) - :use-module (vcomponent formats ical types) + :use-module ((vcomponent formats ical types) + :select (escape-chars get-writer)) :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 +26,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. @@ -101,11 +99,12 @@ (catch #t #; 'wrong-type-arg (lambda () - (writer ((@@ (vcomponent base) get-vline-parameters) vline) - (value vline))) + (writer + (vline-parameters vline) + (vline-value vline))) (lambda (err caller fmt args call-args) (define fallback-string - (with-output-to-string (lambda () (display value)))) + (with-output-to-string (lambda () (display (vline-value vline))))) (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s" key caller call-args fmt args fallback-string) @@ -129,11 +128,10 @@ (define (vline->string vline) - (define key (vline-key vline)) (ical-line-fold ;; Expected output: key;p1=v;p3=10:value (string-append - (symbol->string key) + (symbol->string (key vline)) (string-concatenate (map (match-lambda [(? (compose internal-field? car)) ""] @@ -143,7 +141,7 @@ (string-join (map (compose escape-chars ->string) values) "," 'infix))]) (parameters vline))) - ":" (value-format key vline)))) + ":" (value-format (key vline) vline)))) (define (component->ical-string component) (format #t "BEGIN:~a\r\n" (type component)) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 252a155e..38257fba 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -1,6 +1,7 @@ (define-module (vcomponent formats ical parse) :use-module ((ice-9 rdelim) :select (read-line)) :use-module (ice-9 format) + :use-module (ice-9 curried-definitions) :use-module (hnh util exceptions) :use-module (hnh util) :use-module (datetime) @@ -12,6 +13,8 @@ :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (calp translation) + :use-module (hnh util lens) + :use-module (hnh util table) :export (parse-calendar)) ;;; TODO a few translated strings here contain explicit newlines. Check if that @@ -139,7 +142,7 @@ (define (build-vline key value params) (let ((parser (cond - [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] + [(and=> (table-get params 'VALUE) string->symbol) => get-parser] [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE CREATED DTSTAMP LAST-MODIFIED @@ -246,9 +249,9 @@ (let ((parsed (parser params value))) (if (list? parsed) (apply values - (map (lambda (p) (make-vline key p params)) + (map (lambda (p) (vline key: key vline-value: p vline-parameters: params)) parsed)) - (make-vline key parsed params))))) + (vline key: key vline-value: parsed vline-parameters: params))))) ;; (parse-itemline '("DTEND" "20200407T130000")) ;; => DTEND @@ -256,17 +259,45 @@ ;; => #<hash-table 7f76b5f82a60 0/31> (define (parse-itemline itemline) (define key (string->symbol (car itemline))) - (define parameters (make-hash-table)) - (let loop ((rem (cdr itemline))) - (if (null? (cdr rem)) - (values key (car rem) parameters ) - (let* ((kv (car rem)) - (idx (string-index kv #\=))) - ;; TODO lists in parameters - (hashq-set! parameters (string->symbol (substring kv 0 idx)) - (substring kv (1+ idx))) - (loop (cdr rem)))))) - + ;; (define parameters (make-hash-table)) + (define-values (parameters value) (init+last (cdr itemline))) + (values + key value + (fold (lambda (parameter table) + (let ((idx (string-index parameter #\=))) + ;; TODO lists in parameters + (table-put table (string->symbol (substring parameter 0 idx)) + (substring parameter (1+ idx))))) + (table) + parameters))) + +(define ((warning-handler-proc token) fmt . args) + (let ((linedata (get-metadata token))) + (format + #f + ;; arguments: + ;; linedata + ;; ~? + ;; source line + ;; source file + (G_ "WARNING parse error around ~a + ~? + line ~a ~a~%") + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata) + ))) + +;;; Property keys which are allowed multiple times +(define repeating-properties + '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) ;; (list <tokens>) → <vcomponent> (define (parse lst) @@ -274,69 +305,53 @@ (stack '())) (if (null? lst) stack - (let* ((head* (car lst)) - (head (get-data head*))) + (let* ((token (car lst)) + (head (get-data token))) (catch 'parse-error (lambda () - (parameterize - ((warning-handler - (lambda (fmt . args) - (let ((linedata (get-metadata head*))) - (format - #f - ;; arguments: - ;; linedata - ;; ~? - ;; source line - ;; source file - (G_ "WARNING parse error around ~a - ~? - line ~a ~a~%") - (get-string linedata) - fmt args - (get-line linedata) - (get-file linedata) - ))))) - (cond [(string=? "BEGIN" (car head)) - (loop (cdr lst) - (cons (make-vcomponent (string->symbol (cadr head))) - stack))] - [(string=? "END" (car head)) - (loop (cdr lst) - (if (null? (cdr stack)) - ;; return - (car stack) - (begin (add-child! (cadr stack) (car stack)) - (cdr stack))))] - [else - (let ((key value params (parse-itemline head))) - (call-with-values (lambda () (build-vline key value params)) - (lambda vlines - (for vline in vlines - (define key (vline-key vline)) - - (set! (vline-source vline) - (get-metadata head*)) + (parameterize ((warning-handler (warning-handler-proc token))) + (cond [(string=? "BEGIN" (car head)) + (format (current-error-port) "BEGIN ~s~%" (cadr head)) + (loop (cdr lst) + (cons (vcomponent type: (string->symbol (cadr head))) + stack))] + [(string=? "END" (car head)) + (format (current-error-port) "END ~s~%" (cadr head)) + (loop (cdr lst) + (if (null? (cdr stack)) + ;; return + stack + (cons (add-child (cadr stack) (car stack)) + (cddr stack))))] + [else + (let ((k value params (parse-itemline head))) + (loop (cdr lst) + (let (((values . vlines) (build-vline k value params))) + ;; TODO + ;; (set! (vline-source vline) + ;; (get-metadata token)) ;; See RFC 5545 p.53 for list of all repeating types ;; (for vcomponent) - ;; TODO templetize this, and allow users to set which types are list types, but also validate this upon creation (elsewhere) - (if (memv key '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* (car stack) key) - (set! (prop* (car stack) key) (cons vline it)) - (set! (prop* (car stack) key) (list vline))) - ;; else - (set! (prop* (car stack) key) vline)))))) - - (loop (cdr lst) stack)]))) + ;; TODO templetize this, and allow users to + ;; set which types are list types, but also + ;; validate this upon creation (elsewhere). + (fold (lambda (vline stack) + (modify stack car* + (lambda (comp) + (format (current-error-port) + " stack=~s, comp=~s~%" + stack comp) + (if (memv (key vline) repeating-properties) + (aif (prop* comp (key vline)) + (prop* comp (key vline) (cons vline it)) + (prop* comp (key vline) (list vline))) + ;; else + (prop* comp (key vline) vline))))) + stack vlines))))]))) + (lambda (err proc fmt fmt-args data) - (let ((linedata (get-metadata head*))) + (let ((linedata (get-metadata token))) (display (format #f ;; arguments @@ -353,7 +368,10 @@ (get-line linedata) (get-file linedata)) (current-error-port)) - (let ((key value params (parse-itemline head))) - (set! (prop* (car stack) key) - (make-vline key value params)) - (loop (cdr lst) stack))))))))) + (let ((k value params (parse-itemline head))) + (loop (cdr lst) + (modify stack car* + (lambda (c) (prop* c key + (vline key: k + vline-value: value + vline-parameters: params))))))))))))) diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm index 768f5098..c5259f0d 100644 --- a/module/vcomponent/formats/ical/types.scm +++ b/module/vcomponent/formats/ical/types.scm @@ -2,6 +2,7 @@ (define-module (vcomponent formats ical types) :use-module (hnh util) :use-module (hnh util exceptions) + :use-module (hnh util table) :use-module (base64) :use-module (datetime) :use-module (datetime timespec) @@ -23,7 +24,8 @@ ;; NOTE We really should output TZID from param here, but ;; we first need to change so these writers can output ;; parameters. - (datetime->string (hashq-ref param '-X-HNH-ORIGINAL value) + (datetime->string (or (table-get param '-X-HNH-ORIGINAL) + value) "~Y~m~dT~H~M~S~Z")) (define (write-duration _ value) diff --git a/module/vcomponent/formats/sxcal.scm b/module/vcomponent/formats/sxcal.scm new file mode 100644 index 00000000..c02dbada --- /dev/null +++ b/module/vcomponent/formats/sxcal.scm @@ -0,0 +1,16 @@ +(define-module (vcomponent formats sxcal) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :export (serialize deserialize) + ) + + +(define (serialize component port) + (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/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 4e21d4d0..7f1439ae 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -44,13 +44,14 @@ (partition (lambda (e) (eq? 'VEVENT (type e))) (children item))) - (unless (eq? 'VCALENDAR (type item)) (scm-error 'misc-error "parse-vdir" "Unexepected top level component. Expected VCALENDAR, got ~a. In file ~s" (list (type item) (prop item '-X-HNH-FILENAME)) #f)) + ;; TODO + #; (for child in (children item) (set! (prop child '-X-HNH-FILENAME) (prop (parent child) '-X-HNH-FILENAME))) @@ -65,8 +66,9 @@ ;; the standard. Section 3.8.4.4. (case (length events) [(0) (warning (G_ "No events in component~%~a") - (prop item '-X-HNH-FILENAME))] - [(1) (add-child! calendar (car events))] + (prop item '-X-HNH-FILENAME)) + calendar] + [(1) (add-child calendar (car events))] ;; two or more [else @@ -93,35 +95,36 @@ (car events))) (rest (delete head events eq?))) - (set! (prop head '-X-HNH-ALTERNATIVES) - (alist->hash-table - (map cons - ;; head is added back to the collection to simplify - ;; generation of recurrences. The recurrence - ;; generation assumes that the base event either - ;; contains an RRULE property, OR is in the - ;; -X-HNH-ALTERNATIVES set. This might produce - ;; duplicates, since the base event might also - ;; get included through an RRULE. This however - ;; is almost a non-problem, since RDATES and RRULES - ;; can already produce duplicates, meaning that - ;; we need to filter duplicates either way. - (map (extract 'RECURRENCE-ID) (cons head rest)) - (cons head rest)))) - (add-child! calendar head))]) + (add-child + calendar + ;; TODO this is really ugly + (prop head '-X-HNH-ALTERNATIVES + (alist->hash-table + (map cons + ;; head is added back to the collection to simplify + ;; generation of recurrences. The recurrence + ;; generation assumes that the base event either + ;; contains an RRULE property, OR is in the + ;; -X-HNH-ALTERNATIVES set. This might produce + ;; duplicates, since the base event might also + ;; get included through an RRULE. This however + ;; is almost a non-problem, since RDATES and RRULES + ;; can already produce duplicates, meaning that + ;; we need to filter duplicates either way. + (map (extract 'RECURRENCE-ID) (cons head rest)) + (cons head rest))))))]) ;; return calendar) - (make-vcomponent) + (vcomponent type: 'VIRTUAL) (map #; (@ (ice-9 threads) par-map) (lambda (fname) (let ((fullname (path-append path fname))) - (let ((cal (call-with-input-file fullname - parse-calendar))) - (set! (prop cal 'COLOR) color - (prop cal 'NAME) name - (prop cal '-X-HNH-FILENAME) fullname) - cal))) + (set-properties (call-with-input-file fullname + parse-calendar) + (cons 'COLOR color) + (cons 'NAME name) + (cons '-X-HNH-FILENAME fullname)))) (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) (string= "ics" (string-take-right s 3))))))))) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index ab1985b6..d096405e 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -61,4 +61,4 @@ (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) (delete-file (prop event '-X-HNH-FILENAME)) - (remove-child! parent event)) + (abandon! parent event)) diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm new file mode 100644 index 00000000..29a1d92f --- /dev/null +++ b/module/vcomponent/formats/xcal.scm @@ -0,0 +1,27 @@ +(define-module (vcomponent formats xcal) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module ((vcomponent formats xcal output) + :select (vcomponent->sxcal ns-wrap)) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :use-module ((hnh util) :select (->)) + :export (serialize deserialize)) + + +(define* (serialize component port key: (namespaces '())) + (-> (vcomponent->sxcal component) + ns-wrap + (namespaced-sxml->xml port: port + namespaces: namespaces))) + +(define (serialize/object component) + (call-with-output-string (lambda (p) (serialize component p)))) + + +(define* (deserialize port) + (-> port + xml->namespaced-sxml + root-element ; Strip potential *TOP* + cadr ; Remove containing icalendar + sxcal->vcomponent)) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index 8e92b280..7cf8c591 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -8,28 +8,31 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (calp translation) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :export (vcomponent->sxcal ns-wrap)) (define (vline->value-tag vline) - (define key (vline-key vline)) + (define k (key vline)) (define writer (cond [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer] - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID + [(memv k '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID CREATED DTSTAMP LAST-MODIFIED ACKNOWLEDGED EXDATE)) (get-writer 'DATE-TIME)] - [(memv key '(TRIGGER DURATION)) + [(memv k '(TRIGGER DURATION)) (get-writer 'DURATION)] - [(memv key '(FREEBUSY)) + [(memv k '(FREEBUSY)) (get-writer 'PERIOD)] - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + [(memv k '(CALSCALE METHOD PRODID COMMENT DESCRIPTION LOCATION SUMMARY TZID TZNAME CONTACT RELATED-TO UID @@ -38,69 +41,69 @@ VERSION)) (get-writer 'TEXT)] - [(memv key '(TRANSP + [(memv k '(TRANSP CLASS PARTSTAT STATUS ACTION)) (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] - [(memv key '(TZOFFSETFROM TZOFFSETTO)) + [(memv k '(TZOFFSETFROM TZOFFSETTO)) (get-writer 'UTC-OFFSET)] - [(memv key '(ATTACH TZURL URL)) + [(memv k '(ATTACH TZURL URL)) (get-writer 'URI)] - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + [(memv k '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) (get-writer 'INTEGER)] - [(memv key '(GEO)) + [(memv k '(GEO)) (lambda (_ v) - `(geo + `(,(xml xcal 'geo) (latitude ,(geo-latitude v)) (longitude ,(geo-longitude v))))] - [(memv key '(RRULE)) + [(memv k '(RRULE)) (get-writer 'RECUR)] - [(memv key '(ORGANIZER ATTENDEE)) + [(memv k '(ORGANIZER ATTENDEE)) (get-writer 'CAL-ADDRESS)] - [(x-property? key) + [(x-property? k) (get-writer 'TEXT)] [else - (warning (G_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") k) (get-writer 'TEXT)])) - (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) + (writer ((@@ (vcomponent base) get-vline-parameters) vline) + (value vline))) (define (property->value-tag tag . values) (if (or (eq? tag 'VALUE) (internal-field? tag)) #f - `(,(downcase-symbol tag) + `(,(xml xcal (downcase-symbol tag)) ,@(map (lambda (v) ;; TODO parameter types!!!! (rfc6321 3.5.) - `(text ,(->string v))) + `(,(xml xcal 'text) ,(->string v))) values)))) ;; ((key value ...) ...) -> `(parameters , ... ) (define (parameters-tag parameters) (define outparams (filter-map - (lambda (x) (apply property->value-tag x)) + (lambda (x) (property->value-tag x)) parameters)) (unless (null? outparams) - `(parameters ,@outparams))) + `(,(xml xcal 'parameters) ,@outparams))) (define (vcomponent->sxcal component) (define tagsymb (downcase-symbol (type component))) - (remove null? - `(,tagsymb + `(,(xml xcal tagsymb) ;; only have <properties> when it's non-empty. ,(let ((props (filter-map @@ -108,27 +111,33 @@ [(? (compose internal-field? car)) #f] [(key vlines ...) + (format (current-error-port) "vlines: ~s~%" vlines) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (reduce assq-merge - '() (map parameters vlines))) + '() + (map parameters vlines))) ,@(for vline in vlines (vline->value-tag vline))))] [(key . vline) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (parameters vline)) ,(vline->value-tag vline)))]) - (properties component)))) + ;; NOTE this sort is unnecesasary, but here so tests can work + ;; Possibly add it as a flag instead + (sort* (properties component) + string< (compose symbol->string car))))) (unless (null? props) - `(properties + `(,(xml xcal 'properties) ;; NOTE ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) ,@props))) ,(unless (null? (children component)) - `(components ,@(map vcomponent->sxcal (children component))))))) + `(,(xml xcal 'components) + ,@(map vcomponent->sxcal (children component))))))) (define (ns-wrap sxml) - `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) - ,sxml)) + `(,(xml xcal 'icalendar) + ,sxml)) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 0e638d36..5ae1b928 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -3,18 +3,24 @@ :use-module (hnh util exceptions) :use-module (base64) :use-module (ice-9 match) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :use-module (sxml match) :use-module (vcomponent) :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (datetime) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) :use-module (calp translation) + :use-module (hnh util table) :export (sxcal->vcomponent) ) ;; symbol, ht, (list a) -> non-list -(define (handle-value type props value) +(define (handle-value type parameters value) (case type [(binary) @@ -25,17 +31,17 @@ [(boolean) (string=? "true" (car value))] ;; TODO possibly trim whitespace on text fields - [(cal-address uri text unknown) (car value)] + [(cal-address uri text unknown) (string-concatenate value)] [(date) ;; TODO this is correct, but ensure remaining types - (hashq-set! props 'VALUE "DATE") + (hashq-set! parameters 'VALUE "DATE") (parse-iso-date (car value))] [(date-time) (parse-iso-datetime (car value))] [(duration) - ((get-parser 'DURATION) props value)] + ((get-parser 'DURATION) parameters value)] [(float integer) ; (3.0) (string->number (car value))] @@ -96,35 +102,39 @@ (for key in '(bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos freq until count interval wkst) - (define values (assoc-ref-all value key)) - (if (null? values) - #f - (case key - ;; These fields all have zero or one value - ((freq until count interval wkst) - (list (symbol->keyword key) - (parse-value-of-that-type - key (car (map car values))))) - ;; these fields take lists - ((bysecond byminute byhour byday bymonthday - byyearday byweekno bymonth bysetpos) - (list (symbol->keyword key) - (map (lambda (v) (parse-value-of-that-type key v)) - (map car values)))) - (else (scm-error 'misc-error "handle-value" - "Invalid key ~s" - (list key) - #f)))))))))] + (cond ((find-element (xml xcal key) value) + => (lambda (v) + (case key + ;; These fields all have zero or one value + ((freq until count interval wkst) + (list (symbol->keyword key) + (parse-value-of-that-type + key (cadr v)))) + ;; these fields take lists + ((bysecond byminute byhour byday bymonthday + byyearday byweekno bymonth bysetpos) + (list (symbol->keyword key) + (map (lambda (v) (parse-value-of-that-type key v)) + (cadr v)))) + (else (scm-error 'misc-error "handle-value" + "Invalid key ~s" + (list key) + #f))))) + (else #f)))))))] [(time) (parse-iso-time (car value))] - [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] + [(utc-offset) ((get-parser 'UTC-OFFSET) parameters (car value))] [(geo) ; ((long 1) (lat 2)) (sxml-match (cons 'geo value) [(geo (latitude ,x) (longitude ,y)) - ((@ (vcomponent geo) make-geo) x y)])])) + ((@ (vcomponent geo) make-geo) x y)])] + + [else (scm-error 'misc-error "handle-value" + "Unknown value type: ~s" + (list type) #f)])) (define (symbol-upcase symb) (-> symb @@ -134,16 +144,20 @@ (define (handle-parameters parameters) - (define ht (make-hash-table)) + ;; (assert (element-matches? (xml xcal 'parameters) + ;; parameters)) - (for param in parameters - (match param - [(ptag (ptype pvalue ...) ...) - ;; TODO parameter type (rfc6321 3.5.) + (fold (lambda (param table) + (define ptag (xml-element-tagname (car param))) + ;; (define-values (ptype pvalue) (car+cdr cdr)) ;; TODO multi-valued parameters!!! - (hashq-set! ht (symbol-upcase ptag) - (car (concatenate pvalue)))])) - ht) + (define-values (pytpe pvalue) (car+cdr (cadr param))) + ;; TODO parameter type (rfc6321 3.5.) + ;; TODO namespaces + (table-put table (symbol-upcase ptag) + (concatenate pvalue))) + (table) + (cdr parameters))) (define* (parse-enum str enum optional: (allow-other #t)) (let ((symb (string->symbol str))) @@ -153,7 +167,8 @@ ;; symbol non-list -> non-list -(define (handle-tag tag-name data) +(define (handle-tag xml-tag data) + (define tag-name (xml-element-tagname xml-tag)) (case tag-name [(request-status) ;; TODO @@ -174,6 +189,51 @@ data '(AUDIO DISPLAY EMAIL NONE))) [else data])) +(define (handle-single-property component tree) + (define xml-tag (car tree)) + (define tag (xml-element-tagname xml-tag)) + (define tag* (symbol-upcase tag)) + + (define body (cdr tree)) + + ;; TODO request-status + (define-values (parameters data) + (if (element-matches? (xml xcal 'parameters) + (car body)) + (values (handle-parameters (car body)) + (cdr body)) + (values (make-hash-table) + body))) + + (fold (lambda (typetag component) + (define type (xml-element-tagname (car typetag))) + ;; TODO multi valued data + (define raw-value (cdr typetag)) + (define vline* + (vline type: tag* + value: (handle-tag + xml-tag + (let ((v (handle-value type parameters raw-value))) + ;; TODO possibly more list fields + ;; (if (eq? tag 'categories) + ;; (string-split v #\,) + ;; v) + + v)) + parameters: parameters)) + (if (memv tag* '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* component tag*) + (prop* component tag* (cons vline* it)) + (prop* component tag* (list vline*))) + (prop* component tag* vline*))) + component data)) + ;; Note ;; This doesn't verify the inter-field validity of the object, ;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME @@ -181,83 +241,30 @@ ;; TODO ;; since we are feeding user input into this it really should be fixed. (define (sxcal->vcomponent sxcal) - (define type (symbol-upcase (car sxcal))) - (define component (make-vcomponent type)) - - (awhen (assoc-ref sxcal 'properties) - ;; Loop over multi valued fields, creating one vline - ;; for every value. So - ;; KEY;p=1:a,b - ;; would be expanded into - ;; KEY;p=1:a - ;; KEY;p=1:b - (for property in it - (match property - ;; TODO request-status - - [(tag ('parameters parameters ...) - (type value ...) ...) - (let ((params (handle-parameters parameters)) - (tag* (symbol-upcase tag))) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let () - (define vline - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params)) - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - ))))] - - [(tag (type value ...) ...) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let ((params (make-hash-table)) - (tag* (symbol-upcase tag))) - (define vline - (make-vline tag* - (handle-tag - tag (let ((v (handle-value type params value))) - ;; TODO possibly more list fields - (if (eq? tag 'categories) - (string-split v #\,) - v))) - params)) - ;; - - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - )))]))) - - ;; children - (awhen (assoc-ref sxcal 'components) - (for child in (map sxcal->vcomponent it) - (add-child! component child))) - - component) + + ;; TODO the surrounding icalendar element needs to be removed BEFORE this procedue is called + + (define xml-tag (car sxcal)) + (define type (symbol-upcase (xml-element-tagname xml-tag))) + + (let ((component + (aif (find-element (xml xcal 'properties) (cdr sxcal)) + ;; Loop over multi valued fields, creating one vline + ;; for every value. So + ;; KEY;p=1:a,b + ;; would be expanded into + ;; KEY;p=1:a + ;; KEY;p=1:b + (fold swap handle-single-property + (vcomponent type: type) (cdr it)) + (vcomponent type: type)))) + + ;; children + (aif (find-element (xml xcal 'components) (cdr sxcal)) + ;; NOTE Order of children is insignificant, but this allows + ;; diffs to be stable (which is used by the format tests). + (fold (swap add-child) + component + (map sxcal->vcomponent + (reverse (cdr it)))) + component))) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index 024ca61a..82121d5e 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -3,16 +3,18 @@ :use-module (vcomponent formats ical types) :use-module (datetime) :use-module (calp translation) + :use-module ((calp namespaces) :select (xcal)) + :use-module ((sxml namespaced) :select (xml)) :export (get-writer)) (define (write-boolean _ v) - `(boolean ,(if v "true" "false"))) + `(,(xml xcal 'boolean) ,(if v "true" "false"))) (define (write-date _ v) - `(date ,(date->string v "~Y-~m-~d"))) + `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d"))) (define (write-datetime p v) - `(date-time + `(,(xml xcal 'date-time) ,(datetime->string (hashq-ref p '-X-HNH-ORIGINAL v) ;; 'Z' should be included for UTC, @@ -21,17 +23,17 @@ "~Y-~m-~dT~H:~M:~S~Z"))) (define (write-time _ v) - `(time ,(time->string v "~H:~M:S"))) + `(,(xml xcal 'time) ,(time->string v "~H:~M:S"))) (define (write-recur _ v) - `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) + `(,(xml xcal 'recur) ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) ;; sepparate since this text shouldn't be escaped (define (write-text _ v) ;; TODO out type should be xsd:string. ;; Look into what that means, and escape ;; from there - `(text ,v)) + `(,(xml xcal 'text) ,v)) @@ -40,7 +42,7 @@ #| TODO PERIOD |# URI UTC-OFFSET) (hashq-set! sxml-writers simple-type (lambda (p v) - `(,(downcase-symbol simple-type) + `(,(xml xcal (downcase-symbol simple-type)) ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v))))) (hashq-set! sxml-writers 'BOOLEAN write-boolean) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 07305647..936c2631 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -119,7 +119,7 @@ (branching-fold (lambda (rule dt) (let* ((key value (car+cdr rule)) - (d (if (date? dt) dt (get-date dt))) + (d (if (date? dt) dt (datetime-date dt))) ;; NOTE It's proably an error to give BYHOUR, BYMINUTE, and BYSECOND ;; rules for a date object. This doesn't warn if those are given, but ;; instead silently discards them. @@ -128,8 +128,8 @@ (if (date? dt) (if (date? o) o d) (if (date? o) - (datetime date: o time: t tz: (get-timezone dt)) - (datetime date: d time: o tz: (get-timezone dt))))))) + (datetime date: o time: t tz: (tz dt)) + (datetime date: d time: o tz: (tz dt))))))) (case key [(BYMONTH) (if (and (eq? 'YEARLY (freq rrule)) @@ -141,11 +141,11 @@ (concatenate (map (lambda (wday) (all-wday-in-month - wday (start-of-month (set (month d) value)))) + wday (start-of-month (month d value)))) (map cdr (byday rrule))))) ;; else - (to-dt (set (month d) value)))] + (to-dt (month d value)))] [(BYDAY) (let* ((offset value (car+cdr value))) @@ -201,12 +201,12 @@ [(BYYEARDAY) (to-dt (date+ (start-of-year d) (date day: (1- value))))] [(BYMONTHDAY) - (to-dt (set (day d) + (to-dt (day d (if (positive? value) value (+ 1 value (days-in-month d)))))] - [(BYHOUR) (to-dt (set (hour t) value))] - [(BYMINUTE) (to-dt (set (minute t) value))] - [(BYSECOND) (to-dt (set (second t) value))] + [(BYHOUR) (to-dt (hour t value))] + [(BYMINUTE) (to-dt (minute t value))] + [(BYSECOND) (to-dt (second t value))] [else (scm-error 'wrong-type-arg "update" "Unrecognized by-extender ~s" key #f)]))) @@ -254,7 +254,7 @@ (extend-recurrence-set rrule (if (date? base-date) - (date+ base-date (get-date (make-date-increment rrule))) + (date+ base-date (datetime-date (make-date-increment rrule))) (datetime+ base-date (make-date-increment rrule)))))) (define ((month-mod d) value) @@ -273,7 +273,7 @@ #t (let ((key values (car+cdr (car remaining))) (t (as-time dt)) - (d (if (date? dt) dt (get-date dt)))) + (d (if (date? dt) dt (datetime-date dt)))) (and (case key [(BYMONTH) (memv (month d) values)] [(BYMONTHDAY) (memv (day d) (map (month-mod d) values))] @@ -339,10 +339,10 @@ (rrule-instances-raw rrule (prop event 'DTSTART)))) (else stream-null))) (rdates - (cond ((prop* event 'RDATE) => (lambda (v) (map value v))) + (cond ((prop* event 'RDATE) => (lambda (v) (map vline-value v))) (else '()))) (exdates - (cond ((prop* event 'EXDATE) => (lambda (v) (map value v))) + (cond ((prop* event 'EXDATE) => (lambda (v) (map vline-value v))) (else #f)))) (let ((items (interleave-streams @@ -418,21 +418,19 @@ => (lambda (ht) (aif (hash-ref ht dt) it ; RECURRENCE-ID objects come with their own DTEND - (let ((ev (copy-vcomponent base-event))) - (set! (prop ev 'DTSTART) dt) - (when duration ; (and (not (prop ev 'DTEND)) duration) - ;; p. 123 (3.8.5.3 Recurrence Rule) - ;; specifies that the DTEND should be updated to match how the - ;; initial dtend related to the initial DTSTART. It also notes - ;; that an event of 1 day in length might be longer or shorter - ;; than 24h depending on timezone shifts. - (set! (prop ev 'DTEND) (get-endtime dt duration))) - ev)))) + (let ((ev (prop base-event 'DTSTART dt))) + (if duration ; (and (not (prop ev 'DTEND)) duration) + ;; p. 123 (3.8.5.3 Recurrence Rule) + ;; specifies that the DTEND should be updated to match how the + ;; initial dtend related to the initial DTSTART. It also notes + ;; that an event of 1 day in length might be longer or shorter + ;; than 24h depending on timezone shifts. + (prop ev 'DTEND (get-endtime dt duration)) + ev))))) (else - (let ((ev (copy-vcomponent base-event))) - (set! (prop ev 'DTSTART) dt) - (when duration - (set! (prop ev 'DTEND) (get-endtime dt duration))) - ev)))) + (let ((ev (prop base-event 'DTSTART dt))) + (if duration + (prop ev 'DTEND (get-endtime dt duration)) + ev))))) rrule-stream)) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 5651b265..fef83958 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -96,7 +96,7 @@ type (concatenate (map children (slot-ref this 'calendars))))) (events (awhen (assoc-ref groups 'VEVENT) - (car it))) + it)) (removed remaining (partition (extract 'X-HNH-REMOVED) events))) ;; TODO figure out what to do with removed events @@ -125,7 +125,7 @@ ;;; with the same UID, which is BAD. (define-method (add-event (this <events>) calendar event) - (add-child! calendar event) + (reparent! calendar event) (unless (prop event 'UID) (set! (prop event 'UID) (uuid))) @@ -184,7 +184,7 @@ ;; remove old instance of event from runtime (remove-event this old-event) - (remove-child! old-calendar old-event) + (abandon! old-calendar old-event) ;; Add new event to runtime, ;; MUST be done after since the two events SHOULD share UID. diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index 24eee04e..33dbd0cc 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -1,3 +1,5 @@ +;;; TODO remove this module, it should be part of the vdir interface + (define-module (vcomponent util parse-cal-path) :use-module (hnh util) :use-module ((calp util time) :select (report-time!)) @@ -17,24 +19,21 @@ (define cal (case (stat:type st) [(regular) - (let ((comp (call-with-input-file path parse-calendar))) - (set! (prop comp '-X-HNH-SOURCETYPE) 'file) - comp) ] + (prop (call-with-input-file path parse-calendar) + '-X-HNH-SOURCETYPE 'file)] [(directory) (report-time! (G_ "Parsing ~a") path) - (let ((comp (parse-vdir path))) - (set! (prop comp '-X-HNH-SOURCETYPE) 'vdir - (prop comp '-X-HNH-DIRECTORY) path) - comp)] + (set-properties (parse-vdir path) + (cons '-X-HNH-SOURCETYPE 'vdir) + (cons '-X-HNH-DIRECTORY path))] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (scm-error 'misc-error "parse-cal-path" (G_ "Can't parse file of type ~s") (list t) #f))])) - (unless (prop cal "NAME") - (set! (prop cal "NAME") - (or (prop cal "X-WR-CALNAME") - (string-append "[" (basename path) "]")))) - - cal) + (if (prop cal 'NAME) + cal + (prop cal 'NAME + (or (prop cal 'X-WR-CALNAME) + (string-append "[" (basename path) "]"))))) |