From 55f80b2ca4c8d44255e38ef2eee4564501aa83ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 17 Aug 2020 18:23:08 +0200 Subject: MOORE --- module/html/vcomponent.scm | 2 +- module/output/color.scm | 22 +++++++ module/output/vdir.scm | 55 ------------------ module/server/routes.scm | 8 +-- module/vcomponent/parse.scm | 99 +------------------------------- module/vcomponent/vdir/parse.scm | 102 +++++++++++++++++++++++++++++++++ module/vcomponent/vdir/save-delete.scm | 55 ++++++++++++++++++ 7 files changed, 186 insertions(+), 157 deletions(-) create mode 100644 module/output/color.scm delete mode 100644 module/output/vdir.scm create mode 100644 module/vcomponent/vdir/parse.scm create mode 100644 module/vcomponent/vdir/save-delete.scm (limited to 'module') diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index 559b11c5..5743ff42 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -7,7 +7,7 @@ :use-module (html util) :use-module ((html config) :select (edit-mode)) :use-module ((html components) :select (btn tabset)) - :use-module ((output general) :select (calculate-fg-color)) + :use-module ((output color) :select (calculate-fg-color)) :use-module ((vcomponent datetime output) :select (fmt-time-span format-description diff --git a/module/output/color.scm b/module/output/color.scm new file mode 100644 index 00000000..123d0ba2 --- /dev/null +++ b/module/output/color.scm @@ -0,0 +1,22 @@ +(define-module (output color) + ) + +;; Returns a color with good contrast to the given background color. +;; https://stackoverflow.com/questions/1855884/determine-font-color-based-on-background-color/1855903#1855903 +(define-public (calculate-fg-color c) + (catch #t + (lambda () + (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16)) + ;; (format (current-error-port) "COLOR = ~s~%" c) + (let ((r (str->num c 1)) + (g (str->num c 3)) + (b (str->num c 5))) + (if (< 1/2 (/ (+ (* 0.299 r) + (* 0.587 g) + (* 0.114 b)) + #xFF)) + "#000000" "#FFFFFF"))) + (lambda args + (format (current-error-port) "Error calculating foreground color?~%~s~%" args) + "#FF0000" + ))) diff --git a/module/output/vdir.scm b/module/output/vdir.scm deleted file mode 100644 index 2541f0f9..00000000 --- a/module/output/vdir.scm +++ /dev/null @@ -1,55 +0,0 @@ -;;; Commentary: -;;; Module for writing components to the vdir storage format. -;;; Currently also has some cases for "big" icalendar files, -;;; but those are currently unsupported. - -;;; TODO generalize save-event and remove-event into a general interface, -;;; which different database backends can implement. Actually, do that for all -;;; loading and writing. - -;;; Code: - -(define-module (output vdir) - :use-module (util) - :use-module (vcomponent ical output) - :use-module (vcomponent) - :use-module ((util io) :select (with-atomic-output-to-file)) - ) - - -(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)))) - (set! (prop event 'UID) uid - ;; TODO use existing filename if present? - (prop event '-X-HNH-FILENAME) (string-append - (prop calendar '-X-HNH-DIRECTORY) - / uid ".ics")) - (with-atomic-output-to-file (prop event '-X-HNH-FILENAME) - (lambda () (print-components-with-fake-parent (list event)))) - uid)] - - [else - (error "Source of calendar unknown, aborting.") - ])) - - -(define-public (remove-event event) - (define calendar (parent event)) - (case (prop calendar '-X-HNH-SOURCETYPE) - [(file) - (error "Removing events from large files unsupported")] - - [(vdir) - (delete-file (prop event '-X-HNH-FILENAME))] - - [else - (error "Source of calendar unknown, aborting.") - ])) diff --git a/module/server/routes.scm b/module/server/routes.scm index 142e0477..475e4c43 100644 --- a/module/server/routes.scm +++ b/module/server/routes.scm @@ -150,7 +150,7 @@ (remove-event global-event-object it) (set! (prop it 'X-HNH-REMOVED) #t) (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") - (unless ((@ (output vdir) save-event) it) + (unless ((@ (vcomponent vdir save-delete) save-event) it) (return (build-response code: 500) "Saving event to disk failed.")) (return (build-response code: 204))) @@ -249,7 +249,7 @@ (format (current-error-port) "Unlinking old event from ~a~%" (prop old-event '-X-HNH-FILENAME)) - ((@ (output vdir) remove-event) old-event))) + ((@ (vcomponent vdir save-delete) remove-event) old-event))) (parameterize ((warnings-are-errors #t)) (catch 'warning @@ -261,7 +261,7 @@ ;; NOTE Posibly defer save to a later point. ;; That would allow better asyncronous preformance. - (unless ((@ (output vdir) save-event) event) + (unless ((@ (vcomponent vdir save-delete) save-event) event) (return (build-response code: 500) "Saving event to disk failed.")) @@ -280,7 +280,7 @@ ;; NOTE Posibly defer save to a later point. ;; That would allow better asyncronous preformance. - (unless ((@ (output vdir) save-event) event) + (unless ((@ (vcomponent vdir save-delete) save-event) event) (return (build-response code: 500) "Saving event to disk failed.")) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 67d66b02..290a8d3e 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -1,107 +1,13 @@ -;;; Commentary: -;; Code for parsing vdir's and icalendar files. -;; This module handles the finding of files, while -;; (vcomponent parse ical) handles reading data from icalendar files. -;;; Code: - (define-module (vcomponent parse) - :use-module (srfi srfi-1) - - :use-module ((ice-9 hash-table) :select (alist->hash-table)) - :use-module ((ice-9 rdelim) :select (read-line)) - :use-module ((ice-9 ftw) :select (scandir ftw)) - :use-module (util) - :use-module (util time) - :use-module (util exceptions) :use-module (vcomponent base) + :use-module ((vcomponent vdir parse) :select (parse-vdir)) + :use-module ((util time) :select (report-time!)) :use-module (vcomponent ical parse) :re-export (parse-calendar) ) - - - -;; All VTIMEZONE's seem to be in "local" time in relation to -;; themselves. Therefore, a simple comparison should work, -;; and then the TZOFFSETTO properties can be subtd. -(define (parse-vdir path) - (let ((/ (lambda args (string-join args file-name-separator-string 'infix)))) - (let ((color - (catch 'system-error - (lambda () (call-with-input-file (/ path "color") read-line)) - (const "#FFFFFF"))) - (name - (catch 'system-error - (lambda () (call-with-input-file (/ path "displayname") read-line)) - (const #f)))) - - (reduce (lambda (item calendar) - - (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) - (children item))) - - - ;; (assert (eq? 'VCALENDAR (type calendar))) - (assert (eq? 'VCALENDAR (type item))) - - (for child in (children item) - (set! (prop child '-X-HNH-FILENAME) - (prop (parent child) '-X-HNH-FILENAME))) - - ;; NOTE The vdir standard says that each file should contain - ;; EXACTLY one event. It can however contain multiple VEVENT - ;; components, but they are still the same event. - ;; In our case this means exceptions to reccurence rules, which - ;; is set up here, and then later handled in rrule-generate. - ;; NOTE These events also share UID, but are diferentiated - ;; by RECURRENCE-ID. As far as I can tell this goes against - ;; the standard. Section 3.8.4.4. - (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))] - - ;; two or more - [else - - ;; Sorting on SEQUENCE here would have been nice. - ;; But the patches can apparently share a sequence number - ;; of 0 with the original event! - ;; (╯°□°）╯ ┻━┻ - (let* ((head (find (negate (extract 'RECURRENCE-ID)) - events)) - (rest (delete head events eq?))) - - (set! (prop head '-X-HNH-ALTERNATIVES) - (alist->hash-table - (map cons - (map (extract 'RECURRENCE-ID) rest) - rest)) - #; - (sort*! rest ;; HERE - date/-time< (extract 'RECURRENCE-ID))) - (add-child! calendar head))]) - - ;; return - calendar) - (make-vcomponent) - (map #; (@ (ice-9 threads) par-map) - (lambda (fname) - (let ((fullname (/ path fname))) - (let ((cal (call-with-input-file fullname - parse-calendar))) - (set! (prop cal 'COLOR) color - (prop cal 'NAME) name - (prop cal '-X-HNH-FILENAME) fullname) - cal))) - (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) - (string= "ics" (string-take-right s 3)))))))))) - ;; Parse a vdir or ics file at the given path. (define-public (parse-cal-path path) ;; TODO check (access? path R_OK) ? @@ -127,4 +33,3 @@ (string-append "[" (basename path) "]")))) cal) - diff --git a/module/vcomponent/vdir/parse.scm b/module/vcomponent/vdir/parse.scm new file mode 100644 index 00000000..ae4ea692 --- /dev/null +++ b/module/vcomponent/vdir/parse.scm @@ -0,0 +1,102 @@ +;;; Commentary: +;; Code for parsing vdir's and icalendar files. +;; This module handles the finding of files, while +;; (vcomponent parse ical) handles reading data from icalendar files. +;;; Code: + +(define-module (vcomponent parse) + :use-module (srfi srfi-1) + + :use-module ((ice-9 hash-table) :select (alist->hash-table)) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module ((ice-9 ftw) :select (scandir ftw)) + + :use-module (util) + :use-module (util exceptions) + :use-module (vcomponent base) + + :use-module (vcomponent ical parse) + ) + + + + +;; All VTIMEZONE's seem to be in "local" time in relation to +;; themselves. Therefore, a simple comparison should work, +;; and then the TZOFFSETTO properties can be subtd. +(define (parse-vdir path) + (let ((/ (lambda args (string-join args file-name-separator-string 'infix)))) + (let ((color + (catch 'system-error + (lambda () (call-with-input-file (/ path "color") read-line)) + (const "#FFFFFF"))) + (name + (catch 'system-error + (lambda () (call-with-input-file (/ path "displayname") read-line)) + (const #f)))) + + (reduce (lambda (item calendar) + + (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) + (children item))) + + + ;; (assert (eq? 'VCALENDAR (type calendar))) + (assert (eq? 'VCALENDAR (type item))) + + (for child in (children item) + (set! (prop child '-X-HNH-FILENAME) + (prop (parent child) '-X-HNH-FILENAME))) + + ;; NOTE The vdir standard says that each file should contain + ;; EXACTLY one event. It can however contain multiple VEVENT + ;; components, but they are still the same event. + ;; In our case this means exceptions to reccurence rules, which + ;; is set up here, and then later handled in rrule-generate. + ;; NOTE These events also share UID, but are diferentiated + ;; by RECURRENCE-ID. As far as I can tell this goes against + ;; the standard. Section 3.8.4.4. + (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))] + + ;; two or more + [else + + ;; Sorting on SEQUENCE here would have been nice. + ;; But the patches can apparently share a sequence number + ;; of 0 with the original event! + ;; (╯°□°）╯ ┻━┻ + (let* ((head (find (negate (extract 'RECURRENCE-ID)) + events)) + (rest (delete head events eq?))) + + (set! (prop head '-X-HNH-ALTERNATIVES) + (alist->hash-table + (map cons + (map (extract 'RECURRENCE-ID) rest) + rest)) + #; + (sort*! rest ;; HERE + date/-time< (extract 'RECURRENCE-ID))) + (add-child! calendar head))]) + + ;; return + calendar) + (make-vcomponent) + (map #; (@ (ice-9 threads) par-map) + (lambda (fname) + (let ((fullname (/ path fname))) + (let ((cal (call-with-input-file fullname + parse-calendar))) + (set! (prop cal 'COLOR) color + (prop cal 'NAME) name + (prop cal '-X-HNH-FILENAME) fullname) + cal))) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3)))))))))) + diff --git a/module/vcomponent/vdir/save-delete.scm b/module/vcomponent/vdir/save-delete.scm new file mode 100644 index 00000000..02db9d7a --- /dev/null +++ b/module/vcomponent/vdir/save-delete.scm @@ -0,0 +1,55 @@ +;;; Commentary: +;;; Module for writing components to the vdir storage format. +;;; Currently also has some cases for "big" icalendar files, +;;; but those are currently unsupported. + +;;; TODO generalize save-event and remove-event into a general interface, +;;; which different database backends can implement. Actually, do that for all +;;; loading and writing. + +;;; Code: + +(define-module (vcomponent vdir save-delete) + :use-module (util) + :use-module (vcomponent ical output) + :use-module (vcomponent) + :use-module ((util io) :select (with-atomic-output-to-file)) + ) + + +(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)))) + (set! (prop event 'UID) uid + ;; TODO use existing filename if present? + (prop event '-X-HNH-FILENAME) (string-append + (prop calendar '-X-HNH-DIRECTORY) + / uid ".ics")) + (with-atomic-output-to-file (prop event '-X-HNH-FILENAME) + (lambda () (print-components-with-fake-parent (list event)))) + uid)] + + [else + (error "Source of calendar unknown, aborting.") + ])) + + +(define-public (remove-event event) + (define calendar (parent event)) + (case (prop calendar '-X-HNH-SOURCETYPE) + [(file) + (error "Removing events from large files unsupported")] + + [(vdir) + (delete-file (prop event '-X-HNH-FILENAME))] + + [else + (error "Source of calendar unknown, aborting.") + ])) -- cgit v1.2.3