Start moving stuff out from output.

4 files changed, 1 insertions, 376 deletions

diff --git a/module/output/html.scm b/module/output/html.scm
deleted file mode 100644
index e69de29b..00000000
--- a/module/output/html.scm
+++ /dev/null
diff --git a/module/output/ical.scm b/module/output/ical.scm
deleted file mode 100644
index 45918be0..00000000
--- a/module/output/ical.scm
+++ /dev/null
@@ -1,244 +0,0 @@
-(define-module (output ical)
-  :use-module (ice-9 format)
-  :use-module (ice-9 match)
-  :use-module (util)
-  :use-module (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 (output types)
-  :use-module (output common)
-  :autoload (vcomponent instance) (global-event-object)
-  :use-module ((datetime instance) :select (zoneinfo))
-  )
-
-
-;; 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 '(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)
-        (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) (@ (global) *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
-" (@ (global) *prodid*)
-))
-
-
-(define (print-footer)
-  (format #t "END:VCALENDAR\r\n"))
-
-
-
-(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/output/vdir.scm b/module/output/vdir.scm
index bd21fb24..2541f0f9 100644
--- a/module/output/vdir.scm
+++ b/module/output/vdir.scm
@@ -11,7 +11,7 @@
 
 (define-module (output vdir)
   :use-module (util)
-  :use-module (output ical)
+  :use-module (vcomponent ical output)
   :use-module (vcomponent)
   :use-module ((util io) :select (with-atomic-output-to-file))
   )
diff --git a/module/output/xcal.scm b/module/output/xcal.scm
deleted file mode 100644
index b2c3f899..00000000
--- a/module/output/xcal.scm
+++ /dev/null
@@ -1,131 +0,0 @@
-(define-module (output xcal)
-  :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 <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 ,@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))