diff options
| -rw-r--r-- | module/datetime/app.scm | 18 | ||||
| -rw-r--r-- | module/datetime/zic.scm | 2 | ||||
| -rw-r--r-- | module/entry-points/html.scm | 17 | ||||
| -rw-r--r-- | module/entry-points/ical.scm | 9 | ||||
| -rw-r--r-- | module/entry-points/server.scm | 33 | ||||
| -rwxr-xr-x | module/main.scm | 8 | ||||
| -rw-r--r-- | module/output/html.scm | 14 | ||||
| -rw-r--r-- | module/output/ical.scm | 19 | ||||
| -rw-r--r-- | module/util/app.scm | 50 | ||||
| -rw-r--r-- | module/vcomponent.scm | 61 | ||||
| -rw-r--r-- | module/vcomponent/load.scm | 55 | ||||
| -rwxr-xr-x | tzget | 28 |
12 files changed, 200 insertions, 114 deletions
diff --git a/module/datetime/app.scm b/module/datetime/app.scm new file mode 100644 index 00000000..9797ee39 --- /dev/null +++ b/module/datetime/app.scm @@ -0,0 +1,18 @@ +(define-module (datetime app) + :use-module (util) + :use-module (util app) + :use-module (ice-9 rdelim) + :use-module (datetime zic)) + +(define-method (init-app) + (setf 'zoneinfo + (let* ((pipe + (-> (@ (global) basedir) + dirname + (string-append "/tzget") + ((@ (ice-9 popen) open-input-pipe)))) + (path (read-line pipe)) + (names (string-split (read-line pipe) #\space))) + (read-zoneinfo + (map (lambda (s) (string-append path file-name-separator-string s)) + names))))) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 1c81b706..02f3230f 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -19,7 +19,7 @@ :use-module (srfi srfi-9 gnu)) -(define-public (read-zoneinfo . ports-or-filenames) +(define-public (read-zoneinfo ports-or-filenames) (parsed-zic->zoneinfo (concatenate (map (lambda (port-or-filename) diff --git a/module/entry-points/html.scm b/module/entry-points/html.scm index 70fbde42..d80de3b5 100644 --- a/module/entry-points/html.scm +++ b/module/entry-points/html.scm @@ -4,7 +4,7 @@ :use-module (util) :use-module (util time) :use-module (util config) - :use-module (vcomponent) + ;; :use-module (vcomponent) :use-module (datetime) :use-module (datetime util) :use-module (ice-9 getopt-long) @@ -30,26 +30,17 @@ (define style (string->symbol (option-ref opts 'style "wide"))) - (define-values (calendars events) - (cond [(option-ref opts 'file #f) => (compose load-calendars list)] - [else (load-calendars)])) - - - (report-time! "Calendars loaded") - (case style - [(unchunked) - (html-generate calendars events start end render-calendar)] [(wide) ; previously `chunked' - (html-chunked-main count calendars events start (date month: 1))] + (html-chunked-main count start (date month: 1))] [(week) ;; TODO The small calendar is always centered on months, it might ;; be a good idea to instead center it on the current week, meaning ;; that the active row is always in the center - (html-chunked-main count calendars events + (html-chunked-main count (start-of-week start (get-config 'week-start)) (date day: 7))] [(table) - (html-table-main count calendars events start)] + (html-table-main count start)] [else (error "Unknown html style: ~a" style)])) diff --git a/module/entry-points/ical.scm b/module/entry-points/ical.scm index f2f4e0b5..dc060ec6 100644 --- a/module/entry-points/ical.scm +++ b/module/entry-points/ical.scm @@ -22,11 +22,4 @@ ;; [else (normalize-date* (set (month start) = (+ 1)))] [(date+ start (date month: 1))] )) - - ;; TODO this contains repeated events multiple times - (define-values (calendars regular repeating) - (cond [(option-ref opts 'file #f) => (compose load-calendars* list)] - [else (load-calendars*)])) - - (ical-main calendars regular repeating start end) - ) + (ical-main start end)) diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 3455540d..63fb83a8 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -1,5 +1,6 @@ (define-module (entry-points server) :use-module (util) + :use-module (util app) :use-module (srfi srfi-1) @@ -56,7 +57,7 @@ (cdr (scandir dir)))))) -(define (make-make-routes calendar regular repeating events) +(define-method (make-make-routes) (make-routes (GET "/week/:start-date.html" (start-date) @@ -65,8 +66,8 @@ (return '((content-type text/html)) (with-output-to-string (lambda () - (html-generate calendars: calendar - events: events + (html-generate calendars: (getf 'calendars) + events: (getf 'event-set) start-date: start-date end-date: (date+ start-date (date day: 6)) next-start: (lambda (d) (date+ d (date day: 7))) @@ -80,8 +81,8 @@ (return '((content-type text/html)) (with-output-to-string (lambda () - (html-generate calendars: calendar - events: events + (html-generate calendars: (getf 'calendars) + events: (getf 'event-set) start-date: start-date end-date: (date- (month+ start-date) (date day: 1)) @@ -97,19 +98,12 @@ (return '((content-type text/calendar)) (with-output-to-string (lambda () - (ical-main calendar - regular - repeating - (parse-iso-date start) + (ical-main (parse-iso-date start) (parse-iso-date end)))))) ;; TODO this fails if there's a period in the uid. (GET "/calendar/:uid.ics" (uid) - ;; NOTE build an index. - (aif (or (find (lambda (ev) (equal? uid (attr ev 'UID))) - regular) - (find (lambda (ev) (equal? uid (attr ev 'UID))) - repeating)) + (aif (get-event-by-uid uid) (return '((content-type text/calendar)) (with-output-to-string (lambda () (print-components-with-fake-parent @@ -162,15 +156,6 @@ [(and addr (string-contains addr ".")) AF_INET] [else AF_INET6])) - (define-values (c regular repeating) - (cond [(option-ref opts 'file #f) => (compose load-calendars* list)] - [else (load-calendars*)])) - - (define all-events - ((@ (vcomponent load) calculate-recurrence-set) regular repeating)) - - - ;; update address if it was left blank. A bit clumsy since ;; @var{addr} & @var{family} depend on each other. ;; placed after load-calendars to keep Guile 2.2 compability. @@ -197,7 +182,7 @@ addr port (getpid) (getcwd)) - (run-server (make-make-routes c regular repeating all-events) + (run-server (make-make-routes) 'http `(family: ,family port: ,port diff --git a/module/main.scm b/module/main.scm index b2899014..332d9990 100755 --- a/module/main.scm +++ b/module/main.scm @@ -13,6 +13,7 @@ (util) (util io) (util time) + (util app) ((entry-points html) :prefix html-) ((entry-points terminal) :prefix terminal-) @@ -31,6 +32,7 @@ ) + (define options '((statprof (value optional)) (repl (value optional)) @@ -56,6 +58,12 @@ (when (file-exists? config-file) (primitive-load config-file))) + + ;; (current-app (make-app)) + + ((@ (vcomponent) init-app) (get-config 'calendar-files)) + ((@ (datetime app) init-app)) + (let ((ropt (ornull (option-ref opts '() '()) '("term")))) ((case (string->symbol (car ropt)) diff --git a/module/output/html.scm b/module/output/html.scm index 8a932fd0..702d229d 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -7,6 +7,7 @@ #:use-module (vcomponent group) #:use-module (vcomponent datetime) #:use-module (util) + #:use-module (util app) #:use-module (util exceptions) #:use-module (util config) #:use-module (util tree) @@ -745,7 +746,11 @@ ,@(stream->list (stream-map fmt-day evs)))))))) -(define-public (html-chunked-main count calendars events start-date chunk-length) +(define-method (html-chunked-main count start-date chunk-length) + + (define calendars (getf 'calendars)) + (define events (getf 'event-set)) + ;; TODO This still doesn't account for PWD, file existing but is of ;; wrong type, html directory existing but static symlink missing, ;; static being a different file type, and probably something else @@ -778,7 +783,12 @@ (cdr ms)))))))) -(define-public (html-table-main count calendars events start-date) + +(define-method (html-table-main count start-date) + + (define calendars (getf 'calendars)) + (define events (getf 'event-set)) + ;; TODO same file creation as in html-chunked-main (stream-for-each (lambda (start-of-month) diff --git a/module/output/ical.scm b/module/output/ical.scm index 822d929d..098d4e90 100644 --- a/module/output/ical.scm +++ b/module/output/ical.scm @@ -2,6 +2,7 @@ :use-module (ice-9 format) :use-module (ice-9 match) :use-module (util) + :use-module (util app) :use-module (vcomponent) :use-module (vcomponent datetime) :use-module (srfi srfi-1) @@ -139,10 +140,6 @@ ;; TODO place these somewhere better (define *prodid* "-//hugo//Calparse 0.9//EN") -(define *zoneinfo* (apply read-zoneinfo - ;; TODO move this to config, and figure out - ;; how to best acquire/bundle zoneinfo. - (glob "~/down/tz/{africa,antartica,asia,australasia,europe,northamerica,southamerica,backward}"))) ;; TODO tzid prop on dtstart vs tz field in datetime object ;; how do we keep these two in sync? @@ -156,7 +153,7 @@ (add-child! cal event) (awhen (prop (attr* event 'DTSTART) 'TZID) - (add-child! cal (zoneinfo->vtimezone *zoneinfo* it))) + (add-child! cal (zoneinfo->vtimezone (getf 'zoneinfo) it))) (unless (attr event 'UID) (set! (attr event 'UID) @@ -205,7 +202,7 @@ CALSCALE:GREGORIAN\r (let ((tz-names (get-tz-names events))) (for-each component->ical-string ;; TODO we realy should send the earliest event from each timezone here. - (map (lambda (name) (zoneinfo->vtimezone *zoneinfo* name (car events))) + (map (lambda (name) (zoneinfo->vtimezone (getf 'zoneinfo) name (car events))) tz-names))) (for-each component->ical-string events) @@ -214,15 +211,11 @@ CALSCALE:GREGORIAN\r ;; TODO add support for running without a range limiter, emiting all objects. -;; list x list x list x time x time → -(define-public (ical-main calendars regular-events repeating-events start end) - +(define-public (ical-main start end) (print-components-with-fake-parent - (append (filter-sorted (lambda (ev) ((in-date-range? start end) - (as-date (attr ev 'DTSTART)))) - regular-events) + (append (fixed-events-in-range start end) ;; TODO RECCURENCE-ID exceptions ;; We just dump all repeating objects, since it's much cheaper to do ;; it this way than to actually figure out which are applicable for ;; the given date range. - repeating-events))) + (getf 'repeating-events)))) diff --git a/module/util/app.scm b/module/util/app.scm new file mode 100644 index 00000000..e5b03b0f --- /dev/null +++ b/module/util/app.scm @@ -0,0 +1,50 @@ +(define-module (util app) + :use-module (util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :export (make-app current-app define-method getf setf) + ) + +(define-immutable-record-type <app> + (make-app% ht) app? (ht get-ht)) + +(define-public (make-app) + (make-app% (make-hash-table))) + +(define current-app (make-parameter (make-app))) + +(define-syntax (define-method stx) + (with-syntax ((app (datum->syntax stx 'app))) + (syntax-case stx () + [(_ (name args ...) body ...) + + (let* ((pre post (break (lambda (s) (eqv? key: (syntax->datum s))) + #'(args ...)))) + #`(define*-public (name #,@pre #,@(if (null? post) '(key:) post) + (app (current-app))) + body ...))]))) + + +(define-method (getf field) + (aif (hashq-ref (get-ht app) field) + (force it) + (error "No field" field))) + +(define-syntax setf% + (syntax-rules () + [(_ field value) + (setf% (current-app) field value)] + [(_ app field value) + (hashq-set! (get-ht app) field (delay value))])) + +(define-syntax setf + (syntax-rules () + ;; special case to use current appp) + [(_ key value) + (setf% key value)] + + [(_ app) app] + [(_ app key value rest ...) + (begin (setf% app key value) + (setf app rest ...))])) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 32406f0a..aaaf5d36 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -1,10 +1,69 @@ (define-module (vcomponent) + :use-module (util) + :use-module (util app) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (datetime) + :use-module (datetime util) :use-module (vcomponent base) :use-module (vcomponent parse) :use-module (vcomponent load) - :use-module (util) + :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 load-calendars load-calendars*)) (re-export-modules (vcomponent base)) + + +;; TODO rename function +(define (calculate-recurrence-set regular repeating) + (interleave-streams + ev-time<? + (cons (list->stream regular) + (map (@ (vcomponent recurrence) generate-recurrence-set) repeating) + ))) + + +(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)))) + + (setf 'fixed-and-repeating-events + (let* ((repeating regular (partition repeating? (getf 'events)))) + + ;; (report-time! "Sorting") + ;; NOTE There might be instances where we don't care if the + ;; collection if sorted, but for the time beieng it's much + ;; easier to always sort it. + (list + (sort*! regular date/-time<? (extract 'DTSTART)) + (sort*! repeating date/-time<? (extract 'DTSTART))))) + + (setf 'fixed-events (car (getf 'fixed-and-repeating-events))) + (setf 'repeating-events (cadr (getf 'fixed-and-repeating-events))) + + (setf 'event-set (calculate-recurrence-set + (getf 'fixed-events) + (getf 'repeating-events))) + + (setf 'uid-map + (let ((ht (make-hash-table))) + (for-each (lambda (event) (hash-set! ht (attr 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 (attr ev 'DTSTART)))) + (getf 'fixed-events))) + +(define-method (get-event-by-uid uid) + (hash-ref (getf 'uid-map) uid)) diff --git a/module/vcomponent/load.scm b/module/vcomponent/load.scm index 37d57b56..09dcd3c8 100644 --- a/module/vcomponent/load.scm +++ b/module/vcomponent/load.scm @@ -1,59 +1,10 @@ (define-module (vcomponent load) :export (load-calendars load-calendars*) :use-module (util) - :use-module (util time) :use-module (util config) - :use-module (srfi srfi-1) - :use-module (datetime) - :use-module (datetime util) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - ;; :use-module (parameters) - ;; :use-module (vcomponent) - :use-module (vcomponent base) - :use-module ((vcomponent parse) :select (parse-cal-path)) - :use-module ((vcomponent recurrence) :select (generate-recurrence-set repeating?)) - :use-module ((vcomponent datetime) :select (ev-time<?))) + :use-module ((vcomponent parse) :select (parse-cal-path))) (define-config calendar-files '() "" list?) -(define-public (calculate-recurrence-set regular repeating) - (interleave-streams - ev-time<? - (cons (list->stream regular) - (map generate-recurrence-set repeating) - ))) - -;; Reads all calendar files from disk, generate recurence-sets for all repeating events, -;; and returns a list of calendars, and a stream of all events "ready" for display. -(define* (load-calendars #:optional (calendar-files (get-config 'calendar-files))) - (report-time! "Parsing ~a calendars" (length calendar-files)) - (let* ((calendars regular repeating (load-calendars* calendar-files))) - (report-time! "Calendars loaded, interleaving and reccurring") - (values - calendars - (calculate-recurrence-set regular repeating)))) - -;; Basic version, loads calendrs, sorts the events, and returns -;; regular and repeating events separated from each other. -;; -;; (list string) → (list calendar), (list event), (list event) -(define* (load-calendars* #:optional (calendar-files (get-config 'calendar-files))) - - (define calendars (map parse-cal-path calendar-files)) - (define events (concatenate - ;; TODO does this drop events? - (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o))) - (children cal))) - calendars))) - - (report-time! "Parse done, partitioning...") - (let* ((repeating regular (partition repeating? events))) - - (report-time! "Sorting") - ;; NOTE There might be instances where we don't care if the - ;; collection if sorted, but for the time beieng it's much - ;; easier to always sort it. - (values calendars - (sort*! regular date/-time<? (extract 'DTSTART)) - (sort*! repeating date/-time<? (extract 'DTSTART))))) +(define* (load-calendars calendar-files) + (map parse-cal-path calendar-files)) @@ -0,0 +1,28 @@ +#!/bin/bash + +CACHE_DIR=${CACHE_DIR:-~/.cache/calp} +RELEASE=2020a +TZ_SRC="https://github.com/eggert/tz/archive/$RELEASE.tar.gz" + +mkdir -p $CACHE_DIR +cd $CACHE_DIR + +test -f "$RELEASE.tar.gz" || curl -sOL $TZ_SRC +test -d "tz-$RELEASE" || tar xzf "$RELEASE.tar.gz" +cd "tz-$RELEASE" + +tzpath=$(pwd) + +size=$(stat -c "%s" Makefile) + +cat >> Makefile << EOF +.PHONY: print-tdata +print-tdata: + @echo \$(TDATA_TO_CHECK) +EOF +files=$(make print-tdata) + +truncate -cs $size Makefile + +echo $tzpath +echo $files |