From b157c326fa2139529eee14781f39c9d3ab65668a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 17 Aug 2020 18:06:18 +0200 Subject: Start moving stuff out from output. --- module/calp/entry-points/ical.scm | 2 +- module/html/vcomponent.scm | 4 +- module/output/html.scm | 0 module/output/ical.scm | 244 ------------------------------ module/output/vdir.scm | 2 +- module/output/xcal.scm | 131 ---------------- module/server/routes.scm | 7 +- module/vcomponent/ical/output.scm | 244 ++++++++++++++++++++++++++++++ module/vcomponent/ical/parse.scm | 307 ++++++++++++++++++++++++++++++++++++++ module/vcomponent/parse.scm | 2 +- module/vcomponent/parse/ical.scm | 307 -------------------------------------- module/vcomponent/parse/xcal.scm | 157 ------------------- module/vcomponent/xcal/output.scm | 131 ++++++++++++++++ module/vcomponent/xcal/parse.scm | 157 +++++++++++++++++++ tests/xcal.scm | 4 +- 15 files changed, 849 insertions(+), 850 deletions(-) delete mode 100644 module/output/html.scm delete mode 100644 module/output/ical.scm delete mode 100644 module/output/xcal.scm create mode 100644 module/vcomponent/ical/output.scm create mode 100644 module/vcomponent/ical/parse.scm delete mode 100644 module/vcomponent/parse/ical.scm delete mode 100644 module/vcomponent/parse/xcal.scm create mode 100644 module/vcomponent/xcal/output.scm create mode 100644 module/vcomponent/xcal/parse.scm diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm index 3bf211df..0b6a0535 100644 --- a/module/calp/entry-points/ical.scm +++ b/module/calp/entry-points/ical.scm @@ -2,7 +2,7 @@ :export (main) :use-module (util) :use-module (util options) - :use-module (output ical) + :use-module (vcomponent ical output) :use-module (ice-9 getopt-long) :use-module (datetime) ) diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index 6836e777..559b11c5 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -181,8 +181,8 @@ ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) (prop ev 'LOCATION))))) (div (@ (style "display:none !important;")) - ,((@ (output xcal) ns-wrap) - ((@ (output xcal) vcomponent->sxcal) + ,((@ (vcomponent xcal output) ns-wrap) + ((@ (vcomponent xcal output) vcomponent->sxcal) ev))))))) diff --git a/module/output/html.scm b/module/output/html.scm deleted file mode 100644 index e69de29b..00000000 diff --git a/module/output/ical.scm b/module/output/ical.scm deleted file mode 100644 index 45918be0..00000000 --- a/module/output/ical.scm +++ /dev/null @@ -1,244 +0,0 @@ -(define-module (output ical) - :use-module (ice-9 format) - :use-module (ice-9 match) - :use-module (util) - :use-module (util exceptions) - :use-module (vcomponent) - :use-module (vcomponent datetime) - :use-module (srfi srfi-1) - :use-module (datetime) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - :use-module (datetime zic) - :use-module (glob) - :use-module (vcomponent recurrence) - :use-module (vcomponent geo) - :use-module (output types) - :use-module (output common) - :autoload (vcomponent instance) (global-event-object) - :use-module ((datetime instance) :select (zoneinfo)) - ) - - -;; Format value depending on key type. -;; Should NOT emit the key. -(define (value-format key vline) - - (define writer - ;; fields which can hold lists need not be considered here, - ;; since they are split into multiple vlines when we parse them. - (cond - ;; TODO parameters return? One or many‽ - [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer] - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID - CREATED DTSTAMP LAST-MODIFIED - ACKNOWLEDGED EXDATE)) - (get-writer 'DATE-TIME)] - - [(memv key '(TRIGGER DURATION)) - (get-writer 'DURATION)] - - [(memv key '(FREEBUSY)) - (get-writer 'PERIOD)] - - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION - LOCATION SUMMARY TZID TZNAME - CONTACT RELATED-TO UID - - CATEGORIES RESOURCES - - VERSION)) - (get-writer 'TEXT)] - - [(memv key '(TRANSP - CLASS - PARTSTAT - STATUS - ACTION)) - (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] - - [(memv key '(TZOFFSETFROM TZOFFSETTO)) - (get-writer 'UTC-OFFSET)] - - [(memv key '(ATTACH TZURL URL)) - (get-writer 'URI)] - - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) - (get-writer 'INTEGER)] - - [(memv key '(GEO)) - (lambda (_ v) - (define fl (get-writer 'FLOAT)) - (format #f "~a:~a" - (fl (geo-latitude v)) - (fl (geo-longitude v))))] - - [(memv key '(RRULE)) - (get-writer 'RECUR)] - - [(memv key '(ORGANIZER ATTENDEE)) - (get-writer 'CAL-ADDRESS)] - - [(x-property? key) - (get-writer 'TEXT)] - - [else - (warning "Unknown key ~a" key) - (get-writer 'TEXT)])) - - (catch #t #; 'wrong-type-arg - (lambda () - (writer ((@@ (vcomponent base) get-vline-parameters) vline) - (value vline))) - (lambda (err caller fmt args call-args) - (define fallback-string - (with-output-to-string (lambda () (display value)))) - (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s" - key caller call-args fmt args - fallback-string) - fallback-string))) - - -;; Fold long lines to limit width. -;; Since this works in characters, but ics works in bytes -;; this will overshoot when faced with multi-byte characters. -;; But since the line wrapping is mearly a recomendation it's -;; not a problem. -;; Setting the wrap-len to slightly lower than allowed also help -;; us not overshoot. -(define* (ical-line-fold string #:key (wrap-len 70)) - (cond [(< wrap-len (string-length string)) - (format #f "~a\r\n ~a" - (string-take string wrap-len) - (ical-line-fold (string-drop string wrap-len)))] - [else string])) - - - -(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) - (string-concatenate - (map (match-lambda - [(? (compose internal-field? car)) ""] - [(key values ...) - (string-append - ";" (symbol->string key) "=" - (string-join (map (compose escape-chars ->string) values) - "," 'infix))]) - (parameters vline))) - ":" (value-format key vline)))) - -(define-public (component->ical-string component) - (format #t "BEGIN:~a\r\n" (type component)) - (for-each - ;; Special cases depending on key. - ;; Value formatting is handled in @code{value-format}. - (match-lambda - - [(? (compose internal-field? car)) 'noop] - - [(key vlines ...) - (for vline in vlines - (display (vline->string vline)) - (display "\r\n"))] - - [(key . vline) - (display (vline->string vline)) - (display "\r\n")]) - (properties component)) - (for-each component->ical-string (children component)) - (format #t "END:~a\r\n" (type component)) - - ;; If we have alternatives, splice them in here. - (cond [(prop component '-X-HNH-ALTERNATIVES) - => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) - alts))])) - -;; TODO tzid param on dtstart vs tz field in datetime object -;; TODO remove this, replace with methods from (output vdir) -;; how do we keep these two in sync? -(define (write-event-to-file event calendar-path) - (define cal (make-vcomponent 'VCALENDAR)) - - (set! (prop cal 'PRODID) (@ (global) *prodid*) - (prop cal 'VERSION) "2.0" - (prop cal 'CALSCALE) "GREGORIAN") - - (add-child! cal event) - - (awhen (and (provided? 'zoneinfo) - (param (prop* event 'DTSTART) 'TZID)) - ;; TODO this is broken - (add-child! cal (zoneinfo->vtimezone (zoneinfo) it))) - - (unless (prop event 'UID) - (set! (prop event 'UID) - (uuidgen))) - - (with-output-to-file (glob (format #f "~a/~a.ics" - calendar-path - (prop event 'UID))) - (lambda () (component->ical-string cal)))) - - - -(define (print-header) - (format #t -"BEGIN:VCALENDAR\r -PRODID:~a\r -VERSION:2.0\r -CALSCALE:GREGORIAN\r -" (@ (global) *prodid*) -)) - - -(define (print-footer) - (format #t "END:VCALENDAR\r\n")) - - - -(define-public (print-components-with-fake-parent events) - - ;; The events are probably sorted before, but until I can guarantee - ;; that we sort them again here. We need them sorted from earliest - ;; and up to send the earliest to zoneinfo->vtimezone - (set! events (sort* events date/-time<=? (extract 'DTSTART))) - - (print-header) - - (when (provided? 'zoneinfo) - (let ((tz-names (get-tz-names events))) - (for-each component->ical-string - ;; TODO we realy should send the earliest event from each timezone here, - ;; instead of just the first. - (map (lambda (name) (zoneinfo->vtimezone - (zoneinfo) - name (car events))) - tz-names)))) - - (for-each component->ical-string events) - - (print-footer)) - - -(define-public (print-all-events) - (print-components-with-fake-parent - (append (get-fixed-events global-event-object) - ;; TODO RECCURENCE-ID exceptions - ;; We just dump all repeating objects, since it's much cheaper to do - ;; it this way than to actually figure out which are applicable for - ;; the given date range. - (get-repeating-events global-event-object)))) - -(define-public (print-events-in-interval start end) - (print-components-with-fake-parent - (append (fixed-events-in-range start end) - ;; TODO RECCURENCE-ID exceptions - ;; We just dump all repeating objects, since it's much cheaper to do - ;; it this way than to actually figure out which are applicable for - ;; the given date range. - (get-repeating-events global-event-object)))) diff --git a/module/output/vdir.scm b/module/output/vdir.scm index bd21fb24..2541f0f9 100644 --- a/module/output/vdir.scm +++ b/module/output/vdir.scm @@ -11,7 +11,7 @@ (define-module (output vdir) :use-module (util) - :use-module (output ical) + :use-module (vcomponent ical output) :use-module (vcomponent) :use-module ((util io) :select (with-atomic-output-to-file)) ) diff --git a/module/output/xcal.scm b/module/output/xcal.scm deleted file mode 100644 index b2c3f899..00000000 --- a/module/output/xcal.scm +++ /dev/null @@ -1,131 +0,0 @@ -(define-module (output xcal) - :use-module (util) - :use-module (util exceptions) - :use-module (vcomponent) - :use-module (vcomponent geo) - :use-module (output sxml-types) - :use-module (ice-9 match) - :use-module (output common) - :use-module (datetime) - :use-module (srfi srfi-1) - ) - - -(define (vline->value-tag vline) - (define key (vline-key vline)) - - (define writer - (cond - [(and=> (param vline 'VALUE) (compose string->symbol car)) - => get-writer] - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID - CREATED DTSTAMP LAST-MODIFIED - ACKNOWLEDGED EXDATE)) - (get-writer 'DATE-TIME)] - - [(memv key '(TRIGGER DURATION)) - (get-writer 'DURATION)] - - [(memv key '(FREEBUSY)) - (get-writer 'PERIOD)] - - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION - LOCATION SUMMARY TZID TZNAME - CONTACT RELATED-TO UID - - CATEGORIES RESOURCES - - VERSION)) - (get-writer 'TEXT)] - - [(memv key '(TRANSP - CLASS - PARTSTAT - STATUS - ACTION)) - (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] - - [(memv key '(TZOFFSETFROM TZOFFSETTO)) - (get-writer 'UTC-OFFSET)] - - [(memv key '(ATTACH TZURL URL)) - (get-writer 'URI)] - - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) - (get-writer 'INTEGER)] - - [(memv key '(GEO)) - (lambda (_ v) - `(geo - (latitude ,(geo-latitude v)) - (longitude ,(geo-longitude v))))] - - [(memv key '(RRULE)) - (get-writer 'RECUR)] - - [(memv key '(ORGANIZER ATTENDEE)) - (get-writer 'CAL-ADDRESS)] - - [(x-property? key) - (get-writer 'TEXT)] - - [else - (warning "Unknown key ~a" key) - (get-writer 'TEXT)])) - - (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) - -(define (property->value-tag tag . values) - (if (or (eq? tag 'VALUE) - (internal-field? tag)) - #f - `(,(downcase-symbol tag) - ,@(map (lambda (v) - ;; TODO parameter types!!!! (rfc6321 3.5.) - `(text ,(->string v))) - values)))) - -;; ((key value ...) ...) -> `(parameters , ... ) -(define (parameters-tag parameters) - (define outparams (filter-map - (lambda (x) (apply property->value-tag x)) - parameters)) - - (unless (null? outparams) - `(parameters ,@outparams))) - -(define-public (vcomponent->sxcal component) - - (define tagsymb (downcase-symbol (type component))) - - - (remove null? - `(,tagsymb - ;; only have when it's non-empty. - ,(let ((props - (filter-map - (match-lambda - [(? (compose internal-field? car)) #f] - - [(key vlines ...) - (remove null? - `(,(downcase-symbol key) - ,(parameters-tag (reduce assq-merge - '() (map parameters vlines))) - ,@(for vline in vlines - (vline->value-tag vline))))] - - [(key . vline) - (remove null? - `(,(downcase-symbol key) - ,(parameters-tag (parameters vline)) - ,(vline->value-tag vline)))]) - (properties component)))) - (unless (null? props) - `(properties ,@props))) - ,(unless (null? (children component)) - `(components ,@(map vcomponent->sxcal (children component))))))) - -(define-public (ns-wrap sxml) - `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) - ,sxml)) diff --git a/module/server/routes.scm b/module/server/routes.scm index 6c1d1fcd..142e0477 100644 --- a/module/server/routes.scm +++ b/module/server/routes.scm @@ -25,8 +25,7 @@ :use-module (vcomponent) :use-module (vcomponent search) :use-module (datetime) - ;; :use-module (output html) - :use-module (output ical) + :use-module (vcomponent ical output) :autoload (vcomponent instance) (global-event-object) @@ -194,7 +193,7 @@ ;; *TOP* node is a required part of the sxml. (let ((event - ((@ (vcomponent parse xcal) sxcal->vcomponent) + ((@ (vcomponent xcal parse) sxcal->vcomponent) (catch 'parser-error (lambda () (move-to-namespace @@ -336,7 +335,7 @@ ;; Look into changing how events carry around their ;; parent information, possibly splitting "source parent" ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (output xcal) vcomponent->sxcal) it))))) + (lambda () (sxml->xml ((@ (vcomponent xcal output) vcomponent->sxcal) it))))) (return (build-response code: 404) (format #f "No component with UID=~a found." uid)))) diff --git a/module/vcomponent/ical/output.scm b/module/vcomponent/ical/output.scm new file mode 100644 index 00000000..530203e6 --- /dev/null +++ b/module/vcomponent/ical/output.scm @@ -0,0 +1,244 @@ +(define-module (vcomponent ical output) + :use-module (ice-9 format) + :use-module (ice-9 match) + :use-module (util) + :use-module (util exceptions) + :use-module (vcomponent) + :use-module (vcomponent datetime) + :use-module (srfi srfi-1) + :use-module (datetime) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (datetime zic) + :use-module (glob) + :use-module (vcomponent recurrence) + :use-module (vcomponent geo) + :use-module (output types) + :use-module (output common) + :autoload (vcomponent instance) (global-event-object) + :use-module ((datetime instance) :select (zoneinfo)) + ) + + +;; Format value depending on key type. +;; Should NOT emit the key. +(define (value-format key vline) + + (define writer + ;; fields which can hold lists need not be considered here, + ;; since they are split into multiple vlines when we parse them. + (cond + ;; TODO parameters return? One or many‽ + [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer] + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID + CREATED DTSTAMP LAST-MODIFIED + ACKNOWLEDGED EXDATE)) + (get-writer 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-writer 'DURATION)] + + [(memv key '(FREEBUSY)) + (get-writer 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID + + CATEGORIES RESOURCES + + VERSION)) + (get-writer 'TEXT)] + + [(memv key '(TRANSP + CLASS + PARTSTAT + STATUS + ACTION)) + (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-writer 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-writer 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-writer 'INTEGER)] + + [(memv key '(GEO)) + (lambda (_ v) + (define fl (get-writer 'FLOAT)) + (format #f "~a:~a" + (fl (geo-latitude v)) + (fl (geo-longitude v))))] + + [(memv key '(RRULE)) + (get-writer 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-writer 'CAL-ADDRESS)] + + [(x-property? key) + (get-writer 'TEXT)] + + [else + (warning "Unknown key ~a" key) + (get-writer 'TEXT)])) + + (catch #t #; 'wrong-type-arg + (lambda () + (writer ((@@ (vcomponent base) get-vline-parameters) vline) + (value vline))) + (lambda (err caller fmt args call-args) + (define fallback-string + (with-output-to-string (lambda () (display value)))) + (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s" + key caller call-args fmt args + fallback-string) + fallback-string))) + + +;; Fold long lines to limit width. +;; Since this works in characters, but ics works in bytes +;; this will overshoot when faced with multi-byte characters. +;; But since the line wrapping is mearly a recomendation it's +;; not a problem. +;; Setting the wrap-len to slightly lower than allowed also help +;; us not overshoot. +(define* (ical-line-fold string #:key (wrap-len 70)) + (cond [(< wrap-len (string-length string)) + (format #f "~a\r\n ~a" + (string-take string wrap-len) + (ical-line-fold (string-drop string wrap-len)))] + [else string])) + + + +(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) + (string-concatenate + (map (match-lambda + [(? (compose internal-field? car)) ""] + [(key values ...) + (string-append + ";" (symbol->string key) "=" + (string-join (map (compose escape-chars ->string) values) + "," 'infix))]) + (parameters vline))) + ":" (value-format key vline)))) + +(define-public (component->ical-string component) + (format #t "BEGIN:~a\r\n" (type component)) + (for-each + ;; Special cases depending on key. + ;; Value formatting is handled in @code{value-format}. + (match-lambda + + [(? (compose internal-field? car)) 'noop] + + [(key vlines ...) + (for vline in vlines + (display (vline->string vline)) + (display "\r\n"))] + + [(key . vline) + (display (vline->string vline)) + (display "\r\n")]) + (properties component)) + (for-each component->ical-string (children component)) + (format #t "END:~a\r\n" (type component)) + + ;; If we have alternatives, splice them in here. + (cond [(prop component '-X-HNH-ALTERNATIVES) + => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) + alts))])) + +;; TODO tzid param on dtstart vs tz field in datetime object +;; TODO remove this, replace with methods from (output vdir) +;; how do we keep these two in sync? +(define (write-event-to-file event calendar-path) + (define cal (make-vcomponent 'VCALENDAR)) + + (set! (prop cal 'PRODID) (@ (global) *prodid*) + (prop cal 'VERSION) "2.0" + (prop cal 'CALSCALE) "GREGORIAN") + + (add-child! cal event) + + (awhen (and (provided? 'zoneinfo) + (param (prop* event 'DTSTART) 'TZID)) + ;; TODO this is broken + (add-child! cal (zoneinfo->vtimezone (zoneinfo) it))) + + (unless (prop event 'UID) + (set! (prop event 'UID) + (uuidgen))) + + (with-output-to-file (glob (format #f "~a/~a.ics" + calendar-path + (prop event 'UID))) + (lambda () (component->ical-string cal)))) + + + +(define (print-header) + (format #t +"BEGIN:VCALENDAR\r +PRODID:~a\r +VERSION:2.0\r +CALSCALE:GREGORIAN\r +" (@ (global) *prodid*) +)) + + +(define (print-footer) + (format #t "END:VCALENDAR\r\n")) + + + +(define-public (print-components-with-fake-parent events) + + ;; The events are probably sorted before, but until I can guarantee + ;; that we sort them again here. We need them sorted from earliest + ;; and up to send the earliest to zoneinfo->vtimezone + (set! events (sort* events date/-time<=? (extract 'DTSTART))) + + (print-header) + + (when (provided? 'zoneinfo) + (let ((tz-names (get-tz-names events))) + (for-each component->ical-string + ;; TODO we realy should send the earliest event from each timezone here, + ;; instead of just the first. + (map (lambda (name) (zoneinfo->vtimezone + (zoneinfo) + name (car events))) + tz-names)))) + + (for-each component->ical-string events) + + (print-footer)) + + +(define-public (print-all-events) + (print-components-with-fake-parent + (append (get-fixed-events global-event-object) + ;; TODO RECCURENCE-ID exceptions + ;; We just dump all repeating objects, since it's much cheaper to do + ;; it this way than to actually figure out which are applicable for + ;; the given date range. + (get-repeating-events global-event-object)))) + +(define-public (print-events-in-interval start end) + (print-components-with-fake-parent + (append (fixed-events-in-range start end) + ;; TODO RECCURENCE-ID exceptions + ;; We just dump all repeating objects, since it's much cheaper to do + ;; it this way than to actually figure out which are applicable for + ;; the given date range. + (get-repeating-events global-event-object)))) diff --git a/module/vcomponent/ical/parse.scm b/module/vcomponent/ical/parse.scm new file mode 100644 index 00000000..2c01927b --- /dev/null +++ b/module/vcomponent/ical/parse.scm @@ -0,0 +1,307 @@ +(define-module (vcomponent ical parse) + :use-module (util) + :use-module (util exceptions) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (vcomponent base) + :use-module (datetime) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-26) + :use-module (vcomponent parse types) + :use-module (vcomponent geo) + ) + +;; TODO rename to parse-vcomponent, or parse-ical (?). +(define-public (parse-calendar port) + (parse (map tokenize (read-file port)))) + +(define-immutable-record-type + (make-line string file line) + line? + (string get-string) + (file get-file) + (line get-line)) + + +;; port → (list ) +(define (read-file port) + (define fname (port-filename port)) + (let loop ((line-number 1) (done '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse! done) + (let ((line (string-trim-right line))) + (loop + (1+ line-number) + (if (char=? #\space (string-ref line 0)) + ;; Line Wrapping + ;; TODO if the line is split inside a unicode character + ;; then this produces multiple broken unicode characters. + ;; It could be solved by checking the start of the new line, + ;; and the tail of the old line for broken char + (cons (make-line (string-append (get-string (car done)) + (string-drop line 1)) + fname + (get-line (car done))) + (cdr done)) + (cons (make-line line fname line-number) + done)))))))) + +(define-immutable-record-type + (make-tokens metadata data) + tokens? + (metadata get-metadata) ; + (data get-data) ; (key kv ... value) + ) + +;; (list ) → (list ) +(define (tokenize line-obj) + (define line (get-string line-obj)) + (define colon-idx (string-index line #\:)) + (define semi-idxs + (let loop ((idx 0)) + (aif (string-index line #\; idx colon-idx) + (cons it (loop (1+ it))) + (list colon-idx (string-length line))))) + (make-tokens + line-obj + (map (lambda (start end) + (substring line (1+ start) end)) + (cons -1 semi-idxs) + semi-idxs))) + + +#; +'(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + ) + +(define (list-parser symbol) + (let ((parser (get-parser symbol))) + (lambda (params value) + (map (lambda (v) (parser params v)) + (string-split value #\,))))) + +(define* (enum-parser enum optional: (allow-other #t)) + (let ((parser (compose car (get-parser 'TEXT)))) + (lambda (params value) + (let ((vv (parser params value))) + (when (list? vv) + (throw 'parse-error "List in enum field")) + (let ((v (string->symbol vv))) + (unless (memv v enum) + (warning "~a ∉ { ~{~a~^, ~} }" + v enum)) + v))))) + +;; params could be made optional, with an empty hashtable as default +(define (build-vline key value params) + (let ((parser + (cond + [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] + + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE + CREATED DTSTAMP LAST-MODIFIED + ;; only on VALARM + ACKNOWLEDGED + )) + (get-parser 'DATE-TIME)] + + [(memv key '(EXDATE)) + (list-parser 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-parser 'DURATION)] + + [(memv key '(FREEBUSY)) + (list-parser 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID)) + (lambda (params value) + (let ((v ((get-parser 'TEXT) params value))) + (unless (= 1 (length v)) + (warning "List in non-list field: ~s" v)) + (car v)))] + + ;; TEXT, but allow a list + [(memv key '(CATEGORIES RESOURCES)) + ;; TODO An empty value should lead to an empty set + ;; currently it seems to lead to '("") + (get-parser 'TEXT)] + + [(memv key '(VERSION)) + (lambda (params value) + (let ((v (car ((get-parser 'TEXT) params value)))) + (unless (and (string? v) (string=? "2.0" v)) + #f + ;; (warning "File of unsuported version. Proceed with caution") + ) + v))] + + [(memv key '(TRANSP)) + (enum-parser '(OPAQUE TRANSPARENT) #f)] + + [(memv key '(CLASS)) + (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))] + + [(memv key '(PARTSTAT)) + (enum-parser '(NEEDS-ACTION + ACCEPTED DECLINED + TENTATIVE DELEGATED + IN-PROCESS))] + + [(memv key '(STATUS)) + (enum-parser '(TENTATIVE + CONFIRMED CANCELLED + NEEDS-ACTION COMPLETED IN-PROCESS + DRAFT FINAL CANCELED))] + + [(memv key '(REQUEST-STATUS)) + (throw 'parse-error "TODO Implement REQUEST-STATUS")] + + [(memv key '(ACTION)) + (enum-parser '(AUDIO DISPLAY EMAIL + NONE ; I don't know where NONE is from + ; but it appears to be prevelant. + ))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-parser 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-parser 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-parser 'INTEGER)] + + [(memv key '(GEO)) + ;; two semicolon sepparated floats + (lambda (params value) + (let* (((left right) (string-split value #\;))) + (make-geo ((get-parser 'FLOAT) params left) + ((get-parser 'FLOAT) params right))))] + + [(memv key '(RRULE)) + (get-parser 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-parser 'CAL-ADDRESS)] + + [(x-property? key) + (compose car (get-parser 'TEXT))] + + [else + (warning "Unknown key ~a" key) + (compose car (get-parser 'TEXT))]))) + + ;; If we produced a list create multiple VLINES from it. + ;; NOTE that the created vlines share parameter tables. + ;; TODO possibly allow vlines to reference each other, to + ;; indicate that all these vlines are the same. + (let ((parsed (parser params value))) + (if (list? parsed) + (apply values + (map (lambda (p) (make-vline key p params)) + parsed)) + (make-vline key parsed params))))) + +;; (parse-itemline '("DTEND" "20200407T130000")) +;; => DTEND +;; => "20200407T130000" +;; => # +(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)))))) + + +;; (list ) → +(define (parse lst) + (let loop ((lst lst) + (stack '())) + (if (null? lst) + stack + (let* ((head* (car lst)) + (head (get-data head*))) + (catch 'parse-error + (lambda () + (parameterize + ((warning-handler + (lambda (fmt . args) + (let ((linedata (get-metadata head*))) + (format + #f "WARNING parse error around ~a + ~? + line ~a ~a~%" + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata) + ))))) + (cond [(string=? "BEGIN" (car head)) + (loop (cdr lst) + (cons (make-vcomponent (string->symbol (cadr head))) + stack))] + [(string=? "END" (car head)) + (loop (cdr lst) + (if (null? (cdr stack)) + ;; return + (car stack) + (begin (add-child! (cadr stack) (car stack)) + (cdr stack))))] + [else + (let* ((key value params (parse-itemline head))) + (call-with-values (lambda () (build-vline key value params)) + (lambda vlines + (for vline in vlines + (define key (vline-key vline)) + + (set! (vline-source vline) + (get-metadata head*)) + + ;; See RFC 5545 p.53 for list of all repeating types + ;; (for vcomponent) + (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)]))) + (lambda (err fmt . args) + (let ((linedata (get-metadata head*))) + (display (format + #f "ERROR parse error around ~a + ~? + line ~a ~a + Defaulting to string~%" + (get-string linedata) + fmt args + (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))))))))) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 56e62dad..67d66b02 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -16,7 +16,7 @@ :use-module (util exceptions) :use-module (vcomponent base) - :use-module (vcomponent parse ical) + :use-module (vcomponent ical parse) :re-export (parse-calendar) ) diff --git a/module/vcomponent/parse/ical.scm b/module/vcomponent/parse/ical.scm deleted file mode 100644 index c4bb059f..00000000 --- a/module/vcomponent/parse/ical.scm +++ /dev/null @@ -1,307 +0,0 @@ -(define-module (vcomponent parse ical) - :use-module (util) - :use-module (util exceptions) - :use-module ((ice-9 rdelim) :select (read-line)) - :use-module (vcomponent base) - :use-module (datetime) - :use-module (srfi srfi-1) - :use-module (srfi srfi-9 gnu) - :use-module (srfi srfi-26) - :use-module (vcomponent parse types) - :use-module (vcomponent geo) - ) - -;; TODO rename to parse-vcomponent, or parse-ical (?). -(define-public (parse-calendar port) - (parse (map tokenize (read-file port)))) - -(define-immutable-record-type - (make-line string file line) - line? - (string get-string) - (file get-file) - (line get-line)) - - -;; port → (list ) -(define (read-file port) - (define fname (port-filename port)) - (let loop ((line-number 1) (done '())) - (let ((line (read-line port))) - (if (eof-object? line) - (reverse! done) - (let ((line (string-trim-right line))) - (loop - (1+ line-number) - (if (char=? #\space (string-ref line 0)) - ;; Line Wrapping - ;; TODO if the line is split inside a unicode character - ;; then this produces multiple broken unicode characters. - ;; It could be solved by checking the start of the new line, - ;; and the tail of the old line for broken char - (cons (make-line (string-append (get-string (car done)) - (string-drop line 1)) - fname - (get-line (car done))) - (cdr done)) - (cons (make-line line fname line-number) - done)))))))) - -(define-immutable-record-type - (make-tokens metadata data) - tokens? - (metadata get-metadata) ; - (data get-data) ; (key kv ... value) - ) - -;; (list ) → (list ) -(define (tokenize line-obj) - (define line (get-string line-obj)) - (define colon-idx (string-index line #\:)) - (define semi-idxs - (let loop ((idx 0)) - (aif (string-index line #\; idx colon-idx) - (cons it (loop (1+ it))) - (list colon-idx (string-length line))))) - (make-tokens - line-obj - (map (lambda (start end) - (substring line (1+ start) end)) - (cons -1 semi-idxs) - semi-idxs))) - - -#; -'(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - ) - -(define (list-parser symbol) - (let ((parser (get-parser symbol))) - (lambda (params value) - (map (lambda (v) (parser params v)) - (string-split value #\,))))) - -(define* (enum-parser enum optional: (allow-other #t)) - (let ((parser (compose car (get-parser 'TEXT)))) - (lambda (params value) - (let ((vv (parser params value))) - (when (list? vv) - (throw 'parse-error "List in enum field")) - (let ((v (string->symbol vv))) - (unless (memv v enum) - (warning "~a ∉ { ~{~a~^, ~} }" - v enum)) - v))))) - -;; params could be made optional, with an empty hashtable as default -(define (build-vline key value params) - (let ((parser - (cond - [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] - - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE - CREATED DTSTAMP LAST-MODIFIED - ;; only on VALARM - ACKNOWLEDGED - )) - (get-parser 'DATE-TIME)] - - [(memv key '(EXDATE)) - (list-parser 'DATE-TIME)] - - [(memv key '(TRIGGER DURATION)) - (get-parser 'DURATION)] - - [(memv key '(FREEBUSY)) - (list-parser 'PERIOD)] - - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION - LOCATION SUMMARY TZID TZNAME - CONTACT RELATED-TO UID)) - (lambda (params value) - (let ((v ((get-parser 'TEXT) params value))) - (unless (= 1 (length v)) - (warning "List in non-list field: ~s" v)) - (car v)))] - - ;; TEXT, but allow a list - [(memv key '(CATEGORIES RESOURCES)) - ;; TODO An empty value should lead to an empty set - ;; currently it seems to lead to '("") - (get-parser 'TEXT)] - - [(memv key '(VERSION)) - (lambda (params value) - (let ((v (car ((get-parser 'TEXT) params value)))) - (unless (and (string? v) (string=? "2.0" v)) - #f - ;; (warning "File of unsuported version. Proceed with caution") - ) - v))] - - [(memv key '(TRANSP)) - (enum-parser '(OPAQUE TRANSPARENT) #f)] - - [(memv key '(CLASS)) - (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))] - - [(memv key '(PARTSTAT)) - (enum-parser '(NEEDS-ACTION - ACCEPTED DECLINED - TENTATIVE DELEGATED - IN-PROCESS))] - - [(memv key '(STATUS)) - (enum-parser '(TENTATIVE - CONFIRMED CANCELLED - NEEDS-ACTION COMPLETED IN-PROCESS - DRAFT FINAL CANCELED))] - - [(memv key '(REQUEST-STATUS)) - (throw 'parse-error "TODO Implement REQUEST-STATUS")] - - [(memv key '(ACTION)) - (enum-parser '(AUDIO DISPLAY EMAIL - NONE ; I don't know where NONE is from - ; but it appears to be prevelant. - ))] - - [(memv key '(TZOFFSETFROM TZOFFSETTO)) - (get-parser 'UTC-OFFSET)] - - [(memv key '(ATTACH TZURL URL)) - (get-parser 'URI)] - - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) - (get-parser 'INTEGER)] - - [(memv key '(GEO)) - ;; two semicolon sepparated floats - (lambda (params value) - (let* (((left right) (string-split value #\;))) - (make-geo ((get-parser 'FLOAT) params left) - ((get-parser 'FLOAT) params right))))] - - [(memv key '(RRULE)) - (get-parser 'RECUR)] - - [(memv key '(ORGANIZER ATTENDEE)) - (get-parser 'CAL-ADDRESS)] - - [(x-property? key) - (compose car (get-parser 'TEXT))] - - [else - (warning "Unknown key ~a" key) - (compose car (get-parser 'TEXT))]))) - - ;; If we produced a list create multiple VLINES from it. - ;; NOTE that the created vlines share parameter tables. - ;; TODO possibly allow vlines to reference each other, to - ;; indicate that all these vlines are the same. - (let ((parsed (parser params value))) - (if (list? parsed) - (apply values - (map (lambda (p) (make-vline key p params)) - parsed)) - (make-vline key parsed params))))) - -;; (parse-itemline '("DTEND" "20200407T130000")) -;; => DTEND -;; => "20200407T130000" -;; => # -(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)))))) - - -;; (list ) → -(define (parse lst) - (let loop ((lst lst) - (stack '())) - (if (null? lst) - stack - (let* ((head* (car lst)) - (head (get-data head*))) - (catch 'parse-error - (lambda () - (parameterize - ((warning-handler - (lambda (fmt . args) - (let ((linedata (get-metadata head*))) - (format - #f "WARNING parse error around ~a - ~? - line ~a ~a~%" - (get-string linedata) - fmt args - (get-line linedata) - (get-file linedata) - ))))) - (cond [(string=? "BEGIN" (car head)) - (loop (cdr lst) - (cons (make-vcomponent (string->symbol (cadr head))) - stack))] - [(string=? "END" (car head)) - (loop (cdr lst) - (if (null? (cdr stack)) - ;; return - (car stack) - (begin (add-child! (cadr stack) (car stack)) - (cdr stack))))] - [else - (let* ((key value params (parse-itemline head))) - (call-with-values (lambda () (build-vline key value params)) - (lambda vlines - (for vline in vlines - (define key (vline-key vline)) - - (set! (vline-source vline) - (get-metadata head*)) - - ;; See RFC 5545 p.53 for list of all repeating types - ;; (for vcomponent) - (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)]))) - (lambda (err fmt . args) - (let ((linedata (get-metadata head*))) - (display (format - #f "ERROR parse error around ~a - ~? - line ~a ~a - Defaulting to string~%" - (get-string linedata) - fmt args - (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))))))))) diff --git a/module/vcomponent/parse/xcal.scm b/module/vcomponent/parse/xcal.scm deleted file mode 100644 index 2c8b7fe8..00000000 --- a/module/vcomponent/parse/xcal.scm +++ /dev/null @@ -1,157 +0,0 @@ -(define-module (vcomponent parse xcal) - :use-module (util) - :use-module (util exceptions) - :use-module (util base64) - :use-module (ice-9 match) - :use-module (sxml match) - :use-module (vcomponent) - :use-module (vcomponent geo) - :use-module (vcomponent parse types) - :use-module (datetime) - :use-module (srfi srfi-1) - ) - -;; symbol, ht, (list a) -> non-list -(define (handle-value type props value) - (case type - - [(binary) - ;; rfc6321 allows whitespace in binary - (base64-string->bytevector - (string-delete char-set:whitespace (car value)))] - - [(boolean) (string=? "true" (car value))] - - ;; TODO possibly trim whitespace on text fields - [(cal-address uri text unknown) (car value)] - - [(date) (parse-iso-date (car value))] - - [(date-time) (parse-iso-datetime (car value))] - - [(duration) - ((get-parser 'DURATION) props value)] - - [(float integer) ; (3.0) - (string->number (car value))] - - [(period) - (sxml-match - (cons 'period value) - [(period (start ,start-dt) (end ,end-dt)) - (cons (parse-iso-datetime start-dt) - (parse-iso-datetime end-dt))] - [(period (start ,start-dt) (duration ,duration)) - (cons (parse-iso-datetime start-dt) - ((@ (vcomponent duration) parse-duration) duration))])] - - [(recur) - (apply (@ (vcomponent recurrence internal) make-recur-rule) - (for (k v) in value - (list (symbol->keyword k) v)))] - - [(time) (parse-iso-time (car value))] - - [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] - - [(geo) ; ((long 1) (lat 2)) - (sxml-match - (cons 'geo value) - [(geo (latitude ,x) (longitude ,y)) - ((@ (vcomponent geo) make-geo) x y)])])) - -(define (symbol-upcase symb) - (-> symb - symbol->string - string-upcase - string->symbol)) - -(define (handle-parameters parameters) - - (define ht (make-hash-table)) - - (for param in parameters - (match param - [(ptag (ptype pvalue ...) ...) - ;; TODO parameter type (rfc6321 3.5.) - ;; TODO multi-valued parameters!!! - (hashq-set! ht (symbol-upcase ptag) (car (concatenate pvalue)))])) - ht) - -(define* (parse-enum str enum optional: (allow-other #t)) - (let ((symb (string->symbol str))) - (unless (memv symb enum) - (warning "~a ∉ { ~{~a~^, ~} }" symb enum)) - symb)) - - -;; symbol non-list -> non-list -(define (handle-tag tag-name data) - (case tag-name - [(request-status) - ;; TODO - (warning "Request status not yet implemented") - #f] - - ((transp) (parse-enum - data '(OPAQUE TRANSPARENT) #f)) - ((class) (parse-enum - data '(PUBLIC PRIVATE CONFIDENTIAL))) - ((partstat) (parse-enum - data '(NEEDS-ACTION ACCEPTED DECLINED TENTATIVE - DELEGATED IN-PROCESS))) - ((status) (parse-enum - data '(TENTATIVE CONFIRMED CANCELLED NEEDS-ACTION COMPLETED - IN-PROCESS DRAFT FINAL CANCELED))) - ((action) (parse-enum - data '(AUDIO DISPLAY EMAIL NONE))) - [else data])) - -(define-public (sxcal->vcomponent sxcal) - (define type (symbol-upcase (car sxcal))) - (define component (make-vcomponent type)) - - (awhen (assoc-ref sxcal 'properties) - ;; Loop over multi valued fields, creating one vline - ;; for every value. So - ;; KEY;p=1:a,b - ;; would be expanded into - ;; KEY;p=1:a - ;; KEY;p=1:b - (for property in it - (match property - ;; TODO request-status - - [(tag ('parameters parameters ...) - (type value ...) ...) - (let ((params (handle-parameters parameters)) - (tag* (symbol-upcase tag))) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for - (unless (null? value) - (set! (prop* component tag*) - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params)))))] - - [(tag (type value ...) ...) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for - (unless (null? value) - (let ((params (make-hash-table)) - (tag* (symbol-upcase tag))) - (set! (prop* component tag*) - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params)))))]))) - - ;; children - (awhen (assoc-ref sxcal 'components) - (for child in (map sxcal->vcomponent it) - (add-child! component child))) - - component) diff --git a/module/vcomponent/xcal/output.scm b/module/vcomponent/xcal/output.scm new file mode 100644 index 00000000..a689b2cf --- /dev/null +++ b/module/vcomponent/xcal/output.scm @@ -0,0 +1,131 @@ +(define-module (vcomponent xcal output) + :use-module (util) + :use-module (util exceptions) + :use-module (vcomponent) + :use-module (vcomponent geo) + :use-module (output sxml-types) + :use-module (ice-9 match) + :use-module (output common) + :use-module (datetime) + :use-module (srfi srfi-1) + ) + + +(define (vline->value-tag vline) + (define key (vline-key vline)) + + (define writer + (cond + [(and=> (param vline 'VALUE) (compose string->symbol car)) + => get-writer] + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID + CREATED DTSTAMP LAST-MODIFIED + ACKNOWLEDGED EXDATE)) + (get-writer 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-writer 'DURATION)] + + [(memv key '(FREEBUSY)) + (get-writer 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID + + CATEGORIES RESOURCES + + VERSION)) + (get-writer 'TEXT)] + + [(memv key '(TRANSP + CLASS + PARTSTAT + STATUS + ACTION)) + (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-writer 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-writer 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-writer 'INTEGER)] + + [(memv key '(GEO)) + (lambda (_ v) + `(geo + (latitude ,(geo-latitude v)) + (longitude ,(geo-longitude v))))] + + [(memv key '(RRULE)) + (get-writer 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-writer 'CAL-ADDRESS)] + + [(x-property? key) + (get-writer 'TEXT)] + + [else + (warning "Unknown key ~a" key) + (get-writer 'TEXT)])) + + (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) + +(define (property->value-tag tag . values) + (if (or (eq? tag 'VALUE) + (internal-field? tag)) + #f + `(,(downcase-symbol tag) + ,@(map (lambda (v) + ;; TODO parameter types!!!! (rfc6321 3.5.) + `(text ,(->string v))) + values)))) + +;; ((key value ...) ...) -> `(parameters , ... ) +(define (parameters-tag parameters) + (define outparams (filter-map + (lambda (x) (apply property->value-tag x)) + parameters)) + + (unless (null? outparams) + `(parameters ,@outparams))) + +(define-public (vcomponent->sxcal component) + + (define tagsymb (downcase-symbol (type component))) + + + (remove null? + `(,tagsymb + ;; only have when it's non-empty. + ,(let ((props + (filter-map + (match-lambda + [(? (compose internal-field? car)) #f] + + [(key vlines ...) + (remove null? + `(,(downcase-symbol key) + ,(parameters-tag (reduce assq-merge + '() (map parameters vlines))) + ,@(for vline in vlines + (vline->value-tag vline))))] + + [(key . vline) + (remove null? + `(,(downcase-symbol key) + ,(parameters-tag (parameters vline)) + ,(vline->value-tag vline)))]) + (properties component)))) + (unless (null? props) + `(properties ,@props))) + ,(unless (null? (children component)) + `(components ,@(map vcomponent->sxcal (children component))))))) + +(define-public (ns-wrap sxml) + `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) + ,sxml)) diff --git a/module/vcomponent/xcal/parse.scm b/module/vcomponent/xcal/parse.scm new file mode 100644 index 00000000..16e47e6f --- /dev/null +++ b/module/vcomponent/xcal/parse.scm @@ -0,0 +1,157 @@ +(define-module (vcomponent xcal parse) + :use-module (util) + :use-module (util exceptions) + :use-module (util base64) + :use-module (ice-9 match) + :use-module (sxml match) + :use-module (vcomponent) + :use-module (vcomponent geo) + :use-module (vcomponent parse types) + :use-module (datetime) + :use-module (srfi srfi-1) + ) + +;; symbol, ht, (list a) -> non-list +(define (handle-value type props value) + (case type + + [(binary) + ;; rfc6321 allows whitespace in binary + (base64-string->bytevector + (string-delete char-set:whitespace (car value)))] + + [(boolean) (string=? "true" (car value))] + + ;; TODO possibly trim whitespace on text fields + [(cal-address uri text unknown) (car value)] + + [(date) (parse-iso-date (car value))] + + [(date-time) (parse-iso-datetime (car value))] + + [(duration) + ((get-parser 'DURATION) props value)] + + [(float integer) ; (3.0) + (string->number (car value))] + + [(period) + (sxml-match + (cons 'period value) + [(period (start ,start-dt) (end ,end-dt)) + (cons (parse-iso-datetime start-dt) + (parse-iso-datetime end-dt))] + [(period (start ,start-dt) (duration ,duration)) + (cons (parse-iso-datetime start-dt) + ((@ (vcomponent duration) parse-duration) duration))])] + + [(recur) + (apply (@ (vcomponent recurrence internal) make-recur-rule) + (for (k v) in value + (list (symbol->keyword k) v)))] + + [(time) (parse-iso-time (car value))] + + [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] + + [(geo) ; ((long 1) (lat 2)) + (sxml-match + (cons 'geo value) + [(geo (latitude ,x) (longitude ,y)) + ((@ (vcomponent geo) make-geo) x y)])])) + +(define (symbol-upcase symb) + (-> symb + symbol->string + string-upcase + string->symbol)) + +(define (handle-parameters parameters) + + (define ht (make-hash-table)) + + (for param in parameters + (match param + [(ptag (ptype pvalue ...) ...) + ;; TODO parameter type (rfc6321 3.5.) + ;; TODO multi-valued parameters!!! + (hashq-set! ht (symbol-upcase ptag) (car (concatenate pvalue)))])) + ht) + +(define* (parse-enum str enum optional: (allow-other #t)) + (let ((symb (string->symbol str))) + (unless (memv symb enum) + (warning "~a ∉ { ~{~a~^, ~} }" symb enum)) + symb)) + + +;; symbol non-list -> non-list +(define (handle-tag tag-name data) + (case tag-name + [(request-status) + ;; TODO + (warning "Request status not yet implemented") + #f] + + ((transp) (parse-enum + data '(OPAQUE TRANSPARENT) #f)) + ((class) (parse-enum + data '(PUBLIC PRIVATE CONFIDENTIAL))) + ((partstat) (parse-enum + data '(NEEDS-ACTION ACCEPTED DECLINED TENTATIVE + DELEGATED IN-PROCESS))) + ((status) (parse-enum + data '(TENTATIVE CONFIRMED CANCELLED NEEDS-ACTION COMPLETED + IN-PROCESS DRAFT FINAL CANCELED))) + ((action) (parse-enum + data '(AUDIO DISPLAY EMAIL NONE))) + [else data])) + +(define-public (sxcal->vcomponent sxcal) + (define type (symbol-upcase (car sxcal))) + (define component (make-vcomponent type)) + + (awhen (assoc-ref sxcal 'properties) + ;; Loop over multi valued fields, creating one vline + ;; for every value. So + ;; KEY;p=1:a,b + ;; would be expanded into + ;; KEY;p=1:a + ;; KEY;p=1:b + (for property in it + (match property + ;; TODO request-status + + [(tag ('parameters parameters ...) + (type value ...) ...) + (let ((params (handle-parameters parameters)) + (tag* (symbol-upcase tag))) + (for (type value) in (zip type value) + ;; ignore empty fields + ;; mostly for + (unless (null? value) + (set! (prop* component tag*) + (make-vline tag* + (handle-tag + tag (handle-value type params value)) + params)))))] + + [(tag (type value ...) ...) + (for (type value) in (zip type value) + ;; ignore empty fields + ;; mostly for + (unless (null? value) + (let ((params (make-hash-table)) + (tag* (symbol-upcase tag))) + (set! (prop* component tag*) + (make-vline tag* + (handle-tag + tag (handle-value type params value)) + params)))))]))) + + ;; children + (awhen (assoc-ref sxcal 'components) + (for child in (map sxcal->vcomponent it) + (add-child! component child))) + + component) diff --git a/tests/xcal.scm b/tests/xcal.scm index f11ca1aa..33699016 100644 --- a/tests/xcal.scm +++ b/tests/xcal.scm @@ -1,5 +1,5 @@ -(((vcomponent parse xcal) sxcal->vcomponent) - ((vcomponent parse ical) parse-calendar) +(((vcomponent xcal parse) sxcal->vcomponent) + ((vcomponent ical parse) parse-calendar) ((output xcal) vcomponent->sxcal) ((util) ->) ((vcomponent base) -- cgit v1.2.3