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 -------------------------------------- 1 file changed, 260 deletions(-) delete mode 100644 module/vcomponent/ical/output.scm (limited to 'module/vcomponent/ical/output.scm') 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)))) -- cgit v1.2.3