blob: bba74316d09deea0884d3eafc916abe860f8a7b3 (
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
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
(define-module (vcomponent parse new)
: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)
:use-module ((ice-9 hash-table) :select (alist->hashq-table))
)
(define-public (parse-calendar port)
(let ((component (parse (map tokenize (read-file port)))))
;; (set! (attr component 'X-HNH-FILENAME) (or (port-filename port) "MISSING"))
(link-parents! component)
component))
;; (define f (open-input-file (car (glob "~/.local/var/cal/Calendar/c17*"))))
;; 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))
(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))
;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000"))
;; ⇒ #<<vline> value: "20200407T130000" parameters: #<hash-table 7f4294c913a0 2/31>>
;; (define (parse-itemline itemline)
;; (define all
;; (reverse
;; (let loop ((rem (cdr itemline)))
;; (if (null? (cdr rem))
;; rem ; (list (car rem))
;; (let* ((kv (car rem))
;; (idx (string-index kv #\=)))
;; (cons (cons (string->symbol (substring kv 0 idx))
;; ;; NOTE handle value parsing here?
;; (substring kv (1+ idx)))
;; (loop (cdr rem))))))))
;; (make-vline% (car all) (alist->hashq-table (cdr all))))
(define (handle-value! key vline)
(case key
[(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE)
;; '("Africa/Ceuta" "Europe/Stockholm" "local")
(let ((tz (or (and=> (prop vline 'TZID) car)
(and (string= "Z" (string-take-right (value vline) 1)) "UTC"))))
(let ((type (and=> (prop vline 'VALUE) car)))
(if (or (and=> type (cut string=? <> "DATE-TIME"))
(string-contains (value vline) "T"))
;; TODO TODO TODO
;; 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.
;; We sohuld however save the original datetime in a file like X-HNH-DTSTART,
;; since we don't want to lose that information.
(set! (value vline) (get-datetime (parse-ics-datetime (value vline) tz))
(prop vline 'VALUE) 'DATE-TIME)
(set! (value vline) (parse-ics-date (value vline))
(prop vline 'VALUE) 'DATE)))
;; TOOD actually handle repeated keys
(when (eq? key 'EXDATE)
(set! (value vline) (list (value vline)))))]
[else (set! (value vline)
(list->string
(let loop ((rem (string->list (value vline))))
(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)))))
))) ])
vline)
;; (parse-itemline '("DTEND" "TZID=Europe/Stockholm" "VALUE=DATE-TIME" "20200407T130000"))
;; ⇒ (DTEND . #<<vline> value: #<<datetime> date: 2020-04-07 time: 13:00:00 tz: #f>
;; parameters: #<hash-table 7f88fc1207a0 2/31>>
(define (parse-itemline itemline)
(define key (string->symbol (car itemline)))
(let loop ((rem (cdr itemline))
(done '()))
(if (null? (cdr rem))
;; TODO repeated keys
(cons key
(handle-value!
key (make-vline (car rem)
(alist->hashq-table done))))
(let* ((kv (car rem))
(idx (string-index kv #\=)))
(loop (cdr rem)
(cons (cons (string->symbol (substring kv 0 idx))
(substring kv (1+ idx)))
done))))))
(define (make-component type . children-and-attributes)
(define component
(let* ((children attributes (partition vcomponent? children-and-attributes)))
((@@ (vcomponent base) make-vcomponent%) type children #f (alist->hashq-table attributes))))
;; TODO This is an ugly hack until the rest of the code is updated
;; to work on events without an explicit DTEND attribute.
(when (and (eq? type 'VEVENT) (not (attr component 'DTEND)))
(set! (attr component 'DTEND)
(let ((start (attr component '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)))))))
component)
;; (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 (list (string->symbol (cadr head))) stack))]
[(string=? "END" (car head))
(loop (cdr lst)
(let* ((frame (reverse (car stack)))
(component (apply make-component frame)))
(if (null? (cdr stack))
component
(cons (cons component (cadr stack))
(cddr stack)))))]
[else
(loop (cdr lst)
(cons (cons (parse-itemline head)
(car stack))
(cdr stack)))])))))
(define (link-parents! component)
(for child in (children component)
((@@ (vcomponent base) set-component-parent!) child component)
(link-parents! child)))
;; Repeated keys ('(EXDATE ATTENDEE))
|
