From d00fea566004e67161ee45246b239fff5d416b0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 21 Dec 2021 16:17:28 +0100 Subject: Cleanup modules. Primarly this moves all vcompenent input and output code to clearly labeled modules, instead of being spread out. At the same time it also removes a handfull of unused procedures. --- module/vcomponent/formats/common/types.scm | 139 ++++++++++ module/vcomponent/formats/ical/output.scm | 234 +++++++++++++++++ module/vcomponent/formats/ical/parse.scm | 336 +++++++++++++++++++++++++ module/vcomponent/formats/ical/types.scm | 95 +++++++ module/vcomponent/formats/vdir/parse.scm | 123 +++++++++ module/vcomponent/formats/vdir/save-delete.scm | 40 +++ module/vcomponent/formats/xcal/output.scm | 133 ++++++++++ module/vcomponent/formats/xcal/parse.scm | 259 +++++++++++++++++++ module/vcomponent/formats/xcal/types.scm | 54 ++++ 9 files changed, 1413 insertions(+) create mode 100644 module/vcomponent/formats/common/types.scm create mode 100644 module/vcomponent/formats/ical/output.scm create mode 100644 module/vcomponent/formats/ical/parse.scm create mode 100644 module/vcomponent/formats/ical/types.scm create mode 100644 module/vcomponent/formats/vdir/parse.scm create mode 100644 module/vcomponent/formats/vdir/save-delete.scm create mode 100644 module/vcomponent/formats/xcal/output.scm create mode 100644 module/vcomponent/formats/xcal/parse.scm create mode 100644 module/vcomponent/formats/xcal/types.scm (limited to 'module/vcomponent/formats') diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm new file mode 100644 index 00000000..87425c01 --- /dev/null +++ b/module/vcomponent/formats/common/types.scm @@ -0,0 +1,139 @@ +(define-module (vcomponent formats common types) + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (base64) + :use-module (datetime) + :use-module (srfi srfi-9 gnu) + :use-module (datetime timespec) + ) + +;; BINARY +(define (parse-binary props value) + ;; p 30 + (unless (string=? "BASE64" (hashq-ref props 'ENCODING)) + (warning "Binary field not marked ENCODING=BASE64")) + + ;; For icalendar no extra whitespace is allowed in a + ;; binary field (except for line wrapping). This differs + ;; from xcal. + (base64-string->bytevector value)) + +;; BOOLEAN +(define (parse-boolean props value) + (cond + [(string=? "TRUE" value) #t] + [(string=? "FALSE" value) #f] + [else (warning "~a invalid boolean" value)])) + +;; CAL-ADDRESS ⇒ uri + +;; DATE +(define (parse-date props value) + (parse-ics-date value)) + +;; DATE-TIME +(define (parse-datetime props value) + (define parsed + (parse-ics-datetime + value (hashq-ref props 'TZID #f))) + (hashq-set! props '-X-HNH-ORIGINAL parsed) + (get-datetime parsed)) + +;; DURATION +(define (parse-duration props value) + ((@ (vcomponent duration) parse-duration) + value)) + +;; FLOAT +;; Note that this is overly permissive, and flawed. +;; Numbers such as @expr{1/2} is accepted as exact +;; rationals. Some floats are rounded. +(define (parse-float props value) + (string->number value)) + + +;; INTEGER +(define (parse-integer props value) + (let ((n (string->number value))) + (unless (integer? n) + (warning "Non integer as integer")) + n)) + +;; PERIOD +(define (parse-period props value) + (let* (((left right) (string-split value #\/))) + ;; TODO timezones? VALUE=DATE? + (cons (parse-ics-datetime left) + ((if (memv (string-ref right 0) + '(#\P #\+ #\-)) + (@ (vcomponent duration) parse-duration) + parse-ics-datetime) + right)))) + +;; RECUR +(define (parse-recur props value) + ((@ (vcomponent recurrence parse) parse-recurrence-rule) value)) + +;; TEXT +;; TODO quoted strings +(define (parse-text props value) + (let loop ((rem (string->list value)) + (str '()) + (done '())) + (if (null? rem) + (cons (reverse-list->string str) done) + (case (car rem) + [(#\\) + (case (cadr rem) + [(#\n #\N) (loop (cddr rem) (cons #\newline str) done)] + [(#\; #\, #\\) => (lambda (c) (loop (cddr rem) (cons c str) done))] + [else => (lambda (c) (warning "Non-escapable character: ~a" c) + (loop (cddr rem) str done))])] + [(#\,) + (loop (cdr rem) '() (cons (reverse-list->string str) done))] + [else + (loop (cdr rem) (cons (car rem) str) done)])))) + + +;; TIME +(define (parse-time props value) + ;; TODO time can have timezones... + (parse-ics-time value)) + +;; URI +(define (parse-uri props value) + value) + +;; UTC-OFFSET +(define (parse-utc-offset props value) + (make-timespec + (time + hour: (string->number (substring value 1 3)) + minute: (string->number (substring value 3 5)) + second: (if (= 7 (string-length value)) + (string->number (substring value 5 7)) + 0)) + ;; sign + (string->symbol (substring value 0 1)) + #\z)) + + +(define type-parsers (make-hash-table)) +(hashq-set! type-parsers 'BINARY parse-binary) +(hashq-set! type-parsers 'BOOLEAN parse-boolean) +(hashq-set! type-parsers 'CAL-ADDRESS parse-uri) +(hashq-set! type-parsers 'DATE parse-date) +(hashq-set! type-parsers 'DATE-TIME parse-datetime) +(hashq-set! type-parsers 'DURATION parse-duration) +(hashq-set! type-parsers 'FLOAT parse-float) +(hashq-set! type-parsers 'INTEGER parse-integer) +(hashq-set! type-parsers 'PERIOD parse-period) +(hashq-set! type-parsers 'RECUR parse-recur) +(hashq-set! type-parsers 'TEXT parse-text) +(hashq-set! type-parsers 'TIME parse-time) +(hashq-set! type-parsers 'URI parse-uri) +(hashq-set! type-parsers 'UTC-OFFSET parse-utc-offset) + +(define-public (get-parser type) + (or (hashq-ref type-parsers type #f) + (error "No parser for type" type))) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm new file mode 100644 index 00000000..9efac3c4 --- /dev/null +++ b/module/vcomponent/formats/ical/output.scm @@ -0,0 +1,234 @@ +(define-module (vcomponent formats ical output) + :use-module (calp util exceptions) + :use-module (calp util) + :use-module (datetime) + :use-module (datetime zic) + :use-module ((datetime instance) :select (zoneinfo)) + :use-module (glob) + :use-module (ice-9 format) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (vcomponent) + :use-module (vcomponent datetime) + :use-module (vcomponent geo) + :use-module (vcomponent formats ical types) + :use-module (vcomponent recurrence) + :autoload (vcomponent util instance) (global-event-object) + ) + +(define (prodid) + (format #f "-//hugo//calp ~a//EN" + (@ (calp) version))) + + +;; Format value depending on key type. +;; Should NOT emit the key. +(define (value-format key vline) + + (define writer + ;; fields which can hold lists need not be considered here, + ;; since they are split into multiple vlines when we parse them. + (cond + ;; TODO parameters return? One or many‽ + [(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 '(CATEGORIES RESOURCES)) + (lambda (p v) + (string-join (map (lambda (v) ((get-writer 'TEXT) p v)) + v) + ","))] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID + + 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) + (define fl (get-writer 'FLOAT)) + (format #f "~a:~a" + (fl (geo-latitude v)) + (fl (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)])) + + (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))) + + +;; Fold long lines to limit width. +;; Since this works in characters, but ics works in bytes +;; this will overshoot when faced with multi-byte characters. +;; But since the line wrapping is mearly a recomendation it's +;; not a problem. +;; Setting the wrap-len to slightly lower than allowed also help +;; us not overshoot. +(define* (ical-line-fold string #:key (wrap-len 70)) + (cond [(< wrap-len (string-length string)) + (format #f "~a\r\n ~a" + (string-take string wrap-len) + (ical-line-fold (string-drop string wrap-len)))] + [else string])) + + + +(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 escape-chars ->string) values) + "," 'infix))]) + (parameters vline))) + ":" (value-format key vline)))) + +(define-public (component->ical-string component) + (format #t "BEGIN:~a\r\n" (type component)) + (for-each + ;; Special cases depending on key. + ;; Value formatting is handled in @code{value-format}. + (match-lambda + + [(? (compose internal-field? car)) 'noop] + + [(key vlines ...) + (for vline in vlines + (display (vline->string vline)) + (display "\r\n"))] + + [(key . vline) + (display (vline->string vline)) + (display "\r\n")]) + (properties component)) + (for-each component->ical-string (children component)) + (format #t "END:~a\r\n" (type component)) + + ;; If we have alternatives, splice them in here. + (cond [(prop component '-X-HNH-ALTERNATIVES) + => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) + alts))])) + + + +(define (print-header) + (format #t +"BEGIN:VCALENDAR\r +PRODID:~a\r +VERSION:2.0\r +CALSCALE:GREGORIAN\r +" (prodid) +)) + + +(define (print-footer) + (format #t "END:VCALENDAR\r\n")) + +(define (get-tz-names events) + (lset-difference + equal? (lset-union + equal? '("dummy") + (filter-map + (lambda (vline) (and=> (param vline 'TZID) car)) + (filter-map (extract* 'DTSTART) + events))) + '("dummy" "local"))) + + +(define-public (print-components-with-fake-parent events) + + ;; The events are probably sorted before, but until I can guarantee + ;; that we sort them again here. We need them sorted from earliest + ;; and up to send the earliest to zoneinfo->vtimezone + (set! events (sort* events date/-time<=? (extract 'DTSTART))) + + (print-header) + + (when (provided? 'zoneinfo) + (let ((tz-names (get-tz-names events))) + (for-each component->ical-string + ;; TODO we realy should send the earliest event from each timezone here, + ;; instead of just the first. + (map (lambda (name) (zoneinfo->vtimezone + (zoneinfo) + name (car events))) + tz-names)))) + + (for-each component->ical-string events) + + (print-footer)) + + +(define-public (print-all-events) + (print-components-with-fake-parent + (append (get-fixed-events global-event-object) + ;; TODO RECCURENCE-ID exceptions + ;; We just dump all repeating objects, since it's much cheaper to do + ;; it this way than to actually figure out which are applicable for + ;; the given date range. + (get-repeating-events global-event-object)))) + +(define-public (print-events-in-interval start end) + (print-components-with-fake-parent + (append (fixed-events-in-range start end) + ;; TODO RECCURENCE-ID exceptions + ;; We just dump all repeating objects, since it's much cheaper to do + ;; it this way than to actually figure out which are applicable for + ;; the given date range. + (get-repeating-events global-event-object)))) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm new file mode 100644 index 00000000..d76044a3 --- /dev/null +++ b/module/vcomponent/formats/ical/parse.scm @@ -0,0 +1,336 @@ +(define-module (vcomponent formats ical parse) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (calp util exceptions) + :use-module (calp util) + :use-module (datetime) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + :use-module (srfi srfi-9 gnu) + :use-module (vcomponent base) + :use-module (vcomponent geo) + :use-module (vcomponent formats common types) + ) + +(define string->symbol + (let ((ht (make-hash-table 1000))) + (lambda (str) + (or (hash-ref ht str) + (let ((symb ((@ (guile) string->symbol) str))) + (hash-set! ht str symb) + symb))))) + +;; TODO rename to parse-vcomponent, or parse-ical (?). +(define-public (parse-calendar port) + (parse (map tokenize (read-file port)))) + +(define-immutable-record-type + (make-line string file line) + line? + (string get-string) + (file get-file) + (line get-line)) + + +;; port → (list ) +(define (read-file port) + (define fname (port-filename port)) + (let loop ((line-number 1) (done '())) + (let ((ostr (open-output-string))) + (define ret + (let loop ((line (read-line port))) + (if (eof-object? line) + 'eof + (let ((line (string-trim-right line #\return))) + (let ((next (peek-char port))) + (display line ostr) + (cond ((eof-object? next) + 'final-line) + ;; Line Wrapping + ;; If the first character on a line is space (whitespace?) + ;; then it's a continuation line, and should be merged + ;; with the one preceeding it. + ;; TODO if the line is split inside a unicode character + ;; then this produces multiple broken unicode characters. + ;; It could be solved by checking the start of the new line, + ;; and the tail of the old line for broken char + ;; TODO what about other leading whitespace? + ((char=? next #\space) + (read-char port) ; discard leading whitespace + (loop (read-line port))) + (else + ;; (unread-char next) + 'line))))))) + (case ret + ((line) + (let ((str (get-output-string ostr))) + (close-port ostr) + (loop (1+ line-number) + (cons (make-line str fname line-number) + done)))) + ((eof) + (close-port ostr) + (reverse! done)) + ((final-line) + (let ((str (get-output-string ostr))) + (close-port ostr) + (reverse! (cons (make-line str fname line-number) + done)))))))) + +(define-immutable-record-type + (make-tokens metadata data) + tokens? + (metadata get-metadata) ; + (data get-data) ; (key kv ... value) + ) + +;; → +(define (tokenize line-obj) + (define line (get-string line-obj)) + (define colon-idx (string-index line #\:)) + (define semi-idxs + (let loop ((idx 0)) + (aif (string-index line #\; idx colon-idx) + (cons it (loop (1+ it))) + (list colon-idx (string-length line))))) + (make-tokens + line-obj + (map (lambda (start end) + (substring line (1+ start) end)) + (cons -1 semi-idxs) + semi-idxs))) + + +#; +'(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + ) + +(define (list-parser symbol) + (let ((parser (get-parser symbol))) + (lambda (params value) + (map (lambda (v) (parser params v)) + (string-split value #\,))))) + +(define* (enum-parser enum optional: (allow-other #t)) + (let ((parser (compose car (get-parser 'TEXT)))) + (lambda (params value) + (let ((vv (parser params value))) + (when (list? vv) + (throw 'parse-error "List in enum field")) + (let ((v (string->symbol vv))) + (unless (memv v enum) + (warning "~a ∉ { ~{~a~^, ~} }" + v enum)) + v))))) + +;; params could be made optional, with an empty hashtable as default +(define (build-vline key value params) + (let ((parser + (cond + [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] + + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE + CREATED DTSTAMP LAST-MODIFIED + ;; only on VALARM + ACKNOWLEDGED + )) + (get-parser 'DATE-TIME)] + + [(memv key '(EXDATE)) + (list-parser 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-parser 'DURATION)] + + [(memv key '(FREEBUSY)) + (list-parser 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID)) + (lambda (params value) + (let ((v ((get-parser 'TEXT) params value))) + (unless (= 1 (length v)) + (warning "List in non-list field: ~s" v)) + (string-join v ",")))] + + ;; TEXT, but allow a list + [(memv key '(CATEGORIES RESOURCES)) + ;; TODO An empty value should lead to an empty set + ;; currently it seems to lead to '("") + (get-parser 'TEXT)] + + [(memv key '(VERSION)) + (lambda (params value) + (let ((v (car ((get-parser 'TEXT) params value)))) + (unless (and (string? v) (string=? "2.0" v)) + #f + ;; (warning "File of unsuported version. Proceed with caution") + ) + v))] + + [(memv key '(TRANSP)) + (enum-parser '(OPAQUE TRANSPARENT) #f)] + + [(memv key '(CLASS)) + (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))] + + [(memv key '(PARTSTAT)) + (enum-parser '(NEEDS-ACTION + ACCEPTED DECLINED + TENTATIVE DELEGATED + IN-PROCESS))] + + [(memv key '(STATUS)) + (enum-parser '(TENTATIVE + CONFIRMED CANCELLED + NEEDS-ACTION COMPLETED IN-PROCESS + DRAFT FINAL CANCELED))] + + [(memv key '(REQUEST-STATUS)) + (throw 'parse-error "TODO Implement REQUEST-STATUS")] + + [(memv key '(ACTION)) + (enum-parser '(AUDIO DISPLAY EMAIL + NONE ; I don't know where NONE is from + ; but it appears to be prevelant. + ))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-parser 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-parser 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-parser 'INTEGER)] + + [(memv key '(GEO)) + ;; two semicolon sepparated floats + (lambda (params value) + (let* (((left right) (string-split value #\;))) + (make-geo ((get-parser 'FLOAT) params left) + ((get-parser 'FLOAT) params right))))] + + [(memv key '(RRULE)) + (get-parser 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-parser 'CAL-ADDRESS)] + + [(x-property? key) + (compose car (get-parser 'TEXT))] + + [else + (warning "Unknown key ~a" key) + (compose car (get-parser 'TEXT))]))) + + ;; If we produced a list create multiple VLINES from it. + ;; NOTE that the created vlines share parameter tables. + ;; TODO possibly allow vlines to reference each other, to + ;; indicate that all these vlines are the same. + (let ((parsed (parser params value))) + (if (list? parsed) + (apply values + (map (lambda (p) (make-vline key p params)) + parsed)) + (make-vline key parsed params))))) + +;; (parse-itemline '("DTEND" "20200407T130000")) +;; => DTEND +;; => "20200407T130000" +;; => # +(define (parse-itemline itemline) + (define key (string->symbol (car itemline))) + (define parameters (make-hash-table)) + (let loop ((rem (cdr itemline))) + (if (null? (cdr rem)) + (values key (car rem) parameters ) + (let* ((kv (car rem)) + (idx (string-index kv #\=))) + ;; TODO lists in parameters + (hashq-set! parameters (string->symbol (substring kv 0 idx)) + (substring kv (1+ idx))) + (loop (cdr rem)))))) + + +;; (list ) → +(define (parse lst) + (let loop ((lst lst) + (stack '())) + (if (null? lst) + stack + (let* ((head* (car lst)) + (head (get-data head*))) + (catch 'parse-error + (lambda () + (parameterize + ((warning-handler + (lambda (fmt . args) + (let ((linedata (get-metadata head*))) + (format + #f "WARNING parse error around ~a + ~? + line ~a ~a~%" + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata) + ))))) + (cond [(string=? "BEGIN" (car head)) + (loop (cdr lst) + (cons (make-vcomponent (string->symbol (cadr head))) + stack))] + [(string=? "END" (car head)) + (loop (cdr lst) + (if (null? (cdr stack)) + ;; return + (car stack) + (begin (add-child! (cadr stack) (car stack)) + (cdr stack))))] + [else + (let* ((key value params (parse-itemline head))) + (call-with-values (lambda () (build-vline key value params)) + (lambda vlines + (for vline in vlines + (define key (vline-key vline)) + + (set! (vline-source vline) + (get-metadata head*)) + + ;; See RFC 5545 p.53 for list of all repeating types + ;; (for vcomponent) + (if (memv key '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* (car stack) key) + (set! (prop* (car stack) key) (cons vline it)) + (set! (prop* (car stack) key) (list vline))) + ;; else + (set! (prop* (car stack) key) vline)))))) + + (loop (cdr lst) stack)]))) + (lambda (err fmt . args) + (let ((linedata (get-metadata head*))) + (display (format + #f "ERROR parse error around ~a + ~? + line ~a ~a + Defaulting to string~%" + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata)) + (current-error-port)) + (let* ((key value params (parse-itemline head))) + (set! (prop* (car stack) key) + (make-vline key value params)) + (loop (cdr lst) stack))))))))) diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm new file mode 100644 index 00000000..d063ca8f --- /dev/null +++ b/module/vcomponent/formats/ical/types.scm @@ -0,0 +1,95 @@ +;; see (vcomponent parse types) +(define-module (vcomponent formats ical types) + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (base64) + :use-module (datetime) + :use-module (datetime timespec)) + +;; TODO shouldn't these really take vline:s? + +(define (write-binary _ value) + (bytevector->base64-string value)) + +(define (write-boolean _ value) + (if value "TRUE" "FALSE")) + +(define (write-date _ value) + (date->string value "~Y~m~d")) + +(define (write-datetime param value) + ;; NOTE We really should output TZID from param here, but + ;; we first need to change so these writers can output + ;; parameters. + (datetime->string (hashq-ref param '-X-HNH-ORIGINAL value) + "~Y~m~dT~H~M~S~Z")) + +(define (write-duration _ value) + ((@ (vcomponent duration) format-duration) 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-public (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) + + +(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))) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm new file mode 100644 index 00000000..f3810887 --- /dev/null +++ b/module/vcomponent/formats/vdir/parse.scm @@ -0,0 +1,123 @@ +;;; Commentary: +;; Code for parsing vdir's and icalendar files. +;; This module handles the finding of files, while +;; (vcomponent formats parse ical) handles reading data from icalendar files. +;;; Code: + +(define-module (vcomponent formats vdir parse) + :use-module (srfi srfi-1) + + :use-module ((ice-9 hash-table) :select (alist->hash-table)) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module ((ice-9 ftw) :select (scandir ftw)) + + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (vcomponent base) + + :use-module (vcomponent formats ical parse) + ) + + + + +;; All VTIMEZONE's seem to be in "local" time in relation to +;; themselves. Therefore, a simple comparison should work, +;; and then the TZOFFSETTO properties can be subtd. +(define-public (parse-vdir path) + ;; TODO empty files here cause "#" to appear in the output XML, which is *really* bad. + (let ((color + (catch 'system-error + (lambda () (call-with-input-file (path-append path "color") read-line)) + (const "#FFFFFF"))) + (name + (catch 'system-error + (lambda () (call-with-input-file (path-append path "displayname") read-line)) + (const #f)))) + + (reduce (lambda (item calendar) + + (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) + (children item))) + + + ;; (assert (eq? 'VCALENDAR (type calendar))) + (assert (eq? 'VCALENDAR (type item))) + + (for child in (children item) + (set! (prop child '-X-HNH-FILENAME) + (prop (parent child) '-X-HNH-FILENAME))) + + ;; NOTE The vdir standard says that each file should contain + ;; EXACTLY one event. It can however contain multiple VEVENT + ;; components, but they are still the same event. + ;; In our case this means exceptions to reccurence rules, which + ;; is set up here, and then later handled in rrule-generate. + ;; NOTE These events also share UID, but are diferentiated + ;; by RECURRENCE-ID. As far as I can tell this goes against + ;; the standard. Section 3.8.4.4. + (case (length events) + [(0) (warning "No events in component~%~a" + (prop item '-X-HNH-FILENAME))] + [(1) + (let ((child (car events))) + (assert (memv (type child) '(VTIMEZONE VEVENT))) + (add-child! calendar child))] + + ;; two or more + [else + ;; Sequence numbers on their own specifies revisions of a + ;; single compenent, incremented by a central authorative + ;; source. In that case simply picking the version with the + ;; highest SEQUENCE number would suffice. However, for + ;; recurring events where each instance is its own VEVENT + ;; they also signify something. + ;; TODO Neither version is handled here (or anywhere else). + + + ;; Multiple VEVENT objects can share a UID if they have + ;; different RECURRENCE-ID fields. This signifies that they + ;; are instances of the same event, similar to RDATE. + ;; Here we first check if we have a component which contains + ;; an RRULE or lacks a RECURRENCE-ID, and uses that as base. + ;; Otherwise we just take the first component as base. + ;; + ;; All alternatives (and the base) is added the the -X-HNH-ALTERNATIVES + ;; property of the base object, to be extracted where needed. + (let* ((head (or (find (extract 'RRULE) events) + (find (negate (extract 'RECURRENCE-ID)) events) + (car events))) + (rest (delete head events eq?))) + + (set! (prop head '-X-HNH-ALTERNATIVES) + (alist->hash-table + (map cons + ;; head is added back to the collection to simplify + ;; generation of recurrences. The recurrence + ;; generation assumes that the base event either + ;; contains an RRULE property, OR is in the + ;; -X-HNH-ALTERNATIVES set. This might produce + ;; duplicates, since the base event might also + ;; get included through an RRULE. This however + ;; is almost a non-problem, since RDATES and RRULES + ;; can already produce duplicates, meaning that + ;; we need to filter duplicates either way. + (map (extract 'RECURRENCE-ID) (cons head rest)) + (cons head rest)))) + (add-child! calendar head))]) + + ;; return + calendar) + (make-vcomponent) + (map #; (@ (ice-9 threads) par-map) + (lambda (fname) + (let ((fullname (path-append path fname))) + (let ((cal (call-with-input-file fullname + parse-calendar))) + (set! (prop cal 'COLOR) color + (prop cal 'NAME) name + (prop cal '-X-HNH-FILENAME) fullname) + cal))) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3))))))))) + diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm new file mode 100644 index 00000000..1c70dabf --- /dev/null +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -0,0 +1,40 @@ +;;; Commentary: +;;; Module for writing components to the vdir storage format. +;;; Currently also has some cases for "big" icalendar files, +;;; but those are currently unsupported. + +;;; TODO generalize save-event and remove-event into a general interface, +;;; which different database backends can implement. Actually, do that for all +;;; loading and writing. + +;;; Code: + +(define-module (vcomponent formats vdir save-delete) + :use-module (calp util) + :use-module ((calp util exceptions) :select (assert)) + :use-module (vcomponent formats ical output) + :use-module (vcomponent) + :use-module ((calp util io) :select (with-atomic-output-to-file)) + ) + + +(define-public (save-event event) + (define calendar (parent event)) + + (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) + + (let* ((uid (or (prop event 'UID) (uuidgen)))) + (set! (prop event 'UID) uid + ;; TODO use existing filename if present? + (prop event '-X-HNH-FILENAME) (path-append + (prop calendar '-X-HNH-DIRECTORY) + (string-append uid ".ics"))) + (with-atomic-output-to-file (prop event '-X-HNH-FILENAME) + (lambda () (print-components-with-fake-parent (list event)))) + uid)) + + +(define-public (remove-event event) + (define calendar (parent event)) + (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) + (delete-file (prop event '-X-HNH-FILENAME))) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm new file mode 100644 index 00000000..e2cada83 --- /dev/null +++ b/module/vcomponent/formats/xcal/output.scm @@ -0,0 +1,133 @@ +(define-module (vcomponent formats xcal output) + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (vcomponent) + :use-module (vcomponent geo) + :use-module (vcomponent formats 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 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/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm new file mode 100644 index 00000000..e84f380e --- /dev/null +++ b/module/vcomponent/formats/xcal/parse.scm @@ -0,0 +1,259 @@ +(define-module (vcomponent formats 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 formats common 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 + (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 + (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/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm new file mode 100644 index 00000000..34c7c40d --- /dev/null +++ b/module/vcomponent/formats/xcal/types.scm @@ -0,0 +1,54 @@ +(define-module (vcomponent formats xcal types) + :use-module (calp util) + :use-module (vcomponent formats 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 formats 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))) -- cgit v1.2.3