(define-module (calp html view calendar)
:use-module (hnh util)
:use-module (vcomponent)
:use-module ((vcomponent datetime)
:select (events-between))
:use-module (datetime)
:use-module (calp html components)
:use-module ((calp html vcomponent)
:select (calendar-styles
fmt-day
make-block
fmt-single-event
output-uid
))
:use-module (calp html config)
:use-module (calp html util)
:use-module ((calp html caltable) :select (cal-table))
:use-module (calp 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 recurrence) :select (repeating? generate-recurrence-set))
:use-module ((vcomponent util group)
:select (group-stream get-groups-between))
:use-module ((base64) :select (base64encode))
:use-module (ice-9 format)
)
;;; Main-stuff
;;; NOTE
;;; The side bar filters all earlier events for each day to not create repeats,
;;; and the html-generate procedure also filters, but instead to find earlier eventns.
;;; All this filtering is probably slow, and should be looked into.
;; TODO place this somewhere proper
(define repo-url (make-parameter "https://git.hornquist.se/calp"))
;; TODO document what @var{render-calendar} is supposed to take and return.
;; Can at least note that @var{render-calendar} is strongly encouraged to include
;; (script "const VIEW='??';"), where ?? is replaced by the name of the view.
(define*-public (html-generate
key:
(intervaltype 'all) ; 'week | 'month | 'all
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
;; The pre and post dates are if we want to show some dates just
;; outside our actuall interval. Primarily for whole month views,
;; which needs a bit on each side.
(pre-start start-date)
(post-end end-date))
;; NOTE maybe don't do this again for every month
(define evs (get-groups-between (group-stream events)
start-date end-date))
(define (nav-link display date)
`(a (@ (href ,(date->string date "~Y-~m-~d") ".html")
(class "nav hidelink"))
(div (@ (class "nav"))
,display)))
(unless next-start
(error 'html-generate "Next-start needs to be a procedure"))
(unless prev-start
(error 'html-generate "Prev-start needs to be a procedure"))
(xhtml-doc
(@ (lang sv))
(head
(title "Calendar")
(meta (@ (charset "utf-8")))
;; (meta (@ (http-equiv "Content-Type") (content "application/xhtml+xml")))
(meta (@ (name viewport)
(content "width=device-width, initial-scale=0.5")))
(meta (@ (name description)
(content "Calendar for the dates between "
,(date->string start-date) " and "
,(date->string end-date))))
;; NOTE this is only for the time actually part of this calendar.
;; overflowing times from pre-start and post-end is currently ignored here.
(meta (@ (name start-time)
(content ,(date->string start-date "~s"))))
(meta (@ (name end-time)
(content ,(date->string (date+ end-date (date day: 1)) "~s"))))
(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;
--event-font-size: 8pt;
}"))
,(include-css "/static/style.css")
,(include-alt-css "/static/dark.css" '(title "Dark"))
,(include-alt-css "/static/light.css" '(title "Light"))
(script (@ (src "/static/script.out.js")))
(script (@ (src "/static/user/user-additions.js")))
,(calendar-styles calendars)
,@(when (debug)
'((style ".root { background-color: pink; }"))))
(body
(div (@ (class "root"))
(main
;; Actuall calendar
(@ (style "grid-area: main"))
,@(render-calendar calendars: calendars
events: events
start-date: start-date
end-date: end-date
pre-start: pre-start
post-end: post-end
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
;; component, if one such component exists.
)
;; Page footer
(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")))
;; Small calendar and navigation
(nav (@ (class "calnav") (style "grid-area: nav"))
(div (@ (class "change-view"))
,(btn href: (date->string
(if (= 1 (day start-date))
(start-of-week start-date)
start-date)
"/week/~1.html")
"veckovy")
,(btn href: (date->string (set (day start-date) 1) "/month/~1.html")
"månadsvy")
(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
;; component, meaning that it's broken. This label
;; is for the whole input, which can be enabled
;; if wanted.
;; (label (@ (for "date")) "Hoppa till")
(form (@ (action "/today"))
(input (@ (type hidden)
(name "view")
(value ,(case intervaltype
[(month week) => symbol->string]
[else "month"]))))
(input (@ (type date)
(name "date")
(value ,(date->string start-date "~1"))))
,(btn "➔"))))
(details (@ (open) (style "grid-area: cal"))
(summary "Month overview")
(div (@ (class "smallcall-head"))
,(string-titlecase (date->string start-date "~B ~Y")))
;; NOTE it might be a good idea to put the navigation buttons
;; earlier in the DOM-tree/tag order. At least Vimium's
;; @key{[[} keybind sometimes finds parts of events instead.
(div (@ (class "smallcal"))
;; prev button
,(nav-link "«" (prev-start start-date))
;; calendar table
(div ,(cal-table start-date: start-date end-date: end-date
next-start: next-start
prev-start: prev-start
))
;; next button
,(nav-link "»" (next-start start-date))))
(div (@ (style "grid-area: details"))
;; TODO Style this from as all other input forms in the sidebar.
(form (@ (class "simplesearch")
(action "/search/text"))
(input (@ (type "text")
(name "q")
(placeholder "Sök")))
(input (@ (type "submit")
(value ">"))))
,(when (or (debug) (edit-mode))
`(details (@ (class "sliders"))
(summary "Option sliders")
,@(when (edit-mode)
`((label "Event blankspace")
,(slider-input
variable: "editmode"
min: 0
max: 1
step: 0.01
value: 1)))
,@(when (debug)
`((label "Fontsize")
,(slider-input
unit: "pt"
min: 1
max: 20
step: 1
value: 8
variable: "event-font-size")))))
;; List of calendars
(details (@ (class "calendarlist"))
(summary "Calendar list")
(ul ,@(map
(lambda (calendar)
`(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) ""))))))))
,(prop calendar 'NAME))))
calendars))
;; (div (@ (id "calendar-dropdown-template") (class "template"))
;; )
))
;; List of events
(div (@ (class "eventlist")
(style "grid-area: events"))
;; Events which started before our start point,
;; 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
(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))
(cdr (stream-car evs))))))
,@(stream->list (stream-map fmt-day evs))))
;; This would idealy be a 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 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.
(datalist (@ (id "known-fields"))
,@(map (lambda (f)
`(option (@ (value ,f))))
'(CALSCALE
METHOD PRODID VERSION ATTACH
CATEGORIES CLASS COMMENT
DESCRIPTION GEO LOCATION
PERCENT-COMPLETE PRIORITY
RESOURCES STATUS SUMMARY
COMPLETED DTEND DUE DTSTART
DURATION FREEBUSY
TRANSP TZID TZNAME
TZOFFSETFROM TZOFFSETTO
TZURL ATTENDEE CONTACT
ORGANIZER RECURRENCE-ID
RELATED-TO URL EXDATE
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 formats xcal output) ns-wrap)
(map (@ (vcomponent formats xcal output) vcomponent->sxcal)
(append regular repeating)))))))))