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/vcomponent/xcal/output.scm | 131 +++++++++++++++++++++++++++++++ module/vcomponent/xcal/parse.scm | 157 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 288 insertions(+) create mode 100644 module/vcomponent/xcal/output.scm create mode 100644 module/vcomponent/xcal/parse.scm (limited to 'module/vcomponent/xcal') 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) -- cgit v1.2.3