blob: 7ae9adae45f4ce0c977a3de1fd5cdc32e8597454 (
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
|
(define-module (vcomponent)
:use-module (util)
:use-module (util app)
:use-module (util config)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
:use-module (datetime)
:use-module (vcomponent base)
:use-module (vcomponent parse)
:use-module ((vcomponent recurrence) :select (generate-recurrence-set repeating?))
:use-module ((vcomponent datetime) :select (ev-time<?))
:re-export (make-vcomponent
parse-cal-path parse-calendar))
(re-export-modules (vcomponent base))
(define-config calendar-files '()
"Which files to parse. Takes a list of paths or a single string which will be globbed."
pre: (lambda (v)
(cond [(list? v) v]
[(string? v) ((@ (glob) glob) v)]
[else #f])))
(define-public (load-calendars calendar-files)
(map parse-cal-path calendar-files))
(define-method (init-app calendar-files)
(setf 'calendars (load-calendars calendar-files))
(setf 'events
(concatenate
;; TODO does this drop events?
(map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o)))
(children cal)))
(getf 'calendars))))
(let* ((repeating regular (partition repeating? (getf 'events))))
(setf 'fixed-events (sort*! regular date/-time<? (extract 'DTSTART)))
(setf 'repeating-events (sort*! repeating date/-time<? (extract 'DTSTART))))
(setf 'event-set
(interleave-streams
ev-time<?
(cons (list->stream (getf 'fixed-events))
(map generate-recurrence-set (getf 'repeating-events)))))
(setf 'uid-map
(let ((ht (make-hash-table)))
(for-each (lambda (event) (hash-set! ht (prop event 'UID) event)) (getf 'events))
ht)))
(define-method (fixed-events-in-range start end)
(filter-sorted (lambda (ev) ((in-date-range? start end)
(as-date (prop ev 'DTSTART))))
(getf 'fixed-events)))
(define-method (get-event-by-uid uid)
(hash-ref (getf 'uid-map) uid))
;;; TODO vcomponent should NOT depend on output
(use-modules (output ical))
;;; TODO what should happen when an event with that UID already exists
;;; in the calendar? Fail? Overwrite? Currently it adds a second element
;;; with the same UID, which is BAD.
(define-public (add-event calendar event)
(add-child! calendar event)
(unless (prop event 'UID)
(set! (prop event 'UID) (uuidgen)))
(let ((events (getf 'events)))
(setf 'events (cons event events)))
(if (repeating? event)
(let ((repeating (getf 'repeating-events)))
(setf 'repeating-events (insert-ordered event repeating ev-time<?)))
(let ((regular (getf 'fixed-events)))
(setf 'fixed-events (insert-ordered event regular ev-time<?))))
(let ((event-set (getf 'event-set)))
(setf 'event-set
(interleave-streams
ev-time<?
(list (if (repeating? event)
(generate-recurrence-set event)
(stream event))
event-set))))
(hash-set! (getf 'uid-map) (prop event 'UID)
event)
(prop event 'UID))
(define-public (remove-event event)
(let ((events (getf 'events)))
(setf 'events (delete event events)))
(if (repeating? event)
(let ((repeating (getf 'repeating-events)))
(setf 'repeating-events (delete event repeating)))
(let ((regular (getf 'fixed-events)))
(setf 'fixed-events (delete event regular))))
(let ((event-set (getf 'event-set)))
(setf 'event-set
(stream-remove
(lambda (ev)
(equal? (prop ev 'UID)
(prop event 'UID)))
event-set)))
(hash-set! (getf 'uid-map) (prop event 'UID)
#f))
(define / file-name-separator-string)
(define-public (save-event event)
(define calendar (parent event))
(case (prop calendar 'X-HNH-SOURCETYPE)
[(file)
(error "Importing into direct calendar files not supported")]
[(vdir)
(let* ((uid (or (prop event 'UID) (uuidgen)))
;; copy to enusre writable string
(tmpfile (string-copy (string-append (prop calendar 'X-HNH-DIRECTORY)
/ ".calp-" uid "XXXXXX")))
(port (mkstemp! tmpfile)))
(set! (prop event 'UID) uid)
(with-output-to-port port
(lambda () (print-components-with-fake-parent (list event))))
;; does close flush?
(force-output port)
(close-port port)
(rename-file tmpfile (string-append (prop calendar 'X-HNH-DIRECTORY)
/ uid ".ics"))
uid)]
[else
(error "Source of calendar unknown, aborting.")
]))
|
