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/ical/output.scm | 260 ----------------------------- module/vcomponent/ical/parse.scm | 336 -------------------------------------- module/vcomponent/ical/types.scm | 95 ----------- 3 files changed, 691 deletions(-) delete mode 100644 module/vcomponent/ical/output.scm delete mode 100644 module/vcomponent/ical/parse.scm delete mode 100644 module/vcomponent/ical/types.scm (limited to 'module/vcomponent/ical') diff --git a/module/vcomponent/ical/output.scm b/module/vcomponent/ical/output.scm deleted file mode 100644 index bcc6bb1d..00000000 --- a/module/vcomponent/ical/output.scm +++ /dev/null @@ -1,260 +0,0 @@ -(define-module (vcomponent ical output) - :use-module (ice-9 format) - :use-module (ice-9 match) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (vcomponent) - :use-module (vcomponent datetime) - :use-module (srfi srfi-1) - :use-module (datetime) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - :use-module (datetime zic) - :use-module (glob) - :use-module (vcomponent recurrence) - :use-module (vcomponent geo) - :use-module (vcomponent ical types) - :autoload (vcomponent instance) (global-event-object) - :use-module ((datetime instance) :select (zoneinfo)) - ) - -(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))])) - -;; TODO tzid param on dtstart vs tz field in datetime object -;; TODO remove this, replace with methods from (output vdir) -;; how do we keep these two in sync? -(define (write-event-to-file event calendar-path) - (define cal (make-vcomponent 'VCALENDAR)) - - (set! (prop cal 'PRODID) (prodid) - (prop cal 'VERSION) "2.0" - (prop cal 'CALSCALE) "GREGORIAN") - - (add-child! cal event) - - (awhen (and (provided? 'zoneinfo) - (param (prop* event 'DTSTART) 'TZID)) - ;; TODO this is broken - (add-child! cal (zoneinfo->vtimezone (zoneinfo) it))) - - (unless (prop event 'UID) - (set! (prop event 'UID) - (uuidgen))) - - (with-output-to-file (glob (format #f "~a/~a.ics" - calendar-path - (prop event 'UID))) - (lambda () (component->ical-string cal)))) - - - -(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/ical/parse.scm b/module/vcomponent/ical/parse.scm deleted file mode 100644 index b67ae593..00000000 --- a/module/vcomponent/ical/parse.scm +++ /dev/null @@ -1,336 +0,0 @@ -(define-module (vcomponent ical parse) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module ((ice-9 rdelim) :select (read-line)) - :use-module (vcomponent base) - :use-module (datetime) - :use-module (srfi srfi-1) - :use-module (srfi srfi-9 gnu) - :use-module (srfi srfi-26) - :use-module (vcomponent parse types) - :use-module (vcomponent geo) - ) - -(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/ical/types.scm b/module/vcomponent/ical/types.scm deleted file mode 100644 index 1ec9d0bd..00000000 --- a/module/vcomponent/ical/types.scm +++ /dev/null @@ -1,95 +0,0 @@ -;; see (vcomponent parse types) -(define-module (vcomponent ical types) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (base64) - :use-module (datetime)) - - -(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) - - -(use-modules (datetime timespec)) - -(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))) -- cgit v1.2.3