aboutsummaryrefslogtreecommitdiff
path: root/module/vcomponent/xcal
diff options
context:
space:
mode:
Diffstat (limited to 'module/vcomponent/xcal')
-rw-r--r--module/vcomponent/xcal/output.scm133
-rw-r--r--module/vcomponent/xcal/parse.scm259
-rw-r--r--module/vcomponent/xcal/types.scm54
3 files changed, 0 insertions, 446 deletions
diff --git a/module/vcomponent/xcal/output.scm b/module/vcomponent/xcal/output.scm
deleted file mode 100644
index 70288cba..00000000
--- a/module/vcomponent/xcal/output.scm
+++ /dev/null
@@ -1,133 +0,0 @@
-(define-module (vcomponent xcal output)
- :use-module (calp util)
- :use-module (calp util exceptions)
- :use-module (vcomponent)
- :use-module (vcomponent geo)
- :use-module (vcomponent xcal types)
- :use-module (ice-9 match)
- :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 <properties> 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
- ;; NOTE
- ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME)))
- ,@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
deleted file mode 100644
index c6a2122f..00000000
--- a/module/vcomponent/xcal/parse.scm
+++ /dev/null
@@ -1,259 +0,0 @@
-(define-module (vcomponent xcal parse)
- :use-module (calp util)
- :use-module (calp util exceptions)
- :use-module (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)
- ;; TODO this is correct, but ensure remaining types
- (hashq-set! props '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)
- ;; RFC6221 (xcal) Appendix A 3.3.10 specifies that all components should
- ;; come in a specified order, and by extension that all components of the
- ;; same type should follow each other. Actually checking that is harder
- ;; than to just accept anything in any order. It would also make us less
- ;; robust for other implementations with other ideas.
- (let ((parse-value-of-that-type
- (lambda (type value)
- (case type
- ((wkst)
- ((@ (vcomponent recurrence parse)
- rfc->datetime-weekday)
- (string->symbol value)))
- ((freq) (string->symbol value))
- ((until)
- ;; RFC 6321 (xcal), p. 30 specifies type-until as
- ;; type-until = element until {
- ;; type-date |
- ;; type-date-time
- ;; }
- ;; but doesn't bother defining type-date[-time]...
- ;; This is acknowledged in errata 3315 [1], but
- ;; it lacks a solution...
- ;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16)
- ;; show the date as a direct string we will roll
- ;; with that here to.
- ;; [1]: https://www.rfc-editor.org/errata/eid3315
- (string->date/-time value))
- ((byday) ((@@ (vcomponent recurrence parse) parse-day-spec) value))
- ((count interval bysecond bymunite byhour
- bymonthday byyearday byweekno
- bymonth bysetpos)
- (string->number value))
- (else (throw
- 'key-error
- "Invalid type ~a, with value ~a"
- type value))))))
-
- ;; freq until count interval wkst
-
- (apply (@ (vcomponent recurrence internal) make-recur-rule)
- (concatenate
- (filter identity
- (for key in '(bysecond byminute byhour byday bymonthday
- byyearday byweekno bymonth bysetpos
- freq until count interval wkst)
- (define values (assoc-ref-all value key))
- (if (null? values)
- #f
- (case key
- ;; These fields all have zero or one value
- ((freq until count interval wkst)
- (list (symbol->keyword key)
- (parse-value-of-that-type
- key (car (map car values)))))
- ;; these fields take lists
- ((bysecond byminute byhour byday bymonthday
- byyearday byweekno bymonth bysetpos)
- (list (symbol->keyword key)
- (map (lambda (v) (parse-value-of-that-type key v))
- (map car values)))
- )
- (else (throw 'error)))))))))]
-
- [(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]))
-
-;; Note
-;; This doesn't verify the inter-field validity of the object,
-;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME
-;; are possibilities, which other parts of the code will crash on.
-;; TODO
-;; since we are feeding user input into this it really should be fixed.
-(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 <text/>
- (unless (null? value)
- (let ()
- (define vline
- (make-vline tag*
- (handle-tag
- tag (handle-value type params value))
- params))
- (if (memv tag* '(ATTACH ATTENDEE CATEGORIES
- COMMENT CONTACT EXDATE
- REQUEST-STATUS RELATED-TO
- RESOURCES RDATE
- ;; x-prop
- ;; iana-prop
- ))
- (aif (prop* component tag*)
- (set! (prop* component tag*) (cons vline it))
- (set! (prop* component tag*) (list vline)))
- ;; else
- (set! (prop* component tag*) vline))
- ))))]
-
- [(tag (type value ...) ...)
- (for (type value) in (zip type value)
- ;; ignore empty fields
- ;; mostly for <text/>
- (unless (null? value)
- (let ((params (make-hash-table))
- (tag* (symbol-upcase tag)))
- (define vline
- (make-vline tag*
- (handle-tag
- tag (let ((v (handle-value type params value)))
- ;; TODO possibly more list fields
- (if (eq? tag 'categories)
- (string-split v #\,)
- v)))
- params))
- ;;
-
- (if (memv tag* '(ATTACH ATTENDEE CATEGORIES
- COMMENT CONTACT EXDATE
- REQUEST-STATUS RELATED-TO
- RESOURCES RDATE
- ;; x-prop
- ;; iana-prop
- ))
- (aif (prop* component tag*)
- (set! (prop* component tag*) (cons vline it))
- (set! (prop* component tag*) (list vline)))
- ;; else
- (set! (prop* component tag*) vline))
- )))])))
-
- ;; children
- (awhen (assoc-ref sxcal 'components)
- (for child in (map sxcal->vcomponent it)
- (add-child! component child)))
-
- component)
diff --git a/module/vcomponent/xcal/types.scm b/module/vcomponent/xcal/types.scm
deleted file mode 100644
index 468400f4..00000000
--- a/module/vcomponent/xcal/types.scm
+++ /dev/null
@@ -1,54 +0,0 @@
-(define-module (vcomponent xcal types)
- :use-module (calp util)
- :use-module (vcomponent ical types)
- :use-module (datetime)
- )
-
-(define (write-boolean _ v)
- `(boolean ,(if v "true" "false")))
-
-(define (write-date _ v)
- `(date ,(date->string v "~Y-~m-~d")))
-
-(define (write-datetime p v)
- `(date-time
- ,(datetime->string
- (hashq-ref p '-X-HNH-ORIGINAL v)
- ;; 'Z' should be included for UTC,
- ;; other timezones MUST be specified
- ;; in the TZID parameter.
- "~Y-~m-~dT~H:~M:~S~Z")))
-
-(define (write-time _ v)
- `(time ,(time->string v "~H:~M:S")))
-
-(define (write-recur _ v)
- `(recur ,@((@@ (vcomponent recurrence internal) 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)
- ,(((@ (vcomponent ical types) 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)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-03 05:11:59 +0200