From 3cfa27e710514207a45919fd03a9ddba75b5c2fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 25 Jun 2020 18:09:39 +0200 Subject: ICS writer now handles types and parameters. --- module/output/ical.scm | 164 ++++++++++++++++++++++++++++--------------------- 1 file changed, 95 insertions(+), 69 deletions(-) (limited to 'module/output/ical.scm') diff --git a/module/output/ical.scm b/module/output/ical.scm index fd4091ed..7773cce7 100644 --- a/module/output/ical.scm +++ b/module/output/ical.scm @@ -14,69 +14,85 @@ :use-module (datetime zic) :use-module (glob) :use-module (vcomponent recurrence) + :use-module (output types) ) +;; TODO this is also defined @ (vcomponent parse component) +(define (x-property? symb) + (string=? "X-" (string-take (symbol->string symb) 2))) + ;; Format value depending on key type. ;; Should NOT emit the key. (define (value-format key vline) - (define (handle-value value) - (catch #t #; 'wrong-type-arg - (lambda () - (case key - ((DTSTART DTEND RECURRENCE-ID DTSTAMP - LAST-MODIFIED EXDATE) - (with-output-to-string - (lambda () - (case (and=> (prop vline 'VALUE) car) - [(DATE) (display (date->string (as-date value) - "~Y~m~d"))] - [else ; (DATE-TIME) - (display (datetime->string value "~Y~m~dT~H~M~S")) - (let ((tz (and=> (prop vline 'TZID) car))) - (when (and tz (string= tz "UTC")) - (display #\Z)))])))) - - [(TZOFFSETFROM TZOFFSETTO) - (with-output-to-string - (lambda () - (display (if (time-zero? (timespec-time value)) - '+ (timespec-sign value))) - (display (time->string (timespec-time value) "~H~M")) - (when (not (zero? (second (timespec-time value)))) - (display (time->string (timespec-time value) "~S")))))] - - [(RRULE) - ((@ (vcomponent recurrence internal) - recur-rule->rrule-string) value)] - - (else - (escape-chars value) - ))) - (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 - ))) - - (if (list? (value vline)) - (format #f "~{~a~^,~}" - (map handle-value (value vline))) - (handle-value (value vline)))) - -(define (escape-chars str) - (define (escape char) - (string #\\ char)) - (string-concatenate - (map (lambda (c) - (case c - ((#\newline) "\\n") - ((#\, #\; #\\) => escape) - (else => string))) - (string->list str)))) + (define writer + ;; fields which can hold lists need not be considered here, + ;; since they are split into multiple vlines when we parse them. + (cond + [(and=> (prop vline 'VALUE) string->symbol) => 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)) + (error "Fuck you")] + + [(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))) (define (generate-uuid) ((@ (rnrs io ports) call-with-port) @@ -102,6 +118,26 @@ (string-take-to (symbol->string symbol) (string-length prefix)))) +(define (->string a) + (with-output-to-string (lambda () (display a)))) + +(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 (get-writer 'TEXT) ->string) values) + "," 'infix))]) + (properties vline))) + ":" (value-format key vline)))) + (define-public (component->ical-string component) (format #t "BEGIN:~a\r\n" (type component)) ;; TODO this leaks internal information, @@ -115,21 +151,11 @@ [(key (vlines ...)) (for vline in vlines - (display - (ical-line-fold - ;; Expected output: key;p1=v;p3=10:value - (format #f "~a~:{;~a=~@{~a~^,~}~}:~a" - key (properties vline) - (value-format key vline)))) + (display (vline->string vline)) (display "\r\n"))] [(key vline) - (display - (ical-line-fold - ;; Expected output: key;p1=v;p3=10:value - (format #f "~a~:{;~a=~@{~a~^,~}~}:~a" - key (properties vline) - (value-format key vline)))) + (display (vline->string vline)) (display "\r\n")]) (attributes component)) (for-each component->ical-string (children component)) -- cgit v1.2.3