diff options
Diffstat (limited to 'module/vcomponent')
| -rw-r--r-- | module/vcomponent/base.scm | 1 | ||||
| -rw-r--r-- | module/vcomponent/datetime/output.scm | 8 | ||||
| -rw-r--r-- | module/vcomponent/duration.scm | 16 | ||||
| -rw-r--r-- | module/vcomponent/formats/common/types.scm | 3 | ||||
| -rw-r--r-- | module/vcomponent/formats/ical/parse.scm | 13 | ||||
| -rw-r--r-- | module/vcomponent/formats/vdir/parse.scm | 17 | ||||
| -rw-r--r-- | module/vcomponent/formats/vdir/save-delete.scm | 35 | ||||
| -rw-r--r-- | module/vcomponent/formats/xcal/parse.scm | 14 | ||||
| -rw-r--r-- | module/vcomponent/recurrence/generate.scm | 4 | ||||
| -rw-r--r-- | module/vcomponent/recurrence/internal.scm | 8 | ||||
| -rw-r--r-- | module/vcomponent/recurrence/parse.scm | 16 | ||||
| -rw-r--r-- | module/vcomponent/util/instance/methods.scm | 86 | ||||
| -rw-r--r-- | module/vcomponent/util/parse-cal-path.scm | 5 |
13 files changed, 173 insertions, 53 deletions
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 579382ae..18f31aaf 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -164,6 +164,7 @@ (define-public (copy-vcomponent component) (make-vcomponent% (type component) + ;; TODO deep copy? (children component) (parent component) ;; properties diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index 72ee8eb4..fe909ebb 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -1,7 +1,5 @@ (define-module (vcomponent datetime output) :use-module (hnh util) - :use-module (calp util config) - :use-module (hnh util exceptions) :use-module (datetime) :use-module (vcomponent base) :use-module (text util) @@ -9,12 +7,6 @@ :use-module ((vcomponent recurrence display) :select (format-recurrence-rule)) ) -(define-config summary-filter (lambda (_ a) a) - pre: (ensure procedure?)) - -(define-config description-filter (lambda (_ a) a) - pre: (ensure procedure?)) - ;; ev → sxml ;; TODO translation (define-public (format-recurrence-rule ev) diff --git a/module/vcomponent/duration.scm b/module/vcomponent/duration.scm index 786675b8..637d7db4 100644 --- a/module/vcomponent/duration.scm +++ b/module/vcomponent/duration.scm @@ -20,7 +20,9 @@ key: (sign '+) week day time) (when (and week (or day time)) - (error "Can't give week together with day or time")) + (scm-error 'misc-error "duration" + "Can't give week together with day or time" + #f #f)) (make-duration sign week day time)) @@ -64,7 +66,10 @@ (define (parse-duration str) (let ((m (match-pattern dur-pattern str))) (unless m - (throw 'parse-error "~a doesn't appar to be a duration" str)) + (scm-error 'parse-error "parse-duration" + "~s doesn't appar to be a duration" + (list str) + #f)) (unless (= (peg:end m) (string-length str)) (warning "Garbage at end of duration")) @@ -83,9 +88,12 @@ [(H) `(hour: ,n)] [(M) `(minute: ,n)] [(S) `(second: ,n)] - [else (error "Invalid key")]))] + [else (scm-error 'misc-error "parse-duration" + "Invalid key ~a" type #f)]))] [a - (error "~a not on form ((number <num>) type)" a)]) + (scm-error 'misc-error "parse-duration" + "~s not on expected form ((number <num>) type)" + (list a) #f)]) (context-flatten (lambda (x) (and (pair? (car x)) (eq? 'number (caar x)))) (cdr (member "P" tree))) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index 9768cf70..9e18f1eb 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -137,4 +137,5 @@ (define-public (get-parser type) (or (hashq-ref type-parsers type #f) - (error (_ "No parser for type") type))) + (scm-error 'misc-error "get-parser" (_ "No parser for type ~a") + (list type) #f))) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 8b6cffeb..7f6c89cc 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -1,5 +1,6 @@ (define-module (vcomponent formats ical parse) :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (ice-9 format) :use-module (hnh util exceptions) :use-module (hnh util) :use-module (datetime) @@ -121,7 +122,9 @@ (lambda (params value) (let ((vv (parser params value))) (when (list? vv) - (throw 'parse-error (_ "List in enum field"))) + (scm-error 'parse-error "enum-parser" + (_ "List in enum field") + #f #f)) (let ((v (string->symbol vv))) (unless (memv v enum) (warning "~a ∉ { ~{~a~^, ~} }" @@ -193,7 +196,9 @@ DRAFT FINAL CANCELED))] [(memv key '(REQUEST-STATUS)) - (throw 'parse-error (_ "TODO Implement REQUEST-STATUS"))] + (scm-error 'parse-error "build-vline" + (_ "TODO Implement REQUEST-STATUS") + #f #f)] [(memv key '(ACTION)) (enum-parser '(AUDIO DISPLAY EMAIL @@ -325,7 +330,7 @@ (set! (prop* (car stack) key) vline)))))) (loop (cdr lst) stack)]))) - (lambda (err fmt . args) + (lambda (err proc fmt fmt-args data) (let ((linedata (get-metadata head*))) (display (format #f @@ -339,7 +344,7 @@ line ~a ~a Defaulting to string~%") (get-string linedata) - fmt args + fmt fmt-args (get-line linedata) (get-file linedata)) (current-error-port)) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 4fc96e71..b21a5f2b 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -39,12 +39,16 @@ (reduce (lambda (item calendar) - (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) - (children item))) + (define-values (events other) + (partition (lambda (e) (eq? 'VEVENT (type e))) + (children item))) - ;; (assert (eq? 'VCALENDAR (type calendar))) - (assert (eq? 'VCALENDAR (type item))) + (unless (eq? 'VCALENDAR (type item)) + (scm-error 'misc-error "parse-vdir" + "Unexepected top level component. Expected VCALENDAR, got ~a. In file ~s" + (list (type item) (prop item '-X-HNH-FILENAME)) + #f)) (for child in (children item) (set! (prop child '-X-HNH-FILENAME) @@ -61,10 +65,7 @@ (case (length events) [(0) (warning (_ "No events in component~%~a") (prop item '-X-HNH-FILENAME))] - [(1) - (let ((child (car events))) - (assert (memv (type child) '(VTIMEZONE VEVENT))) - (add-child! calendar child))] + [(1) (add-child! calendar (car events))] ;; two or more [else diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index 6068e34c..01d34f9f 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -11,8 +11,8 @@ (define-module (vcomponent formats vdir save-delete) :use-module (hnh util) + :use-module (hnh util uuid) :use-module ((hnh util path) :select (path-append)) - :use-module ((hnh util exceptions) :select (assert)) :use-module (vcomponent formats ical output) :use-module (vcomponent) :use-module ((hnh util io) :select (with-atomic-output-to-file)) @@ -22,14 +22,25 @@ (define-public (save-event event) (define calendar (parent event)) - (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) - - (let* ((uid (or (prop event 'UID) (uuidgen)))) - (set! (prop event 'UID) uid - ;; TODO use existing filename if present? - (prop event '-X-HNH-FILENAME) (path-append - (prop calendar '-X-HNH-DIRECTORY) - (string-append uid ".ics"))) + (unless calendar + (scm-error 'wrong-type-arg "save-event" + (_ "Can only save events belonging to calendars, event uid = ~s") + (list (prop event 'UID)) + #f)) + + (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) + (scm-error 'wrong-type-arg "save-event" + (_ "Can only save events belonging to vdir calendars. Calendar is of type ~s") + (list (prop calendar '-X-HNH-SOURCETYPE)) + #f)) + + (let* ((uid (or (prop event 'UID) (uuid)))) + (set! (prop event 'UID) uid) + (unless (prop event 'X-HNH-FILENAME) + (set! (prop event '-X-HNH-FILENAME) + (path-append + (prop calendar '-X-HNH-DIRECTORY) + (string-append uid ".ics")))) (with-atomic-output-to-file (prop event '-X-HNH-FILENAME) (lambda () (print-components-with-fake-parent (list event)))) uid)) @@ -37,5 +48,9 @@ (define-public (remove-event event) (define calendar (parent event)) - (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) + (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) + (scm-error 'wrong-type-arg "remove-event" + (_ "Can only remove events belonging to vdir calendars. Calendar is of type ~s") + (list (prop calendar '-X-HNH-SOURCETYPE)) + #f)) (delete-file (prop event '-X-HNH-FILENAME))) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 66bb8460..d9020858 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -82,10 +82,10 @@ bymonthday byyearday byweekno bymonth bysetpos) (string->number value)) - (else (throw - 'key-error + (else (scm-error 'key-error "handle-value" (_ "Invalid type ~a, with value ~a") - type value)))))) + (list type value) + #f)))))) ;; freq until count interval wkst @@ -109,9 +109,11 @@ byyearday byweekno bymonth bysetpos) (list (symbol->keyword key) (map (lambda (v) (parse-value-of-that-type key v)) - (map car values))) - ) - (else (throw 'error)))))))))] + (map car values)))) + (else (scm-error 'misc-error "handle-value" + "Invalid key ~s" + (list key) + #f)))))))))] [(time) (parse-iso-time (car value))] diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index b498e033..33f86e3d 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -217,7 +217,9 @@ [(BYHOUR) (to-dt (set (hour t) value))] [(BYMINUTE) (to-dt (set (minute t) value))] [(BYSECOND) (to-dt (set (second t) value))] - [else (error "Unrecognized by-extender" key)]))) + [else (scm-error 'wrong-type-arg "update" + "Unrecognized by-extender ~s" + key #f)]))) date-object extension-rule)) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index b4f09d92..ae521d77 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -5,6 +5,7 @@ #:use-module ((vcomponent base) :select (prop)) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 format) #:use-module (hnh util) ) @@ -46,11 +47,14 @@ wkst) (export! count) +;; Interval and wkst have default values, since those are assumed +;; anyways, and having them set frees us from having to check them at +;; the use site. (define*-public (make-recur-rule key: - freq until count interval bysecond byminute byhour + freq until count (interval 1) bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos - wkst) + (wkst monday)) ;; TODO possibly validate fields here ;; to prevent creation of invalid rules. ;; This was made apparent when wkst was (incorrectly) set to MO, diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index 3477f6d4..d45cedf9 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -51,7 +51,9 @@ (define-macro (quick-case key . cases) (let ((else-clause (or (assoc-ref cases 'else) - '(error "Guard failed")))) + '(scm-error 'misc-error "quick-case" + "Guard failed" + #f #f)))) `(case ,key ,@(map (match-lambda ((key guard '=> body ...) @@ -72,6 +74,12 @@ `(else ,@body))) cases)))) +(define* (string->number/throw string optional: (radix 10)) + (or (string->number string radix) + (scm-error 'wrong-type-arg + "string->number/throw" + "Can't parse ~s as number in base ~a" + (list string radix) (list string radix)))) ;; RFC 5545, Section 3.3.10. Recurrence Rule, states that the UNTIL value MUST have ;; the same type as the DTSTART of the event (date or datetime). I have seen events @@ -92,8 +100,8 @@ (parse-ics-datetime val))) (day (rfc->datetime-weekday (string->symbol val))) (days (map parse-day-spec (string-split val #\,))) - (num (string->number val)) - (nums (map string->number (string-split val #\,)))) + (num (string->number/throw val)) + (nums (map string->number/throw (string-split val #\,)))) ;; It's an error to give BYHOUR and smaller for pure dates. ;; 3.3.10. p 41 @@ -123,7 +131,7 @@ (else o))))) ;; obj - (make-recur-rule interval: 1 wkst: mon) + (make-recur-rule) ;; ((key val) ...) (map (cut string-split <> #\=) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index e2e8a777..57d12f6b 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -1,5 +1,6 @@ (define-module (vcomponent util instance methods) :use-module (hnh util) + :use-module (hnh util uuid) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) @@ -19,8 +20,14 @@ get-event-by-uid fixed-events-in-range + get-calendar-by-name + get-event-set get-calendars get-fixed-events get-repeating-events + + add-and-save-event + + add-calendars )) (define-public (load-calendars calendar-files) @@ -28,12 +35,21 @@ (define-class <events> () - (calendar-files init-keyword: calendar-files:) - (calendars getter: get-calendars) + ;; Files which calendars where loaded from + (calendar-files init-keyword: calendar-files: + init-value: '()) + ;; calendar objects + (calendars getter: get-calendars + init-value: '()) + ;; events, which should all be children of the calendars (events getter: get-events) + ;; subset of events (repeating-events getter: get-repeating-events) + ;; subset of events (fixed-events getter: get-fixed-events) + ;; events again, but as stream with repeating events realised (event-set getter: get-event-set) + ;; hash-table from event UID:s, to the events uid-map ) @@ -42,6 +58,10 @@ (hash-ref (slot-ref this 'uid-map) uid)) +(define-method (get-calendar-by-name (this <events>) string) + (find (lambda (c) (string=? string (prop c 'NAME))) + (get-calendars this))) + (define-method (fixed-events-in-range (this <events>) start end) (filter-sorted (lambda (ev) ((in-date-range? start end) @@ -56,8 +76,12 @@ (for calendar in (slot-ref this 'calendar-files) (format (current-error-port) " - ~a~%" calendar)) - (slot-set! this 'calendars (load-calendars (slot-ref this 'calendar-files))) + (let ((calendars (load-calendars (slot-ref this 'calendar-files)))) + (apply add-calendars this calendars))) + +(define-method (add-calendars (this <events>) . calendars) + (slot-set! this 'calendars (append calendars (slot-ref this 'calendars))) (let* ((groups (group-by @@ -95,7 +119,7 @@ (add-child! calendar event) (unless (prop event 'UID) - (set! (prop event 'UID) (uuidgen))) + (set! (prop event 'UID) (uuid))) @@ -139,3 +163,57 @@ (hash-set! (slot-ref this 'uid-map) (prop event 'UID) #f)) + + +(define-method (add-and-save-event (this <events>) calendar event) + (cond + [(get-event-by-uid this (prop event 'UID)) + => (lambda (old-event) + + ;; remove old instance of event from runtime + (remove-event this old-event) + + ;; Add new event to runtime, + ;; MUST be done after since the two events SHOULD share UID. + ;; NOTE that this can emit warnings + (add-event this calendar event) + + (set! (prop event 'LAST-MODIFIED) + (current-datetime)) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + + ;; save-event sets -X-HNH-FILENAME from the UID. This is fine + ;; since the two events are guaranteed to have the same UID. + (unless ((@ (vcomponent formats vdir save-delete) save-event) event) + (throw 'misc-error (_ "Saving event to disk failed."))) + + + (unless (eq? calendar (parent old-event)) + ;; change to a new calendar + (format (current-error-port) + (_ "Unlinking old event from ~a~%") + (prop old-event '-X-HNH-FILENAME)) + ;; NOTE that this may fail, leading to a duplicate event being + ;; created (since we save beforehand). This is just a minor problem + ;; which either a better atomic model, or a propper error + ;; recovery log would solve. + ((@ (vcomponent formats vdir save-delete) remove-event) old-event)) + + + (format (current-error-port) + (_ "Event updated ~a~%") (prop event 'UID)))] + + [else + (add-event this calendar event) + + (set! (prop event 'LAST-MODIFIED) (current-datetime)) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + (unless ((@ (vcomponent formats vdir save-delete) save-event) event) + (throw 'misc-error (_ "Saving event to disk failed."))) + + (format (current-error-port) + (_ "Event inserted ~a~%") (prop event 'UID))])) diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index 7a5fea29..4baa647e 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -26,7 +26,10 @@ (prop comp '-X-HNH-DIRECTORY) path) comp)] [(block-special char-special fifo socket unknown symlink) - => (lambda (t) (error (_ "Can't parse file of type ") t))])) + => (lambda (t) (scm-error 'misc-error "parse-cal-path" + (_ "Can't parse file of type ~s") + (list t) + #f))])) (unless (prop cal "NAME") (set! (prop cal "NAME") |