diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-06-25 22:36:45 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-06-25 22:36:45 +0200 |
commit | cafb91d173a0a552cc94441a41ec5f8c1cb9bc36 (patch) | |
tree | 8de4160603cd68ed695a607419f3fffc156579ee /module/output | |
parent | Fix GEO output. (diff) | |
download | calp-cafb91d173a0a552cc94441a41ec5f8c1cb9bc36.tar.gz calp-cafb91d173a0a552cc94441a41ec5f8c1cb9bc36.tar.xz |
Add xcal output!
Diffstat (limited to 'module/output')
-rw-r--r-- | module/output/sxml-types.scm | 53 | ||||
-rw-r--r-- | module/output/xcal.scm | 108 |
2 files changed, 161 insertions, 0 deletions
diff --git a/module/output/sxml-types.scm b/module/output/sxml-types.scm new file mode 100644 index 00000000..623ff9e8 --- /dev/null +++ b/module/output/sxml-types.scm @@ -0,0 +1,53 @@ +(define-module (output sxml-types) + :use-module (util) + :use-module (output types) + :use-module (datetime) + :use-module (datetime util) + ) + +(define (write-boolean _ v) + `(boolean ,(if v "true" "false"))) + +(define (write-date _ value) + `(date ,(date->string v "~Y-~m-~d"))) + +(define (write-datetime p v) + ;; TODO TZID? + (datetime->string + (hashq-ref p 'X-HNH-ORIGINAL v) + ;; TODO ~z? + "~Y-~m-~dT~H:~M:~S~Z")) + +(define (write-time _ v) + (time->string v "~H:~M:S")) + +(define (write-recur _ v) + `(recur ,@(recur-rule->rrule-sxml v))) + +;; sepparate since this text shouldn't be escaped +(define (write-text _ v) + ;; TODO out type should be xsd:string. + ;; Look into what that means, and escape + ;; from there + `(text ,v)) + + + +(define sxml-writers (make-hash-table)) +(for simple-type in '(BINARY DURATION CAL-ADDRESS DURATION FLOAT INTEGER + #| TODO PERIOD |# URI UTC-OFFSET) + (hashq-set! sxml-writers simple-type + (lambda (p v) + `(,(downcase-symbol simple-type) + ,((get-writer simple-type) p v))))) + +(hashq-set! sxml-writers 'BOOLEAN write-boolean) +(hashq-set! sxml-writers 'DATE write-date) +(hashq-set! sxml-writers 'DATE-TIME write-datetime) +(hashq-set! sxml-writers 'TIME write-time) +(hashq-set! sxml-writers 'RECUR write-recur) +(hashq-set! sxml-writers 'TEXT write-text) + +(define-public (get-writer type) + (or (hashq-ref sxml-writers type #f) + (error "No writer for type" type))) diff --git a/module/output/xcal.scm b/module/output/xcal.scm new file mode 100644 index 00000000..554955c5 --- /dev/null +++ b/module/output/xcal.scm @@ -0,0 +1,108 @@ +(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 (datetime util) + ) + + +(define (vline->value-tag vline) + (define key (vline-key vline)) + + (define writer + (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)) + (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-public (vcomponent->sxml component) + `(,(downcase-symbol (type component)) + (properties + ,@(hash-map->list + (match-lambda* + [(? (compose internal-field? car)) '()] + + ;; TODO parameters + + [(key (vlines ...)) + `(,(downcase-symbol key) + #; + ,(unless (null? (properties vline)) + `(parameters + ,@(map vline->value-tag (properties vline)))) + ,@(for vline in vlines + (vline->value-tag vline)))] + + [(key vline) + `(,(downcase-symbol key) + #; + ,(unless (null? (properties vline)) + `(parameters + ,@(map vline->value-tag (properties vline)))) + ,(vline->value-tag vline))]) + (attributes component))) + (components ,@(map vcomponent->sxml (children component))))) + +(define-public (main calendar) + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) + ,(vcomponent->sxml calendar)))) |