aboutsummaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/entry-points/server.scm3
-rw-r--r--module/html/vcomponent.scm88
-rw-r--r--module/html/view/calendar.scm18
-rw-r--r--module/vcomponent/parse/xcal.scm31
4 files changed, 86 insertions, 54 deletions
diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm
index 466860cd..dc675813 100644
--- a/module/entry-points/server.scm
+++ b/module/entry-points/server.scm
@@ -163,6 +163,9 @@
(format #f "No event with UID '~a'" uid))))
;; TODO this fails when dtstart is <date>.
+ ;; TODO If data has an explicit UID and that UID already exists we
+ ;; overwrite it in the database. We however don't remove the old
+ ;; event from the in-memory set, but rather just adds the new.
(POST "/insert" (cal data)
(unless (and cal data)
diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm
index 9189b59e..fdaea217 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 '()))
@@ -165,28 +169,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 2371cfe0..72fcccbd 100644
--- a/module/html/view/calendar.scm
+++ b/module/html/view/calendar.scm
@@ -284,10 +284,18 @@
(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 -")
+ ,@(map (lambda (calendar)
+ `(option (@ (value ,(html-attr (prop calendar 'NAME))))
+ ,(prop calendar 'NAME)))
+ calendars))
+ )))
;; List of events
(div (@ (class "eventlist")
@@ -317,7 +325,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/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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 05:27:41 +0200