blob: c2d297fda15f629e3c255ab0ee5b83f8506b1b97 (
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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
(define-module (vcomponent parse component)
:use-module (util)
:use-module (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-26)
)
(define-public (parse-calendar port)
(parse (map tokenize (read-file port))))
;; port → (list string)
(define (read-file port)
(let loop ((done '()))
(let ((line (read-line port)))
(if (eof-object? line)
(reverse! done)
(let ((line (string-trim-right line)))
(loop
(if (char=? #\space (string-ref line 0))
;; Line Wrapping
;; 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
(cons (string-append (car done)
(string-drop line 1))
(cdr done))
(cons line done))))))))
;; (list string) → (list (key kv ... value))
(define (tokenize line)
(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)))))
(map (lambda (start end)
(substring line (1+ start) end))
(cons -1 semi-idxs)
semi-idxs))
;; params could be made optional, with an empty hashtable as default
(define (build-vline key value params)
(case key
[(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE)
;; '("Africa/Ceuta" "Europe/Stockholm" "local")
(let ((tz (or (hashq-ref params 'TZID)
(and (string= "Z" (string-take-right value 1)) "UTC"))))
(let ((type (hashq-ref params 'VALUE)))
(if (or (and=> type (cut string=? <> "DATE-TIME"))
(string-index value #\T))
;; we move all parsed datetimes to local time here. This
;; gives a MASSIVE performance boost over calling get-datetime
;; in all procedures which want to guarantee local time for proper calculations.
;; 20s vs 70s runtime on my laptop.
(let ((datetime (parse-ics-datetime value tz)))
(hashq-set! params 'VALUE 'DATE-TIME)
(values (make-vline key (get-datetime datetime) params)
(make-vline (symbol-append 'X-ORIGINAL- key) datetime params)))
(begin (hashq-set! params 'VALUE 'DATE)
(make-vline key (parse-ics-date value) params)))))]
[else
(make-vline key
(list->string
(let loop ((rem (string->list value)))
(if (null? rem)
'()
(if (char=? #\\ (car rem))
(case (cadr rem)
[(#\n #\N) (cons #\newline (loop (cddr rem)))]
[(#\; #\, #\\) => (lambda (c) (cons c (loop (cddr rem))))]
[else => (lambda (c) (warning "Non-escapable character: ~a" c)
(loop (cddr rem)))])
(cons (car rem) (loop (cdr rem)))))))
params)]))
;; (parse-itemline '("DTEND" "20200407T130000"))
;; => DTEND
;; => "20200407T130000"
;; => #<hash-table 7f76b5f82a60 0/31>
(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 #\=)))
(hashq-set! parameters (string->symbol (substring kv 0 idx))
(substring kv (1+ idx)))
(loop (cdr rem))))))
;; (list (key kv ... value)) → <vcomponent>
(define (parse lst)
(let loop ((lst lst)
(stack '()))
(if (null? lst)
stack
(let ((head (car lst)))
(cond [(string=? "BEGIN" (car head))
(loop (cdr lst) (cons (make-vcomponent (string->symbol (cadr head))) stack))]
[(string=? "END" (car head))
;; TODO This is an ugly hack until the rest of the code is updated
;; to work on events without an explicit DTEND attribute.
(when (eq? (type (car stack)) 'VEVENT)
(when (not (attr (car stack) 'DTEND))
(set! (attr (car stack) 'DTEND)
(let ((start (attr (car stack) 'DTSTART)))
;; p. 54, 3.6.1
;; If DTSTART is a date then it's an all
;; day event. If DTSTART instead is a
;; datetime then the event has a length
;; of 0?
(if (date? start)
(date+ start (date day: 1))
(datetime+ start (datetime time: (time hour: 1)))))))
;; This isn't part of the field values since we "need"
;; the type of DTSTART for UNTIL to work.
;; This could however be side steped by auto detecting
;; @type{date}s vs @type{datetime}s in @function{parse-recurrence-rule}.
(when (attr (car stack) 'RRULE)
(set! (attr (car stack) 'RRULE)
((@ (vcomponent recurrence) parse-recurrence-rule)
(attr (car stack) 'RRULE)
(if (date? (attr (car stack) 'DTSTART))
parse-ics-date parse-ics-datetime)))))
(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))
;; Which types are allowed to be given multiple times
(if (memv key '(EXDATE ATTENDEE))
(aif (attr* (car stack) key)
(set! (attr* (car stack) key) (cons vline it))
(set! (attr* (car stack) key) (list vline)))
;; else
(set! (attr* (car stack) key) vline))))))
(loop (cdr lst) stack)])))))
|
