From c64a4bc56f93c08cf55fb907078e588ad737684c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 5 Sep 2023 00:55:35 +0200 Subject: Major work on, something. --- module/calp/html/view/calendar.scm | 12 +- module/calp/server/webdav.scm | 1 + .../calp/webdav/resource/calendar/collection.scm | 9 +- module/hnh/util/assert.scm | 9 + module/hnh/util/lens.scm | 8 +- module/hnh/util/table.scm | 31 ++- module/vcomponent.scm | 15 +- module/vcomponent/base.scm | 252 ++++++++------------- module/vcomponent/create.scm | 85 +++---- module/vcomponent/data-stores/sqlite.scm | 2 +- module/vcomponent/data-stores/vdir.scm | 50 ++-- module/vcomponent/data-stores/virtual.scm | 22 ++ module/vcomponent/datetime.scm | 154 +++++++------ module/vcomponent/formats/ical/output.scm | 15 +- module/vcomponent/formats/ical/parse.scm | 168 ++++++++------ module/vcomponent/formats/ical/types.scm | 4 +- module/vcomponent/formats/vdir/parse.scm | 55 ++--- module/vcomponent/formats/xcal/output.scm | 34 +-- module/vcomponent/formats/xcal/parse.scm | 107 ++++----- module/vcomponent/recurrence/generate.scm | 32 ++- module/vcomponent/util/parse-cal-path.scm | 23 +- tests/formats/test.scm | 18 +- tests/run-tests.scm | 28 ++- tests/test/add-and-save.scm | 123 ---------- tests/test/annoying-events.scm | 2 +- tests/test/create.scm | 14 +- tests/test/hnh-util-lens.scm | 38 ++++ tests/test/param.scm | 33 +-- tests/test/recurrence-advanced.scm | 2 +- tests/test/vcomponent.scm | 125 +++++++--- 30 files changed, 733 insertions(+), 738 deletions(-) create mode 100644 module/hnh/util/assert.scm create mode 100644 module/vcomponent/data-stores/virtual.scm delete mode 100644 tests/test/add-and-save.scm diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 3c7e2546..070d1c3f 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -381,13 +381,11 @@ window.default_calendar='~a';" (repeating% regular (partition repeating? flat-events)) (repeating (for ev in repeating% - (define instance (copy-vcomponent ev)) - - (set! (prop instance 'UID) (output-uid instance)) - (delete-parameter! (prop* instance 'DTSTART) '-X-HNH-ORIGINAL) - (delete-parameter! (prop* instance 'DTEND) '-X-HNH-ORIGINAL) - - instance))) + ;; TODO + (-> (set-properties ev 'UID (output-uid ev)) + ;; (focus (prop* instance 'DTSTART) (lambda (vline) (remove-parameter vline key))) + ;; (focus (prop* instance 'DTEND) (lambda (vline) (remove-parameter vline key))) + )))) `( ;; Mapping showing which events belongs to which calendar, diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm index f26b97f6..781a85d9 100644 --- a/module/calp/server/webdav.scm +++ b/module/calp/server/webdav.scm @@ -126,6 +126,7 @@ (declare-method! "LOCK" 'LOCK) (declare-method! "UNLOCK" 'UNLOCK) (declare-method! "REPORT" 'REPORT) +(declare-method! "MKCALENDAR" 'REPORT) diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm index 9acb6701..e1bf73fd 100644 --- a/module/calp/webdav/resource/calendar/collection.scm +++ b/module/calp/webdav/resource/calendar/collection.scm @@ -9,7 +9,7 @@ :use-module ((vcomponent formats ical) :prefix #{ics:}#) :use-module ((vcomponent) :prefix vcs-) :use-module ((vcomponent base) - :select (type prop make-vcomponent)) + :select (type prop vcomponent)) :use-module (web request) :use-module (web uri) @@ -33,10 +33,7 @@ (description init-value: #f accessor: description) (data-store getter: data-store - init-keyword: store:) - #; - (content% init-value: (make-vcomponent 'VIRTUAL) - accessor: content%)) + init-keyword: store:)) (define-method (is-collection? (_ )) @@ -57,7 +54,7 @@ (define-method (base-timezone ) ;; (zoneinfo->vtimezone '() "Europe/Stockholm" 'ev) - (make-vcomponent 'VTIMEZONE) + (vcomponent type: 'VTIMEZONE) ) diff --git a/module/hnh/util/assert.scm b/module/hnh/util/assert.scm new file mode 100644 index 00000000..74715654 --- /dev/null +++ b/module/hnh/util/assert.scm @@ -0,0 +1,9 @@ +(define-module (hnh util assert) + :use-module (rnrs base) + :export (assert*) + ) + +(define-syntax assert* + (syntax-rules () + ((_ assertion) + (assert assertion)))) diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm index 7a8fbd19..26c75be7 100644 --- a/module/hnh/util/lens.scm +++ b/module/hnh/util/lens.scm @@ -9,7 +9,9 @@ compose-lenses lens-compose - ref car* cdr*)) + ref car* cdr* + + each)) (define (modify object lens f . args) @@ -97,3 +99,7 @@ (define car* (make-lens car (lambda (pair value) (cons value (cdr pair))))) (define cdr* (make-lens cdr (lambda (pair value) (cons (car pair) value)))) + +(define (each obj lens proc) + (modify obj lens + (lambda (lst) (map proc lst)))) diff --git a/module/hnh/util/table.scm b/module/hnh/util/table.scm index 5835851b..a57e6591 100644 --- a/module/hnh/util/table.scm +++ b/module/hnh/util/table.scm @@ -8,6 +8,8 @@ :export ((make-tree . table) (tree-get . table-get) (tree-put . table-put) + (tree-remove . table-remove) + (tree->list . table->list) (tree? . table?) (alist->tree . alist->table))) @@ -41,13 +43,30 @@ tree-put k v)))) (define (tree-get tree k) - (cond ((tree-terminal? tree) (throw 'out-of-range)) + (cond ((tree-terminal? tree) #f ; (throw 'out-of-range) + ) ((eq? k (key tree)) (value tree)) ((symbollist tree) (if (tree-terminal? tree) @@ -60,10 +79,10 @@ (define (tree-map f tree) (if (tree-terminal? tree) '() - (tree-node (key tree) - (f (key tree) (value tree)) - (tree-map f (left tree)) - (tree-map f (right tree))))) + (tree-node key: (key tree) + value: (f (key tree) (value tree)) + left: (tree-map f (left tree)) + right: (tree-map f (right tree))))) ;; pre-order (define (tree-fold f init tree) @@ -74,7 +93,7 @@ (tree-fold f b (right tree)))))) (define (alist->tree alist) - (fold (lambda (kv tree) (apply tree-put tree kv)) + (fold (lambda (kv tree) (tree-put tree (car kv) (cdr kv))) (tree-terminal) alist)) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 0f000ba5..7930bf92 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -2,12 +2,21 @@ :use-module (hnh util) :use-module (vcomponent base) :use-module (vcomponent config) - ;; :use-module ((vcomponent util instance methods) - ;; :select (make-vcomponent)) :use-module ((vcomponent util parse-cal-path) :select (parse-cal-path)) - :re-export (make-vcomponent + :re-export ( + vcomponent + set-properties + properties + children + type + prop + prop* parse-cal-path + param + ;; value + vline? + vline-parameters ;; configuration items calendar-files default-calendar)) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 472c5074..ff2382bf 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,41 +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 - reparent! - abandon! - orphan! - - delete-property! + remove-property prop* prop extract extract* - delete-parameter! - value + set-properties + + remove-parameter + ;; value param parameters properties - copy-as-orphan - copy-vcomponent x-property? internal-field? - - ) ) @@ -53,170 +51,95 @@ ;;; ;;; -(define-record-type - (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! - - (lambda (v p) - (format p "#< 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 - (make-vcomponent% type children properties) - vcomponent? - (type type) - (children children set-component-children!) - (properties get-component-properties)) - -((@ (srfi srfi-9 gnu) set-record-type-printer!) - - (lambda (c p) - (format p "#< ~a, len(child)=~a>" - (type c) - (length (children c)) - ))) - - -(define parent% (make-object-property)) -(define (parent x) (parent% x)) - -(define* (make-vcomponent optional: (type 'VIRTUAL)) - (make-vcomponent% type '() (make-hash-table))) - -;; TODO should this be renamed to `adopt!'? Adopting a child better implies -;; that the old parent should no longer be considered its parent. -(define (reparent! parent child) - (set-component-children! parent (cons child (children parent))) - (set! (parent% child) parent)) - -(define (abandon! parent-component child) - (set-component-children! parent-component (delq1! child (children parent-component))) - (when (eq? parent-component (parent% child)) - (orphan! child))) - -;; TODO should this exist? It's really weird to remove our reference to our -;; parent, without the parent removing their reference to us. -(define (orphan! child) - (set! (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 "#< 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 "#< ~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-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 (copy-as-orphan component))) - (when (parent component) - (reparent! (parent component) ev)) - ev)) + (map (compose list car+cdr) + (table->list (component-properties component)))) (define (extract field) (lambda (e) (prop e field))) @@ -231,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 index 374da8b4..5704b0f1 100644 --- a/module/vcomponent/create.scm +++ b/module/vcomponent/create.scm @@ -1,13 +1,15 @@ (define-module (vcomponent create) - :use-module (vcomponent base) - :use-module ((srfi srfi-1) :select (last drop-right car+cdr)) + :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 ((ice-9 hash-table) :select (alist->hashq-table)) - :use-module ((hnh util) :select (kvlist->assq ->)) + :use-module ((hnh util table) :select (alist->table)) + :use-module ((hnh util) :select (swap init+last kvlist->assq ->)) :export (with-parameters as-list vcomponent @@ -40,26 +42,17 @@ -(define-immutable-record-type - (make-almost-vline parameters value) - almost-vline? - (parameters almost-vline-parameters) - (value almost-vline-value)) - -(define (almost-vline->vline key almost-vline) - (make-vline key - (almost-vline-value almost-vline) - (almost-vline-parameters almost-vline))) - -(define (with-parameters . args*) - (define parameters (drop-right args* 1)) - (define value (last args*)) - (make-almost-vline +(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->hashq-table) - value)) + alist->table))) @@ -74,36 +67,26 @@ (define (vcomponent type . attrs*) - (define component (make-vcomponent type)) - (define attrs*-len (length attrs*)) - (unless (zero? attrs*-len) - (let ((attrs children - (if (and (list? (list-ref attrs* (- attrs*-len 1))) - (or (= 1 attrs*-len) - (not (keyword? (list-ref attrs* (- attrs*-len 2)))))) - (values (drop-right attrs* 1) - (last attrs*)) - (values attrs* '())))) - (for-each (lambda (pair) - (let ((key value (car+cdr pair))) - (cond - ((almost-vline? value) - (set! (prop* component key) - (almost-vline->vline key value))) - ((list-value? value) - (set! (prop* component key) - (map (lambda (value) - (make-vline key value (make-hash-table))) - (list-value-value value)))) - (else - (set! (prop component key) value))))) - (upcase-keys (kvlist->assq attrs))) - - ;; Attach children - (for-each (lambda (child) (reparent! component child)) - children))) - - component) + (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)) diff --git a/module/vcomponent/data-stores/sqlite.scm b/module/vcomponent/data-stores/sqlite.scm index b5b566a8..5d487028 100644 --- a/module/vcomponent/data-stores/sqlite.scm +++ b/module/vcomponent/data-stores/sqlite.scm @@ -113,7 +113,7 @@ CREATE TABLE IF NOT EXISTS event_instances_valid_range (define-method (get-calendar (this )) (let ((db (database this)) - (calendar (make-vcomponent 'VCALENDAR))) + (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 diff --git a/module/vcomponent/data-stores/vdir.scm b/module/vcomponent/data-stores/vdir.scm index f0ed0fdc..9320c44e 100644 --- a/module/vcomponent/data-stores/vdir.scm +++ b/module/vcomponent/data-stores/vdir.scm @@ -7,6 +7,9 @@ :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 () @@ -29,23 +32,23 @@ (define-method (get-all (this )) (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" - "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)) + (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" + "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)) @@ -63,13 +66,12 @@ (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)) + (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 ) vcomponent) ;; TODO Multiple components 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 () + ) + +(define-method (get-all (this )) + #f) + +(define-method (get-by-uid (this ) + (uid )) + #f) + + +(define-method (color (this )) + "") + +(define-method (displayname (this )) + "Virtual Calendar") diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index a66ba38a..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) - (reparent! 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)) - - (reparent! 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)) - (reparent! 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/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index 57860d2a..5fa004bb 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -14,7 +14,8 @@ :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) @@ -98,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) @@ -126,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)) ""] @@ -140,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 f0a19ba5..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 @@ ;; => # (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 ) → (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 (reparent! (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/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 8fe69fc6..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) (reparent! 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)))) - (reparent! 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/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index e4a84efb..7cf8c591 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -15,24 +15,24 @@ (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 @@ -41,39 +41,39 @@ 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) `(,(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) @@ -92,7 +92,7 @@ ;; ((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) @@ -111,10 +111,12 @@ [(? (compose internal-field? car)) #f] [(key vlines ...) + (format (current-error-port) "vlines: ~s~%" vlines) (remove null? `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (reduce assq-merge - '() (map parameters vlines))) + '() + (map parameters vlines))) ,@(for vline in vlines (vline->value-tag vline))))] diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 7ed8c637..5ae1b928 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -15,6 +15,7 @@ :use-module (srfi srfi-71) :use-module (srfi srfi-88) :use-module (calp translation) + :use-module (hnh util table) :export (sxcal->vcomponent) ) @@ -146,18 +147,17 @@ ;; (assert (element-matches? (xml xcal 'parameters) ;; parameters)) - (define ht (make-hash-table)) - - (for param in (cdr parameters) - (define ptag (xml-element-tagname (car param))) - ;; (define-values (ptype pvalue) (car+cdr cdr)) - ;; TODO multi-valued parameters!!! - (define-values (pytpe pvalue) (car+cdr (cadr param))) - ;; TODO parameter type (rfc6321 3.5.) - ;; TODO namespaces - (hashq-set! ht (symbol-upcase ptag) - (concatenate pvalue))) - ht) + (fold (lambda (param table) + (define ptag (xml-element-tagname (car param))) + ;; (define-values (ptype pvalue) (car+cdr cdr)) + ;; TODO multi-valued parameters!!! + (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))) @@ -189,7 +189,7 @@ data '(AUDIO DISPLAY EMAIL NONE))) [else data])) -(define (handle-single-property! component tree) +(define (handle-single-property component tree) (define xml-tag (car tree)) (define tag (xml-element-tagname xml-tag)) (define tag* (symbol-upcase tag)) @@ -205,12 +205,13 @@ (values (make-hash-table) body))) - (for typetag in data - (define type (xml-element-tagname (car typetag))) - ;; TODO multi valued data - (define raw-value (cdr typetag)) - (define vline - (make-vline tag* (handle-tag + (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 @@ -219,18 +220,19 @@ ;; v) v)) - parameters)) - (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))) - (set! (prop* component tag*) vline)))) + 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, @@ -244,24 +246,25 @@ (define xml-tag (car sxcal)) (define type (symbol-upcase (xml-element-tagname xml-tag))) - (define component (make-vcomponent type)) - - (awhen (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 - (map (lambda (x) (handle-single-property! component x)) - (cdr it))) - - ;; children - (awhen (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). - (for child in (map sxcal->vcomponent - (reverse (cdr it))) - (reparent! component child))) - - component) + + (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/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index cc725b09..936c2631 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -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/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index fe3a6b7d..33dbd0cc 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -19,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) "]"))))) diff --git a/tests/formats/test.scm b/tests/formats/test.scm index b4a00a73..dfa04f22 100755 --- a/tests/formats/test.scm +++ b/tests/formats/test.scm @@ -79,15 +79,15 @@ exec $GUILE -s "$0" "$@" (call-with-output-string (lambda (p) (serialize component p))))) - (test-equal "Deserialized object serializes back into source" - (sanitize-string component-str) - (sanitize-string - (call-with-output-string - (lambda (p) - (serialize - (call-with-input-string - component-str deserialize) - p))))) + (test-group "Deserialize" + (let ((object (call-with-input-string component-str deserialize))) + (test-assert "Deserialize worked" (vcomponent? object)) + + (test-equal "Deserialized object serializes back into source" + (sanitize-string component-str) + (sanitize-string + (call-with-output-string + (lambda (p) (serialize object p))))))) (test-assert "Serialized string can still be read back in" diff --git a/tests/run-tests.scm b/tests/run-tests.scm index d3ba53f8..6c6ff95a 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -74,7 +74,8 @@ fi '((skip (value #t)) (only (value #t)) (verbose (single-char #\v)) - (coverage (value optional)))) + (coverage (value optional)) + (catch))) (define options (getopt-long (command-line) option-spec)) @@ -112,17 +113,22 @@ fi ;;; Catch/print-trace should intercept thrown exceptions, print them prettily with a stack trace, and then continue -#; -(define (catch/print-trace proc) - (catch #t proc - (case-lambda - ((err from msg args data) - (test-assert (format #f "~a in ~a: ~?" err from msg args) - #f)) - (args - (test-assert (format #f "~a (~s)" f args) - #f))))) + +(define catch/print-trace + (if (option-ref options 'catch #f) + (lambda (proc) + (catch #t proc + (case-lambda + ((err from msg args data) + (test-assert (format #f "~a in ~a: ~?" err from msg args) + #f)) + (args + (test-assert (format #f "~a (~s)" f args) + #f))))) + (lambda (proc) (proc)))) + +#; (define (catch/print-trace proc) (proc)) diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm deleted file mode 100644 index efbfe09e..00000000 --- a/tests/test/add-and-save.scm +++ /dev/null @@ -1,123 +0,0 @@ -(define-module (test add-and-save) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module (hnh util) - :use-module (datetime) - :use-module (datetime timespec) - ;; :use-module ((vcomponent) :select (prop)) - :use-module ((vcomponent base) :select (prop type children make-vcomponent)) - :use-module ((srfi srfi-1) :select (find)) - :use-module ((vcomponent formats vdir save-delete) :select (save-event)) - :use-module ((vcomponent create) - :select (with-parameters - vcalendar vevent - vtimezone standard daylight)) - :use-module (vcomponent recurrence) - :use-module ((vcomponent util instance methods) - :select (add-calendars - add-and-save-event - remove-event - ))) - -(define timezone - (vtimezone - tzid: "Europe/Stockholm" - (list - (standard - tzoffsetto: (parse-time-spec "01:00") - dtstart: #1996-10-27T01:00:00 - tzname: "CET" - tzoffsetfrom: (parse-time-spec "02:00") - rrule: (make-recur-rule - freq: 'YEARLY - interval: 1 - byday: (list (cons -1 sun)) - bymonth: (list 10) - )) - (daylight - tzoffsetto: (parse-time-spec "02:00") - dtstart: #1981-03-29T01:00:00 - tzname: "CEST" - tzoffsetfrom: (parse-time-spec "00:00") - rrule: (make-recur-rule - freq: 'YEARLY - interval: 1 - byday: (list (cons -1 sun)) - bymonth: (list 3)))))) - -(define ev - (vevent - uid: "3da506ad-8d27-4810-94b3-6ab341baa1f2" - summary: "Test Event #1" - dtstart: (with-parameters - tzid: "Europe/Stockholm" - #2021-12-21T10:30:00) - dtstamp: #2021-12-21T14:10:56Z - dtend: (with-parameters - tzid: "Europe/Stockholm" - #2021-12-21T11:45:00))) - -(define rep-ev - (vevent - uid: "4ebd6632-d192-4bf4-a33a-7a8388185914" - summary: "Repeating Test Event #1" - rrule: (make-recur-rule freq: 'DAILY) - dtstart: (with-parameters - tzid: "Europe/Stockholm" - #2021-12-21T10:30:00) - dtstamp: #2021-12-21T14:10:56Z - dtend: (with-parameters - tzid: "Europe/Stockholm" - #2021-12-21T11:45:00) - )) - -(define directory (mkdtemp (string-copy"/tmp/guile-test-XXXXXX"))) -(format #t "Using ~a~%" directory) - -(define event-object ((@ (oop goops) make) - (@@ (vcomponent util instance methods) ))) - - -(define calendar - (vcalendar - #:-X-HNH-SOURCETYPE 'vdir - #:-X-HNH-DIRECTORY directory - )) - -(add-calendars event-object calendar) - -;; Try adding and saving a new regular event -(add-and-save-event event-object calendar ev) - -;; Try changing and saving an existing regular event -(set! (prop ev 'SUMMARY) "Changed summary") -(add-and-save-event event-object calendar ev) - -;; Try adding and saving a new repeating event -(add-and-save-event event-object calendar rep-ev) - -;; Try changing and saving an existing repeating event -;; TODO setting start time to later than end time leads to nonsense -;; errors when trying to generate the recurrence set. -(set! (prop rep-ev 'DTSTART) (datetime+ (prop rep-ev 'DTSTART) - (datetime time: (time hour: 1)))) -(add-and-save-event event-object calendar rep-ev) - -;; Try adding and saving a new event with multiple instances -;; Try changing and saving an existing event with multiple instances - -;; (add-and-save-event event-object calendar event) - - -(test-equal "Correct amount of children in calendar" - 5 (length (children calendar))) - - -(define get-events (@@ (vcomponent util instance methods) get-events)) -(test-equal "Event object contains correct number of events (single calendar)" - 2 (length (get-events event-object))) - -(remove-event event-object (car (get-events event-object))) - -(test-equal "Correct number of events after removing first element" - 1 (length (get-events event-object))) diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm index d41ee450..a6f5e946 100644 --- a/tests/test/annoying-events.scm +++ b/tests/test/annoying-events.scm @@ -9,7 +9,7 @@ stream-filter stream-take-while)) :use-module ((vcomponent base) - :select (extract prop make-vcomponent)) + :select (extract prop)) :use-module ((vcomponent datetime) :select (event-overlaps?)) :use-module ((datetime) :select (date date+ date<)) :use-module ((hnh util) :select (set!)) diff --git a/tests/test/create.scm b/tests/test/create.scm index ca055df1..7cc00419 100644 --- a/tests/test/create.scm +++ b/tests/test/create.scm @@ -2,8 +2,12 @@ :use-module ((srfi srfi-1) :select (every)) :use-module (srfi srfi-64) :use-module (srfi srfi-88) - :use-module (vcomponent create) - :use-module (vcomponent)) + :use-module ((vcomponent create) + :select (vcomponent + with-parameters + as-list)) + :use-module ((vcomponent) + :select (children properties type prop prop* param vline?))) ;; vevent, vcalendar, vtimezone, standard, and daylight all trivial ;; and therefore not tested @@ -26,7 +30,8 @@ (list child)))) (test-equal '() (properties ev)) (test-equal 1 (length (children ev))) - (test-eq child (car (children ev))))) + ; (test-eq child (car (children ev))) + )) (test-group "Component with both children and properties" (let* ((child (vcomponent 'CHILD)) @@ -36,7 +41,8 @@ (test-equal '(PROP) (map car (properties ev))) (test-equal "VALUE" (prop ev 'PROP)) (test-equal 1 (length (children ev))) - (test-eq child (car (children ev))))) + ; (test-eq child (car (children ev))) + )) (test-group "Component with no children, where last elements value is a list" (let ((ev (vcomponent 'TEST prop: (list 1 2 3)))) diff --git a/tests/test/hnh-util-lens.scm b/tests/test/hnh-util-lens.scm index bcfafba2..0508553a 100644 --- a/tests/test/hnh-util-lens.scm +++ b/tests/test/hnh-util-lens.scm @@ -19,3 +19,41 @@ (test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10)) ;; (set (list (iota 10)) first first 11) + +(define cadr* (compose-lenses cdr* car*)) + +(test-group "Primitive lenses get and set" + (define lst '(1 2 3 4 5)) + (test-equal 1 (car* lst)) + (test-equal '(2 3 4 5) (cdr* lst)) + + (test-equal '(10 2 3 4 5) + (car* lst 10))) + +(test-group "Primitive lens composition" + (define lst '(1 2 3 4 5)) + (test-equal 2 (cadr* lst)) + (test-equal '(1 10 3 4 5) (cadr* lst 10))) + +(test-group "Modify" + (define lst '(1 2 3 4 5)) + (test-equal '(10 2 3 4 5) (modify lst car* * 10)) + (test-equal '(1 20 3 4 5) (modify lst cadr* * 10)) + ) + +(test-group "Modify*" + (define lst '(1 2 3 4 5)) + (test-equal '(1 2 4 4 5) (modify* lst cdr* cdr* car* 1+))) + +;; modify +;; modify* +;; set +;; get + +;; identity-lens +;; compose-lenses +;; lens-compose + +;; ref car* cdr* + +;; each diff --git a/tests/test/param.scm b/tests/test/param.scm index 34f7b826..431a8f46 100644 --- a/tests/test/param.scm +++ b/tests/test/param.scm @@ -8,10 +8,10 @@ :use-module (srfi srfi-64 test-error) :use-module (srfi srfi-88) :use-module ((vcomponent base) - :select (param prop* parameters prop)) + :select (param prop* parameters prop vline?)) :use-module ((vcomponent formats ical parse) :select (parse-calendar)) - :use-module ((vcomponent) :select (make-vcomponent)) + :use-module ((vcomponent) :select (vcomponent properties set-properties)) :use-module ((hnh util) :select (sort* set!)) :use-module ((ice-9 ports) :select (call-with-input-string)) :use-module ((vcomponent formats xcal output) @@ -23,11 +23,12 @@ ;; TODO possibly change parsing (define v - (call-with-input-string - "BEGIN:DUMMY + (car + (call-with-input-string + "BEGIN:DUMMY X-KEY;A=1;B=2:Some text END:DUMMY" - parse-calendar)) + parse-calendar))) (test-equal '("1") (param (prop* v 'X-KEY) 'A)) @@ -35,17 +36,20 @@ END:DUMMY" (test-equal #f (param (prop* v 'X-KEY) 'C)) -(test-equal - '(A B) - (sort* (map car (parameters (prop* v 'X-KEY))) - stringstring)) + +(test-group "Properties" + (let ((p (properties v))) + (test-assert (list? p)) + (test-eqv 1 (length p)) + (test-eq 'X-KEY (caar p)) + (test-assert (vline? (cadar p))))) + ;; TODO possibly move this. ;; Checks that a warning is properly raised for ;; unkonwn keys (without an X-prefix) -(test-error +(test-error "Ensure parse-calendar warns on unknown keys" 'warning (call-with-input-string "BEGIN:DUMMY @@ -54,10 +58,9 @@ END:DUMMY" parse-calendar)) ;; Similar thing happens for sxcal, but during serialization instead -(let ((component (make-vcomponent 'DUMMY))) - (set! (prop component 'KEY) "Anything") +(let ((component (set-properties (vcomponent type: 'DUMMY) + (cons 'KEY "Anything")))) + (test-error 'warning (vcomponent->sxcal component))) - - diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm index c4684ba7..c2d71e61 100644 --- a/tests/test/recurrence-advanced.scm +++ b/tests/test/recurrence-advanced.scm @@ -23,7 +23,7 @@ :use-module ((vcomponent recurrence internal) :select (count until)) :use-module ((vcomponent base) - :select (make-vcomponent prop prop* extract make-vline)) + :select (prop prop* extract)) :use-module (vcomponent create) :use-module ((datetime) :select (parse-ics-datetime diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm index a6989776..bdaefa95 100644 --- a/tests/test/vcomponent.scm +++ b/tests/test/vcomponent.scm @@ -1,52 +1,103 @@ ;;; Commentary: -;; Test that vcomponent parsing works at all. +;; Test base functionallity of vcomponent structures. ;;; Code: (define-module (test vcomponent) :use-module (srfi srfi-17) :use-module (srfi srfi-64) :use-module (srfi srfi-88) - :use-module ((vcomponent base) - :select (prop make-vcomponent reparent! abandon! - copy-vcomponent - type parent children))) + :use-module (hnh util table) + :use-module (datetime) + :use-module (vcomponent base)) + + + (define ev - (let ((ev (make-vcomponent 'DUMMY))) - (set! (prop ev 'X-KEY) "value") - ev)) + (prop (vcomponent type: 'DUMMY) + 'X-KEY "value")) -(test-assert (eq? #f (prop ev 'MISSING))) +(test-eqv "Non-existant properties return #f" + #f (prop ev 'MISSING)) -(test-assert (prop ev 'X-KEY)) +(test-assert "Existing property is non-false" + (prop ev 'X-KEY)) -(test-equal "value" (prop ev 'X-KEY)) +(test-equal "Getting value of existing property" + "value" (prop ev 'X-KEY)) -(define calendar (make-vcomponent 'VCALENDAR)) +(define calendar (add-child (vcomponent type: 'VCALENDAR) + ev)) -(reparent! calendar ev) (test-equal 1 (length (children calendar))) -(abandon! calendar ev) -(test-equal 0 (length (children calendar))) - - -(test-group "Copy VComponent" - (let ((ev1 (make-vcomponent 'A)) - (ev2 (make-vcomponent 'B)) - (ev3 (make-vcomponent 'C))) - (set! (prop ev3 'TEST) (list 1 2 3)) - (reparent! ev1 ev2) - (reparent! ev2 ev3) - (let* ((ev2* (copy-vcomponent ev2)) - (ev3* (car (children ev2*)))) - ;; NOTE replace this with `vcomponent=?' if that gets written - (test-group "New object is equivalent to old one" - (test-equal (type ev2) (type ev2*)) - (test-equal (length (children ev2)) (length (children ev2*)))) - (test-eq ev1 (parent ev2)) - - (set! (car (prop ev3* 'TEST)) 10) - (test-equal "Property values aren't deep copied" - '(10 2 3) (prop ev3 'TEST)) - (test-equal '(10 2 3) (prop ev3* 'TEST)) - ))) + +;;; TODO remove child +;; (abandon! calendar ev) +;; (test-equal 0 (length (children calendar))) + + + +(define vline* + (vline + key: 'DTSTART + vline-value: #2020-01-02 + vline-parameters: (alist->table + '((VALUE . "DATE"))) + vline-source: "DTSTART;VALUE=DATE:2020-01-02")) + +(test-group "vline" + (test-assert "Type check works as expected" + (vline? vline*))) + +(define vcomponent* + (vcomponent type: 'VEVENT)) + +(test-assert "Type check works as expected" + (vcomponent? vcomponent*)) + +(define child + (vcomponent type: 'CHILD)) + + +(test-eqv + "An added component extends length" + 1 (length (children (add-child vcomponent* child)))) + +(test-eqv + "But the source isn't modified" + 0 (length (children vcomponent*))) + +(test-equal "Setting property" + (list (list 'KEY (vline key: 'KEY vline-value: "Value"))) + (properties + (prop vcomponent* 'KEY "Value"))) + +(let ((vl (vline key: 'KEY vline-value: "Value"))) + (test-equal "Setting property vline" + (list (list 'KEY vl)) + (properties + (prop* vcomponent* 'KEY vl)))) + +(test-equal "Set properties test" + '(K1 K2) + (map car + (properties + (apply set-properties + vcomponent* + `((K1 . "V1") + (K2 . "V2")))))) + +;; remove-property + +;; extract extract* + + +;; remove-parameter +;; value +;; param + +;; parameters +;; properties + +;; x-property? +;; internal-field? -- cgit v1.2.3