From 5a91457a5b8595969957cd6676afc2fff858251e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 17:19:37 +0200 Subject: HTML Created events now have a description. Unfortunately they ALWAYS have a description. --- module/html/vcomponent.scm | 5 +++-- module/html/view/calendar.scm | 3 ++- 2 files changed, 5 insertions(+), 3 deletions(-) (limited to 'module') diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index f9c24ecd..ca8a81c2 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -78,8 +78,9 @@ (div (@ (class "location")) ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) (prop ev 'LOCATION))))) - ,(and=> (prop ev 'DESCRIPTION) - (lambda (str) (format-description ev str))) + ,(awhen (prop ev 'DESCRIPTION) + `(span (@ (class "description")) + ,(format-description ev it))) ,(awhen (prop ev 'RRULE) `(span (@ (class "rrule")) ,@(format-recurrence-rule ev))) diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index 2371cfe0..4753e1e6 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -317,7 +317,8 @@ ;; cloned mulitple times. dtstart: (datetime) dtend: (datetime) - summary: "New Event")))) + summary: "New Event" + description: "None yet")))) (event (car (children cal)))) `((div (@ (class "template event-container") (id "event-template") ;; Only needed to create a duration. So actual dates -- cgit v1.2.3 From ad78b193271abb6df486d3acfd7ab94f51cd101c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 19:39:37 +0200 Subject: Can create events without descriptions again. --- module/html/view/calendar.scm | 5 ++++- module/vcomponent/parse/xcal.scm | 30 ++++++++++++++++++------------ 2 files changed, 22 insertions(+), 13 deletions(-) (limited to 'module') diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index 4753e1e6..f058d01e 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -318,7 +318,10 @@ dtstart: (datetime) dtend: (datetime) summary: "New Event" - description: "None yet")))) + ;; force a description field, + ;; but don't put anything in + ;; it. + description: "")))) (event (car (children cal)))) `((div (@ (class "template event-container") (id "event-template") ;; Only needed to create a duration. So actual dates diff --git a/module/vcomponent/parse/xcal.scm b/module/vcomponent/parse/xcal.scm index 76bdb251..06745864 100644 --- a/module/vcomponent/parse/xcal.scm +++ b/module/vcomponent/parse/xcal.scm @@ -126,21 +126,27 @@ (let ((params (handle-parameters parameters)) (tag* (symbol-upcase tag))) (for (type value) in (zip type value) - (set! (prop* component tag*) - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params))))] + ;; ignore empty fields + ;; mostly for + (unless (null? value) + (set! (prop* component tag*) + (make-vline tag* + (handle-tag + tag (handle-value type params value)) + params)))))] [(tag (type value ...) ...) (for (type value) in (zip type value) - (let ((params (make-hash-table)) - (tag* (symbol-upcase tag))) - (set! (prop* component tag*) - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params))))]))) + ;; ignore empty fields + ;; mostly for + (unless (null? value) + (let ((params (make-hash-table)) + (tag* (symbol-upcase tag))) + (set! (prop* component tag*) + (make-vline tag* + (handle-tag + tag (handle-value type params value)) + params)))))]))) ;; children (awhen (assoc-ref sxcal 'components) -- cgit v1.2.3 From 995929362ea939adf7abf420adf02eb549392fae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 19:40:24 +0200 Subject: Add TODO about trimming text. --- module/vcomponent/parse/xcal.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'module') diff --git a/module/vcomponent/parse/xcal.scm b/module/vcomponent/parse/xcal.scm index 06745864..2c8b7fe8 100644 --- a/module/vcomponent/parse/xcal.scm +++ b/module/vcomponent/parse/xcal.scm @@ -22,6 +22,7 @@ [(boolean) (string=? "true" (car value))] + ;; TODO possibly trim whitespace on text fields [(cal-address uri text unknown) (car value)] [(date) (parse-iso-date (car value))] -- cgit v1.2.3 From 2e684fd427097965834bd5f1f22196be99b82757 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 19:49:28 +0200 Subject: Allow events to enter edit mode after creation. --- module/html/vcomponent.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'module') diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index ca8a81c2..308f779a 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -175,6 +175,9 @@ title: "Stäng" onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))" class: '("close-tooltip")) + ,(btn "🖊️" + title: "Redigera" + onclick: "place_in_edit_mode(document.getElementById(this.closest('.popup-container').id.substr(5)))") ,(btn "🗑" title: "Ta bort" onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")) -- cgit v1.2.3 From 7c914d16b60fb72aa25aa469b60b85f06fb3a518 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 20:05:40 +0200 Subject: Keep summary when editing existing elements. --- module/html/view/calendar.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'module') diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index f058d01e..7d38140f 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -317,7 +317,7 @@ ;; cloned mulitple times. dtstart: (datetime) dtend: (datetime) - summary: "New Event" + summary: "" ;; force a description field, ;; but don't put anything in ;; it. -- cgit v1.2.3 From aa18e57dfdf2bd0f626d7101ab712e6a0ff6dbf3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 20:05:56 +0200 Subject: Focus summary when editing existing. --- module/entry-points/server.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'module') diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 466860cd..dc675813 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -163,6 +163,9 @@ (format #f "No event with UID '~a'" uid)))) ;; TODO this fails when dtstart is . + ;; TODO If data has an explicit UID and that UID already exists we + ;; overwrite it in the database. We however don't remove the old + ;; event from the in-memory set, but rather just adds the new. (POST "/insert" (cal data) (unless (and cal data) -- cgit v1.2.3 From 70dd50111a339fd9fcf54cc2f9670c1313a154a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 20:25:56 +0200 Subject: Mercge CAL and CAL_bg css classes. --- module/html/vcomponent.scm | 20 +++++++++----------- module/html/view/calendar.scm | 2 +- 2 files changed, 10 insertions(+), 12 deletions(-) (limited to 'module') diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index 308f779a..1b17f039 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -50,7 +50,7 @@ ;; (format (current-error-port) "fmt-single-event: ~a~%" (prop ev 'X-HNH-FILENAME)) `(article (@ ,@(assq-merge attributes - `((class "eventtext CAL_bg_" + `((class "eventtext CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown")) ,(when (and (prop ev 'PARTSTAT) (eq? 'TENTATIVE (prop ev 'PARTSTAT))) @@ -119,16 +119,14 @@ (define-public (calendar-styles calendars) `(style - ,(format - #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~a }~%~}" - (map (lambda (c) - (let* ((name (html-attr (prop c 'NAME))) - (bg-color (prop c 'COLOR)) - (fg-color (and=> (prop c 'COLOR) - calculate-fg-color))) - (list name (or bg-color 'white) (or fg-color 'black) - name (or bg-color 'black)))) - calendars)))) + ,(format #f "~:{.CAL_~a { --color: ~a; --complement: ~a }~%~}" + (map (lambda (c) + (let* ((name (html-attr (prop c 'NAME))) + (bg-color (prop c 'COLOR)) + (fg-color (and=> (prop c 'COLOR) + calculate-fg-color))) + (list name (or bg-color 'white) (or fg-color 'black)))) + calendars)))) ;; "Physical" block in calendar view (define*-public (make-block ev optional: (extra-attributes '())) diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index 7d38140f..4fad41c8 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -284,7 +284,7 @@ (summary "Calendar list") (ul ,@(map (lambda (calendar) - `(li (@ (class "CAL_bg_" + `(li (@ (class "CAL_" ,(html-attr (prop calendar 'NAME)))) ,(prop calendar 'NAME))) calendars)))) -- cgit v1.2.3 From 54c613f48caa01f05fac2774dc2d2253568b552e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 20:17:25 +0200 Subject: Add dropdown editing event. --- module/html/view/calendar.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'module') diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index 4fad41c8..39f1092d 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -287,7 +287,14 @@ `(li (@ (class "CAL_" ,(html-attr (prop calendar 'NAME)))) ,(prop calendar 'NAME))) - calendars)))) + calendars)) + (div (@ (id "calendar-dropdown-template") (class "template")) + (select + ,@(map (lambda (calendar) + `(option (@ (value ,(prop calendar 'NAME))) + ,(prop calendar 'NAME))) + calendars)) + ))) ;; List of events (div (@ (class "eventlist") -- cgit v1.2.3 From 263e64dfe8549e6c726fb06dd5cdc03fa6a90298 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 20:41:28 +0200 Subject: Limit CAL_ class to once per 'thing'. --- module/html/vcomponent.scm | 52 +++++++++++++++++++++++-------------------- module/html/view/calendar.scm | 2 +- 2 files changed, 29 insertions(+), 25 deletions(-) (limited to 'module') diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index 1b17f039..5123af09 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -43,18 +43,21 @@ ;; TODO better format, add show in calendar button ,(fmt-single-event event))))) -;; For sidebar, just text +;; Format event as text. +;; Used in +;; - sidebar +;; - popup overwiew tab +;; - search result (event details) (define*-public (fmt-single-event ev optional: (attributes '()) key: (fmt-header list)) ;; (format (current-error-port) "fmt-single-event: ~a~%" (prop ev 'X-HNH-FILENAME)) `(article (@ ,@(assq-merge attributes - `((class "eventtext CAL_" - ,(html-attr (or (prop (parent ev) 'NAME) "unknown")) + `((class " eventtext " ,(when (and (prop ev 'PARTSTAT) (eq? 'TENTATIVE (prop ev 'PARTSTAT))) - " tentative"))))) + " tentative "))))) (h3 ,(fmt-header (when (prop ev 'RRULE) `(span (@ (class "repeating")) "↺")) @@ -100,13 +103,15 @@ (class "hidelink")) ,s)))) ,@(stream->list (stream-map - (lambda (ev) (fmt-single-event - ev `((id ,(html-id ev))) - fmt-header: - (lambda body - `(a (@ (href "#" ,(date-link (as-date (prop ev 'DTSTART)))) - (class "hidelink")) - ,@body)))) + (lambda (ev) + (fmt-single-event + ev `((id ,(html-id ev)) + (class "CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown")))) + fmt-header: + (lambda body + `(a (@ (href "#" ,(date-link (as-date (prop ev 'DTSTART)))) + (class "hidelink")) + ,@body)))) (stream-filter (lambda (ev) ;; If start was an earlier day @@ -165,10 +170,9 @@ (define-public (popup ev id) `(div (@ (class "popup-container") (id ,id) (onclick "event.stopPropagation()")) - (div (@ (class "popup")) - (nav (@ (class "popup-control CAL_" - ,(html-attr (or (prop (parent ev) 'NAME) - "unknown")))) + (div (@ (class "popup CAL_" ,(html-attr (or (prop (parent ev) 'NAME) + "unknown"))) ) + (nav (@ (class "popup-control")) ,(btn "×" title: "Stäng" onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))" @@ -181,12 +185,12 @@ onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")) ,(tabset - `(("📅" title: "Översikt" - ,(fmt-single-event ev)) - ("⤓" title: "Nedladdning" - (div (@ (style "font-family:sans")) - (p "Ladda ner") - (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) - "som iCal")) - (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) - "som xCal")))))))))) + `(("📅" title: "Översikt" + ,(fmt-single-event ev)) + ("⤓" title: "Nedladdning" + (div (@ (style "font-family:sans")) + (p "Ladda ner") + (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics")) + "som iCal")) + (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs")) + "som xCal")))))))))) diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index 39f1092d..3c239bc6 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -291,7 +291,7 @@ (div (@ (id "calendar-dropdown-template") (class "template")) (select ,@(map (lambda (calendar) - `(option (@ (value ,(prop calendar 'NAME))) + `(option (@ (value ,(html-attr (prop calendar 'NAME)))) ,(prop calendar 'NAME))) calendars)) ))) -- cgit v1.2.3 From e360d3566eb878a944dada510a0c7e8437a5554b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 21:31:52 +0200 Subject: Fix frontend for calendar choosing. --- module/html/vcomponent.scm | 9 ++++++--- module/html/view/calendar.scm | 1 + 2 files changed, 7 insertions(+), 3 deletions(-) (limited to 'module') diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index 5123af09..3fac17bb 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -168,10 +168,13 @@ (define-public (popup ev id) - `(div (@ (class "popup-container") (id ,id) + `(div (@ (id ,id) (class "popup-container CAL_" + ,(html-attr (or (prop (parent ev) 'NAME) + "unknown"))) (onclick "event.stopPropagation()")) - (div (@ (class "popup CAL_" ,(html-attr (or (prop (parent ev) 'NAME) - "unknown"))) ) + ;; TODO all (?) code uses .popup-container as the popup, while .popup sits and does nothing. + ;; Do something about this? + (div (@ (class "popup")) (nav (@ (class "popup-control")) ,(btn "×" title: "Stäng" diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index 3c239bc6..72fcccbd 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -290,6 +290,7 @@ calendars)) (div (@ (id "calendar-dropdown-template") (class "template")) (select + (option "- Choose a Calendar -") ,@(map (lambda (calendar) `(option (@ (value ,(html-attr (prop calendar 'NAME)))) ,(prop calendar 'NAME))) -- cgit v1.2.3 From aa1670d5a0973ef52f75d7771ccfc7f0f5807e1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 06:47:49 +0200 Subject: Slightly clean up server imports. --- module/entry-points/server.scm | 17 +++++++---------- module/html/view/calendar.scm | 2 ++ module/server/macro.scm | 3 ++- 3 files changed, 11 insertions(+), 11 deletions(-) (limited to 'module') diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index dc675813..ec9d3c3f 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -1,6 +1,5 @@ (define-module (entry-points server) :use-module (util) - :use-module (util config) :use-module (util options) :use-module (util exceptions) @@ -9,11 +8,9 @@ :use-module (ice-9 match) :use-module (ice-9 control) - :use-module (ice-9 rdelim) - :use-module (ice-9 curried-definitions) - :use-module (ice-9 ftw) + :use-module ((ice-9 rdelim) :select (read-string)) + :use-module ((ice-9 ftw) :select (scandir)) :use-module (ice-9 getopt-long) - :use-module (ice-9 iconv) :use-module (ice-9 regex) #| regex here due to bad macros |# :use-module (web server) @@ -38,6 +35,7 @@ :autoload (vcomponent instance) (global-event-object) :use-module (html view calendar) + :use-module ((html view search) :select (search-result-page)) :export (main) ) @@ -101,8 +99,7 @@ ;; It would be much better if most of the page could still make it. (GET "/week/:start-date.html" (start-date) (let* ((start-date - (start-of-week (parse-iso-date start-date) - (get-config 'week-start)))) + (start-of-week (parse-iso-date start-date)))) (return `((content-type application/xhtml+xml)) (with-output-to-string @@ -132,8 +129,8 @@ prev-start: month- render-calendar: (@ (html view calendar month) render-calendar-table) - pre-start: (start-of-week start-date (get-config 'week-start)) - post-end: (end-of-week (end-of-month start-date) (get-config 'week-start)) + pre-start: (start-of-week start-date) + post-end: (end-of-week (end-of-month start-date)) intervaltype: 'month )))))) @@ -332,7 +329,7 @@ (with-output-to-string (lambda () (sxml->xml - ((@ (html view search) search-result-page) + (search-result-page search-term search-result page paginator q=)))))) ;; NOTE this only handles files with extensions. Limited, but since this diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index 72fcccbd..ed6ea066 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -304,6 +304,8 @@ ;; but "spill" into our time span. (section (@ (class "text-day")) (header (h2 "Tidigare")) + ;; TODO this group gets styles applied incorrectly. + ;; Figure out way to merge it with the below call. ,@(stream->list (stream-map fmt-single-event diff --git a/module/server/macro.scm b/module/server/macro.scm index b6983c7e..15bc0d0a 100644 --- a/module/server/macro.scm +++ b/module/server/macro.scm @@ -92,7 +92,8 @@ (args (cdr content-type))) (when (eq? type 'application/x-www-form-urlencoded) (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - (parse-query (bytevector->string body encoding) + (parse-query ((@ (ice-9 iconv) bytevector->string) + body encoding) encoding))))))))))) (case-lambda ((headers body new-state) (values headers body new-state)) ((headers body) (values headers body state)) -- cgit v1.2.3 From 241ad632399e1e1f136b4e84fb3b4624897bf154 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 07:10:08 +0200 Subject: Broke away routes from server entry-points. --- module/entry-points/server.scm | 350 +-------------------------------------- module/server/macro.scm | 63 +++---- module/server/routes.scm | 362 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 403 insertions(+), 372 deletions(-) create mode 100644 module/server/routes.scm (limited to 'module') diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index ec9d3c3f..76cdc7d1 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -4,363 +4,27 @@ :use-module (util exceptions) :use-module (srfi srfi-1) - :use-module (srfi srfi-17) - :use-module (ice-9 match) - :use-module (ice-9 control) - :use-module ((ice-9 rdelim) :select (read-string)) - :use-module ((ice-9 ftw) :select (scandir)) :use-module (ice-9 getopt-long) :use-module (ice-9 regex) #| regex here due to bad macros |# - :use-module (web server) - :use-module (web request) - :use-module (web response) - :use-module (web uri) - :use-module (web http) + :use-module ((web server) :select (run-server)) - :use-module (sxml simple) - :use-module (sxml xpath) - :use-module (sxml namespace) - - :use-module (server util) - :use-module (server macro) - - :use-module (vcomponent) - :use-module (vcomponent search) - :use-module (datetime) + ;; :use-module (vcomponent) + ;; :use-module (vcomponent search) + ;; :use-module (datetime) ;; :use-module (output html) - :use-module (output ical) - - :autoload (vcomponent instance) (global-event-object) + ;; :use-module (output ical) - :use-module (html view calendar) - :use-module ((html view search) :select (search-result-page)) + :use-module ((server routes) :select (make-make-routes)) :export (main) ) -(define (sxml->html-string sxml) - (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 (// dir k)))) - `(tr (td ,(case (stat:type stat) - [(directory) "📁"] - [(regular) "📰"] - [else "🙃"])) - (td (a (@ (href "/" ,dir "/" ,k)) ,k)) - (td ,(number->string (stat:perms stat) 8))))) - (cdr (scandir dir)))))) - -(define get-query-page - ;; A user of the website is able to fill up all of the hosts memory by - ;; requesting a bunch of different search pages, and forcing a bunch - ;; of pages on each. Clean up this table from time to time, possibly - ;; by popularity-rank. - (let ((query-pages (make-hash-table))) - (lambda (search-term) - (aif (hash-ref query-pages search-term) - it - (let* ((q (prepare-query - (build-query-proc search-term) - (get-event-set global-event-object)))) - (hash-set! query-pages search-term q) - q))))) - - - - -;; TODO ensure encoding on all fields which take user provided data. -;; Possibly a fallback which strips everything unknown, and treats -;; the bytevector as ascii. -(define (make-make-routes) - (make-routes - - ;; Manual redirect to not reserve root. - (GET "/" () - (return '((content-type text/html)) - (sxml->html-string '(a (@ (href "/today")) "Gå till idag")))) - - (GET "/favicon.ico" () - (return - `((content-type image/svg+xml)) - (call-with-input-file "static/calendar.svg" read-string))) - - ;; TODO any exception in this causes the whole page to fail - ;; It would be much better if most of the page could still make it. - (GET "/week/:start-date.html" (start-date) - (let* ((start-date - (start-of-week (parse-iso-date start-date)))) - - (return `((content-type application/xhtml+xml)) - (with-output-to-string - (lambda () - (html-generate calendars: (get-calendars global-event-object) - events: (get-event-set global-event-object) - start-date: start-date - end-date: (date+ start-date (date day: 6)) - next-start: (lambda (d) (date+ d (date day: 7))) - prev-start: (lambda (d) (date- d (date day: 7))) - render-calendar: (@ (html view calendar week) render-calendar) - intervaltype: 'week - )))))) - - (GET "/month/:start-date.html" (start-date) - (let* ((start-date (start-of-month (parse-iso-date start-date)))) - - (return '((content-type application/xhtml+xml)) - (with-output-to-string - (lambda () - (html-generate calendars: (get-calendars global-event-object) - events: (get-event-set global-event-object) - start-date: start-date - end-date: (date- (month+ start-date) - (date day: 1)) - next-start: month+ - prev-start: month- - render-calendar: (@ (html view calendar month) - render-calendar-table) - pre-start: (start-of-week start-date) - post-end: (end-of-week (end-of-month start-date)) - intervaltype: 'month - )))))) - - - (POST "/remove" (uid) - (unless uid - (return (build-response code: 400) - "uid required")) - - (aif (get-event-by-uid global-event-object uid) - (begin - ;; It's hard to properly remove a file. I also want a way to undo accidental - ;; deletions. Therefore I simply save the X-HNH-REMOVED flag to the file, and - ;; then simple don't use those events when loading. - (catch 'stack-overflow (lambda () (remove-event global-event-object it)) - (lambda _ - (display "It overflew...\n" (current-error-port)) - (return (build-response code: 500) - "It overflew again..."))) - (set! (prop it 'X-HNH-REMOVED) #t) - (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") - (unless ((@ (output vdir) save-event) it) - (return (build-response code: 500) - "Saving event to disk failed.")) - (return (build-response code: 204) "")) - (return (build-response code: 400) - (format #f "No event with UID '~a'" uid)))) - - ;; TODO this fails when dtstart is . - ;; TODO If data has an explicit UID and that UID already exists we - ;; overwrite it in the database. We however don't remove the old - ;; event from the in-memory set, but rather just adds the new. - (POST "/insert" (cal data) - - (unless (and cal data) - (return (build-response code: 400) - "Both 'cal' and 'data' required\r\n")) - - - ;; NOTE that this leaks which calendar exists, - ;; but you can only query for existance. - ;; also, the default output gives everything. - (let ((calendar - (find (lambda (c) (string=? cal (prop c 'NAME))) - (get-calendars global-event-object)))) - - (unless calendar - (return (build-response code: 400) - (format #f "No calendar with name [~a]\r\n" cal))) - - ;; Expected form of data (but in XML) is: - ;; @example - ;; (*TOP* - ;; (*PI* ...) - ;; (icalendar (@ (xmlns "...")) - ;; (vcalendar - ;; (vevent ...)))) - ;; @end example - ;; However, *PI* will probably be omited, and currently events - ;; are sent without the vcalendar part. Earlier versions - ;; Also omitted the icalendar part. And I'm not sure if the - ;; *TOP* node is a required part of the sxml. - - (let ((event - ((@ (vcomponent parse xcal) sxcal->vcomponent) - (catch 'parser-error - (lambda () - (move-to-namespace - ;; TODO Multiple event components - (car ((sxpath '(// IC:vevent)) - (xml->sxml data namespaces: '((IC . "urn:ietf:params:xml:ns:icalendar-2.0"))))) - #f)) - (lambda (err port . args) - (return (build-response code: 400) - (format #f "XML parse error ~{~a~}\r\n" args))))))) - - (unless (eq? 'VEVENT (type event)) - (return (build-response code: 400) - "Object not a VEVENT\r\n")) - - ;; NOTE add-event uses the given UID if one is given, - ;; but generates its own if not. It might be a good idea - ;; to require that UID is unset here, and force users - ;; to use a /update endpoint to change events. This to prevent - ;; accidental overwriting. - - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - (unless ((@ (output vdir) save-event) event) - (return (build-response code: 500) - "Saving event to disk failed.")) - - (format (current-error-port) - "Event inserted ~a~%" (prop event 'UID)) - - (return '((content-type application/xml)) - (with-output-to-string - (lambda () - (sxml->xml - `(properties - (uid (text ,(prop event 'UID))))))))))) - - ;; Get specific page by query string instead of by path. - ;; Useful for
's, since they always submit in this form, but also - ;; useful when javascript is disabled, since a link to "today" needs some - ;; form of evaluation when clicked. - (GET "/today" (view date) - (define location - (build-relative-ref - path: - (format #f "/~a/~a.html" - (or view "week") - (date->string - (cond [date => parse-iso-date] - [else (current-date)]) - "~1"))) ) - - (return (build-response - code: 302 - headers: `((location . ,location))))) - - (GET "/calendar" (start end) - (return '((content-type text/calendar)) - (with-output-to-string - (lambda () - (if (or start end) - (print-events-in-interval - (aif start (parse-iso-date it) (current-date)) - (aif end (parse-iso-date it) (current-date))) - (print-all-events)))))) - - (GET "/calendar/:uid{.*}.xcs" (uid) - (aif (get-event-by-uid global-event-object uid) - (return '((content-type application/calendar+xml)) - ;; TODO sxml->xml takes a port, would be better - ;; to give it the return port imidiately. - (with-output-to-string - ;; TODO this is just the vevent part. - ;; A surounding vcalendar is required, as well as - ;; a doctype. - ;; Look into changing how events carry around their - ;; parent information, possibly splitting "source parent" - ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (output xcal) vcomponent->sxcal) it))))) - (return (build-response code: 404) - (format #f "No component with UID=~a found." uid)))) - - (GET "/calendar/:uid{.*}.ics" (uid) - (aif (get-event-by-uid global-event-object uid) - (return '((content-type text/calendar)) - (with-output-to-string - (lambda () (print-components-with-fake-parent - (list it))))) - (return (build-response code: 404) - (format #f "No component with UID=~a found." uid)))) - - ;; TODO search without query should work - (GET "/search" (q p) - (define search-term (prepare-string q)) - - (define q= (find (lambda (s) - (and (<= 2 (string-length s)) - (string=? "q=" (string-take s 2)))) - (string-split r:query #\&))) - - (define paginator (get-query-page search-term)) - - (define page (string->number (or p "0"))) - - ;; TODO Propagate errors - (define search-result - (catch 'max-page - ;; TODO Get-page only puts a time limiter per page, meaning that - ;; if a user requests page 1000 the server is stuck trying to - ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+ - ;; A timeout here, and also an actual multithreaded server should - ;; solve this. - (lambda () (get-page paginator page)) - (lambda (err page-number) - (define location - (build-relative-ref - path: r:path ; host: r:host port: r:port - query: (format #f "~a&p=~a" q= page-number))) - (return (build-response - code: 307 - headers: `((location . ,location))))))) - - (return '((content-type application/xhtml+xml)) - (with-output-to-string - (lambda () - (sxml->xml - (search-result-page - search-term search-result page paginator q=)))))) - - ;; 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/:*{.*}.:ext" (* ext) - - ;; Actually parsing /etc/mime.types would be better. - (define mime - (case (string->symbol ext) - [(js) "javascript"] - [else ext])) - - (return - `((content-type ,(string->symbol (string-append "text/" mime)))) - (call-with-input-file (string-append "static/" * "." ext) - read-string))) - (GET "/static/:*{.*}" (*) - (return - '((content-type text/html)) - (sxml->html-string - (directory-table (// "static" *))))) + - (GET "/count" () - ;; (sleep 1) - (return '((content-type text/plain)) - (string-append (number->string state) "\n") - (1+ state))))) (define options '((port (value #t) (single-char #\p) diff --git a/module/server/macro.scm b/module/server/macro.scm index 15bc0d0a..2fb87f54 100644 --- a/module/server/macro.scm +++ b/module/server/macro.scm @@ -63,38 +63,43 @@ (format (current-error-port) "~a~%" request) ;; ALl these bindings generate compile time warnings since the expansion ;; of the macro might not use them. This isn't really a problem. - (let ((r:method (request-method request)) - (r:uri (request-uri request)) - (r:version (request-version request)) - (r:headers (request-headers request)) - (r:meta (request-meta request)) - (r:port (request-port request))) - (let ((r:scheme (uri-scheme r:uri)) - (r:userinfo (uri-userinfo r:uri)) - (r:host (or (uri-host r:uri) (request-host request))) - (r:port (or (uri-port r:uri) (request-port request))) - (r:path (uri-path r:uri)) - (r:query (uri-query r:uri)) - (r:fragment (uri-fragment r:uri))) + (let ((r:method ((@ (web request) request-method) request)) + (r:uri ((@ (web request) request-uri) request)) + (r:version ((@ (web request) request-version) request)) + (r:headers ((@ (web request) request-headers) request)) + (r:meta ((@ (web request) request-meta) request)) + (r:port ((@ (web request) request-port) request))) + (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) + (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) + (r:host (or ((@ (web uri) uri-host) r:uri) + ((@ (web request) request-host) + request))) + (r:port (or ((@ (web uri) uri-port) r:uri) + ((@ (web request) request-port) + request))) + (r:path ((@ (web uri) uri-path) r:uri)) + (r:query ((@ (web uri) uri-query) r:uri)) + (r:fragment ((@ (web uri) uri-fragment) r:uri))) (call-with-values (lambda () - (call/ec (lambda (return) - (apply - (cond ,@(map generate-case routes) - (else (lambda* _ (return (build-response #:code 404) - "404 Not Fonud")))) - (append - (parse-query r:query) + ((@ (ice-9 control) call/ec) + (lambda (return) + (apply + (cond ,@(map generate-case routes) + (else (lambda* _ (return (build-response #:code 404) + "404 Not Fonud")))) + (append + (parse-query r:query) - (let ((content-type (assoc-ref r:headers 'content-type))) - (when content-type - (let ((type (car content-type)) - (args (cdr content-type))) - (when (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - (parse-query ((@ (ice-9 iconv) bytevector->string) - body encoding) - encoding))))))))))) + (let ((content-type (assoc-ref r:headers 'content-type))) + (when content-type + (let ((type (car content-type)) + (args (cdr content-type))) + (when (eq? type 'application/x-www-form-urlencoded) + (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) + (parse-query ((@ (ice-9 iconv) bytevector->string) + body encoding) + encoding))))))))))) (case-lambda ((headers body new-state) (values headers body new-state)) ((headers body) (values headers body state)) ((headers) (values headers "" state)))))))) diff --git a/module/server/routes.scm b/module/server/routes.scm new file mode 100644 index 00000000..fefc9702 --- /dev/null +++ b/module/server/routes.scm @@ -0,0 +1,362 @@ +(define-module (server routes) + :use-module (util) + :use-module (util options) + :use-module (util exceptions) + + :use-module (srfi srfi-1) + + :use-module ((ice-9 rdelim) :select (read-string)) + :use-module ((ice-9 ftw) :select (scandir)) + :use-module (ice-9 regex) #| regex here due to bad macros |# + + :use-module ((web response) :select (build-response)) + :use-module ((web uri) :select (build-relative-ref)) + + :use-module (sxml simple) + :use-module (sxml xpath) + :use-module (sxml namespace) + + :use-module (server util) + :use-module (server macro) + + :use-module (vcomponent) + :use-module (vcomponent search) + :use-module (datetime) + ;; :use-module (output html) + :use-module (output ical) + + :autoload (vcomponent instance) (global-event-object) + + :use-module (html view calendar) + :use-module ((html view search) :select (search-result-page)) + + + ) + + + +(define (sxml->html-string sxml) + (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 (// dir k)))) + `(tr (td ,(case (stat:type stat) + [(directory) "📁"] + [(regular) "📰"] + [else "🙃"])) + (td (a (@ (href "/" ,dir "/" ,k)) ,k)) + (td ,(number->string (stat:perms stat) 8))))) + (cdr (scandir dir)))))) + + + +(define get-query-page + ;; A user of the website is able to fill up all of the hosts memory by + ;; requesting a bunch of different search pages, and forcing a bunch + ;; of pages on each. Clean up this table from time to time, possibly + ;; by popularity-rank. + (let ((query-pages (make-hash-table))) + (lambda (search-term) + (aif (hash-ref query-pages search-term) + it + (let* ((q (prepare-query + (build-query-proc search-term) + (get-event-set global-event-object)))) + (hash-set! query-pages search-term q) + q))))) + + + + +;; TODO ensure encoding on all fields which take user provided data. +;; Possibly a fallback which strips everything unknown, and treats +;; the bytevector as ascii. +(define-public (make-make-routes) + (make-routes + + ;; Manual redirect to not reserve root. + (GET "/" () + (return '((content-type text/html)) + (sxml->html-string '(a (@ (href "/today")) "Gå till idag")))) + + (GET "/favicon.ico" () + (return + `((content-type image/svg+xml)) + (call-with-input-file "static/calendar.svg" read-string))) + + ;; TODO any exception in this causes the whole page to fail + ;; It would be much better if most of the page could still make it. + (GET "/week/:start-date.html" (start-date) + (let* ((start-date + (start-of-week (parse-iso-date start-date)))) + + (return `((content-type application/xhtml+xml)) + (with-output-to-string + (lambda () + (html-generate calendars: (get-calendars global-event-object) + events: (get-event-set global-event-object) + start-date: start-date + end-date: (date+ start-date (date day: 6)) + next-start: (lambda (d) (date+ d (date day: 7))) + prev-start: (lambda (d) (date- d (date day: 7))) + render-calendar: (@ (html view calendar week) render-calendar) + intervaltype: 'week + )))))) + + (GET "/month/:start-date.html" (start-date) + (let* ((start-date (start-of-month (parse-iso-date start-date)))) + + (return '((content-type application/xhtml+xml)) + (with-output-to-string + (lambda () + (html-generate calendars: (get-calendars global-event-object) + events: (get-event-set global-event-object) + start-date: start-date + end-date: (date- (month+ start-date) + (date day: 1)) + next-start: month+ + prev-start: month- + render-calendar: (@ (html view calendar month) + render-calendar-table) + pre-start: (start-of-week start-date) + post-end: (end-of-week (end-of-month start-date)) + intervaltype: 'month + )))))) + + + (POST "/remove" (uid) + (unless uid + (return (build-response code: 400) + "uid required")) + + (aif (get-event-by-uid global-event-object uid) + (begin + ;; It's hard to properly remove a file. I also want a way to undo accidental + ;; deletions. Therefore I simply save the X-HNH-REMOVED flag to the file, and + ;; then simple don't use those events when loading. + (catch 'stack-overflow (lambda () (remove-event global-event-object it)) + (lambda _ + (display "It overflew...\n" (current-error-port)) + (return (build-response code: 500) + "It overflew again..."))) + (set! (prop it 'X-HNH-REMOVED) #t) + (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") + (unless ((@ (output vdir) save-event) it) + (return (build-response code: 500) + "Saving event to disk failed.")) + (return (build-response code: 204) "")) + (return (build-response code: 400) + (format #f "No event with UID '~a'" uid)))) + + ;; TODO this fails when dtstart is . + ;; TODO If data has an explicit UID and that UID already exists we + ;; overwrite it in the database. We however don't remove the old + ;; event from the in-memory set, but rather just adds the new. + (POST "/insert" (cal data) + + (unless (and cal data) + (return (build-response code: 400) + "Both 'cal' and 'data' required\r\n")) + + + ;; NOTE that this leaks which calendar exists, + ;; but you can only query for existance. + ;; also, the default output gives everything. + (let ((calendar + (find (lambda (c) (string=? cal (prop c 'NAME))) + (get-calendars global-event-object)))) + + (unless calendar + (return (build-response code: 400) + (format #f "No calendar with name [~a]\r\n" cal))) + + ;; Expected form of data (but in XML) is: + ;; @example + ;; (*TOP* + ;; (*PI* ...) + ;; (icalendar (@ (xmlns "...")) + ;; (vcalendar + ;; (vevent ...)))) + ;; @end example + ;; However, *PI* will probably be omited, and currently events + ;; are sent without the vcalendar part. Earlier versions + ;; Also omitted the icalendar part. And I'm not sure if the + ;; *TOP* node is a required part of the sxml. + + (let ((event + ((@ (vcomponent parse xcal) sxcal->vcomponent) + (catch 'parser-error + (lambda () + (move-to-namespace + ;; TODO Multiple event components + (car ((sxpath '(// IC:vevent)) + (xml->sxml data namespaces: '((IC . "urn:ietf:params:xml:ns:icalendar-2.0"))))) + #f)) + (lambda (err port . args) + (return (build-response code: 400) + (format #f "XML parse error ~{~a~}\r\n" args))))))) + + (unless (eq? 'VEVENT (type event)) + (return (build-response code: 400) + "Object not a VEVENT\r\n")) + + ;; NOTE add-event uses the given UID if one is given, + ;; but generates its own if not. It might be a good idea + ;; to require that UID is unset here, and force users + ;; to use a /update endpoint to change events. This to prevent + ;; accidental overwriting. + + (parameterize ((warnings-are-errors #t)) + (catch 'warning + (lambda () (add-event global-event-object calendar event)) + (lambda (err fmt args) + (return (build-response code: 400) + (format #f "~?~%" fmt args))))) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + (unless ((@ (output vdir) save-event) event) + (return (build-response code: 500) + "Saving event to disk failed.")) + + (format (current-error-port) + "Event inserted ~a~%" (prop event 'UID)) + + (return '((content-type application/xml)) + (with-output-to-string + (lambda () + (sxml->xml + `(properties + (uid (text ,(prop event 'UID))))))))))) + + ;; Get specific page by query string instead of by path. + ;; Useful for 's, since they always submit in this form, but also + ;; useful when javascript is disabled, since a link to "today" needs some + ;; form of evaluation when clicked. + (GET "/today" (view date) + (define location + (build-relative-ref + path: + (format #f "/~a/~a.html" + (or view "week") + (date->string + (cond [date => parse-iso-date] + [else (current-date)]) + "~1"))) ) + + (return (build-response + code: 302 + headers: `((location . ,location))))) + + (GET "/calendar" (start end) + (return '((content-type text/calendar)) + (with-output-to-string + (lambda () + (if (or start end) + (print-events-in-interval + (aif start (parse-iso-date it) (current-date)) + (aif end (parse-iso-date it) (current-date))) + (print-all-events)))))) + + (GET "/calendar/:uid{.*}.xcs" (uid) + (aif (get-event-by-uid global-event-object uid) + (return '((content-type application/calendar+xml)) + ;; TODO sxml->xml takes a port, would be better + ;; to give it the return port imidiately. + (with-output-to-string + ;; TODO this is just the vevent part. + ;; A surounding vcalendar is required, as well as + ;; a doctype. + ;; Look into changing how events carry around their + ;; parent information, possibly splitting "source parent" + ;; and "program parent" into different fields. + (lambda () (sxml->xml ((@ (output xcal) vcomponent->sxcal) it))))) + (return (build-response code: 404) + (format #f "No component with UID=~a found." uid)))) + + (GET "/calendar/:uid{.*}.ics" (uid) + (aif (get-event-by-uid global-event-object uid) + (return '((content-type text/calendar)) + (with-output-to-string + (lambda () (print-components-with-fake-parent + (list it))))) + (return (build-response code: 404) + (format #f "No component with UID=~a found." uid)))) + + ;; TODO search without query should work + (GET "/search" (q p) + (define search-term (prepare-string q)) + + (define q= (find (lambda (s) + (and (<= 2 (string-length s)) + (string=? "q=" (string-take s 2)))) + (string-split r:query #\&))) + + (define paginator (get-query-page search-term)) + + (define page (string->number (or p "0"))) + + ;; TODO Propagate errors + (define search-result + (catch 'max-page + ;; TODO Get-page only puts a time limiter per page, meaning that + ;; if a user requests page 1000 the server is stuck trying to + ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+ + ;; A timeout here, and also an actual multithreaded server should + ;; solve this. + (lambda () (get-page paginator page)) + (lambda (err page-number) + (define location + (build-relative-ref + path: r:path ; host: r:host port: r:port + query: (format #f "~a&p=~a" q= page-number))) + (return (build-response + code: 307 + headers: `((location . ,location))))))) + + (return '((content-type application/xhtml+xml)) + (with-output-to-string + (lambda () + (sxml->xml + (search-result-page + search-term search-result page paginator q=)))))) + + ;; 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/:*{.*}.:ext" (* ext) + + ;; Actually parsing /etc/mime.types would be better. + (define mime + (case (string->symbol ext) + [(js) "javascript"] + [else ext])) + + (return + `((content-type ,(string->symbol (string-append "text/" mime)))) + (call-with-input-file (string-append "static/" * "." ext) + read-string))) + + (GET "/static/:*{.*}" (*) + (return + '((content-type text/html)) + (sxml->html-string + (directory-table (// "static" *))))) + + + (GET "/count" () + ;; (sleep 1) + (return '((content-type text/plain)) + (string-append (number->string state) "\n") + (1+ state))))) -- cgit v1.2.3 From 6f2bab1cbd3434ba7057aad0dfa33bbf39368826 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 13:07:10 +0200 Subject: Move run-server to (server server). --- module/entry-points/server.scm | 37 +++++-------------------------------- module/server/routes.scm | 1 - module/server/server.scm | 34 ++++++++++++++++++++++++++++++++++ 3 files changed, 39 insertions(+), 33 deletions(-) create mode 100644 module/server/server.scm (limited to 'module') diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 76cdc7d1..dfa94cc7 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -6,24 +6,11 @@ :use-module (srfi srfi-1) :use-module (ice-9 getopt-long) - :use-module (ice-9 regex) #| regex here due to bad macros |# + ;; :use-module (ice-9 regex) #| regex here due to bad macros |# - :use-module ((web server) :select (run-server)) + :use-module ((server server) :select (start-server)) - ;; :use-module (vcomponent) - ;; :use-module (vcomponent search) - ;; :use-module (datetime) - ;; :use-module (output html) - ;; :use-module (output ical) - - :use-module ((server routes) :select (make-make-routes)) - - :export (main) - ) - - - - + :export (main)) (define options @@ -64,16 +51,6 @@ (if (eqv? family AF_INET6) "::" "0.0.0.0"))) - ;; NOTE The default make-default-socket is broken for IPv6. - ;; A patch has been submitted to the mailing list. 2020-03-31 - (module-set! - (resolve-module '(web server http)) - 'make-default-socket - (lambda (family addr port) - (let ((sock (socket family SOCK_STREAM 0))) - (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - (bind sock family addr port) - sock))) (format #t "Starting server on ~a:~a~%I'm ~a, runing from ~a~%" addr port @@ -81,12 +58,8 @@ (catch 'system-error (lambda () - (run-server (make-make-routes) - 'http - `(family: ,family - port: ,port - host: ,addr) - 0)) + (start-server `(family: ,family port: ,port host: ,addr))) + ;; probably address already in use (lambda (err proc fmt args errno) (format (current-error-port) "~a: ~?~%" diff --git a/module/server/routes.scm b/module/server/routes.scm index fefc9702..1e3af921 100644 --- a/module/server/routes.scm +++ b/module/server/routes.scm @@ -133,7 +133,6 @@ intervaltype: 'month )))))) - (POST "/remove" (uid) (unless uid (return (build-response code: 400) diff --git a/module/server/server.scm b/module/server/server.scm new file mode 100644 index 00000000..9c857b6d --- /dev/null +++ b/module/server/server.scm @@ -0,0 +1,34 @@ +(define-module (server server) + :use-module (util) + :use-module (web server) + :use-module ((server routes) :select (make-make-routes)) + :use-module (ice-9 threads)) + +;; NOTE The default make-default-socket is broken for IPv6. +;; A patch has been submitted to the mailing list. 2020-03-31 +(module-set! + (resolve-module '(web server http)) + 'make-default-socket + (lambda (family addr port) + (let ((sock (socket family SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock))) + +(define handler (make-make-routes)) + +;; (define impl (lookup-server-impl 'http)) +;; (define server (open-server impl open-params)) + + +(define-public (start-server open-params) + (run-server handler 'http open-params 1) + ;; NOTE at first this seems to work, but it quickly deteriorates. + ;; (for i in (iota 16) + ;; (begin-thread + ;; (let lp ((state (list 0))) + ;; (lp (serve-one-client handler impl server state))))) + ;; (pause) + ) + + -- cgit v1.2.3 From 389257e31dc99d8d20c73aacffd8ec026ee59c93 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 13:25:08 +0200 Subject: Event edit within calendar now works. --- module/server/routes.scm | 68 +++++++++++++++++++++++++++++++++------------- module/vcomponent/base.scm | 10 ++++++- 2 files changed, 58 insertions(+), 20 deletions(-) (limited to 'module') diff --git a/module/server/routes.scm b/module/server/routes.scm index 1e3af921..bf5165a9 100644 --- a/module/server/routes.scm +++ b/module/server/routes.scm @@ -158,9 +158,6 @@ (format #f "No event with UID '~a'" uid)))) ;; TODO this fails when dtstart is . - ;; TODO If data has an explicit UID and that UID already exists we - ;; overwrite it in the database. We however don't remove the old - ;; event from the in-memory set, but rather just adds the new. (POST "/insert" (cal data) (unless (and cal data) @@ -170,7 +167,7 @@ ;; NOTE that this leaks which calendar exists, ;; but you can only query for existance. - ;; also, the default output gives everything. + ;; also, the calendar view already show all calendars. (let ((calendar (find (lambda (c) (string=? cal (prop c 'NAME))) (get-calendars global-event-object)))) @@ -215,21 +212,54 @@ ;; to use a /update endpoint to change events. This to prevent ;; accidental overwriting. - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - (unless ((@ (output vdir) save-event) event) - (return (build-response code: 500) - "Saving event to disk failed.")) - - (format (current-error-port) - "Event inserted ~a~%" (prop event 'UID)) + + (cond + [(get-event-by-uid global-event-object (prop event 'UID)) + => (lambda (old-event) + + (if (eq? calendar (parent old-event)) + (begin (vcomponent-update! old-event event) + ;; for save below + (set! event old-event)) + ;; change calendar + (begin + ;; (remove-from-calendar! old-event) + (remove-event global-event-object old-event) + + (parameterize ((warnings-are-errors #t)) + (catch 'warning + (lambda () (add-event global-event-object calendar event)) + (lambda (err fmt args) + (return (build-response code: 400) + (format #f "~?~%" fmt args))))))) + + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + (unless ((@ (output vdir) save-event) event) + (return (build-response code: 500) + "Saving event to disk failed.")) + + + (format (current-error-port) + "Event updated ~a~%" (prop event 'UID)))] + + [else + (parameterize ((warnings-are-errors #t)) + (catch 'warning + (lambda () (add-event global-event-object calendar event)) + (lambda (err fmt args) + (return (build-response code: 400) + (format #f "~?~%" fmt args))))) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + (unless ((@ (output vdir) save-event) event) + (return (build-response code: 500) + "Saving event to disk failed.")) + + (format (current-error-port) + "Event inserted ~a~%" (prop event 'UID))]) (return '((content-type application/xml)) (with-output-to-string diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 3e75e566..7b81fb05 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -148,7 +148,7 @@ (hash-map->list cons (get-component-properties component))) (define-public (property-keys component) - (map car (get-component-properties component))) + (hash-map->list (lambda (a _) a) (get-component-properties component))) (define (copy-vline vline) (make-vline (vline-key vline) @@ -169,6 +169,14 @@ (copy-vline value)))) (get-component-properties component))))) +;; updates target with all fields from source. +;; fields in target but not in source left unchanged. +;; parent and children unchanged +(define-public (vcomponent-update! target source) + (for key in (property-keys source) + (set! (prop* target key) + (prop* source key)))) + (define-public (extract field) (lambda (e) (prop e field))) -- cgit v1.2.3 From 002787fd54d7e7b5dc2965e164691f85cccc3953 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 14:04:31 +0200 Subject: Can create events in different calentdars, given that the calendars have simple names. --- module/html/vcomponent.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'module') diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index fdaea217..5e7b4ba8 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -142,6 +142,7 @@ (div (@ ,@(assq-merge extra-attributes `((id ,(html-id ev)) + (data-calendar ,(html-attr (or (prop (parent ev) 'NAME) "unknown"))) (class "event CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown")) ,(when (and (prop ev 'PARTSTAT) -- cgit v1.2.3 From 89418ccb92b9389d3442be2af128c593fa362acc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 15:34:55 +0200 Subject: Calendar names now encoded with modified base64 --- module/html/util.scm | 31 +++++++++++++++++++++++++++++-- module/server/routes.scm | 14 ++++++++++---- 2 files changed, 39 insertions(+), 6 deletions(-) (limited to 'module') diff --git a/module/html/util.scm b/module/html/util.scm index 36b1d929..edbcf756 100644 --- a/module/html/util.scm +++ b/module/html/util.scm @@ -1,10 +1,37 @@ (define-module (html util) + :use-module ((util base64) + :select (base64encode base64decode)) :use-module (util)) +;;; @var{html-attr} & @var{html-unattr} used to just strip any +;;; attributes not valid in css. That allowed a human reader to +;;; quickly see what data it was. The downside was that it was one +;;; way. The new base64 based system supports both an encode and a +;;; decode without problem. +;;; +;;; The encoded string substitutes { + => å, / => ä, = => ö } to be +;;; valid CSS selector names. + ;; Retuns an HTML-safe version of @var{str}. (define-public (html-attr str) - (define cs (char-set-adjoin char-set:letter+digit #\- #\_)) - (string-filter (lambda (c) (char-set-contains? cs c)) str)) + (string-map (lambda (c) + (case c + ((#\+) #\å) + ((#\/) #\ä) + ((#\=) #\ö) + (else c))) + (base64encode str))) + +(define-public (html-unattr str) + (base64decode + (string-map (lambda (c) + (case c + ((#\å) #\+) + ((#\ä) #\/) + ((#\ö) #\=) + (else c))) + str))) + (define-public (date-link date) ((@ (datetime) date->string) date "~Y-~m-~d")) diff --git a/module/server/routes.scm b/module/server/routes.scm index bf5165a9..552c43ef 100644 --- a/module/server/routes.scm +++ b/module/server/routes.scm @@ -16,6 +16,9 @@ :use-module (sxml xpath) :use-module (sxml namespace) + + :use-module ((html util) :select (html-unattr)) + :use-module (server util) :use-module (server macro) @@ -158,6 +161,8 @@ (format #f "No event with UID '~a'" uid)))) ;; TODO this fails when dtstart is . + ;; @var{cal} should be the name of the calendar encoded with + ;; modified base64. See (html util). (POST "/insert" (cal data) (unless (and cal data) @@ -168,13 +173,14 @@ ;; NOTE that this leaks which calendar exists, ;; but you can only query for existance. ;; also, the calendar view already show all calendars. - (let ((calendar - (find (lambda (c) (string=? cal (prop c 'NAME))) - (get-calendars global-event-object)))) + (let* ((calendar-name (html-unattr cal)) + (calendar + (find (lambda (c) (string=? calendar-name (prop c 'NAME))) + (get-calendars global-event-object)))) (unless calendar (return (build-response code: 400) - (format #f "No calendar with name [~a]\r\n" cal))) + (format #f "No calendar with name [~a]\r\n" calendar-name))) ;; Expected form of data (but in XML) is: ;; @example -- cgit v1.2.3 From fd72079c5163f9881872d70b64aafde03b8b2385 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 15:57:55 +0200 Subject: Add option for default calendar. --- module/html/view/calendar.scm | 20 ++++++++++++++------ module/vcomponent.scm | 4 ++++ 2 files changed, 18 insertions(+), 6 deletions(-) (limited to 'module') diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm index ed6ea066..76d1e79f 100644 --- a/module/html/view/calendar.scm +++ b/module/html/view/calendar.scm @@ -16,10 +16,14 @@ )) :use-module (html config) :use-module (html util) + + :use-module (util config) + :use-module (srfi srfi-1) :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) + :use-module ((vcomponent group) :select (group-stream get-groups-between)) :use-module ((git) @@ -288,13 +292,17 @@ ,(html-attr (prop calendar 'NAME)))) ,(prop calendar 'NAME))) calendars)) - (div (@ (id "calendar-dropdown-template") (class "template")) - (select + (div (@ (id "calendar-dropdown-template") (class "template")) + (select (option "- Choose a Calendar -") - ,@(map (lambda (calendar) - `(option (@ (value ,(html-attr (prop calendar 'NAME)))) - ,(prop calendar 'NAME))) - calendars)) + ,@(let ((dflt (get-config 'default-calendar))) + (map (lambda (calendar) + (define name (prop calendar 'NAME)) + `(option (@ (value ,(html-attr name)) + ,@(when (string=? name dflt) + '((selected)))) + ,name)) + calendars))) ))) ;; List of events diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 66b72162..b4a30c83 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -17,3 +17,7 @@ [(string? v) ((@ (glob) glob) v)] [else #f]))) +(define-config default-calendar "" + description: "Default calendar to use for operations. Set to empty string to unset" + pre: (ensure string?)) + -- cgit v1.2.3 From 4efa7e8846f383b48d55fd42c87198d63c17dadd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 16:32:18 +0200 Subject: Remove stack overflow handler for /remove/. --- module/server/routes.scm | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'module') diff --git a/module/server/routes.scm b/module/server/routes.scm index 552c43ef..3c03ae14 100644 --- a/module/server/routes.scm +++ b/module/server/routes.scm @@ -146,17 +146,13 @@ ;; It's hard to properly remove a file. I also want a way to undo accidental ;; deletions. Therefore I simply save the X-HNH-REMOVED flag to the file, and ;; then simple don't use those events when loading. - (catch 'stack-overflow (lambda () (remove-event global-event-object it)) - (lambda _ - (display "It overflew...\n" (current-error-port)) - (return (build-response code: 500) - "It overflew again..."))) + (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) (return (build-response code: 500) "Saving event to disk failed.")) - (return (build-response code: 204) "")) + (return (build-response code: 204))) (return (build-response code: 400) (format #f "No event with UID '~a'" uid)))) @@ -227,9 +223,11 @@ (begin (vcomponent-update! old-event event) ;; for save below (set! event old-event)) + ;; change calendar (begin ;; (remove-from-calendar! old-event) + ;; TODO remove the old event from disk here (remove-event global-event-object old-event) (parameterize ((warnings-are-errors #t)) -- cgit v1.2.3 From 4377415e35c0914bfa79c406fd5759c09c1af411 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 16:57:54 +0200 Subject: Improve filtering when loading vcomponents. --- module/vcomponent/instance/methods.scm | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) (limited to 'module') diff --git a/module/vcomponent/instance/methods.scm b/module/vcomponent/instance/methods.scm index 4baf9409..ea3522f9 100644 --- a/module/vcomponent/instance/methods.scm +++ b/module/vcomponent/instance/methods.scm @@ -54,13 +54,18 @@ (slot-set! this 'calendars (load-calendars (slot-ref this 'calendar-files))) - (slot-set! this 'events - (concatenate - (map (lambda (cal) (remove - (extract 'X-HNH-REMOVED) - (filter (lambda (o) (eq? 'VEVENT (type o))) - (children cal)))) - (slot-ref this 'calendars)))) + + (let* ((groups + (group-by + type (concatenate + (map children (slot-ref this 'calendars))))) + (events (awhen (assoc-ref groups 'VEVENT) + (car it))) + (removed remaining (partition (extract 'X-HNH-REMOVED) events))) + + ;; TODO figure out what to do with removed events + + (slot-set! this 'events (append #|removed|# remaining))) (let* ((repeating regular (partition repeating? (slot-ref this 'events)))) (slot-set! this 'fixed-events (sort*! regular date/-time Date: Wed, 12 Aug 2020 16:58:03 +0200 Subject: Minor changes. --- module/util.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'module') diff --git a/module/util.scm b/module/util.scm index fce1c014..1cc357fa 100644 --- a/module/util.scm +++ b/module/util.scm @@ -375,6 +375,7 @@ (for value in lst (let ((key (proc value))) (hash-set! h key (cons value (hash-ref h key '()))))) + ;; NOTE changing this list to cons allows the output to work with assq-merge. (hash-map->list list h))) ;; (group-by '(0 1 2 3 4 2 5 6) 2) -- cgit v1.2.3 From 4ffab9225cd618c2c9d2e95c06ef7b71c2dd5b11 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 13 Aug 2020 10:36:47 +0200 Subject: Changing calendar now unlinks old file. --- module/output/vdir.scm | 23 ++++++++++++++++++++--- module/server/routes.scm | 27 ++++++++++++++++++++++++--- 2 files changed, 44 insertions(+), 6 deletions(-) (limited to 'module') diff --git a/module/output/vdir.scm b/module/output/vdir.scm index cf4f6c8d..f23e0062 100644 --- a/module/output/vdir.scm +++ b/module/output/vdir.scm @@ -22,12 +22,29 @@ [(vdir) (let* ((uid (or (prop event 'UID) (uuidgen)))) - (set! (prop event 'UID) uid) - (with-atomic-output-to-file - (string-append (prop calendar '-X-HNH-DIRECTORY) / uid ".ics") + (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 3c03ae14..8d51fc22 100644 --- a/module/server/routes.scm +++ b/module/server/routes.scm @@ -219,6 +219,10 @@ [(get-event-by-uid global-event-object (prop event 'UID)) => (lambda (old-event) + ;; procedure to run after save. + ;; used as hook to remove old event from disk below + (define after-save (const #f)) + (if (eq? calendar (parent old-event)) (begin (vcomponent-update! old-event event) ;; for save below @@ -226,9 +230,25 @@ ;; change calendar (begin - ;; (remove-from-calendar! old-event) - ;; TODO remove the old event from disk here - (remove-event global-event-object old-event) + + (format (current-error-port) + "Calendar change~%") + + ;; remove from runtime + ((@ (vcomponent instance methods) remove-event) + global-event-object old-event) + + ;; Actually puring the old event should be safe, + ;; since we first make sure we write the new event to disk. + ;; Currently the whole transaction isn't atomic, so a duplicate + ;; event can still be created. + (set! after-save + ;; remove from disk + (lambda () + (format (current-error-port) + "Unlinking old event from ~a~%" + (prop old-event '-X-HNH-FILENAME)) + ((@ (output vdir) remove-event) old-event))) (parameterize ((warnings-are-errors #t)) (catch 'warning @@ -244,6 +264,7 @@ (return (build-response code: 500) "Saving event to disk failed.")) + (after-save) (format (current-error-port) "Event updated ~a~%" (prop event 'UID)))] -- cgit v1.2.3 From 9d98e97b5ce3cdfa1ff95bfa5bbee7519b024bdc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 13 Aug 2020 10:37:29 +0200 Subject: Comment about generalizing. --- module/output/vdir.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'module') diff --git a/module/output/vdir.scm b/module/output/vdir.scm index f23e0062..bd21fb24 100644 --- a/module/output/vdir.scm +++ b/module/output/vdir.scm @@ -2,6 +2,11 @@ ;;; 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) -- cgit v1.2.3