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/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 ++- 14 files changed, 489 insertions(+), 514 deletions(-) create mode 100644 module/vcomponent/data-stores/virtual.scm (limited to 'module/vcomponent') 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) "]"))))) -- cgit v1.2.3