From cafb91d173a0a552cc94441a41ec5f8c1cb9bc36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 25 Jun 2020 22:36:45 +0200 Subject: Add xcal output! --- module/output/sxml-types.scm | 53 +++++++++++++++ module/output/xcal.scm | 108 ++++++++++++++++++++++++++++++ module/vcomponent/recurrence/internal.scm | 68 ++++++++++++------- 3 files changed, 204 insertions(+), 25 deletions(-) create mode 100644 module/output/sxml-types.scm create mode 100644 module/output/xcal.scm 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)))) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index b15ce90e..8c295bb9 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -82,36 +82,54 @@ (datetime) (srfi srfi-1)) -(define-public (recur-rule->rrule-string rrule) +(define (field->string field value) + (case field + [(wkst) + (string-upcase + (week-day-name value 2 + locale: (make-locale (list LC_TIME) "C")))] + [(byday) + (string-join (map byday->string value) ",")] + [(freq count interval) + (format #f "~a" value)] + [(until) + (if (date? value) + (date->string value "~Y~m~d") + (datetime->string value "~Y~m~dT~H~M~S~Z"))] + [else (format #f "~{~a~^,~}" value)])) + +(define (map-fields proc rrule) (define (get f) ((record-accessor f) rrule)) + (filter-map + (lambda (field) + (if (not (get field)) + #f (proc field (get field)))) + (record-type-fields ))) + +(define-public (recur-rule->rrule-string rrule) (string-join - (filter-map - (lambda (field) - (if (not (get field)) - #f - (string-append - (string-upcase (symbol->string field)) - "=" - (case field - [(wkst) - (string-upcase - (week-day-name (get field) 2 - locale: (make-locale (list LC_TIME) "C")))] - [(byday) - (string-join (map byday->string (get field)) ",")] - [(freq count interval) - (format #f "~a" (get field))] - [(until) - (let ((o (get field))) - (if (date? o) - (date->string o "~Y~m~d") - (datetime->string o "~Y~m~dT~H~M~S~Z") - ))] - [else (format #f "~{~a~^,~}" (get field))])))) - (record-type-fields )) + (map-fields + (lambda (field value) + (string-append + (string-upcase (symbol->string field)) + "=" (field->string field value))) + rrule) ";")) +(define (downcase-symbol symb) + (-> symb + symbol->string + string-downcase + string->symbol)) + +(define-public (recur-rule->rrule-sxml rrule) + (map-fields + (lambda (field value) + `(,(downcase-symbol field) + ,(field->string filed value))) + rrule)) + -- cgit v1.2.3