From 14a050dbebfaf53517c4cf1eed07974af41d2c1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 29 Apr 2020 21:55:37 +0200 Subject: Handle TZ-rule with minimum start. --- module/datetime/zic.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 52457ada..1c81b706 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -377,7 +377,8 @@ ;; group rules and put in map (awhen (assoc-ref groups 'rule) (for-each (lambda (group) - (hashq-set! rules (car group) (sort* (cadr group) < rule-from))) + (hashq-set! rules (car group) (sort* (cadr group) (lambda (a b) (if (eq? 'minimum) #t (< a b))) + rule-from))) (group-by rule-name (car it)))) ;; put zones in map -- cgit v1.2.3 From 7968d3b30a4da523ffaa2fbd23120921084bf54b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 12:56:05 +0200 Subject: Move environment setup to standalone sh file. --- README | 2 +- README.in | 2 +- main | 6 ++++++ module/main.scm | 8 +++----- 4 files changed, 11 insertions(+), 7 deletions(-) create mode 100755 main diff --git a/README b/README index ef1eab18..d958cc27 100644 --- a/README +++ b/README @@ -14,7 +14,7 @@ For basic usage, create a file ~/.config/calp/config.scm which (at leasts) calls the f`calendar-files' with a list of files or directories containing ics file. (Both single calendar files, and vdir's are supported, see vdirsyncer and ikhal). Then run: - module/main.scm html --chunked --count 1 + ./main html --chunked --count 1 Which should generate a single HTML-page for the current month. Contributing diff --git a/README.in b/README.in index 1b5515bb..f00fa796 100644 --- a/README.in +++ b/README.in @@ -5,7 +5,7 @@ Calp is primarily a program for loading calendar files (.ics's) from drendering them in different formats. The goal is however to also support fancy filtering, an edit server, and more. The currently working frontends is the HTML-frontend, which have the two main modes of a month-by-month in "week" view, or a table of a single month, and the terminal frontend. The terminatend is mostly for debugging purposes, but it's quite usable still. For basic usage, create a file ~/.config/calp/config.scm which (at leasts) calls the f`calendar-files' with a list of files or directories containing ics file. (Both single calendar files, and vdir's are supported, see vdirsyncer and ikhal). Then run: - module/main.scm html --chunked --count 1 + ./main html --chunked --count 1 Which should generate a single HTML-page for the current month. Contributing diff --git a/main b/main new file mode 100755 index 00000000..2d3e7e4a --- /dev/null +++ b/main @@ -0,0 +1,6 @@ +#!/bin/bash + +here=$(dirname $(realpath $0)) +. $here/env + +exec guile -e main -s $here/module/main.scm "$@" diff --git a/module/main.scm b/module/main.scm index 246e729c..c90adb0c 100755 --- a/module/main.scm +++ b/module/main.scm @@ -1,10 +1,8 @@ -#!/bin/bash -# -*- mode: scheme; geiser-scheme-implementation: guile -*- +;; -*- geiser-scheme-implementation: guile -*- -. $(dirname $(dirname $(realpath $0)))/env +(when (current-filename) + (add-to-load-path (dirname (current-filename)))) -exec guile -e main -s $0 "$@" -!# (use-modules (srfi srfi-1) (srfi srfi-41) -- cgit v1.2.3 From af2bc0d360082721197128171eddaad2d12a6905 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 12:56:20 +0200 Subject: Add "missing" regex import. --- module/repl.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/repl.scm b/module/repl.scm index f73f3da6..a0133403 100644 --- a/module/repl.scm +++ b/module/repl.scm @@ -1,6 +1,6 @@ (define-module (repl) :use-module (system repl server) - ) + :use-module (ice-9 regex)) (define-public (runtime-dir) (or (getenv "XDG_RUNTIME_DIR") -- cgit v1.2.3 From 3fe27b00588c442af4fca49f9c106c0486bd235a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 18:18:23 +0200 Subject: Add global basedir var. --- module/global.scm | 10 ++++++++++ module/main.scm | 1 + 2 files changed, 11 insertions(+) create mode 100644 module/global.scm diff --git a/module/global.scm b/module/global.scm new file mode 100644 index 00000000..f8d0cd7f --- /dev/null +++ b/module/global.scm @@ -0,0 +1,10 @@ +(define-module (global)) + +;; TODO encapsulating these in +;; atomic boxes might be a good +;; idea. + +(define-once basedir #f) + +(export basedir) + diff --git a/module/main.scm b/module/main.scm index c90adb0c..b2899014 100755 --- a/module/main.scm +++ b/module/main.scm @@ -3,6 +3,7 @@ (when (current-filename) (add-to-load-path (dirname (current-filename)))) +(set! (@ (global) basedir) (car %load-path)) (use-modules (srfi srfi-1) (srfi srfi-41) -- cgit v1.2.3 From 65dfe0abc3e898dcff5672e668aab720d5891cc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 18:34:06 +0200 Subject: Add `app' type. --- module/util/app.scm | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 module/util/app.scm diff --git a/module/util/app.scm b/module/util/app.scm new file mode 100644 index 00000000..269812aa --- /dev/null +++ b/module/util/app.scm @@ -0,0 +1,44 @@ +(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 + (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 (getf app field) + (aif (hashq-ref (get-ht app) field) + (force it) + #f)) + +(define-syntax setf% + (syntax-rules () + [(_ app field value) + (hashq-set! (get-ht app) field (delay (begin value)))])) + +(define-syntax setf + (syntax-rules () + [(_ app) app] + [(_ app key value rest ...) + (begin (setf% app key value) + (setf app rest ...))])) -- cgit v1.2.3 From 5a4e98ebe9b82c8b4abae3d1e4535fadcfbd8907 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 18:35:15 +0200 Subject: Update vcomponent to load into the app object. --- module/vcomponent.scm | 61 +++++++++++++++++++++++++++++++++++++++++++++- module/vcomponent/load.scm | 55 +++-------------------------------------- 2 files changed, 63 insertions(+), 53 deletions(-) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 32406f0a..83954f52 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-timestream regular) + (map (@ (vcomponent recurrence) generate-recurrence-set) repeating) + ))) + + +(define-method (init-app calendar-files) + (setf app 'calendars (load-calendars calendar-files)) + + (setf app 'events + (concatenate + ;; TODO does this drop events? + (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o))) + (children cal))) + (getf app 'calendars)))) + + (setf app 'fixed-and-repeating-events + (let* ((repeating regular (partition repeating? (getf app '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/-timestream 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 Date: Thu, 30 Apr 2020 18:36:39 +0200 Subject: Add tzget script. --- tzget | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100755 tzget diff --git a/tzget b/tzget new file mode 100755 index 00000000..1fd2340a --- /dev/null +++ b/tzget @@ -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 -- cgit v1.2.3 From 8b426edf1b6d4de0ec825da8a34b1df7b51212db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 18:37:03 +0200 Subject: Update ical parts to use app context. --- module/datetime/app.scm | 18 ++++++++++++++++++ module/datetime/zic.scm | 2 +- module/entry-points/ical.scm | 9 +-------- module/main.scm | 8 ++++++++ module/output/ical.scm | 19 ++++++------------- 5 files changed, 34 insertions(+), 22 deletions(-) create mode 100644 module/datetime/app.scm diff --git a/module/datetime/app.scm b/module/datetime/app.scm new file mode 100644 index 00000000..989a0847 --- /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 app '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/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/main.scm b/module/main.scm index b2899014..96fe2da1 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/ical.scm b/module/output/ical.scm index 822d929d..8388bfc1 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 (current-app) '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 (current-app) '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 (current-app) 'repeating-events)))) -- cgit v1.2.3 From c74486cbb2efda112dc2631aa3ed84824fc61c8a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 18:41:39 +0200 Subject: Update HTML to use app. --- module/entry-points/html.scm | 17 ++++------------- module/output/html.scm | 14 ++++++++++++-- 2 files changed, 16 insertions(+), 15 deletions(-) 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/output/html.scm b/module/output/html.scm index 8a932fd0..740be7b9 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 app 'calendars)) + (define events (getf app '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 app 'calendars)) + (define events (getf app 'event-set)) + ;; TODO same file creation as in html-chunked-main (stream-for-each (lambda (start-of-month) -- cgit v1.2.3 From fe294992fda2015305c9f85725e8b68a1b3ccfeb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 19:01:31 +0200 Subject: Minor changes. --- module/main.scm | 2 +- module/util/app.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/module/main.scm b/module/main.scm index 96fe2da1..332d9990 100755 --- a/module/main.scm +++ b/module/main.scm @@ -59,7 +59,7 @@ (primitive-load config-file))) - (current-app (make-app)) + ;; (current-app (make-app)) ((@ (vcomponent) init-app) (get-config 'calendar-files)) ((@ (datetime app) init-app)) diff --git a/module/util/app.scm b/module/util/app.scm index 269812aa..95df741a 100644 --- a/module/util/app.scm +++ b/module/util/app.scm @@ -29,7 +29,7 @@ (define (getf app field) (aif (hashq-ref (get-ht app) field) (force it) - #f)) + (error "No field" field))) (define-syntax setf% (syntax-rules () -- cgit v1.2.3 From 8872d37332619820c7f00f95867eb836fc0c3950 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 19:01:44 +0200 Subject: Update server to use app. --- module/entry-points/server.scm | 33 +++++++++------------------------ 1 file changed, 9 insertions(+), 24 deletions(-) diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 408b00b3..6a4558a6 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) @@ -54,7 +55,7 @@ (cddr (scandir dir)))))) -(define (make-make-routes calendar regular repeating events) +(define-method (make-make-routes) (make-routes (GET "/week/:start-date.html" (start-date) @@ -63,8 +64,8 @@ (return '((content-type text/html)) (with-output-to-string (lambda () - (html-generate calendars: calendar - events: events + (html-generate calendars: (getf app 'calendars) + events: (getf app 'event-set) start-date: start-date end-date: (date+ start-date (date day: 6)) next-start: (lambda (d) (date+ d (date day: 7))) @@ -78,8 +79,8 @@ (return '((content-type text/html)) (with-output-to-string (lambda () - (html-generate calendars: calendar - events: events + (html-generate calendars: (getf app 'calendars) + events: (getf app 'event-set) start-date: start-date end-date: (date- (month+ start-date) (date day: 1)) @@ -95,19 +96,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 returns "invalid" events, since the surrounding VCALENDAR is missing. (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 @@ -160,15 +154,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. @@ -195,7 +180,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 -- cgit v1.2.3 From 986afaf97fa07832d895e62a48cf5eda07cd0aa3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 22:58:18 +0200 Subject: Escape closes all popups. --- static/script.js | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/static/script.js b/static/script.js index b94e8f06..8617159a 100644 --- a/static/script.js +++ b/static/script.js @@ -222,6 +222,12 @@ function setVar(str, val) { document.documentElement.style.setProperty("--" + str, val); } +function close_all_popups () { + for (let popup of document.getElementsByClassName("popup")) { + popup.classList.remove("show"); + } +} + window.onload = function () { start_time.setTime(document.querySelector("meta[name='start-time']").content * 1000) end_time.setTime(document.querySelector("meta[name='end-time']").content * 1000) @@ -255,4 +261,11 @@ window.onload = function () { e.parentElement.removeAttribute("href"); } + document.onkeydown = function (evt) { + evt = evt || window.event; + if (evt.key.startsWith("Esc")) { + close_all_popups(); + } + } + } -- cgit v1.2.3 From aa44c16ce953c090b2eb3ce580c60fa8934a7720 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 19:17:35 +0200 Subject: Change call signature for [gs]etf. --- module/datetime/app.scm | 10 +++++----- module/entry-points/server.scm | 8 ++++---- module/output/html.scm | 8 ++++---- module/output/ical.scm | 6 +++--- module/util/app.scm | 10 ++++++++-- module/vcomponent.scm | 28 ++++++++++++++-------------- 6 files changed, 38 insertions(+), 32 deletions(-) diff --git a/module/datetime/app.scm b/module/datetime/app.scm index 989a0847..9797ee39 100644 --- a/module/datetime/app.scm +++ b/module/datetime/app.scm @@ -5,12 +5,12 @@ :use-module (datetime zic)) (define-method (init-app) - (setf app 'zoneinfo + (setf 'zoneinfo (let* ((pipe - (-> (@ (global) basedir) - dirname - (string-append "/tzget") - ((@ (ice-9 popen) open-input-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 diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 6a4558a6..3dab6e9c 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -64,8 +64,8 @@ (return '((content-type text/html)) (with-output-to-string (lambda () - (html-generate calendars: (getf app 'calendars) - events: (getf app 'event-set) + (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))) @@ -79,8 +79,8 @@ (return '((content-type text/html)) (with-output-to-string (lambda () - (html-generate calendars: (getf app 'calendars) - events: (getf app 'event-set) + (html-generate calendars: (getf 'calendars) + events: (getf 'event-set) start-date: start-date end-date: (date- (month+ start-date) (date day: 1)) diff --git a/module/output/html.scm b/module/output/html.scm index 740be7b9..702d229d 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -748,8 +748,8 @@ (define-method (html-chunked-main count start-date chunk-length) - (define calendars (getf app 'calendars)) - (define events (getf app 'event-set)) + (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, @@ -786,8 +786,8 @@ (define-method (html-table-main count start-date) - (define calendars (getf app 'calendars)) - (define events (getf app 'event-set)) + (define calendars (getf 'calendars)) + (define events (getf 'event-set)) ;; TODO same file creation as in html-chunked-main (stream-for-each diff --git a/module/output/ical.scm b/module/output/ical.scm index 8388bfc1..098d4e90 100644 --- a/module/output/ical.scm +++ b/module/output/ical.scm @@ -153,7 +153,7 @@ (add-child! cal event) (awhen (prop (attr* event 'DTSTART) 'TZID) - (add-child! cal (zoneinfo->vtimezone (getf (current-app) 'zoneinfo) it))) + (add-child! cal (zoneinfo->vtimezone (getf 'zoneinfo) it))) (unless (attr event 'UID) (set! (attr event 'UID) @@ -202,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 (getf (current-app) 'zoneinfo) name (car events))) + (map (lambda (name) (zoneinfo->vtimezone (getf 'zoneinfo) name (car events))) tz-names))) (for-each component->ical-string events) @@ -218,4 +218,4 @@ CALSCALE:GREGORIAN\r ;; 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. - (getf (current-app) 'repeating-events)))) + (getf 'repeating-events)))) diff --git a/module/util/app.scm b/module/util/app.scm index 95df741a..e5b03b0f 100644 --- a/module/util/app.scm +++ b/module/util/app.scm @@ -26,18 +26,24 @@ body ...))]))) -(define (getf app field) +(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 (begin 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) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 83954f52..aaaf5d36 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -28,17 +28,17 @@ (define-method (init-app calendar-files) - (setf app 'calendars (load-calendars calendar-files)) + (setf 'calendars (load-calendars calendar-files)) - (setf app 'events + (setf 'events (concatenate ;; TODO does this drop events? (map (lambda (cal) (filter (lambda (o) (eq? 'VEVENT (type o))) (children cal))) - (getf app 'calendars)))) + (getf 'calendars)))) - (setf app 'fixed-and-repeating-events - (let* ((repeating regular (partition repeating? (getf app 'events)))) + (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 @@ -48,22 +48,22 @@ (sort*! regular date/-time Date: Thu, 30 Apr 2020 23:08:48 +0200 Subject: Update error on /calendar/ endpoint. --- module/entry-points/server.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 408b00b3..83d80c27 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -101,7 +101,7 @@ (parse-iso-date start) (parse-iso-date end)))))) - ;; TODO this returns "invalid" events, since the surrounding VCALENDAR is missing. + ;; 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))) -- cgit v1.2.3 From 6471a30a58334aedb32f8fb90c720746306c8aae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 1 May 2020 13:03:49 +0200 Subject: Server make-routes now support custom regexes. --- module/server/macro.scm | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/module/server/macro.scm b/module/server/macro.scm index b9ce94bb..28565c3b 100644 --- a/module/server/macro.scm +++ b/module/server/macro.scm @@ -9,15 +9,28 @@ (define-public (parse-endpoint-string str) - (let ((rx (make-regexp ":([^/.]+)"))) + (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) (let loop ((str str) (string "") (tokens '())) (let ((m (regexp-exec rx str 0))) (if (not m) + ;; done (values (string-append string str) (reverse tokens)) + (loop (match:suffix m) - (string-append string (match:prefix m) "([^/.]+)") + (string-append string (match:prefix m) + (aif (match:substring m 3) + (string-append "(" it ")") + "([^/.]+)") + ;; period directly following matched variable. + ;; since many variables break on period, we often + ;; want to match a literal period directly after them. + ;; Ideally all periods outside of pattern should be + ;; matched literally, but that's harder to implement. + (regexp-quote + (aif (match:substring m 4) + "." ""))) (cons (string->symbol (match:substring m 1)) tokens))))))) -- cgit v1.2.3 From 5ddd131b95389712e17c7d556a28dc6f1ad6719e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 1 May 2020 13:04:12 +0200 Subject: Server server any subdir under static. --- module/entry-points/server.scm | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 83d80c27..3455540d 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -38,20 +38,22 @@ (with-output-to-string (lambda () (display "\n") (sxml->xml sxml)))) +(define (// . args) (string-join args file-name-separator-string )) + (define (directory-table dir) `(table (thead (tr (th "") (th "Name") (th "Perm"))) (tbody ,@(map (lambda (k) - (let* ((stat (lstat k))) + (let* ((stat (lstat (// dir k)))) `(tr (td ,(case (stat:type stat) [(directory) "📁"] [(regular) "📰"] [else "🙃"])) - (td (a (@ (href "/" ,dir ,k)) ,k)) + (td (a (@ (href "/" ,dir "/" ,k)) ,k)) (td ,(number->string (stat:perms stat) 8))))) - (cddr (scandir dir)))))) + (cdr (scandir dir)))))) (define (make-make-routes calendar regular repeating events) @@ -115,23 +117,23 @@ (return (build-response code: 404) (format #f "No component with UID=~a found." uid)))) - (GET "/static" () - (return - '((content-type text/html)) - (sxml->html-string - (directory-table "static/")))) + ;; NOTE this only handles files with extensions. Limited, but since this + ;; is mostly for development, and something like nginx should be used in + ;; production it isn't a huge problem. - (GET "/static/:filename.css" (filename) + (GET "/static/:*{.*}.:ext" (* ext) (return - `((content-type text/css)) - (call-with-input-file (string-append "static/" filename ".css") + ;; TODO actually check mimetype + `((content-type ,(string->symbol (string-append "text/" ext)))) + (call-with-input-file (string-append "static/" * "." ext) read-string))) - (GET "/static/:filename.js" (filename) + (GET "/static/:*{.*}" (*) (return - `((content-type text/javascript)) - (call-with-input-file (string-append "static/" filename ".js") - read-string))) + '((content-type text/html)) + (sxml->html-string + (directory-table (// "static" *))))) + (GET "/count" () ;; (sleep 1) -- cgit v1.2.3