aboutsummaryrefslogtreecommitdiff
path: root/module/calp/html
diff options
context:
space:
mode:
Diffstat (limited to 'module/calp/html')
-rw-r--r--module/calp/html/caltable.scm89
-rw-r--r--module/calp/html/components.scm127
-rw-r--r--module/calp/html/config.scm18
-rw-r--r--module/calp/html/util.scm46
-rw-r--r--module/calp/html/vcomponent.scm229
-rw-r--r--module/calp/html/view/calendar.scm289
-rw-r--r--module/calp/html/view/calendar/month.scm117
-rw-r--r--module/calp/html/view/calendar/shared.scm96
-rw-r--r--module/calp/html/view/calendar/week.scm121
-rw-r--r--module/calp/html/view/search.scm38
-rw-r--r--module/calp/html/view/small-calendar.scm19
11 files changed, 1189 insertions, 0 deletions
diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm
new file mode 100644
index 00000000..65a70252
--- /dev/null
+++ b/module/calp/html/caltable.scm
@@ -0,0 +1,89 @@
+(define-module (calp html caltable)
+ :use-module (util)
+ :use-module (calp html util)
+ :use-module (datetime)
+ :use-module (srfi srfi-41)
+ )
+
+;; Small calendar similar to the one below.
+;; TODO highlight days depending on which events they contain
+;; TODO run this standalone, for embedding in other websites.
+;; @example
+;; må ti on to fr lö sö
+;; 1 2 3 4 5 6 7
+;; 8 9 10 11 12 13 14
+;; 15 16 17 18 19 20 21
+;; 22 23 24 25 26 27 28
+;; 29 30
+;; @end example
+;;
+;; start-date : <date>
+;; end-date : <date>
+;; next-start : <date> → <date>
+;; prev-start : <date> → <date>
+(define*-public (cal-table key: start-date end-date next-start prev-start)
+
+ (define (->link date)
+ (date->string date "~Y-~m-~d.html"))
+
+ ;; (<date> → sxml-attributes) → <date> → sxml
+ (define (td attr)
+ (lambda (date)
+ `(a (@ ,@(attr date))
+ ;; NOTE This time object is the correct place to show the existance
+ ;; of an event on a given day in this small calendar. For example
+ ;; making the text red for all holidays, or creating a yellow background
+ ;; for events from a specific source.
+ (time (@ (datetime ,(date->string date "~Y-~m-~d")))
+ ,(day date)))))
+
+ (define month-start (start-of-month start-date))
+ (define pre-start (start-of-week month-start))
+ (define month-end (end-of-month start-date))
+ (define post-end (end-of-week month-end))
+
+ `(div (@ (class "small-calendar"))
+
+ ;; Cell 0, 0. The letter v. for week number
+ (div (@ (class "column-head row-head")) "v.")
+
+ ;; top row, names of week days
+ ,@(map (lambda (d) `(div (@ (class "column-head"))
+ ,(string-titlecase (week-day-name d 2))))
+ (weekday-list))
+
+ ;; left columun, week numbers
+ ,@(map (lambda (v) `(div (@ (class "row-head")) ,v))
+ (map week-number
+ (stream->list
+ (stream-take-while (lambda (s) (date<= s post-end))
+ (week-stream pre-start)))))
+
+ ;; actual days
+
+ ,@(map (td (lambda (date)
+ `((class "prev")
+ (href ,(->link
+ ;; (prev-start date)
+ (iterate
+ prev-start
+ (lambda (d) (date<= d date (next-start d)))
+ start-date))
+ "#" ,(date-link date)))))
+ (date-range pre-start (remove-day start-date)))
+
+
+ ,@(map (td (lambda (date) `((href "#" ,(date-link date)))))
+ (date-range start-date end-date))
+
+
+ ,@(map (td (lambda (date)
+ `((class "next")
+ (href ,(->link
+ ;; (next-start date)
+ (iterate
+ next-start
+ (lambda (d) (and (date<= d date)
+ (date< date (next-start d))))
+ start-date)) "#" ,(date-link date)))))
+ (date-range (add-day end-date) post-end))))
diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm
new file mode 100644
index 00000000..49f00e52
--- /dev/null
+++ b/module/calp/html/components.scm
@@ -0,0 +1,127 @@
+(define-module (calp html components)
+ :use-module (util)
+ :use-module (util exceptions)
+ :export (xhtml-doc)
+ )
+
+;; Wraps a number of sxml forms into a valid sxhtml-tree.
+(define-syntax xhtml-doc
+ (syntax-rules (@)
+ ((_ (@ attr ...) body ...)
+ `(*TOP*
+ (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+ (html (@ (xmlns "http://www.w3.org/1999/xhtml") attr ...)
+ body ...)))
+ ((_ body ...)
+ (xhtml-doc (@) body ...))))
+
+
+;; Add a slider with an associated number input. Keeps the two in check.
+;; Uses the js function setVar (which must be provided elsewhere)
+;; set the the value of @var{variable}.
+(define*-public (slider-input key: variable
+ (min 0)
+ (max 10)
+ (step 1)
+ (value 1)
+ (unit ""))
+ (let ((groupname (symbol->string (gensym "slider"))))
+ `(div (@ (class "input-group"))
+ (script
+ "function " ,groupname "fn (value) {"
+ "setVar('" ,variable "', value + '" ,unit "');"
+ "for (let el of document.getElementsByClassName('" ,groupname "')) {"
+ " el.value = value;"
+ "}}")
+ (input (@ (type "range")
+ (class ,groupname)
+ (min ,min)
+ (max ,max)
+ (step ,step)
+ (value ,value)
+ (oninput ,groupname "fn(this.value)")
+ ))
+ (input (@ (type "number")
+ (class ,groupname)
+ (min ,min)
+ (max ,max)
+ (step ,step)
+ (value ,value)
+ (oninput ,groupname "fn(this.value)"))
+ ))))
+
+;; Generates a button or button-like link.
+;; TODO <div/> inside <button/> isn't valid.
+(define*-public (btn key: onclick href (class '())
+ allow-other-keys:
+ rest: args)
+ (when (and onclick href)
+ (error "Only give one of onclick, href and submit."))
+
+ (let ((body #f))
+ `(,(cond [href 'a]
+ [else 'button])
+ (@ (class ,(string-join (cons "btn" class) " "))
+ ,@(cond [onclick `((onclick ,onclick))]
+ [href `((href ,href))]
+ [else '()])
+ ,@(let loop ((rem args))
+ (cond
+ [(null? rem) '()]
+ [(memv (car rem) '(onclick: href: class:))
+ (loop (cddr rem))]
+ [(keyword? (car rem))
+ (cons* `(,(keyword->symbol (car rem))
+ ,(cadr rem))
+ (loop (cddr rem)))]
+ [else
+ (set! body (car rem))
+ (loop (cdr rem))])))
+ (div ,body))))
+
+
+;; Creates a group of tabs from a given specification. The specification
+;; @var{elements} should be a list, where each element is a sublist on
+;; the form
+;; @example
+;; ("tab icon" arguments ... tab-body)
+;; @end example
+;; where arguments are zero or more pairs of keyword arguments. For example:
+;; @example
+;; ("📅" title: "Översikt" ,(fmt-single-event ev))
+;; @end example
+;; Creates a tab with an calendar emoji as icon, "Översikt" is sent as the
+;; extra argument #:title, and the body is the return from fmt-single-event.
+(define-public (tabset elements)
+ (define tabgroup (symbol->string (gensym "tabgroup")))
+
+ `(div (@ (class "tabgroup"))
+ ,@(for (i (key args ... body)) in (enumerate elements)
+ (define id (symbol->string (gensym "tab")))
+ `(div (@ (class "tab"))
+ (input (@ (type "radio") (id ,id) (name ,tabgroup)
+ ,@(when (zero? i) '((checked)))))
+ ;; It would be preferable to place the labels in a separate
+ ;; div and set that to have fixed position, since we could
+ ;; then just flow them. That hovever doesn't work since we
+ ;; need a css-selector for the label to the selected radio
+ ;; option.
+ (label (@ ,@(assq-merge `((for ,id)
+ (style "top: calc(var(--tab-size) * " ,i ")"))
+ (kvlist->assq args)))
+ ,key)
+ (div (@ (class "content")) ,body)))))
+
+
+(define-public (include-css path . extra-attributes)
+ `(link (@ (type "text/css")
+ (rel "stylesheet")
+ (href ,path)
+ ,@extra-attributes)))
+
+
+(define-public (include-alt-css path . extra-attributes)
+ `(link (@ (type "text/css")
+ (rel "alternate stylesheet")
+ (href ,path)
+ ,@extra-attributes)))
diff --git a/module/calp/html/config.scm b/module/calp/html/config.scm
new file mode 100644
index 00000000..6f156c98
--- /dev/null
+++ b/module/calp/html/config.scm
@@ -0,0 +1,18 @@
+(define-module (calp html config)
+ :use-module (util)
+ :use-module (util config)
+ )
+
+(define-public debug (make-parameter #f))
+(define-config debug #f
+ description: "Places the generated thingy in debug mode"
+ post: debug)
+
+
+;;; NOTE edit mode should preferably depend on login-status of the user
+;;; but this works for the time being.
+(define-public edit-mode (make-parameter #t))
+(define-config edit-mode #t
+ description: "Makes the document editable"
+ post: edit-mode)
+
diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm
new file mode 100644
index 00000000..8410472c
--- /dev/null
+++ b/module/calp/html/util.scm
@@ -0,0 +1,46 @@
+(define-module (calp html util)
+ :use-module ((base64) :select (base64encode base64decode))
+ :use-module (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
+ (let ((id (make-object-property)))
+ (lambda (ev)
+ (or (id ev)
+ (set/r! (id ev) (symbol->string (gensym "__html_id_")))))))
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)))))))))
diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
new file mode 100644
index 00000000..67a1a7b5
--- /dev/null
+++ b/module/calp/html/view/calendar.scm
@@ -0,0 +1,289 @@
+(define-module (calp html view calendar)
+ :use-module (util)
+ :use-module (vcomponent)
+ :use-module ((vcomponent datetime)
+ :select (events-between))
+ :use-module ((vcomponent build)
+ :select (vcalendar vevent))
+ :use-module (datetime)
+ :use-module (calp html components)
+ :use-module ((calp html vcomponent)
+ :select (popup
+ calendar-styles
+ fmt-day
+ make-block
+ fmt-single-event
+ ))
+ :use-module (calp html config)
+ :use-module (calp html util)
+ :use-module ((calp html caltable) :select (cal-table))
+
+ :use-module (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 group)
+ :select (group-stream get-groups-between))
+ )
+
+
+;;; 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"))
+
+
+;; 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 events start-date end-date
+ 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 "EDIT_MODE=" ,(if (edit-mode) "true" "false") ";")
+
+ (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 (@ (defer) (src "/static/script.js")))
+ ,(calendar-styles calendars))
+
+ (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
+ )
+ ;; 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 (a (@ (href ,(repo-url) "/calparse"))
+ "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")
+
+ ,(btn id: "today-button"
+ 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"))
+ ,(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 (@ (class "CAL_"
+ ,(html-attr (prop calendar '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)))
+ )))
+
+ ;; 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
+ fmt-single-event
+ (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 <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)))))))))
diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm
new file mode 100644
index 00000000..ce8957da
--- /dev/null
+++ b/module/calp/html/view/calendar/month.scm
@@ -0,0 +1,117 @@
+(define-module (calp html view calendar month)
+ :use-module (util)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-41)
+ :use-module (srfi srfi-41 util)
+ :use-module (datetime)
+ :use-module (calp html view calendar shared)
+ :use-module (calp html config)
+ :use-module (vcomponent)
+ :use-module ((vcomponent datetime)
+ :select (really-long-event?
+ events-between))
+ :use-module ((calp html vcomponent)
+ :select (make-block))
+ :use-module ((vcomponent group)
+ :select (group-stream get-groups-between))
+ )
+
+;; (stream event-group) -> sxml
+(define*-public (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys)
+
+ (define-values (long-events short-events)
+ ;; TODO should be really-long-event? or event-spanning-midnight
+ (partition really-long-event? (stream->list (events-between pre-start post-end events))))
+
+ (define short-event-groups
+ (get-groups-between (group-stream (list->stream short-events))
+ pre-start post-end))
+
+ (define long-event-groups
+ (map (lambda (s)
+ (define e (date+ s (date day: 6)))
+ (cons* s e
+ (stream->list
+ (events-between s e (list->stream long-events)))))
+ (date-range pre-start post-end (date day: 7))))
+
+ `((script "const VIEW='month';")
+ (header (@ (class "table-head"))
+ ,(string-titlecase (date->string start-date "~B ~Y")))
+ (div (@ (class "caltable")
+ (style "grid-template-rows: 2em"
+ ,(string-concatenate
+ (map (lambda (long-group)
+ (format #f " [time] 15pt [long] ~amm [short] 1fr"
+ (min 10 (* 4 (length (cddr long-group))))))
+ long-event-groups))))
+ ,@(map (lambda (d) `(div (@ (class "thead")) ,(string-titlecase (week-day-name d))))
+ (weekday-list))
+ ,@(map (lambda (group i)
+ (let* (((s e . events) group))
+ `(div (@ (class "cal-cell longevents event-container")
+ (style "grid-area: long " ,i ";"
+ "grid-column: 1 / span 7;")
+ (data-start ,(date->string s))
+ (data-end ,(date->string (add-day e))))
+ ,@(lay-out-long-events
+ s e events))))
+ long-event-groups
+ (iota (length long-event-groups) 1))
+
+ ,@(caltable-time-cells start-date end-date
+ pre-start post-end)
+
+ ,@(stream->list
+ (stream-map
+ (lambda (group i)
+ (define day-date (car group))
+ (define events (cdr group))
+ `(div (@ (style "grid-area:short " ,i)
+ (class "cal-cell cal-cell-short event-container")
+ (data-start ,(date->string day-date))
+ (data-end ,(date->string (add-day day-date))))
+ (div (@ (style "overflow-y:auto;"))
+ ,@(map make-small-block (stream->list events)))))
+ short-event-groups
+ (repeating-naturals 1 7)
+ )))
+
+ ;; 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))))
+ ))
+
+
+
+;;; Table output
+
+(define (make-small-block event)
+ (make-block event))
+
+(define (caltable-time-cells start-date end-date
+ pre-start post-end)
+ (map (lambda (day-date i)
+ `(div (@ (style "grid-area:time " ,i)
+ (class "cal-cell cal-cell-time"))
+ (a (@ (class "hidelink")
+ (href "/week/" ,(date->string day-date "~Y-~m-~d")
+ ".html#" ,(date->string day-date "~Y-~m-~d")))
+ (time (@ (class "date-info "
+ ,(if (or (date< day-date start-date)
+ (date< end-date day-date))
+ "non-current"
+ "current"))
+ (datetime ,(date->string day-date "~1")))
+ (span (@ (class "day-number"))
+ ,(date->string day-date "~e"))
+ ,(when (= 1 (day day-date))
+ `(span (@ (class "month-name"))
+ ,(date->string day-date "~b")))
+ ,(when (= 1 (month day-date) (day day-date))
+ `(span (@ (class "year-number"))
+ ", " ,(date->string day-date "~Y")))))))
+ (date-range pre-start post-end)
+ (map floor (iota (length (date-range pre-start post-end)) 1 1/7))))
diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm
new file mode 100644
index 00000000..73698060
--- /dev/null
+++ b/module/calp/html/view/calendar/shared.scm
@@ -0,0 +1,96 @@
+(define-module (calp html view calendar shared)
+ :use-module (util)
+ :use-module (srfi srfi-1)
+ :use-module (vcomponent)
+ :use-module ((vcomponent datetime)
+ :select (event-length
+ overlapping?
+ event-length/clamped))
+ :use-module ((vcomponent datetime output)
+ :select (format-summary))
+ :use-module (util tree)
+ :use-module (datetime)
+ :use-module (calp html config)
+ :use-module ((calp html components)
+ :select (btn tabset))
+ :use-module ((calp html vcomponent)
+ :select (make-block) )
+ )
+
+
+
+(define-public x-pos (make-object-property))
+(define-public width (make-object-property))
+
+
+;; Takes a list of vcomponents, sets their widths and x-positions to optimally
+;; fill out the space, without any overlaps.
+(define*-public (fix-event-widths! lst key: event-length-key (event-length-comperator date/-time>?))
+ ;; The tree construction is greedy. This means
+ ;; that if a smaller event preceeds a longer
+ ;; event it would capture the longer event to
+ ;; only find events which also overlaps the
+ ;; smaller event.
+
+ ;; @var{x} is how for left in the container we are.
+ (let inner ((x 0)
+ (tree (make-tree overlapping?
+ (sort* lst event-length-comperator event-length-key
+ ))))
+ (unless (null? tree)
+ (let ((w (/ (- 1 x)
+ (+ 1 (length-of-longst-branch (left-subtree tree))))))
+ (set! (width (car tree)) w
+ (x-pos (car tree)) x)
+ (inner (+ x w) (left-subtree tree))
+ (inner x (right-subtree tree))))))
+
+
+(define-public (lay-out-long-events start end events)
+ (fix-event-widths! events event-length-key: event-length
+ event-length-comperator: date/-time>)
+ (map (lambda (e) (create-top-block start end e))
+ events))
+
+;; date{,time}-difference works in days, and days are simply multiplied by 24 to
+;; get hours. This means that a day is always assumed to be 24h, even when that's
+;; wrong. This might lead to some weirdness when the timezon switches (DST), but it
+;; makes everything else behave MUCH better.
+(define-public (create-top-block start-date end-date ev)
+
+ (define total-length
+ (* 24 (days-in-interval start-date end-date)))
+
+ (define top (* 100 (x-pos ev)))
+ (define height (* 100 (width ev)))
+ (define left ; start time
+ (* 100
+ (let* ((dt (datetime date: start-date))
+ (diff (datetime-difference
+ (datetime-max dt (as-datetime (prop ev 'DTSTART)))
+ dt)))
+ (/ (datetime->decimal-hour diff start-date) total-length))))
+
+ ;; Set length of event, which makes end time
+ (define width*
+ (* 100
+ (/ (datetime->decimal-hour
+ (as-datetime (event-length/clamped start-date end-date ev))
+ start-date)
+ total-length)))
+
+ (define style
+ (if (edit-mode)
+ (format #f "top:calc(var(--editmode)*~,3f%);height:calc(var(--editmode)*~,3f%);left:~,3f%;width:~,3f%;"
+ top height left width*)
+ (format #f "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;"
+ top height left width*)))
+
+ (make-block
+ ev `((class
+ ,(when (date/-time< (prop ev 'DTSTART) start-date)
+ " continued")
+ ,(when (and (prop ev 'DTEND)
+ (date/-time< (date+ end-date (date day: 1)) (prop ev 'DTEND)))
+ " continuing"))
+ (style ,style))))
diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm
new file mode 100644
index 00000000..ca6aa9f8
--- /dev/null
+++ b/module/calp/html/view/calendar/week.scm
@@ -0,0 +1,121 @@
+(define-module (calp html view calendar week)
+ :use-module (util)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-41)
+ :use-module (datetime)
+ :use-module (calp html view calendar shared)
+ :use-module (calp html config)
+ :use-module (calp html util)
+ :use-module (vcomponent)
+ :use-module ((vcomponent datetime)
+ :select (long-event?
+ event-length/day
+ event-zero-length?
+ events-between))
+ :use-module ((calp html vcomponent)
+ :select (make-block) )
+ :use-module ((vcomponent group)
+ :select (group-stream get-groups-between))
+ )
+
+
+(define*-public (render-calendar key: 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';")
+ (div (@ (class "calendar"))
+ (div (@ (class "days"))
+ ,@(time-marker-div)
+ (div (@ (class "longevents event-container")
+ (data-start ,(date->string start-date) )
+ (data-end ,(date->string (add-day end-date)) )
+ (style "grid-column-end: span " ,(days-in-interval start-date end-date)))
+ ,@(lay-out-long-events start-date end-date long-events))
+ ,@(map (lambda (day-date)
+ `(div (@ (class "meta"))
+ (span (@ (class "daydate"))
+ ,(date->string day-date "~Y-~m-~d"))
+ (span (@ (class "dayname"))
+ ,(string-titlecase (date->string day-date "~a")))))
+ range)
+ ,@(stream->list
+ (stream-map
+ lay-out-day
+ (get-groups-between (group-stream (list->stream short-events))
+ start-date end-date)))
+
+ ,@(for event in (stream->list
+ (events-between start-date end-date events))
+ ((@ (calp html vcomponent ) popup) event (string-append "popup" (html-id event))))
+
+ )))))
+
+
+
+(define (time-marker-div)
+ ;; element to make rest of grid align correct.
+ ;; Could be extended to contain something fun.
+ `((div (@ (style "grid-row: 1 / span 2")))
+ (div (@ (class "sideclock"))
+ ,@(map (lambda (time)
+ `(div (@ (class "clock clock-" ,time))
+ (span (@ (class "clocktext"))
+ ,time ":00")))
+ (iota 12 0 2)))))
+
+;; Lay out complete day (graphical)
+;; (date . (events)) -> sxml
+(define (lay-out-day day)
+ (let* (((day-date . events) day)
+ (time-obj (datetime date: day-date))
+ (zero-length-events short-events
+ (partition event-zero-length? (stream->list events))))
+
+ (fix-event-widths! short-events event-length-key:
+ (lambda (e) (event-length/day day-date e)))
+
+ `(div (@ (class "events event-container") (id ,(date-link day-date))
+ (data-start ,(date->string day-date))
+ (data-end ,(date->string (add-day day-date)) ))
+ ,@(map (lambda (time)
+ `(div (@ (class "clock clock-" ,time))))
+ (iota 12 0 2))
+ (div (@ (class "zero-width-events"))
+ ,(map make-block zero-length-events))
+ ,@(map (lambda (e) (create-block day-date e)) short-events))))
+
+
+
+;; Format single event for graphical display
+;; This is extremely simmilar to create-top-block, which currently recides in ./shared
+(define (create-block date ev)
+ ;; (define time (date->time-utc day))
+
+ (define left (* 100 (x-pos ev)))
+ (define width* (* 100 (width ev)))
+ (define top (if (date= date (as-date (prop ev 'DTSTART)))
+ (* 100/24
+ (time->decimal-hour
+ (as-time (prop ev 'DTSTART))))
+ 0))
+ (define height (* 100/24 (time->decimal-hour (event-length/day date ev))))
+
+
+ (define style
+ ;; The calc's here is to enable an "edit-mode".
+ ;; Setting --editmode ≈ 0.8 gives some whitespace to the right
+ ;; of the events, alowing draging there for creating new events.
+ (if (edit-mode)
+ (format #f "left:calc(var(--editmode)*~,3f%);width:calc(var(--editmode)*~,3f%);top:~,3f%;height:~,3f%;"
+
+ left width* top height)
+ (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;"
+ left width* top height)))
+
+ (make-block
+ ev `((class
+ ,(when (date<? (as-date (prop ev 'DTSTART)) date)
+ " continued")
+ ,(when (and (prop ev 'DTEND) (date<? date (as-date (prop ev 'DTEND))))
+ " continuing"))
+ (style ,style))))
diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm
new file mode 100644
index 00000000..faefe6dc
--- /dev/null
+++ b/module/calp/html/view/search.scm
@@ -0,0 +1,38 @@
+(define-module (calp html view search)
+ :use-module (util)
+ :use-module (vcomponent)
+ :use-module (vcomponent search)
+ :use-module ((ice-9 pretty-print) :select (pretty-print))
+ :use-module ((calp html components)
+ :select (xhtml-doc include-css))
+ :use-module ((calp html vcomponent)
+ :select (compact-event-list))
+ )
+
+(define-public (search-result-page
+ has-query? search-term search-result page paginator q=)
+ (xhtml-doc
+ (@ (lang sv))
+ (head (title "Search results")
+ ,(include-css "/static/style.css"))
+ (body
+ (h2 "Search term")
+ (form
+ (pre (textarea (@ (name "q") (rows 5) (spellcheck false)
+ (style "width:100%"))
+ ,(when has-query?
+ (with-output-to-string
+ (lambda () (pretty-print search-term))))))
+ (input (@ (type submit))))
+ (h2 "Result (page " ,page ")")
+ (ul
+ ,@(compact-event-list search-result))
+ (div (@ (class "paginator"))
+ ,@(paginator->list
+ paginator
+ (lambda (p) (if (= p page)
+ `(span ,p)
+ `(a (@ (href "?" ,q= "&p=" ,p)) ,p)))
+ (lambda (p) `(a (@ (href "?" ,q= "&p=" ,p)) "»"))))
+ )))
+
diff --git a/module/calp/html/view/small-calendar.scm b/module/calp/html/view/small-calendar.scm
new file mode 100644
index 00000000..80cbbaf2
--- /dev/null
+++ b/module/calp/html/view/small-calendar.scm
@@ -0,0 +1,19 @@
+(define-module (calp html view small-calendar)
+ :use-module ((calp html components) :select (xhtml-doc include-css))
+ :use-module ((calp html caltable) :select (cal-table))
+ :use-module ((datetime) :select (month- month+ remove-day date->string))
+ )
+
+(define-public (render-small-calendar month standalone)
+ (define table (cal-table
+ start-date: month
+ end-date: (remove-day (month+ month))
+ next-start: month+
+ prev-start: month-
+ ))
+ (if standalone
+ (xhtml-doc
+ (head (title ,(date->string month "~1"))
+ ,(include-css "/static/smallcal.css"))
+ (body ,table))
+ table))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 17:11:46 +0200