aboutsummaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2021-12-20 22:09:57 +0100
committerHugo Hörnquist <hugo@lysator.liu.se>2021-12-20 22:09:57 +0100
commitd75ebbab2a414fe1a9a09d703a3bc7be782f1f1e (patch)
tree0de4f1c17afd6fbefbafc3a0a8a91bc85cb30355 /module
parentDocument testrunner syntax. (diff)
parentDocumentation updates for util. (diff)
downloadcalp-d75ebbab2a414fe1a9a09d703a3bc7be782f1f1e.tar.gz
calp-d75ebbab2a414fe1a9a09d703a3bc7be782f1f1e.tar.xz
Merge Javascript rewrite.
Diffstat (limited to 'module')
-rw-r--r--module/calp/html/components.scm2
-rw-r--r--module/calp/html/util.scm31
-rw-r--r--module/calp/html/vcomponent.scm974
-rw-r--r--module/calp/html/view/calendar.scm214
-rw-r--r--module/calp/html/view/calendar/month.scm27
-rw-r--r--module/calp/html/view/calendar/week.scm61
-rw-r--r--module/calp/server/routes.scm14
-rw-r--r--module/calp/util.scm40
-rw-r--r--module/datetime.scm18
-rw-r--r--module/vcomponent.scm6
-rw-r--r--module/vcomponent/base.scm11
-rw-r--r--module/vcomponent/recurrence/generate.scm2
-rw-r--r--module/vcomponent/vdir/parse.scm1
-rw-r--r--module/vcomponent/vdir/save-delete.scm2
-rw-r--r--module/vcomponent/xcal/output.scm5
-rw-r--r--module/vcomponent/xcal/parse.scm139
-rw-r--r--module/vulgar/termios.scm5
17 files changed, 851 insertions, 701 deletions
diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm
index 816975e7..1d677c0d 100644
--- a/module/calp/html/components.scm
+++ b/module/calp/html/components.scm
@@ -79,7 +79,7 @@
[else
(set! body (car rem))
(loop (cdr rem))])))
- (div ,body))))
+ ,body)))
;; Creates a group of tabs from a given specification. The specification
diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm
index cd5aaeab..40852279 100644
--- a/module/calp/html/util.scm
+++ b/module/calp/html/util.scm
@@ -1,42 +1,11 @@
(define-module (calp html util)
- :use-module ((base64) :select (base64encode base64decode))
:use-module (calp 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)
- (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"))
-
;; Generate an html id for an event.
;; TODO? same event placed multiple times, when spanning multiple cells
(define-public html-id
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm
index 105c6cc5..3e7cc4dc 100644
--- a/module/calp/html/vcomponent.scm
+++ b/module/calp/html/vcomponent.scm
@@ -1,5 +1,6 @@
(define-module (calp html vcomponent)
:use-module (calp util)
+ :use-module ((calp util exceptions) :select (warning))
:use-module (vcomponent)
:use-module (srfi srfi-1)
:use-module (srfi srfi-26)
@@ -14,6 +15,7 @@
:use-module ((calp util color) :select (calculate-fg-color))
:use-module ((crypto) :select (sha256 checksum->string))
:use-module ((xdg basedir) :prefix xdg-)
+ :use-module ((vcomponent recurrence) :select (repeating?))
:use-module ((vcomponent recurrence internal) :prefix #{rrule:}#)
:use-module ((vcomponent datetime output)
:select (fmt-time-span
@@ -21,8 +23,11 @@
format-summary
format-recurrence-rule
))
+ :use-module ((calp util config) :select (get-config))
+ :use-module ((base64) :select (base64encode))
)
+;; used by search view
(define-public (compact-event-list list)
(define calendars
@@ -33,11 +38,12 @@
(define (summary event)
`(summary (div (@ (class "summary-line "))
- (span (@ (class "square CAL_"
- ,(html-attr
- (or (prop (parent event)
- 'NAME)
- "unknown")))))
+ (span (@ (class "square")
+ (data-calendar
+ ,(base64encode
+ (or (prop (parent event)
+ 'NAME)
+ "unknown")))))
(time ,(let ((dt (prop event 'DTSTART)))
(if (datetime? dt)
(datetime->string dt "~Y-~m-~d ~H:~M")
@@ -58,259 +64,144 @@
;; - sidebar
;; - popup overwiew tab
;; - search result (event details)
+;; Note that the <vevent-description/> tag is bound as a JS custem element, which
+;; will re-render all this, through description-template. This also means that
+;; the procedures output is intended to be static, and to NOT be changed by JavaScript.
(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))
- `(div (@ ,@(assq-merge
- attributes
- `((data-bindby "bind_view")
- (class " eventtext summary-tab "
- ,(when (and (prop ev 'PARTSTAT)
- (eq? 'TENTATIVE (prop ev 'PARTSTAT)))
- " tentative ")))))
- (h3 ,(fmt-header
- (when (prop ev 'RRULE)
- `(span (@ (class "repeating")) "↺"))
- `(span (@ (class "bind summary")
- (data-property "summary"))
- ,(prop ev 'SUMMARY))))
- (div
- ,(call-with-values (lambda () (fmt-time-span ev))
- (case-lambda [(start)
- `(div (time (@ (class "bind dtstart")
- (data-property "dtstart")
- (data-fmt ,(string-append "~L" start))
- (datetime ,(datetime->string
- (as-datetime (prop ev 'DTSTART))
- "~1T~3")))
- ,(datetime->string
- (as-datetime (prop ev 'DTSTART))
- start)))]
- [(start end)
- `(div (time (@ (class "bind dtstart")
- (data-property "dtstart")
- (data-fmt ,(string-append "~L" start))
- (datetime ,(datetime->string
- (as-datetime (prop ev 'DTSTART))
- "~1T~3")))
- ,(datetime->string (as-datetime (prop ev 'DTSTART))
- start))
- " — "
- (time (@ (class "bind dtend")
- (data-property "dtend")
- (data-fmt ,(string-append "~L" end))
- (datetime ,(datetime->string
- (as-datetime (prop ev 'DTSTART))
- "~1T~3")))
- ,(datetime->string (as-datetime (prop ev 'DTEND))
- end)))]))
-
- ;; TODO add optional fields when added in frontend
- ;; Possibly by always having them here, just hidden.
-
- (div (@ (class "fields"))
- ,(when (and=> (prop ev 'LOCATION) (negate string-null?))
- `(div (b "Plats: ")
- (div (@ (class "bind location") (data-property "location"))
- ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
- (prop ev 'LOCATION)))))
- ,(awhen (prop ev 'DESCRIPTION)
- `(div (@ (class "bind description")
- (data-property "description"))
- ,(format-description ev it)))
-
- ,@(awhen (prop* ev 'ATTACH)
- ;; attach satisfies @code{vline?}
- (for attach in it
- (if (and=> (param attach 'VALUE)
- (lambda (p) (string=? "BINARY" (car p))))
- ;; Binary data
- ;; TODO guess datatype if FMTTYPE is missing
- (awhen (and=> (param attach 'FMTTYPE)
- (lambda (it) (string-split
- (car it) #\/)))
- ;; TODO other file formats
- (when (string=? "image" (car it))
- (let* ((chk (-> (value attach)
- sha256
- checksum->string))
- (dname
- (path-append (xdg-runtime-dir)
- "calp-data" "images"))
- (filename (-> dname
- (path-append chk)
- ;; TODO second part of mimetypes
- ;; doesn't always result in a valid
- ;; file extension.
- ;; Take a look in mime.types.
- (string-append "." (cadr it)))))
- (unless (file-exists? filename)
- ;; TODO handle tmp directory globaly
- (mkdir (dirname dname))
- (mkdir dname)
- (call-with-output-file filename
- (lambda (port)
- (put-bytevector port (value attach)))))
- (let ((link (path-append
- "/tmpfiles"
- ;; TODO better mimetype to extension
- (string-append chk "." (cadr it)))))
- `(a (@ (href ,link))
- (img (@ (class "attach")
- (src ,link))))))))
- ;; URI
- (cond ((and=> (param attach 'FMTTYPE)
- (compose (cut string= <> "image" 0 5) car))
- `(img (@ (class "attach")
- (src ,(value attach)))))
- (else `(a (@ (class "attach")
- (href ,(value attach)))
- ,(value attach)))))))
-
- ;; TODO add bind once I figure out how to bind lists
- ,(awhen (prop ev 'CATEGORIES)
- `(div (@ (class "categories"))
- ,@(map (lambda (c)
- `(a (@ (class "category")
- ;; TODO centralize search terms
- (href
- "/search/?"
- ,(encode-query-parameters
- `((q . (member
- ,(->string c)
- (or (prop event 'CATEGORIES)
- '())))))))
- ,c))
- it)))
-
- ;; TODO bind
- ,(awhen (prop ev 'RRULE)
- `(div (@ (class "rrule"))
- ,@(format-recurrence-rule ev)))
-
- ,(when (prop ev 'LAST-MODIFIED)
- `(div (@ (class "last-modified")) "Senast ändrad "
- ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M"))))
-
- )))
-
-(define*-public (fmt-for-edit ev
- optional: (attributes '())
- key: (fmt-header list))
- `(div (@ (class " eventtext edit-tab ")
- (data-bindby "bind_edit"))
- (form (@ (class "edit-form"))
- (div (@ (class "dropdown-goes-here")))
- (h3 (input (@ (type "text")
- (placeholder "Sammanfattning")
- (name "summary") (required)
- (class "bind") (data-property "summary")
- (value ,(prop ev 'SUMMARY)))))
-
- ,(let ((start (prop ev 'DTSTART))
- (end (prop ev 'DTEND)))
- `(div (@ (class "timeinput"))
-
- ,@(with-label
- "Starttid"
- `(div (@ (class "date-time bind")
- (data-bindby "bind_date_time")
- (name "dtstart"))
- (input (@ (type "date")
- (value ,(date->string (as-date start)))))
- (input (@ (type "time")
- (value ,(time->string (as-time start) "~H:~M"))
- ,@(when (date? start) '((disabled)))
- ))))
-
- ;; TODO some way to add an endtime if missing beforehand
- ;; TODO, actually proper support for event without end times
- ,@(when end
- (with-label
- "Sluttid"
- `(div (@ (class "date-time bind")
- (data-bindby "bind_date_time")
- (name "dtend"))
- (input (@ (type "date")
- (value ,(date->string (as-date end)))))
- (input (@ (type "time")
- (value ,(time->string (as-time end) "~H:~M"))
- ,@(when (date? end) '((disabled))))))))
-
- (div
- ,@(with-label
- "Heldag?"
- `(input (@ (type "checkbox")
- (class "bind")
- (data-bindby "bind_wholeday")
- (name "wholeday")
- ,@(when (date? start) '((checked)))))))
-
- ))
-
- ,@(with-label
- "Plats"
- `(input (@ (placeholder "Plats")
- (name "location")
- (type "text")
- (class "bind") (data-property "location")
- (value ,(or (prop ev 'LOCATION) "")))))
-
- ,@(with-label
- "Beskrivning"
- `(textarea (@ (placeholder "Beskrivning")
- (class "bind") (data-property "description")
- (name "description"))
- ,(prop ev 'DESCRIPTION)))
-
- ,@(with-label
- "Kategorier"
- ;; It would be better if these input-list's worked on the same
- ;; class=bind system as the fields above. The problem with that
- ;; is however that each input-list requires different search
- ;; and join procedures. Currently this is bound in the JS, see
- ;; [CATEGORIES_BIND].
- ;; It matches on ".input-list[data-property='categories']".
- `(div (@ (class "input-list")
- (data-property "categories"))
- ,@(awhen (prop ev 'CATEGORIES)
- (map (lambda (c)
- `(input (@ (size 2)
- (class "unit")
- (value ,c))))
- it))
-
- (input (@ (class "unit final")
- (size 2)
- (type "text")
- ))))
-
- (hr)
-
- ;; For custom user fields
- ;; TODO these are currently not bound to anything, so entering data
- ;; here does nothing. Bigest hurdle to overcome is supporting arbitrary
- ;; fields which will come and go in the JavaScript.
- ;; TODO also, all (most? maybe not LAST-MODIFIED) remaining properties
- ;; should be exposed here.
- (div (@ (class "input-list"))
- (div (@ (class "unit final newfield"))
- (input (@ (type "text")
- (list "known-fields")
- (placeholder "Nytt fält")))
- (select (@ (name "TYPE"))
- (option (@ (value "TEXT")) "Text"))
- (span
- (input (@ (type "text")
- (placeholder "Värde"))))))
-
- (hr)
+ `(vevent-description
+ (@ ,@(assq-merge
+ attributes
+ `(
+ (class ,(when (and (prop ev 'PARTSTAT)
+ (eq? 'TENTATIVE (prop ev 'PARTSTAT)))
+ " tentative "))
+ (data-uid ,(output-uid ev)))))
+ (div (@ (class "vevent eventtext summary-tab"))
+ (h3 ,(fmt-header
+ (when (prop ev 'RRULE)
+ `(span (@ (class "repeating")) "↺"))
+ `(span (@ (class "summary")
+ (data-property "summary"))
+ ,(prop ev 'SUMMARY))))
+ (div
+ ,(call-with-values (lambda () (fmt-time-span ev))
+ (case-lambda [(start)
+ `(div (time (@ (class "dtstart")
+ (data-property "dtstart")
+ (data-fmt ,(string-append "~L" start))
+ (datetime ,(datetime->string
+ (as-datetime (prop ev 'DTSTART))
+ "~1T~3")))
+ ,(datetime->string
+ (as-datetime (prop ev 'DTSTART))
+ start)))]
+ [(start end)
+ `(div (time (@ (class "dtstart")
+ (data-property "dtstart")
+ (data-fmt ,(string-append "~L" start))
+ (datetime ,(datetime->string
+ (as-datetime (prop ev 'DTSTART))
+ "~1T~3")))
+ ,(datetime->string (as-datetime (prop ev 'DTSTART))
+ start))
+ " — "
+ (time (@ (class "dtend")
+ (data-property "dtend")
+ (data-fmt ,(string-append "~L" end))
+ (datetime ,(datetime->string
+ (as-datetime (prop ev 'DTSTART))
+ "~1T~3")))
+ ,(datetime->string (as-datetime (prop ev 'DTEND))
+ end)))]))
+
+ (div (@ (class "fields"))
+ ,(when (and=> (prop ev 'LOCATION) (negate string-null?))
+ `(div (b "Plats: ")
+ (div (@ (class "location") (data-property "location"))
+ ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
+ (prop ev 'LOCATION)))))
+ ,(awhen (prop ev 'DESCRIPTION)
+ `(div (@ (class "description")
+ (data-property "description"))
+ ,(format-description ev it)))
+
+ ,@(awhen (prop* ev 'ATTACH)
+ ;; attach satisfies @code{vline?}
+ (for attach in it
+ (if (and=> (param attach 'VALUE)
+ (lambda (p) (string=? "BINARY" (car p))))
+ ;; Binary data
+ ;; TODO guess datatype if FMTTYPE is missing
+ (awhen (and=> (param attach 'FMTTYPE)
+ (lambda (it) (string-split
+ (car it) #\/)))
+ ;; TODO other file formats
+ (when (string=? "image" (car it))
+ (let* ((chk (-> (value attach)
+ sha256
+ checksum->string))
+ (dname
+ (path-append (xdg-runtime-dir)
+ "calp-data" "images"))
+ (filename (-> dname
+ (path-append chk)
+ ;; TODO second part of mimetypes
+ ;; doesn't always result in a valid
+ ;; file extension.
+ ;; Take a look in mime.types.
+ (string-append "." (cadr it)))))
+ (unless (file-exists? filename)
+ ;; TODO handle tmp directory globaly
+ (mkdir (dirname dname))
+ (mkdir dname)
+ (call-with-output-file filename
+ (lambda (port)
+ (put-bytevector port (value attach)))))
+ (let ((link (path-append
+ "/tmpfiles"
+ ;; TODO better mimetype to extension
+ (string-append chk "." (cadr it)))))
+ `(a (@ (href ,link))
+ (img (@ (class "attach")
+ (src ,link))))))))
+ ;; URI
+ (cond ((and=> (param attach 'FMTTYPE)
+ (compose (cut string= <> "image" 0 5) car))
+ `(img (@ (class "attach")
+ (src ,(value attach)))))
+ (else `(a (@ (class "attach")
+ (href ,(value attach)))
+ ,(value attach)))))))
+
+ ,(awhen (prop ev 'CATEGORIES)
+ `(div (@ (class "categories"))
+ ,@(map (lambda (c)
+ `(a (@ (class "category")
+ ;; TODO centralize search terms
+ (href
+ "/search/?"
+ ,(encode-query-parameters
+ `((q . (member
+ ,(->string c)
+ (or (prop event 'CATEGORIES)
+ '())))))))
+ ,c))
+ it)))
+
+ ,(awhen (prop ev 'RRULE)
+ `(div (@ (class "rrule"))
+ ,@(format-recurrence-rule ev)))
+
+ ,(when (prop ev 'LAST-MODIFIED)
+ `(div (@ (class "last-modified")) "Senast ändrad "
+ ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M"))))
+
+ ))))
- (input (@ (type "submit")))
- )))
-
;; Single event in side bar (text objects)
(define-public (fmt-day day)
@@ -324,7 +215,7 @@
(lambda (ev)
(fmt-single-event
ev `((id ,(html-id ev))
- (class "CAL_" ,(html-attr (or (prop (parent ev) 'NAME) "unknown"))))
+ (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown"))))
fmt-header:
(lambda body
`(a (@ (href "#" ,(html-id ev) #; (date-link (as-date (prop ev 'DTSTART)))
@@ -341,60 +232,61 @@
events))))))
+;; Specific styles for each calendar.
+;; TODO only emit the CSS here, requiring the caller to handle the context,
+;; since that would allow us to use this in other contexts.
(define-public (calendar-styles calendars)
`(style
- ,(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))))
+ ,(lambda () (format #t "~:{ [data-calendar=\"~a\"] { --color: ~a; --complement: ~a }~%~}"
+ (map (lambda (c)
+ (let* ((name (base64encode (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 '()))
+ ;; surrounding <a /> element which allows something to happen when an element
+ ;; is clicked with JS turned off. Our JS disables this, and handles clicks itself.
`((a (@ (href "#" ,(html-id ev))
(class "hidelink"))
- (div (@ ,@(assq-merge
- extra-attributes
- `((id ,(html-id ev))
- (data-calendar ,(html-attr (or (prop (parent ev) 'NAME) "unknown")))
- ;; (data-bindon "bind_view")
- (class "event CAL_" ,(html-attr (or (prop (parent ev) 'NAME)
- "unknown"))
- ,(when (and (prop ev 'PARTSTAT)
- (eq? 'TENTATIVE (prop ev 'PARTSTAT)))
- " tentative")
- ,(when (and (prop ev 'TRANSP)
- (eq? 'TRANSPARENT (prop ev 'TRANSP)))
- " transparent")
- )
- (onclick "toggle_popup('popup' + this.id)")
- )))
- ;; Inner div to prevent overflow. Previously "overflow: none"
- ;; was set on the surounding div, but the popup /needs/ to
- ;; overflow (for the tabs?).
- (div (@ (class "event-body"))
- ,(when (prop ev 'RRULE)
- `(span (@ (class "repeating")) "↺"))
- (span (@ (class "bind summary")
- (data-property "summary"))
- ,(format-summary ev (prop ev 'SUMMARY)))
- ,(when (prop ev 'LOCATION)
- `(span (@ (class "bind location")
- (data-property "location"))
- ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
- (prop ev 'LOCATION))))
- ;; Document symbol when we have text
- ,(when (and=> (prop ev 'DESCRIPTION) (negate string-null?))
- `(span (@ (class "description"))
- "🗎")))
- (div (@ (style "display:none !important;"))
- ,((@ (vcomponent xcal output) ns-wrap)
- ((@ (vcomponent xcal output) vcomponent->sxcal)
- ev)))))))
+ (vevent-block (@ ,@(assq-merge
+ extra-attributes
+ `((id ,(html-id ev))
+ (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown")))
+ (data-uid ,(output-uid ev))
+
+ (class "vevent event"
+ ,(when (and (prop ev 'PARTSTAT)
+ (eq? 'TENTATIVE (prop ev 'PARTSTAT)))
+ " tentative")
+ ,(when (and (prop ev 'TRANSP)
+ (eq? 'TRANSPARENT (prop ev 'TRANSP)))
+ " transparent")
+ ))))
+ ;; Inner div to prevent overflow. Previously "overflow: none"
+ ;; was set on the surounding div, but the popup /needs/ to
+ ;; overflow (for the tabs?).
+ ;; TODO the above comment is no longer valid. Popups are now stored
+ ;; separately from the block.
+ (div (@ (class "event-body"))
+ ,(when (prop ev 'RRULE)
+ `(span (@ (class "repeating")) "↺"))
+ (span (@ (class "summary")
+ (data-property "summary"))
+ ,(format-summary ev (prop ev 'SUMMARY)))
+ ,(when (prop ev 'LOCATION)
+ `(span (@ (class "location")
+ (data-property "location"))
+ ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
+ (prop ev 'LOCATION))))
+ ;; Document symbol when we have text
+ ,(when (and=> (prop ev 'DESCRIPTION) (negate string-null?))
+ `(span (@ (class "description"))
+ "🗎")))))))
(define (repeat-info event)
@@ -421,208 +313,284 @@
(else (->string value))))))
(prop event 'RRULE)))))
-;; TODO bind this into the xcal
-(define (editable-repeat-info event)
- `(div (@ (class "eventtext"))
- (h2 "Upprepningar")
- ,@(when (debug)
- '((button (@ (style "position:absolute;right:1ex;top:1ex")
- (onclick "console.log(event_from_popup(this.closest('.popup-container')).properties.rrule.asJcal());"))
- "js")))
- (table (@ (class "recur-components bind")
- (name "rrule")
- (data-bindby "bind_recur"))
- ,@(map ; (@@ (vcomponent recurrence internal) map-fields)
- (lambda (key )
- `(tr (@ (class ,key)) (th ,key)
- (td
- ,(case key
- ((freq)
- `(select (@ (class "bind-rr") (name "freq"))
- (option "-")
- ,@(map (lambda (x) `(option (@ (value ,x)
- ,@(awhen (prop event 'RRULE)
- (awhen (rrule:freq it)
- (awhen (eq? it x)
- '((selected))))))
- ,(string-titlecase
- (symbol->string x))))
- '(SECONDLY MINUTELY HOURLY
- DAILY WEEKLY
- MONTHLY YEARLY))))
- ((until)
- (if (date? (prop event 'DTSTART))
- `(input (@ (type "date")
- (name "until")
- (class "bind-rr")
- (value ,(awhen (prop event 'RRULE)
- (awhen (rrule:until it)
- (date->string it))))))
- `(span (@ (class "bind-rr date-time")
- (name "until"))
- (input (@ (type "date")
- (value ,(awhen (prop event 'RRULE)
- (awhen (rrule:until it)
- (date->string
- (as-date it)))))))
- (input (@ (type "time")
- (value ,(awhen (prop event 'RRULE)
- (awhen (rrule:until it)
- (time->string
- (as-time it))))))))))
- ((count)
- `(input (@ (type number) (min 0) (size 4)
- (value ,(awhen (prop event 'RRULE)
- (or (rrule:count it) "")))
- (name "count")
- (class "bind-rr")
- )))
- ((interval)
- `(input (@ (type number) (min 0) (size 4)
- (value ,(awhen (prop event 'RRULE)
- (or (rrule:interval it) "")))
- (name "interval")
- (class "bind-rr"))))
- ((wkst)
- `(select (@ (name "wkst") (class "bind-rr"))
- (option "-")
- ,@(map (lambda (i)
- `(option (@ (value ,i)
- ,@(awhen (prop event 'RRULE)
- (awhen (rrule:wkst it)
- (awhen (eqv? it i)
- '((selected))))))
- ,(week-day-name i)))
- (iota 7))))
-
- ((byday)
- (let ((input (lambda* (optional: (byday '(#f . #f)) key: final?)
- `(div (@ (class "unit" ,(if final? " final" "")))
- ;; TODO make this thiner, and clearer that
- ;; it belongs to the following dropdown
- (input (@ (type number)
- (value ,(awhen (car byday) it))))
- (select (option "-")
- ,@(map (lambda (i)
- `(option (@ (value ,i)
- ,@(if (eqv? i (cdr byday))
- '((selected)) '()))
- ,(week-day-name i)))
- (iota 7)))))))
- ;; TODO how does this bind?
- `(div (@ (class "bind-rr input-list"))
- ,@(cond ((and=> (prop event 'RRULE)
- rrule:byday)
- => (lambda (it) (map input it)))
- (else '()))
-
- ,(input final?: #t))))
-
- ((bysecond byminute byhour
- bymonthday byyearday
- byweekno bymonth bysetpos)
- (let ((input
- (lambda* (value optional: (final ""))
- `(input (@ (class "unit " ,final)
- (type "number")
- (size 2)
- (value ,value)
- (min ,(case key
- ((bysecond byminute byhour) 0)
- ((bymonthday) -31)
- ((byyearday) -366)
- ((byweekno) -53)
- ((bymonth) -12)
- ((bysetpos) -366)
- ))
- (max ,(case key
- ((bysecond) 60)
- ((byminute) 59)
- ((byhour) 23)
- ((bymonthday) 31)
- ((byyearday) 366)
- ((byweekno) 53)
- ((bymonth) 12)
- ((bysetpos) 366))))))))
- `(div (@ (name ,key)
- (class "bind-rr input-list"))
- ,@(map input
- (awhen (prop event 'RRULE)
- (or ((case key
- ((bysecond) rrule:bysecond)
- ((byminute) rrule:byminute)
- ((byhour) rrule:byhour)
- ((bymonthday) rrule:bymonthday)
- ((byyearday) rrule:byyearday)
- ((byweekno) rrule:byweekno)
- ((bymonth) rrule:bymonth)
- ((bysetpos) rrule:bysetpos))
- it)
- '())))
- ,(input '() "final"))))
- (else (error "Unknown field, " key))))
-
- ;; TODO enable this button
- (td (button (@ (class "clear-input") (title "Rensa input")) "🗙"))
+
+;; Return a unique identifier for a specific instance of an event.
+;; Allows us to reference each instance of a repeating event separately
+;; from any other
+(define-public (output-uid event)
+ (string-concatenate
+ (cons
+ (prop event 'UID)
+ (when (repeating? event)
+ ;; TODO this will break if a UID already looks like this...
+ ;; Just using a pre-generated unique string would solve it,
+ ;; until someone wants to break us. Therefore, we just give
+ ;; up for now, until a proper solution can be devised.
+ (list "---"
+ ;; TODO Will this give us a unique identifier?
+ ;; Or can two events share UID along with start time
+ (datetime->string
+ (as-datetime (or
+ ;; TODO What happens if the parameter RANGE=THISANDFUTURE is set?
+ (prop event 'RECURRENCE-ID)
+ (prop event 'DTSTART)))
+ "~Y-~m-~dT~H:~M:~S"))))))
+
+
+(define (week-day-select args)
+ `(select (@ ,@args)
+ (option "-")
+ ,@(map (lambda (x) `(option (@ (value ,(car x))) ,(cadr x)))
+ '((MO "Monday")
+ (TU "Tuesday")
+ (WE "Wednesday")
+ (TH "Thursday")
+ (FR "Friday")
+ (SA "Saturday")
+ (SU "Sunday")))))
+
+
+;;; Templates
+
+
+;; edit tab of popup
+(define-public (edit-template calendars)
+ `(template
+ (@ (id "vevent-edit"))
+ (div (@ (class " eventtext edit-tab "))
+ (form (@ (class "edit-form"))
+ (select (@ (class "calendar-selection"))
+ (option "- Choose a Calendar -")
+ ,@(let ((dflt (get-config 'default-calendar)))
+ (map (lambda (calendar)
+ (define name (prop calendar 'NAME))
+ `(option (@ (value ,(base64encode name))
+ ,@(when (string=? name dflt)
+ '((selected))))
+ ,name))
+ calendars)))
+ (h3 (input (@ (type "text")
+ (placeholder "Sammanfattning")
+ (name "summary") (required)
+ (data-property "summary")
+ ; (value ,(prop ev 'SUMMARY))
+ )))
+
+ (div (@ (class "timeinput"))
+
+ ,@(with-label
+ "Starttid"
+ '(date-time-input (@ (name "dtstart")
+ (data-property "dtstart")
+ )))
+
+ ,@(with-label
+ "Sluttid"
+ '(date-time-input (@ (name "dtend")
+ (data-property "dtend"))))
+
+ (div (@ (class "checkboxes"))
+ ,@(with-label
+ "Heldag?"
+ `(input (@ (type "checkbox")
+ (name "wholeday")
+ )))
+ ,@(with-label
+ "Upprepande?"
+ `(input (@ (type "checkbox")
+ (name "has_repeats")
+ ))))
+
+ )
+
+ ,@(with-label
+ "Plats"
+ `(input (@ (placeholder "Plats")
+ (name "location")
+ (type "text")
+ (data-property "location")
+ ; (value ,(or (prop ev 'LOCATION) ""))
+ )))
+
+ ,@(with-label
+ "Beskrivning"
+ `(textarea (@ (placeholder "Beskrivning")
+ (data-property "description")
+ (name "description"))
+ ; ,(prop ev 'DESCRIPTION)
+ ))
+
+ ,@(with-label
+ "Kategorier"
+ `(input-list
+ (@ (name "categories")
+ (data-property "categories"))
+ (input (@ (type "text")
+ (placeholder "Kattegori")))))
+
+ ;; TODO This should be a "list" where any field can be edited
+ ;; directly. Major thing holding us back currently is that
+ ;; <input-list /> doesn't supported advanced inputs
+ ;; (div (@ (class "input-list"))
+ ;; (div (@ (class "unit final newfield"))
+ ;; (input (@ (type "text")
+ ;; (list "known-fields")
+ ;; (placeholder "Nytt fält")))
+ ;; (select (@ (name "TYPE"))
+ ;; (option (@ (value "TEXT")) "Text"))
+ ;; (span
+ ;; (input (@ (type "text")
+ ;; (placeholder "Värde"))))))
+
+ ;; (hr)
+
+
+ (input (@ (type "submit")))
+ ))))
+
+;; description in sidebar / tab of popup
+;; Template data for <vevent-description />
+(define-public (description-template)
+ '(template
+ (@ (id "vevent-description"))
+ (div (@ (class " vevent eventtext summary-tab " ()))
+ (h3 ((span (@ (class "repeating"))
+ "↺")
+ (span (@ (class "summary")
+ (data-property "summary")))))
+ (div (div (time (@ (class "dtstart")
+ (data-property "dtstart")
+ (data-fmt "~L~H:~M")
+ (datetime ; "2021-09-29T19:56:46"
+ ))
+ ; "19:56"
+ )
+ "\xa0—\xa0"
+ (time (@ (class "dtend")
+ (data-property "dtend")
+ (data-fmt "~L~H:~M")
+ (datetime ; "2021-09-29T19:56:46"
+ ))
+ ; "20:56"
))
- '(freq until count interval bysecond byminute byhour
- byday bymonthday byyearday byweekno bymonth bysetpos
- wkst)
- ; (prop event 'RRULE)
- ))))
-
-
-(define-public (popup ev 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"))
- ,(btn "×"
- title: "Stäng"
- onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))"
- class: '("close-tooltip"))
- ,(when (edit-mode)
- (list
- (btn "🖊️"
- title: "Redigera"
- onclick: "place_in_edit_mode(event_from_popup(this.closest('.popup-container')))")
- (btn "🗑"
- title: "Ta bort"
- onclick: "remove_event(event_from_popup(this.closest('.popup-container')))"))))
-
- ,(tabset
- `(("📅" title: "Översikt"
- ,(fmt-single-event ev))
-
- ,@(when (edit-mode)
- `(("📅" title: "Redigera"
- ,(fmt-for-edit ev))))
-
- ,@(when (debug)
- `(("🐸" title: "Debug"
- (div
- (pre ,(prop ev 'UID))))))
-
- ("⤓" title: "Nedladdning"
- (div (@ (class "eventtext") (style "font-family:sans"))
- (h2 "Ladda ner")
- (div (@ (class "side-by-side"))
- (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics"))
- "som iCal"))
- (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs"))
- "som xCal")))
- ,@(when (debug)
- `((ul
- (li (button (@ (onclick "console.log(event_to_jcal(event_from_popup(this.closest('.popup-container'))));")) "js"))
- (li (button (@ (onclick "console.log(jcal_to_xcal(event_to_jcal(event_from_popup(this.closest('.popup-container')))));")) "xml"))
- (li (button (@ (onclick "console.log(event_from_popup(this.closest('.popup-container')))")) "this"))
- ))))
- ))
-
- ,@(when (prop ev 'RRULE)
- `(("↺" title: "Upprepningar" class: "repeating"
- ,(editable-repeat-info ev)))))))))
+ (div (@ (class "fields"))
+ (div (b "Plats: ")
+ (div (@ (class "location")
+ (data-property "location"))
+ ; "Alsättersgatan 13"
+ ))
+ (div (@ (class "description")
+ (data-property "description"))
+ ; "With a description"
+ )
+
+ (div (@ (class "categories")
+ (data-property "categories")))
+ ;; (div (@ (class "categories"))
+ ;; (a (@ (class "category")
+ ;; (href "/search/?"
+ ;; "q=%28member%20%22test%22%20%28or%20%28prop%20event%20%28quote%20CATEGORIES%29%29%20%28quote%20%28%29%29%29%29"))
+ ;; test))
+ ;; (div (@ (class "rrule"))
+ ;; "Upprepas "
+ ;; "varje vecka"
+ ;; ".")
+ (div (@ (class "last-modified"))
+ "Senast ändrad -"
+ ; "2021-09-29 19:56"
+ ))))))
+
+(define-public (vevent-edit-rrule-template)
+ `(template
+ (@ (id "vevent-edit-rrule"))
+ (div (@ (class "eventtext"))
+ (h2 "Upprepningar")
+ (dl
+ (dt "Frequency")
+ (dd (select (@ (name "freq"))
+ (option "-")
+ ,@(map (lambda (x) `(option (@ (value ,x)) ,(string-titlecase (symbol->string x))))
+ '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY))))
+
+ (dt "Until")
+ (dd (date-time-input (@ (name "until"))))
+
+ (dt "Conut")
+ (dd (input (@ (type "number") (name "count") (min 0))))
+
+ (dt "Interval")
+ (dd (input (@ (type "number") (name "interval") ; min and max depend on FREQ
+ )))
+
+ ,@(concatenate
+ (map (lambda (pair)
+ (define name (list-ref pair 0))
+ (define pretty-name (list-ref pair 1))
+ (define min (list-ref pair 2))
+ (define max (list-ref pair 3))
+ `((dt ,pretty-name)
+ (dd (input-list (@ (name ,name))
+ (input (@ (type "number")
+ (min ,min) (max ,max)))))))
+ '((bysecond "By Second" 0 60)
+ (byminute "By Minute" 0 59)
+ (byhour "By Hour" 0 23)
+ (bymonthday "By Month Day" -31 31) ; except 0
+ (byyearday "By Year Day" -366 366) ; except 0
+ (byweekno "By Week Number" -53 53) ; except 0
+ (bymonth "By Month" 1 12)
+ (bysetpos "By Set Position" -366 366) ; except 0
+ )))
+
+ ;; (dt "By Week Day")
+ ;; (dd (input-list (@ (name "byweekday"))
+ ;; (input (@ (type number)
+ ;; (min -53) (max 53) ; except 0
+ ;; ))
+ ;; ,(week-day-select '())
+ ;; ))
+
+ (dt "Weekstart")
+ (dd ,(week-day-select '((name "wkst")))))))
+ )
+
+
+;; Based on popup:s output
+(define-public (popup-template)
+ `(template
+ (@ (id "popup-template"))
+ ;; becomes the direct child of <popup-element/>
+ (div (@ (class "popup-root window")
+ (onclick "event.stopPropagation()"))
+
+ (nav (@ (class "popup-control"))
+ (button (@ (class "close-button")
+ (title "Stäng")
+ (aria-label "Close"))
+ "×")
+ (button (@ (class "maximize-button")
+ (title "Fullskärm")
+ ;; (aria-label "")
+ )
+ "🗖")
+ (button (@ (class "remove-button")
+ (title "Ta Bort"))
+ "🗑"))
+
+ (tab-group (@ (class "window-body"))
+ (vevent-description
+ (@ (data-label "📅") (data-title "Översikt")
+ (class "vevent")))
+
+ (vevent-edit
+ (@ (data-label "🖊") (data-title "Redigera")))
+
+ ;; (vevent-edit-rrule
+ ;; (@ (data-label "↺") (data-title "Upprepningar")))
+
+ (vevent-changelog
+ (@ (data-label "📒") (date-title "Changelog")))
+
+ ,@(when (debug)
+ '((vevent-dl
+ (@ (data-label "🐸") (data-title "Debug")))))))))
diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index 4574f517..aa311fcb 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -8,11 +8,11 @@
:use-module (datetime)
:use-module (calp html components)
:use-module ((calp html vcomponent)
- :select (popup
- calendar-styles
+ :select (calendar-styles
fmt-day
make-block
fmt-single-event
+ output-uid
))
:use-module (calp html config)
:use-module (calp html util)
@@ -25,8 +25,10 @@
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
+ :use-module ((vcomponent recurrence) :select (repeating? generate-recurrence-set))
:use-module ((vcomponent group)
:select (group-stream get-groups-between))
+ :use-module ((base64) :select (base64encode))
)
@@ -48,7 +50,10 @@
(define*-public (html-generate
key:
(intervaltype 'all) ; 'week | 'month | 'all
- calendars events start-date end-date
+ calendars ; All calendars to work on, probably (get-calendars global-event-object)
+ events ; All events which can be worked on, probably (get-event-set global-event-object)
+ start-date ; First date in interval to show
+ end-date ; Last date in interval to show
render-calendar ; (bunch of kv args) → (list sxml)
next-start ; date → date
prev-start ; date → date
@@ -93,7 +98,14 @@
(meta (@ (name end-time)
(content ,(date->string (date+ end-date (date day: 1)) "~s"))))
- (script "EDIT_MODE=" ,(if (edit-mode) "true" "false") ";")
+ (script
+ ,(format #f
+ "
+EDIT_MODE=~:[false~;true~];
+window.default_calendar='~a';"
+ (edit-mode)
+ (base64encode (get-config 'default-calendar))))
+
(style ,(format #f "html {
--editmode: 1.0;
@@ -104,19 +116,8 @@
,(include-alt-css "/static/dark.css" '(title "Dark"))
,(include-alt-css "/static/light.css" '(title "Light"))
- (script (@ (defer) (src "/static/types.js")))
- (script (@ (defer) (src "/static/lib.js")))
- (script (@ (defer) (src "/static/jcal.js")))
- (script (@ (defer) (src "/static/dragable.js")))
- (script (@ (defer) (src "/static/clock.js")))
- (script (@ (defer) (src "/static/popup.js")))
- (script (@ (defer) (src "/static/rrule.js")))
- (script (@ (defer) (src "/static/binders.js")))
- (script (@ (defer) (src "/static/server_connect.js")))
- (script (@ (defer) (src "/static/input_list.js")))
- (script (@ (defer) (src "/static/date_time.js")))
- (script (@ (defer) (src "/static/vcal.js")))
- (script (@ (defer) (src "/static/script.js")))
+ (script (@ (src "/static/script.out.js")))
+
,(calendar-styles calendars)
,@(when (debug)
@@ -136,6 +137,10 @@
next-start: next-start
prev-start: prev-start
)
+
+ ,(btn onclick: "addNewEvent()"
+ "+")
+
;; Popups used to be here, but was moved into render-calendar so each
;; sub-view can itself decide where to put them. This is important
;; since they need to be placed as children to the scrolling
@@ -146,6 +151,7 @@
(footer
(@ (style "grid-area: footer"))
(span "Page generated " ,(date->string (current-date)))
+ (span "Current time " (current-time (@ (interval 1))))
(span (a (@ (href ,(repo-url)))
"Source Code")))
@@ -162,13 +168,14 @@
,(btn href: (date->string (set (day start-date) 1) "/month/~1.html")
"månadsvy")
- ,(btn id: "today-button"
- href: (string-append
- "/today?" (case intervaltype
- [(month) "view=month"]
- [(week) "view=week"]
- [else ""]))
- "idag"))
+ (today-button
+ (a (@ (class "btn")
+ (href ,(string-append
+ "/today?" (case intervaltype
+ [(month) "view=month"]
+ [(week) "view=week"]
+ [else ""]))))
+ "idag")))
(div (@ (id "jump-to"))
;; Firefox's accessability complain about each date
@@ -248,32 +255,22 @@
(summary "Calendar list")
(ul ,@(map
(lambda (calendar)
- `(li (@ (class "CAL_"
- ,(html-attr (prop calendar 'NAME))))
+ `(li (@ (data-calendar ,(base64encode (prop calendar 'NAME))))
(a (@ (href "/search?"
- ,((@ (web uri-query) encode-query-parameters)
- `((q . (and (date/-time<=?
- ,(current-datetime)
- (prop event 'DTSTART))
- ;; TODO this seems to miss some calendars,
- ;; I belive it's due to some setting X-WR-CALNAME,
- ;; which is only transfered /sometimes/ into NAME.
- (string=? ,(->string (prop calendar 'NAME))
- (or (prop (parent event) 'NAME) ""))))))))
+ ,((@ (web uri-query) encode-query-parameters)
+ `((q . (and (date/-time<=?
+ ,(current-datetime)
+ (prop event 'DTSTART))
+ ;; TODO this seems to miss some calendars,
+ ;; I belive it's due to some setting X-WR-CALNAME,
+ ;; which is only transfered /sometimes/ into NAME.
+ (string=? ,(->string (prop calendar 'NAME))
+ (or (prop (parent event) 'NAME) ""))))))))
,(prop calendar 'NAME))))
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)))
- )))
+ ;; (div (@ (id "calendar-dropdown-template") (class "template"))
+ ;; )
+ ))
;; List of events
(div (@ (class "eventlist")
@@ -286,7 +283,11 @@
;; Figure out way to merge it with the below call.
,@(stream->list
(stream-map
- fmt-single-event
+ (lambda (ev)
+ (fmt-single-event
+ ev `((id ,(html-id ev))
+ (data-calendar ,(base64encode (or (prop (parent ev) 'NAME)
+ "unknown"))))))
(stream-take-while
(compose (cut date/-time<? <> start-date)
(extract 'DTSTART))
@@ -296,32 +297,40 @@
;; This would idealy be a <template> element, but there is some
;; form of special case with those in xhtml, but I can't find
;; the documentation for it.
- ,@(let* ((cal (vcalendar
- name: "Generated"
- children: (list (vevent
- ;; The event template SHOULD lack
- ;; a UID, to stop potential problems
- ;; with conflicts when multiple it's
- ;; cloned mulitple times.
- dtstart: (datetime)
- dtend: (datetime)
- 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
- ;; dosen't matter
- (data-start "2020-01-01")
- (data-end "2020-01-02"))
- ,(caddar ; strip <a> tag
- (make-block event `((class " generated ")))))
- ;; TODO merge this into the event-set, add attribute
- ;; for non-displaying elements.
- (div (@ (class "template") (id "popup-template"))
- ,(popup event (string-append "popup" (html-id event))))))
+ ;; ,@(let* ((cal (vcalendar
+ ;; name: "Generated"
+ ;; children: (list (vevent
+ ;; ;; The event template SHOULD lack
+ ;; ;; a UID, to stop potential problems
+ ;; ;; with conflicts when multiple it's
+ ;; ;; cloned mulitple times.
+ ;; dtstart: (datetime)
+ ;; dtend: (datetime)
+ ;; 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
+ ;; ;; ;; dosen't matter
+ ;; ;; (data-start "2020-01-01")
+ ;; ;; (data-end "2020-01-02"))
+ ;; ;; ,(caddar ; strip <a> tag
+ ;; ;; (make-block event `((class " generated ")))))
+ ;; ;; TODO merge this into the event-set, add attribute
+ ;; ;; for non-displaying elements.
+ ;; ;; (div (@ (class "template") (id "popup-template"))
+ ;; ;; ,(popup event (string-append "popup" (html-id event))))
+ ;; ))
+
+ ;;; Templates used by our custom components
+ ,((@ (calp html vcomponent) edit-template) calendars)
+ ,((@ (calp html vcomponent) description-template))
+ ,((@ (calp html vcomponent) vevent-edit-rrule-template))
+ ,((@ (calp html vcomponent) popup-template))
;; Auto-complets when adding new fields to a component
;; Any string is however still valid.
@@ -344,4 +353,59 @@
RDATE RRULE ACTION REPEAT
TRIGGER CREATED DTSTAMP LAST-MODIFIED
SEQUENCE REQUEST-STATUS
- ))))))
+ )))
+
+ ,@(let* (
+ (flat-events
+ ;; A simple filter-sorted-stream on event-overlaps? here fails.
+ ;; See tests/annoying-events.scm
+ (stream->list
+ (stream-filter
+ (lambda (ev)
+ ((@ (vcomponent datetime) event-overlaps?)
+ ev pre-start
+ (date+ post-end (date day: 1))))
+ (stream-take-while (lambda (ev) (date<
+ (as-date (prop ev 'DTSTART))
+ (date+ post-end (date day: 1))))
+ events))))
+ (repeating% regular (partition repeating? flat-events))
+ (repeating
+ (for ev in repeating%
+ (define instance (copy-vcomponent ev))
+
+ (set! (prop instance 'UID) (output-uid instance))
+ (delete-parameter! (prop* instance 'DTSTART) '-X-HNH-ORIGINAL)
+ (delete-parameter! (prop* instance 'DTEND) '-X-HNH-ORIGINAL)
+
+ instance)))
+
+ `(
+ ;; Mapping showing which events belongs to which calendar,
+ ;; on the form
+ ;; (calendar (@ (key ,(base64-encode calendar-name)))
+ ;; (li ,event-uid) ...)
+ (div (@ (style "display:none !important;")
+ (id "calendar-event-mapping"))
+ ,(let ((ht (make-hash-table)))
+ (for-each (lambda (event)
+ (define name (prop (parent event) 'NAME))
+ (hash-set! ht name
+ (cons (prop event 'UID)
+ (hash-ref ht name '()))))
+ (append regular repeating))
+
+ (hash-map->list
+ (lambda (key values)
+ `(calendar (@ (key ,(base64encode key)))
+ ,@(map (lambda (uid) `(li ,uid))
+ values)))
+ ht)))
+
+ ;; Calendar data for all events in current interval,
+ ;; rendered as xcal.
+ (div (@ (style "display:none !important;")
+ (id "xcal-data"))
+ ,((@ (vcomponent xcal output) ns-wrap)
+ (map (@ (vcomponent xcal output) vcomponent->sxcal)
+ (append regular repeating)))))))))
diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm
index 0ac69292..02689fd5 100644
--- a/module/calp/html/view/calendar/month.scm
+++ b/module/calp/html/view/calendar/month.scm
@@ -11,7 +11,7 @@
:select (really-long-event?
events-between))
:use-module ((calp html vcomponent)
- :select (make-block))
+ :select (make-block output-uid))
:use-module ((vcomponent group)
:select (group-stream get-groups-between))
)
@@ -35,7 +35,7 @@
(events-between s e (list->stream long-events)))))
(date-range pre-start post-end (date day: 7))))
- `((script "const VIEW='month';")
+ `((script "window.VIEW='month';")
(header (@ (class "table-head"))
,(string-titlecase (date->string start-date "~B ~Y")))
(div (@ (class "caltable")
@@ -77,11 +77,26 @@
(repeating-naturals 1 7)
)))
- ;; These popups are relative the document root. Can thus be placed anywhere in the DOM.
+ ;; These popups are relative the document root.
+ ;; Can thus be placed anywhere in the DOM.
,@(for event in (stream->list
- (events-between start-date end-date events))
- ((@ (calp html vcomponent) popup) event
- (string-append "popup" ((@ (calp html util) html-id) event))))
+ (events-between pre-start post-end events))
+ `(popup-element
+ (@ (class "vevent")
+ (data-uid ,(output-uid event)))))
+
+ (template
+ (@ (id "vevent-block"))
+ ;; TODO this is more or less copied verbatim from week's
+ ;; version, warts and all. Figure out what should and shouldn't
+ ;; be shared between the two.
+ (div (@ (data-calendar "unknown"))
+ (div (@ (class "event-body"))
+ (span (@ (class "repeating")))
+ (span (@ (class "summary")
+ (data-property "summary")))
+ (span (@ (class "location")
+ (data-property "location"))))))
))
diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm
index 556c3d85..499de1d6 100644
--- a/module/calp/html/view/calendar/week.scm
+++ b/module/calp/html/view/calendar/week.scm
@@ -2,6 +2,7 @@
:use-module (calp util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
+ :use-module (rnrs records syntactic)
:use-module (datetime)
:use-module (calp html view calendar shared)
:use-module (calp html config)
@@ -13,16 +14,18 @@
event-zero-length?
events-between))
:use-module ((calp html vcomponent)
- :select (make-block) )
+ :select (make-block output-uid) )
+ ;; :use-module ((calp html components)
+ ;; :select ())
:use-module ((vcomponent group)
:select (group-stream get-groups-between))
)
-(define*-public (render-calendar key: events start-date end-date #:allow-other-keys)
+(define*-public (render-calendar key: calendars events start-date end-date #:allow-other-keys)
(let* ((long-events short-events (partition long-event? (stream->list (events-between start-date end-date events))))
(range (date-range start-date end-date)))
- `((script "const VIEW='week';")
+ `((script "window.VIEW='week';")
(div (@ (class "calendar"))
(div (@ (class "days"))
;; Top left area
@@ -52,10 +55,54 @@
,@(for event in (stream->list
(events-between start-date end-date events))
- ((@ (calp html vcomponent ) popup) event (string-append "popup" (html-id event))))
-
- )))))
-
+ `(popup-element
+ (@ (class "vevent")
+ (data-uid ,(output-uid event)))))))
+
+
+ ;; This template is here, instead of in (calp html calendar) since it only
+ ;; applies to this specific view. (calp html calendar month) is assumed to
+ ;; have its own variant of it.
+ (template (@ (id "vevent-block"))
+ ,(block-template)
+ )
+
+
+)))
+
+
+;; "physical" block
+(define (block-template)
+ `(div (@ ; (id ,(html-id ev))
+ (data-calendar "unknown")
+ #;
+ (class " CAL_unknown"
+ ;; ,(when (and (prop ev 'PARTSTAT)
+ ;; (eq? 'TENTATIVE (prop ev 'PARTSTAT)))
+ ;; " tentative")
+ ;; ,(when (and (prop ev 'TRANSP)
+ ;; (eq? 'TRANSPARENT (prop ev 'TRANSP)))
+ ;; " transparent")
+ )
+ ; (onclick "toggle_popup('popup' + this.id)")
+ )
+ ;; Inner div to prevent overflow. Previously "overflow: none"
+ ;; was set on the surounding div, but the popup /needs/ to
+ ;; overflow (for the tabs?).
+ (div (@ (class "event-body"))
+ (span (@ (class "repeating")) ; "↺"
+ )
+ (span (@ (class "summary")
+ (data-property "summary"))
+ ; ,(format-summary ev (prop ev 'SUMMARY))
+ )
+ (span (@ (class "location")
+ (data-property "location")))
+ ;; Document symbol when we have text
+ (span (@ (class "description"))
+ ; "🗎"
+ ))
+ ) )
(define (time-marker-div)
diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm
index b024ed4f..08e48714 100644
--- a/module/calp/server/routes.scm
+++ b/module/calp/server/routes.scm
@@ -20,7 +20,7 @@
:use-module ((rnrs io ports) :select (get-bytevector-all))
:use-module ((xdg basedir) :prefix xdg-)
- :use-module ((calp html util) :select (html-unattr))
+ :use-module ((base64) :select (base64decode))
:use-module (web http make-routes)
@@ -58,7 +58,12 @@
[else "🙃"]))
(td (a (@ (href "/" ,dir "/" ,k)) ,k))
(td ,(number->string (stat:perms stat) 8)))))
- (cdr (scandir dir))))))
+ (cdr (or (scandir dir)
+ (scm-error
+ 'misc-error
+ "directory-table"
+ "Scandir argument invalid or not directory: ~a"
+ (list dir) '())))))))
@@ -162,8 +167,7 @@
(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 (calp html util).
+ ;; @var{cal} should be the name of the calendar encoded in base64.
(POST "/insert" (cal data)
(unless (and cal data)
@@ -174,7 +178,7 @@
;; 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))
+ (let* ((calendar-name (base64decode cal))
(calendar
(find (lambda (c) (string=? calendar-name (prop c 'NAME)))
(get-calendars global-event-object))))
diff --git a/module/calp/util.scm b/module/calp/util.scm
index 06767658..96ca2f01 100644
--- a/module/calp/util.scm
+++ b/module/calp/util.scm
@@ -9,7 +9,6 @@
set/r!
catch-multiple
quote?
- re-export-modules
-> ->> set set-> aif awhen
let-lazy let-env
case* define-many
@@ -298,19 +297,10 @@
(define-public (as-symb s)
(if (string? s) (string->symbol s) s))
-
-
(define-public (enumerate lst)
(zip (iota (length lst))
lst))
-;; Map with index
-(define-syntax-rule (map-each proc lst)
- (map (lambda (x i) (proc x i))
- lst (iota (length lst))))
-
-(export map-each)
-
;; Takes a procedure returning multiple values, and returns a function which
;; takes the same arguments as the original procedure, but only returns one of
;; the procedures. Which procedure can be sent as an additional parameter.
@@ -339,14 +329,6 @@
(cons (proc (car dotted-list))
(map/dotted proc (cdr dotted-list))))))
-(define-syntax re-export-modules
- (syntax-rules ()
- ((_ (mod ...) ...)
- (begin
- (module-use! (module-public-interface (current-module))
- (resolve-interface '(mod ...)))
- ...))))
-
;; Merges two association lists, comparing with eq.
;; The cdrs in all pairs in both lists should be lists,
;; If a key is present in both then the contents of b is
@@ -380,7 +362,7 @@
;; 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)
+;; (split-by '(0 1 2 3 4 2 5 6) 2)
;; ⇒ ((0 1) (3 4) (5 6))
(define-public (split-by list item)
(let loop ((done '())
@@ -523,6 +505,21 @@
(call-with-values (lambda () (apply proc args)) list))
lists)))
+(define (ass%-ref-all alist key =)
+ (map cdr (filter (lambda (pair) (= key (car pair)))
+ alist)))
+
+;; Equivalent to assoc-ref (and family), but works on association lists with
+;; non-unique keys, returning all mathing records (instead of just the first).
+;; @begin lisp
+;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a)
+;; ⇒ (1 3)
+;; @end
+(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?))
+(define-public (assq-ref-all alist key) (ass%-ref-all alist key eq?))
+(define-public (assv-ref-all alist key) (ass%-ref-all alist key eqv?))
+
+
(define-public (vector-last v)
@@ -536,6 +533,10 @@
(define-public (->quoted-string any)
(with-output-to-string (lambda () (write any))))
+
+
+
+;; TODO shouldn't this use `file-name-separator-string'?
(define-public (path-append . strings)
(fold (lambda (s done)
(string-append
@@ -554,6 +555,7 @@
+;;; TODO shouldn't this use dynamic-wind? To handle non-local exits?
(define-syntax let-env
(syntax-rules ()
[(_ ((name value) ...)
diff --git a/module/datetime.scm b/module/datetime.scm
index c1fae3ce..50817084 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -73,7 +73,8 @@
(catch 'misc-error
(lambda () (display (date->string r "#~Y-~m-~d") p))
(lambda (err _ fmt args . rest)
- (format p "BAD~s-~s-~s" (year r) (month r) (day r))))))
+ (format p "#<<date> BAD year=~s month=~s day=~s>"
+ (year r) (month r) (day r))))))
;;; TIME
@@ -91,8 +92,8 @@
(lambda (r p)
(catch 'misc-error
(lambda () (display (time->string r "#~H:~M:~S") p))
- (lambda (err _ fmt args rest)
- (format p "BAD~s:~s:~s"
+ (lambda (err _ fmt args rest)
+ (format p "#<<time> hour=~s minute=~s second=~s>"
(hour r) (minute r) (second r))))))
@@ -124,9 +125,14 @@
(set-record-type-printer!
<datetime>
(lambda (r p)
- (if (and (tz r) (not (string=? "UTC" (tz r))))
- (write (datetime->sexp r) p)
- (display (datetime->string r "#~1T~3~Z") p))))
+ (catch 'misc-error
+ (lambda ()
+ (if (and (tz r) (not (string=? "UTC" (tz r))))
+ (write (datetime->sexp r) p)
+ (display (datetime->string r "#~1T~3~Z") p)))
+ (lambda (err _ fmt args . rest)
+ (format p "#<<datetime> BAD date=~s time=~s tz=~s>"
+ (get-date r) (get-time% r) (tz r))))))
diff --git a/module/vcomponent.scm b/module/vcomponent.scm
index a53523c0..226b740f 100644
--- a/module/vcomponent.scm
+++ b/module/vcomponent.scm
@@ -7,8 +7,10 @@
:re-export (make-vcomponent
parse-cal-path parse-calendar))
-(re-export-modules (vcomponent base)
- (vcomponent instance methods))
+(define cm (module-public-interface (current-module)))
+(module-use! cm (resolve-interface '(vcomponent base)))
+(module-use! cm (resolve-interface '(vcomponent instance methods)))
+
(define-config calendar-files '()
description: "Which files to parse. Takes a list of paths or a single string which will be globbed."
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
index 9066b257..ab2121a2 100644
--- a/module/vcomponent/base.scm
+++ b/module/vcomponent/base.scm
@@ -110,6 +110,11 @@
get-prop*
set-prop*!))
+(define-public (delete-property! component key)
+ (hashq-remove! (get-component-properties component)
+ (as-symb key)))
+
+
;; vcomponent x (or str symb) → value
(define (get-prop component key)
(let ((props (get-prop* component key)))
@@ -139,6 +144,12 @@
(hashq-set! (get-vline-parameters vline)
(as-symb parameter-key) val))))
+
+(define-public (delete-parameter! vline parameter-key)
+ (hashq-remove! (get-vline-parameters vline)
+ (as-symb parameter-key)))
+
+
;; Returns the parameters of a property as an assoc list.
;; @code{(map car <>)} leads to available parameters.
(define-public (parameters vline)
diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm
index 3b0f7083..1d262202 100644
--- a/module/vcomponent/recurrence/generate.scm
+++ b/module/vcomponent/recurrence/generate.scm
@@ -364,9 +364,9 @@
#f))
+;; <vevent> -> (stream <vevent>)
(define-public (generate-recurrence-set base-event)
-
(define duration
;; NOTE DTEND is an optional field.
(let ((end (prop base-event 'DTEND)))
diff --git a/module/vcomponent/vdir/parse.scm b/module/vcomponent/vdir/parse.scm
index 7b10af07..6bbd1329 100644
--- a/module/vcomponent/vdir/parse.scm
+++ b/module/vcomponent/vdir/parse.scm
@@ -25,6 +25,7 @@
;; themselves. Therefore, a simple comparison should work,
;; and then the TZOFFSETTO properties can be subtd.
(define-public (parse-vdir path)
+ ;; TODO empty files here cause "#<eof>" to appear in the output XML, which is *really* bad.
(let ((color
(catch 'system-error
(lambda () (call-with-input-file (path-append path "color") read-line))
diff --git a/module/vcomponent/vdir/save-delete.scm b/module/vcomponent/vdir/save-delete.scm
index d17b595e..b3c7f9c5 100644
--- a/module/vcomponent/vdir/save-delete.scm
+++ b/module/vcomponent/vdir/save-delete.scm
@@ -11,7 +11,7 @@
(define-module (vcomponent vdir save-delete)
:use-module (calp util)
- :use-module ((calp util exceptions) :select (assert))
+ :use-module ((calp util exceptions) :select (assert))
:use-module (vcomponent ical output)
:use-module (vcomponent)
:use-module ((calp util io) :select (with-atomic-output-to-file))
diff --git a/module/vcomponent/xcal/output.scm b/module/vcomponent/xcal/output.scm
index 692b3ec2..70288cba 100644
--- a/module/vcomponent/xcal/output.scm
+++ b/module/vcomponent/xcal/output.scm
@@ -121,7 +121,10 @@
,(vline->value-tag vline)))])
(properties component))))
(unless (null? props)
- `(properties ,@props)))
+ `(properties
+ ;; NOTE
+ ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME)))
+ ,@props)))
,(unless (null? (children component))
`(components ,@(map vcomponent->sxcal (children component)))))))
diff --git a/module/vcomponent/xcal/parse.scm b/module/vcomponent/xcal/parse.scm
index 124a91f4..c6a2122f 100644
--- a/module/vcomponent/xcal/parse.scm
+++ b/module/vcomponent/xcal/parse.scm
@@ -49,40 +49,68 @@
((@ (vcomponent duration) parse-duration) duration))])]
[(recur)
- (apply (@ (vcomponent recurrence internal) make-recur-rule)
- (concatenate
- (for (k v) in value
- (list (symbol->keyword k)
- (case k
- ((wkst)
- ((@ (vcomponent recurrence parse)
- rfc->datetime-weekday)
- (string->symbol v)))
- ((freq) (string->symbol v))
- ((until)
- ;; RFC 6321 (xcal), p. 30 specifies type-until as
- ;; type-until = element until {
- ;; type-date |
- ;; type-date-time
- ;; }
- ;; but doesn't bother defining type-date[-time]...
- ;; This is acknowledged in errata 3315 [1], but
- ;; it lacks a solution...
- ;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16)
- ;; show the date as a direct string we will roll
- ;; with that here to.
- ;; [1]: https://www.rfc-editor.org/errata/eid3315
- (string->date/-time v))
- ((byday) #|TODO|#
- (throw 'not-yet-implemented))
- ((count interval bysecond bymunite byhour
- bymonthday byyearday byweekno
- bymonth bysetpos)
- (string->number v))
- (else (throw
- 'key-error
- "Invalid key ~a, with value ~a"
- k v)))))))]
+ ;; RFC6221 (xcal) Appendix A 3.3.10 specifies that all components should
+ ;; come in a specified order, and by extension that all components of the
+ ;; same type should follow each other. Actually checking that is harder
+ ;; than to just accept anything in any order. It would also make us less
+ ;; robust for other implementations with other ideas.
+ (let ((parse-value-of-that-type
+ (lambda (type value)
+ (case type
+ ((wkst)
+ ((@ (vcomponent recurrence parse)
+ rfc->datetime-weekday)
+ (string->symbol value)))
+ ((freq) (string->symbol value))
+ ((until)
+ ;; RFC 6321 (xcal), p. 30 specifies type-until as
+ ;; type-until = element until {
+ ;; type-date |
+ ;; type-date-time
+ ;; }
+ ;; but doesn't bother defining type-date[-time]...
+ ;; This is acknowledged in errata 3315 [1], but
+ ;; it lacks a solution...
+ ;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16)
+ ;; show the date as a direct string we will roll
+ ;; with that here to.
+ ;; [1]: https://www.rfc-editor.org/errata/eid3315
+ (string->date/-time value))
+ ((byday) ((@@ (vcomponent recurrence parse) parse-day-spec) value))
+ ((count interval bysecond bymunite byhour
+ bymonthday byyearday byweekno
+ bymonth bysetpos)
+ (string->number value))
+ (else (throw
+ 'key-error
+ "Invalid type ~a, with value ~a"
+ type value))))))
+
+ ;; freq until count interval wkst
+
+ (apply (@ (vcomponent recurrence internal) make-recur-rule)
+ (concatenate
+ (filter identity
+ (for key in '(bysecond byminute byhour byday bymonthday
+ byyearday byweekno bymonth bysetpos
+ freq until count interval wkst)
+ (define values (assoc-ref-all value key))
+ (if (null? values)
+ #f
+ (case key
+ ;; These fields all have zero or one value
+ ((freq until count interval wkst)
+ (list (symbol->keyword key)
+ (parse-value-of-that-type
+ key (car (map car values)))))
+ ;; these fields take lists
+ ((bysecond byminute byhour byday bymonthday
+ byyearday byweekno bymonth bysetpos)
+ (list (symbol->keyword key)
+ (map (lambda (v) (parse-value-of-that-type key v))
+ (map car values)))
+ )
+ (else (throw 'error)))))))))]
[(time) (parse-iso-time (car value))]
@@ -171,11 +199,25 @@
;; 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)))))]
+ (let ()
+ (define vline
+ (make-vline tag*
+ (handle-tag
+ tag (handle-value type params value))
+ params))
+ (if (memv tag* '(ATTACH ATTENDEE CATEGORIES
+ COMMENT CONTACT EXDATE
+ REQUEST-STATUS RELATED-TO
+ RESOURCES RDATE
+ ;; x-prop
+ ;; iana-prop
+ ))
+ (aif (prop* component tag*)
+ (set! (prop* component tag*) (cons vline it))
+ (set! (prop* component tag*) (list vline)))
+ ;; else
+ (set! (prop* component tag*) vline))
+ ))))]
[(tag (type value ...) ...)
(for (type value) in (zip type value)
@@ -184,7 +226,7 @@
(unless (null? value)
(let ((params (make-hash-table))
(tag* (symbol-upcase tag)))
- (set! (prop* component tag*)
+ (define vline
(make-vline tag*
(handle-tag
tag (let ((v (handle-value type params value)))
@@ -192,7 +234,22 @@
(if (eq? tag 'categories)
(string-split v #\,)
v)))
- params)))))])))
+ params))
+ ;;
+
+ (if (memv tag* '(ATTACH ATTENDEE CATEGORIES
+ COMMENT CONTACT EXDATE
+ REQUEST-STATUS RELATED-TO
+ RESOURCES RDATE
+ ;; x-prop
+ ;; iana-prop
+ ))
+ (aif (prop* component tag*)
+ (set! (prop* component tag*) (cons vline it))
+ (set! (prop* component tag*) (list vline)))
+ ;; else
+ (set! (prop* component tag*) vline))
+ )))])))
;; children
(awhen (assoc-ref sxcal 'components)
diff --git a/module/vulgar/termios.scm b/module/vulgar/termios.scm
index 75181ff3..f88882c9 100644
--- a/module/vulgar/termios.scm
+++ b/module/vulgar/termios.scm
@@ -102,7 +102,7 @@
;; Macro for creating accessor bindings for slots in a list, which are wrapped
;; inside a <termios> record. Called exactly once below.
(define-macro (create-bindings! . symbols)
- `(begin ,@(map-each
+ `(begin ,@(map
(lambda (symb i)
`(define-public ,symb
(make-procedure-with-setter
@@ -110,7 +110,8 @@
(lambda (t v) (let ((lst (as-list t)))
(list-set! lst ,i v)
(set-list! t lst))))))
- symbols)))
+ symbols
+ (iota (length symbols)))))
(create-bindings! ; accessors
iflag oflag cflag lflag line cc ispeed ospeed)
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 01:48:53 +0200