aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2020-08-13 10:43:33 +0200
committerHugo Hörnquist <hugo@lysator.liu.se>2020-08-13 10:43:33 +0200
commita902eb51621521d45c648d6a4d06d70d981dfaeb (patch)
treeafc31d4d17fa3939585ad30878b5b690d3b80db3
parentAdd TODO's (diff)
parentComment about generalizing. (diff)
downloadcalp-a902eb51621521d45c648d6a4d06d70d981dfaeb.tar.gz
calp-a902eb51621521d45c648d6a4d06d70d981dfaeb.tar.xz
Merge branch 'calchooser' into master
Diffstat
-rw-r--r--config.scm1
-rw-r--r--module/entry-points/server.scm373
-rw-r--r--module/html/util.scm31
-rw-r--r--module/html/vcomponent.scm89
-rw-r--r--module/html/view/calendar.scm28
-rw-r--r--module/output/vdir.scm28
-rw-r--r--module/server/macro.scm62
-rw-r--r--module/server/routes.scm416
-rw-r--r--module/server/server.scm34
-rw-r--r--module/util.scm1
-rw-r--r--module/vcomponent.scm4
-rw-r--r--module/vcomponent/base.scm10
-rw-r--r--module/vcomponent/instance/methods.scm19
-rw-r--r--module/vcomponent/parse/xcal.scm31
-rw-r--r--static/script.js130
-rw-r--r--static/style.css27
-rwxr-xr-xtests/run-tests.scm4
-rw-r--r--tests/web-server.scm38
18 files changed, 851 insertions, 475 deletions
diff --git a/config.scm b/config.scm
index c2d395a4..b6f22941 100644
--- a/config.scm
+++ b/config.scm
@@ -76,3 +76,4 @@
[else (parse-links str)])))
(set-config! 'week-start mon)
+(set-config! 'default-calendar "Calendar")
diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm
index 466860cd..dfa94cc7 100644
--- a/module/entry-points/server.scm
+++ b/module/entry-points/server.scm
@@ -1,366 +1,17 @@
(define-module (entry-points server)
:use-module (util)
- :use-module (util config)
:use-module (util options)
: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)
- :use-module (ice-9 curried-definitions)
- :use-module (ice-9 ftw)
:use-module (ice-9 getopt-long)
- :use-module (ice-9 iconv)
- :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)
- :use-module (web request)
- :use-module (web response)
- :use-module (web uri)
- :use-module (web http)
+ :use-module ((server server) :select (start-server))
- :use-module (sxml simple)
- :use-module (sxml xpath)
- :use-module (sxml namespace)
+ :export (main))
- :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)
-
- :export (main)
- )
-
-(define (sxml->html-string sxml)
- (with-output-to-string
- (lambda () (display "<!doctype html>\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)
- (get-config 'week-start))))
-
- (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 (get-config 'week-start))
- post-end: (end-of-week (end-of-month start-date) (get-config 'week-start))
- 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 <date>.
- (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 <form>'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
- ((@ (html view search) 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)
@@ -400,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
@@ -417,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/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/html/vcomponent.scm b/module/html/vcomponent.scm
index 9189b59e..5e7b4ba8 100644
--- a/module/html/vcomponent.scm
+++ b/module/html/vcomponent.scm
@@ -44,18 +44,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_bg_"
- ,(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")) "↺"))
@@ -79,8 +82,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)))
@@ -100,13 +104,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
@@ -119,16 +125,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 '()))
@@ -138,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)
@@ -165,28 +170,34 @@
(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()"))
+ ;; 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 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))"
class: '("close-tooltip"))
,(when (edit-mode)
- (btn "🗑"
- title: "Ta bort"
- onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")))
+ (list
+ (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)))"))))
,(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 a15b5c1d..a0de3551 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)
@@ -292,10 +296,22 @@
(summary "Calendar list")
(ul ,@(map
(lambda (calendar)
- `(li (@ (class "CAL_bg_"
+ `(li (@ (class "CAL_"
,(html-attr (prop calendar 'NAME))))
,(prop calendar 'NAME)))
- calendars))))
+ calendars))
+ (div (@ (id "calendar-dropdown-template") (class "template"))
+ (select
+ (option "- Choose a Calendar -")
+ ,@(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
(div (@ (class "eventlist")
@@ -304,6 +320,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
@@ -325,7 +343,11 @@
;; cloned mulitple times.
dtstart: (datetime)
dtend: (datetime)
- summary: "New Event"))))
+ summary: ""
+ ;; 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/output/vdir.scm b/module/output/vdir.scm
index cf4f6c8d..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)
@@ -22,12 +27,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/macro.scm b/module/server/macro.scm
index b6983c7e..2fb87f54 100644
--- a/module/server/macro.scm
+++ b/module/server/macro.scm
@@ -63,37 +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 (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..8d51fc22
--- /dev/null
+++ b/module/server/routes.scm
@@ -0,0 +1,416 @@
+(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 ((html util) :select (html-unattr))
+
+ :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 "<!doctype html>\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.
+ (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: 400)
+ (format #f "No event with UID '~a'" uid))))
+
+ ;; TODO this fails when dtstart is <date>.
+ ;; @var{cal} should be the name of the calendar encoded with
+ ;; modified base64. See (html util).
+ (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 calendar view already show all calendars.
+ (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" calendar-name)))
+
+ ;; 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.
+
+
+ (cond
+ [(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
+ (set! event old-event))
+
+ ;; change calendar
+ (begin
+
+ (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
+ (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."))
+
+ (after-save)
+
+ (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
+ (lambda ()
+ (sxml->xml
+ `(properties
+ (uid (text ,(prop event 'UID)))))))))))
+
+ ;; Get specific page by query string instead of by path.
+ ;; Useful for <form>'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)))))
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)
+ )
+
+
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)
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?))
+
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)))
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<? (extract 'DTSTART)))
diff --git a/module/vcomponent/parse/xcal.scm b/module/vcomponent/parse/xcal.scm
index 76bdb251..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))]
@@ -126,21 +127,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 <text/>
+ (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 <text/>
+ (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)
diff --git a/static/script.js b/static/script.js
index 6e82dd27..7303d1c6 100644
--- a/static/script.js
+++ b/static/script.js
@@ -122,6 +122,20 @@ function bind_popup_control (nav) {
});
}
+/*
+ * Finds the first element of the DOMTokenList whichs value matches
+ * the supplied regexp. Returns a pair of the index and the value.
+ */
+DOMTokenList.prototype.find = function (regexp) {
+ let entries = this.entries();
+ let entry;
+ while (! (entry = entries.next()).done) {
+ if (entry.value[1].match(regexp)) {
+ return entry.value;
+ }
+ }
+}
+
class EventCreator {
/* dynamicly created event when dragging */
@@ -372,11 +386,12 @@ function close_all_popups () {
async function create_event (event) {
let xml = event.getElementsByTagName("icalendar")[0].outerHTML
+ let calendar = event.properties.calendar;
- console.log(xml);
+ console.log(calendar, xml);
let data = new URLSearchParams();
- data.append("cal", "Calendar");
+ data.append("cal", calendar);
data.append("data", xml);
let response = await fetch ( '/insert', {
@@ -386,7 +401,8 @@ async function create_event (event) {
console.log(response);
if (response.status < 200 || response.status >= 300) {
- alert(`HTTP error ${response.status}\n${response.statusText}`)
+ let body = await response.text();
+ alert(`HTTP error ${response.status}\n${body}`)
return;
}
@@ -416,7 +432,6 @@ async function create_event (event) {
}
event.classList.remove("generated");
- event.classList.add("CAL_Calendar");
toggle_popup("popup" + event.id);
}
@@ -428,6 +443,7 @@ function place_in_edit_mode (event) {
let input = makeElement ('input', {
type: "time",
required: true,
+ value: field.innerText,
onchange: function (e) {
/* Only update datetime when the input is filled out */
@@ -456,8 +472,9 @@ function place_in_edit_mode (event) {
let summary = popup.getElementsByClassName("summary")[0];
let input = makeElement('input', {
- name: "dtstart",
- placeholder: summary.innerText,
+ name: "summary",
+ value: summary.innerText,
+ placeholder: "Sammanfattning",
required: true,
});
@@ -473,6 +490,63 @@ function place_in_edit_mode (event) {
/* ---------------------------------------- */
+ /* TODO add elements if the arent't already there
+ * Almost all should be direct children of '.event-body' (or
+ * '.eventtext'?).
+ * Biggest problem is generated fields relative order.
+ */
+ let descs = popup.getElementsByClassName("description");
+ if (descs.length === 1) {
+ let description = descs[0];
+ let textarea = makeElement('textarea', {
+ name: "description",
+ placeholder: "Description (optional)",
+ innerHTML: description.innerText,
+ required: false,
+ });
+
+ textarea.oninput = function () {
+ event.properties["description"] = this.value;
+ }
+
+ let slot = event.properties["_slot_description"]
+ let idx = slot.findIndex(e => e[0] === description);
+ slot.splice(idx, 1, [input, (s, v) => s.innerHTML = v])
+
+ description.replaceWith(textarea);
+ }
+
+ /* ---------------------------------------- */
+
+ let evtext = popup.getElementsByClassName('eventtext')[0]
+ let calendar_dropdown = document.getElementById('calendar-dropdown-template').firstChild.cloneNode(true);
+
+ let [_, calclass] = popup.classList.find(/^CAL_/);
+ label: {
+ for (let [i, option] of calendar_dropdown.childNodes.entries()) {
+ if (option.value === calclass.substr(4)) {
+ calendar_dropdown.selectedIndex = i;
+ break label;
+ }
+ }
+ /* no match, try find default calendar */
+ let t;
+ if ((t = calendar_dropdown.querySelector("[selected]"))) {
+ event.properties.calendar = t.value;
+ }
+ }
+
+
+ /* Instant change while user is stepping through would be
+ * preferable. But I believe that <option> first gives us the
+ * input once selected */
+ calendar_dropdown.onchange = function () {
+ event.properties.calendar = this.value;
+ }
+ evtext.prepend(calendar_dropdown);
+
+ /* ---------------------------------------- */
+
let submit = makeElement( 'input', {
type: 'submit',
value: 'Skapa event',
@@ -490,6 +564,11 @@ function place_in_edit_mode (event) {
article.replaceWith(wrappingForm);
wrappingForm.appendChild(article);
+ /* this is for existing events.
+ * Newly created events aren't in the DOM tree yet, and can
+ * therefore not yet be focused */
+ input.focus();
+
}
window.onload = function () {
@@ -515,7 +594,7 @@ window.onload = function () {
let popupElement = document.getElementById("popup" + event.id);
open_popup(popupElement);
- popupElement.querySelector("input[name='dtstart']").focus();
+ popupElement.querySelector("input[name='summary']").focus();
});
}
@@ -533,7 +612,7 @@ window.onload = function () {
let popupElement = document.getElementById("popup" + event.id);
open_popup(popupElement);
- popupElement.querySelector("input[name='dtstart']").focus();
+ popupElement.querySelector("input[name='summary']").focus();
});
}
@@ -755,4 +834,39 @@ function bind_properties (el, wide_event=false) {
[el.style,
(s, v) => s[wide_event?'right':'bottom'] = 100 * (1 - (to_local(v)-start)/(end-start)) + "%"]);
}
+
+ if (! el.dataset.calendar) {
+ el.dataset.calendar = "Unknown";
+ }
+
+ el.properties._value_calendar = el.dataset.calendar;
+ el.properties._slot_calendar = [];
+
+ /* TODO merge this and instance above */
+ let field = 'calendar';
+ Object.defineProperty(
+ el.properties, field,
+ {
+ get: function () {
+ return this["_value_" + field];
+ },
+ set: function (value) {
+ this["_value_" + field] = value;
+ for (let [slot,updater] of el.properties["_slot_" + field]) {
+ updater(slot, value);
+ }
+ }
+ });
+
+ const rplcs = (s, v) => {
+ let [_, calclass] = s.classList.find(/^CAL_/);
+ s.classList.replace(calclass, "CAL_" + v);
+ }
+
+ el.properties._slot_calendar.push([popup, rplcs]);
+ el.properties._slot_calendar.push([el, rplcs]);
+
+ el.properties._slot_calendar.push(
+ [el, (s, v) => s.dataset.calendar = v]);
+
}
diff --git a/static/style.css b/static/style.css
index 193cc1fb..79fd06ab 100644
--- a/static/style.css
+++ b/static/style.css
@@ -300,6 +300,7 @@ along with their colors.
list-style-type: none;
border-left-width: 1em;
border-left-style: solid;
+ border-color: var(--color);
padding-left: 1ex;
/* force to single line */
@@ -507,9 +508,11 @@ along with their colors.
transition: 0.3s;
font-size: var(--event-font-size);
overflow: visible;
+ background-color: var(--color);
+ color: var(--complement);
}
-.event input {
+.popup input {
white-space: initial;
border: 1px solid gray;
max-width: 100%;
@@ -607,6 +610,10 @@ along with their colors.
padding-right: 1em;
}
+.eventlist .eventtext {
+ border-color: var(--color);
+}
+
.eventlist .eventtext.tentative {
border-left-style: dashed;
}
@@ -634,8 +641,16 @@ along with their colors.
}
+/*
+ * All other CAL_ classes are generated by the backend.
+ * NOTE Possibly move this there.
+ */
+.CAL_Generated {
+ background-color: #55FF55;
+}
+
.event.generated {
- background-color: #55FF5550;
+ opacity: 40%;
transition: none;
}
@@ -734,6 +749,11 @@ along with their colors.
user-select: none;
cursor: grab;
+ background-color: var(--color);
+ /* Transition for background color
+ * Matches that of '.event'.
+ * TODO break out to common place */
+ transition: 0.3s;
}
.popup-control .btn {
@@ -810,7 +830,7 @@ along with their colors.
}
.tab [type=radio]:checked ~ label ~ .content {
- z-index: 1;
+ z-index: 1;
}
/* Other
@@ -829,6 +849,7 @@ along with their colors.
.square {
width: 1em;
height: 1em;
+ background-color: var(--color);
}
/* Icalendar
diff --git a/tests/run-tests.scm b/tests/run-tests.scm
index 7eb0bb73..b162522d 100755
--- a/tests/run-tests.scm
+++ b/tests/run-tests.scm
@@ -76,7 +76,9 @@
#:allocation-limit #e10e8
#:module (make-sandbox-module
(append modules
- '(((srfi srfi-64) test-assert test-equal test-error)
+ '(((srfi srfi-64) test-assert
+ test-equal test-error
+ test-eqv)
((ice-9 ports) call-with-input-string)
((guile) make-struct/no-tail)
)
diff --git a/tests/web-server.scm b/tests/web-server.scm
new file mode 100644
index 00000000..612911f0
--- /dev/null
+++ b/tests/web-server.scm
@@ -0,0 +1,38 @@
+(((server routes) make-make-routes)
+ ((web server) run-server)
+ ((ice-9 threads) call-with-new-thread cancel-thread)
+ ((web client) http-get)
+ ((util) let*)
+ ((web response) response-code response-location)
+ ((web uri) build-uri uri-path)
+ ((guile) AF_INET))
+
+;; TODO find some free address.
+(define port 8090)
+(define host "127.8.9.5")
+
+(define server-thread
+ (call-with-new-thread
+ (lambda ()
+ (run-server (make-make-routes)
+ 'http
+ `(family: ,AF_INET
+ host: ,host
+ port: ,port
+ ))
+ ;; This test should always fail, but should never be run
+ (test-assert "Server returned unexpectedly" #f)
+ )))
+
+(let* ((response body (http-get (build-uri 'http host: host port: port))))
+ (test-eqv "Basic connect" 200 (response-code response)))
+
+(let* ((response body (http-get (build-uri 'http host: host port: port
+ path: "/today"
+ query: "view=week&date=2020-01-04"))))
+ (test-eqv "Redirect"
+ 302 (response-code response))
+ (test-equal "Fully specified redirect position"
+ "/week/2020-01-04.html" (uri-path (response-location response))))
+
+(cancel-thread server-thread)
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-18 06:58:57 +0200