aboutsummaryrefslogtreecommitdiff
path: root/module/calp/html/view/calendar
diff options
context:
space:
mode:
Diffstat (limited to '')
-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
3 files changed, 214 insertions, 88 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-04 09:43:39 +0200