blob: fcb755261fa6d8cee3f31ce71be693f716d0d080 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
(define-module (output ical)
:use-module (ice-9 getopt-long)
:use-module (ice-9 format)
:use-module (ice-9 match)
:use-module (util)
:use-module (vcomponent)
:use-module (srfi srfi-1)
:use-module (srfi srfi-19)
:use-module (srfi srfi-19 util)
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
)
(define opt-spec
'((from (value #t) (single-char #\f))
(to (value #t) (single-char #\t))))
;; Format value depending on key type.
;; Should NOT emit the key.
(define (value-format key vline)
(catch 'wrong-type-arg
(lambda ()
(case key
((DTSTART DTEND)
(time->string (value vline) (if (prop vline 'TZID)
"~Y~m~dT~H~M~S"
"~Y~m~dT~H~M~SZ" )))
((DURATION X-HNH-DURATION)
#; (time->string value "~H~M~S")
(let ((s (time-second (value vline))))
(format #f "~a~a~a"
(floor/ s 3600)
(floor/ (modulo s 3600) 60)
(modulo s 60))
))
((RRULE) (value vline))
(else (escape-chars (value vline)))))
(lambda (err caller fmt args call-args)
(format (current-error-port)
"WARNING: ~k~%" fmt args)
(with-output-to-string (lambda () (display (value vline))))
)))
(define (escape-chars str)
(with-output-to-string
(lambda ()
(string-for-each (lambda (ch)
(case ch
((#\, #\; #\\) => (lambda (c) (display "\\") (display c)))
((#\newline) (display "\\n"))
(else (display ch)))
) str))))
;; 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 (component->ical-string component)
(format #t "BEGIN:~a\r\n" (type component))
(hash-for-each
;; Special cases depending on key.
;; Value formatting is handled in @code{value-format}.
(match-lambda*
[('X-HNH-ALTERNATIVES _) 'noop]
[(key vline)
(display
(ical-line-fold
;; Expected output: key;p1=v;p3=10:value
(format #f "~a~:{;~a=~@{~a~^,~}~}:~a"
key (properties vline)
(value-format key vline))))
(display "\r\n")])
(attributes component))
(for-each component->ical-string (children component))
(format #t "END:~a\r\n" (type component))
)
(define (print-header)
(format #t
"BEGIN:VCALENDAR\r
PRODID:-//hugo//Calparse 0.5//EN\r
VERSION:2.0\r
CALSCALE:GREGORIAN\r
"
))
(define (print-footer)
(format #t "END:VCALENDAR\r\n"))
(define-public (ical-main calendars events args)
(define opts (getopt-long args opt-spec))
(define start (cond [(option-ref opts 'from #f) => parse-freeform-date]
[else (start-of-month (current-date))]))
(define end (cond [(option-ref opts 'to #f) => parse-freeform-date]
[else (normalize-date* (set (date-month start) = (+ 1)))]))
(print-header)
(let ((tzs (make-hash-table)))
(for cal in calendars
(for tz in (filter (lambda (e) (eq? 'VTIMEZONE (type e))) (children cal))
(hash-set! tzs (attr tz 'TZID) tz)))
(hash-for-each (lambda (key component) (component->ical-string component))
tzs))
;; TODO this contains repeated events multiple times
(stream-for-each
component->ical-string
(filter-sorted-stream (lambda (ev) ((in-date-range? start end)
(time-utc->date (attr ev 'DTSTART))))
events))
(print-footer))
|
