aboutsummaryrefslogtreecommitdiff
path: root/module/calp/html/vcomponent.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/calp/html/vcomponent.scm')
-rw-r--r--module/calp/html/vcomponent.scm229
1 files changed, 229 insertions, 0 deletions
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm
new file mode 100644
index 00000000..be6b6166
--- /dev/null
+++ b/module/calp/html/vcomponent.scm
@@ -0,0 +1,229 @@
+(define-module (calp html vcomponent)
+ :use-module (util)
+ :use-module (vcomponent)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-41)
+ :use-module (datetime)
+ :use-module (calp html util)
+ :use-module ((calp html config) :select (edit-mode))
+ :use-module ((calp html components) :select (btn tabset))
+ :use-module ((util color) :select (calculate-fg-color))
+ :use-module ((vcomponent datetime output)
+ :select (fmt-time-span
+ format-description
+ format-summary
+ format-recurrence-rule
+ ))
+ )
+
+(define-public (compact-event-list list)
+
+ (define calendars
+ (delete-duplicates!
+ (filter (lambda (x) (eq? 'VCALENDAR (type x)))
+ (map parent list))
+ eq?))
+
+ (define (summary event)
+ `(summary (div (@ (class "summary-line "))
+ (span (@ (class "square CAL_"
+ ,(html-attr
+ (or (prop (parent event)
+ 'NAME)
+ "unknown")))))
+ (time ,(let ((dt (prop event 'DTSTART)))
+ (if (datetime? dt)
+ (datetime->string dt "~Y-~m-~d ~H:~M")
+ (date->string dt "~Y-~m-~d" ))))
+ (span ,(prop event 'SUMMARY)))))
+ (cons
+ (calendar-styles calendars)
+ (for event in list
+ `(details
+ ,(summary event)
+ ;; TODO better format, add show in calendar button
+ ,(fmt-single-event event)))))
+
+;; 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))
+ `(div (@ ,@(assq-merge
+ attributes
+ `((class " eventtext "
+ ,(when (and (prop ev 'PARTSTAT)
+ (eq? 'TENTATIVE (prop ev 'PARTSTAT)))
+ " tentative ")))))
+ (h3 ,(fmt-header
+ (when (prop ev 'RRULE)
+ `(span (@ (class "repeating")) "↺"))
+ `(span (@ (class "summary")) ,(prop ev 'SUMMARY))))
+ (div
+ ,(call-with-values (lambda () (fmt-time-span ev))
+ (case-lambda [(start)
+ `(div (time (@ (class "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-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-fmt ,(string-append "~L" end))
+ (datetime ,(datetime->string
+ (as-datetime (prop ev 'DTSTART))
+ "~1T~3")))
+ ,(datetime->string (as-datetime (prop ev 'DTEND))
+ end)))]))
+ ,(when (and=> (prop ev 'LOCATION) (negate string-null?))
+ `(div (b "Plats: ")
+ (div (@ (class "location"))
+ ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
+ (prop ev 'LOCATION)))))
+ ,(awhen (prop ev 'DESCRIPTION)
+ `(span (@ (class "description"))
+ ,(format-description ev it)))
+ ,(awhen (prop ev 'RRULE)
+ `(span (@ (class "rrule"))
+ ,@(format-recurrence-rule ev)))
+ ,(when (prop ev 'LAST-MODIFIED)
+ `(span (@ (class "last-modified")) "Senast ändrad "
+ ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M")))
+
+ )))
+
+
+;; Single event in side bar (text objects)
+(define-public (fmt-day day)
+ (let* (((date . events) day))
+ `(section (@ (class "text-day"))
+ (header (h2 ,(let ((s (date->string date "~Y-~m-~d")))
+ `(a (@ (href "#" ,s)
+ (class "hidelink")) ,s))))
+ ,@(stream->list
+ (stream-map
+ (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 "#" ,(html-id ev) #; (date-link (as-date (prop ev 'DTSTART)))
+ )
+ (class "hidelink"))
+ ,@body))))
+ (stream-filter
+ (lambda (ev)
+ ;; If start was an earlier day
+ ;; This removes all descriptions from
+ ;; events for previous days,
+ ;; solving duplicates.
+ (date/-time<=? date (prop ev 'DTSTART)))
+ events))))))
+
+
+(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))))
+
+;; "Physical" block in calendar view
+(define*-public (make-block ev optional: (extra-attributes '()))
+
+ `((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")))
+ (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 "summary"))
+ ,(format-summary ev (prop ev 'SUMMARY)))
+ ,(when (prop ev 'LOCATION)
+ `(span (@ (class "location"))
+ ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
+ (prop ev 'LOCATION)))))
+ (div (@ (style "display:none !important;"))
+ ,((@ (vcomponent xcal output) ns-wrap)
+ ((@ (vcomponent xcal output) vcomponent->sxcal)
+ ev)))))))
+
+
+(define (repeat-info event)
+ `(div (@ (class "eventtext"))
+ (h2 "Upprepningar")
+ (pre ,(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(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 (@ (class "eventtext") (style "font-family:sans"))
+ (h2 "Ladda ner")
+ (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics"))
+ "som iCal"))
+ (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs"))
+ "som xCal")))))
+ ,@(when (prop ev 'RRULE)
+ `(("↺" title: "Upprepningar" class: "repeating"
+ ,(repeat-info ev)))))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-02 04:37:59 +0200