From 30a5c6c07828d88ddd3a0ffb7972dd8c0c32b26a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 7 Apr 2020 23:55:42 +0200 Subject: Parse EXDATES, basic handling of repeated keys. --- module/vcomponent/parse.scm | 158 +++++++++++++++++++++++++------------------- 1 file changed, 89 insertions(+), 69 deletions(-) (limited to 'module/vcomponent/parse.scm') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index c7cb39d6..7ff1237e 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -91,6 +91,36 @@ 'end-of-line]))) +(define (handle-value! key vline strbuf) + (case key + ;; As far as I can tell the RFC says nothing about special + ;; encoding for individual fields. It mentieons UTF-8, and + ;; that transfer encoding should be set in the mime-headers. + ;; That however seems like a breach of abstractions. + ;; Currently I allow a CHARSET property on SUMMARY fields, + ;; since I know that at least www.lysator.liu.se/alma/alma.cgi + ;; uses it. + [(SUMMARY) + (cond [(and=> (prop vline 'CHARSET) car) + => (lambda (encoding) + (set! (value vline) + (strbuf->string strbuf ((@ (rnrs io ports) make-transcoder) + encoding))))])] + + [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE) + + ;; '("Africa/Ceuta" "Europe/Stockholm" "local") + (let ((tz (or (and=> (prop vline 'TZID) car) + (and (string= "Z" (string-take-right (value vline) 1)) "UTC")))) + + (let ((type (and=> (prop vline 'VALUE) car))) + (if (or (and=> type (cut string=? <> "DATE-TIME")) + (string-contains (value vline) "T")) + (set! (value vline) (parse-ics-datetime (value vline) tz) + (prop vline 'VALUE) 'DATE-TIME) + (set! (value vline) (parse-ics-date (value vline)) + (prop vline 'VALUE) 'DATE))))])) + ;; Reads a vcomponent from the given port. (define-public (parse-calendar port) ;; (report-time! "Parsing ~a" port) @@ -99,6 +129,10 @@ (let ((component (make-vcomponent)) (ctx (make-parse-ctx (port-filename port))) (strbuf (make-strbuf))) + ;; TODO this would be a good candidate for a parameter, + ;; allowing any function to call warning whenever, but easily + ;; allowing a parent function to override waring with their + ;; own which can provide extra context. (define (warning fmt . args) (display (format #f @@ -110,7 +144,8 @@ row ~a column ~a ctx = ~a (get-filename ctx) (get-row ctx) (get-col ctx) (get-ctx ctx) (get-line-key ctx) (get-param-key ctx) - fmt args)) ) + fmt args) + (current-error-port))) (with-throw-handler #t (lambda () @@ -156,78 +191,63 @@ row ~a column ~a ctx = ~a (case (fold-proc ctx c) [(end-of-line) (let ((str (strbuf->string strbuf))) - ;; I believe that an empty line is against the standard - ;; in every whey. But it's nice to handle it. - (if (and (eq? 'key (get-ctx ctx)) - (string-null? str)) - (warning "Unexpected completely empty line") - (begin - (cond [(eq? 'BEGIN (get-line-key ctx)) - (let ((child (make-vcomponent (string->symbol str)))) - (add-child! component child) - (set! component child))] - - [(eq? (get-line-key ctx) 'END) - - ;; Ensure that we have a DTEND - ;; TODO Objects aren't required to have a DTEND, or a DURATION. - ;; write fancier code which acknoledges this. - (when (and (eq? 'VEVENT (type component)) - (not (attr component 'DTEND))) - (set! (attr component 'DTEND) - (let ((start (attr component 'DTSTART))) - (if (date? start) - (date+ start (date day: 1)) - (datetime+ start (datetime time: (time hour: 1))))))) - - (set! component (parent component))] - - [else ; Regular key-value line - ;; TODO repeated keys - (let ((it (make-vline str (get-param-table ctx)))) - ;; Type specific processing - (case (get-line-key ctx) - ;; As far as I can tell the RFC says nothing about special - ;; encoding for individual fields. It mentieons UTF-8, and - ;; that transfer encoding should be set in the mime-headers. - ;; That however seems like a breach of abstractions. - ;; Currently I allow a CHARSET property on SUMMARY fields, - ;; since I know that at least www.lysator.liu.se/alma/alma.cgi - ;; uses it. - [(SUMMARY) - (cond [(and=> (prop it 'CHARSET) car) - => (lambda (encoding) - (set! (value it) - (strbuf->string strbuf ((@ (rnrs io ports) make-transcoder) - encoding))))])] - - [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP) - - ;; '("Africa/Ceuta" "Europe/Stockholm" "local") - (let ((tz (or (and=> (prop it 'TZID) car) - (and (string= "Z" (string-take-right (value it) 1)) "UTC")))) - - (let ((type (and=> (prop it 'VALUE) car))) - (if (or (and=> type (cut string=? <> "DATE-TIME")) - (string-contains (value it) "T")) - (set! (value it) (parse-ics-datetime (value it) tz) - (prop it 'VALUE) 'DATE-TIME) - (set! (value it) (parse-ics-date (value it)) - (prop it 'VALUE) 'DATE))))]) - - - ;; From RFC 5545 §3.6.1 - ;; DTEND and DURATION are mutually exclusive - ;; DTSTART is required to exist while the other two are optional. - ;; None can appear more than once. - - (set-vline! component (get-line-key ctx) it)) - (set-param-table! ctx (make-hash-table))]))) + (cond [(and (eq? 'key (get-ctx ctx)) + (string-null? str)) + ;; I believe that an empty line is against the standard + ;; in every way. But it's nice to handle it. + (warning "Unexpected completely empty line")] + + [(eq? 'BEGIN (get-line-key ctx)) + (let ((child (make-vcomponent (string->symbol str)))) + (add-child! component child) + (set! component child))] + + [(eq? (get-line-key ctx) 'END) + + ;; Ensure that we have a DTEND + ;; TODO Objects aren't required to have a DTEND, or a DURATION. + ;; write fancier code which acknoledges this. + (when (and (eq? 'VEVENT (type component)) + (not (attr component 'DTEND))) + (set! (attr component 'DTEND) + (let ((start (attr component 'DTSTART))) + (if (date? start) + (date+ start (date day: 1)) + (datetime+ start (datetime time: (time hour: 1))))))) + + (set! component (parent component))] + + [else ; Regular key-value line + (let ((key (get-line-key ctx)) + (vline (make-vline str (get-param-table ctx)))) + ;; Type specific processing + (handle-value! key vline strbuf) + + ;; From RFC 5545 §3.6.1 + ;; DTEND and DURATION are mutually exclusive + ;; DTSTART is required to exist while the other two are optional. + + ;; Allowed (some) repeated keys + (if (memv key '(EXDATE)) + (aif (attr* component key) + (begin (warning "Merging EXDATE fields") + ;; updates the current vline + ;; NOTE that this discards any properties belonging to this object + (set! (value it) (cons (value vline) (value it)))) + (begin (mod! (value vline) list) + (set-vline! component key vline))) + ;; Keys which aren't allowed to be repeated. + (begin + (awhen (attr* component key) + (warning "Key ~a encountered more than once, overriding old value [~a] with [~a]" + key (value it) (value vline))) + (set-vline! component key vline)))) + (set-param-table! ctx (make-hash-table))]) (strbuf-reset! strbuf) (ctx-dump-strings! ctx) (set-ctx! ctx 'key))] - [(fold) 'noop] ; Good case, here to catch errors in else + [(fold) 'noop] ; Good case, here to catch errors in else [else => (lambda (a) (error "Bad return from fold, unexpected" a))])] ;; Escaped characters -- cgit v1.2.3