diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-06-25 18:09:39 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-06-25 18:25:33 +0200 |
commit | 3cfa27e710514207a45919fd03a9ddba75b5c2fb (patch) | |
tree | 9cc342b1363da551a6993a8ba308802cd42fab54 | |
parent | Merge UTC-OFFSET and TIMESPEC into one. (diff) | |
download | calp-3cfa27e710514207a45919fd03a9ddba75b5c2fb.tar.gz calp-3cfa27e710514207a45919fd03a9ddba75b5c2fb.tar.xz |
ICS writer now handles types and parameters.
-rw-r--r-- | module/output/ical.scm | 164 | ||||
-rw-r--r-- | module/output/types.scm | 103 |
2 files changed, 198 insertions, 69 deletions
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)) diff --git a/module/output/types.scm b/module/output/types.scm new file mode 100644 index 00000000..08ac878a --- /dev/null +++ b/module/output/types.scm @@ -0,0 +1,103 @@ +;; see (vcomponent parse types) +(define-module (output types) + :use-module (util) + :use-module (util exceptions) + :use-module (util base64) + :use-module (datetime) + :use-module (datetime util) + :use-module (rnrs io ports)) + + +(define (write-binary _ value) + (bytevector->string (bytevector->base64 value) + (make-transcoder (latin-1-codec)))) + +(define (write-boolean _ value) + (if value "TRUE" "FALSE")) + +(define (write-date _ value) + (date->string value "~Y~m~d")) + +(define (write-datetime prop value) + (datetime->string (hashq-ref prop 'X-HNH-ORIGINAL value) + ;; TODO ~Z ? + "~Y~m~dT~H~M~S~Z" + #; + (let ((tz (and=> (prop vline 'TZID) car))) + (when (and tz (string= tz "UTC")) + (display #\Z))))) + +;; TODO +(define (write-duration _ value) + (warning "DURATION writer not yet implemented") + (with-output-to-string + (lambda () (write value)))) + +(define (write-float _ value) + (number->string value)) + +(define (write-integer _ value) + (number->string value)) + +;; TODO +(define (write-period _ value) + (warning "PERIOD writer not yet implemented") + (with-output-to-string + (lambda () (write value)))) + +(define (write-recur _ value) + ((@ (vcomponent recurrence internal) + recur-rule->rrule-string) value)) + +(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 (write-text _ value) + (escape-chars value)) + +(define (write-time _ value) + (time->string value "~H~M~S")) + +(define (write-uri _ value) + value) + + +(use-modules (datetime timespec)) + +(define (write-utc-offset _ value) + (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")))))) + + +(define type-writers (make-hash-table)) +(hashq-set! type-writers 'BINARY write-binary) +(hashq-set! type-writers 'BOOLEAN write-boolean) +(hashq-set! type-writers 'CAL-ADDRESS write-uri) +(hashq-set! type-writers 'DATE write-date) +(hashq-set! type-writers 'DATE-TIME write-datetime) +(hashq-set! type-writers 'DURATION write-duration) +(hashq-set! type-writers 'FLOAT write-float) +(hashq-set! type-writers 'INTEGER write-integer) +(hashq-set! type-writers 'PERIOD write-period) +(hashq-set! type-writers 'RECUR write-recur) +(hashq-set! type-writers 'TEXT write-text) +(hashq-set! type-writers 'TIME write-time) +(hashq-set! type-writers 'URI write-uri) +(hashq-set! type-writers 'UTC-OFFSET write-utc-offset) + +(define-public (get-writer type) + (or (hashq-ref type-writers type #f) + (error "No writer for type" type))) |