diff options
Diffstat (limited to 'module/calp')
-rw-r--r-- | module/calp/entry-points/html.scm | 8 | ||||
-rw-r--r-- | module/calp/html/caltable.scm | 89 | ||||
-rw-r--r-- | module/calp/html/components.scm | 127 | ||||
-rw-r--r-- | module/calp/html/config.scm | 18 | ||||
-rw-r--r-- | module/calp/html/util.scm | 46 | ||||
-rw-r--r-- | module/calp/html/vcomponent.scm | 229 | ||||
-rw-r--r-- | module/calp/html/view/calendar.scm | 289 | ||||
-rw-r--r-- | module/calp/html/view/calendar/month.scm | 117 | ||||
-rw-r--r-- | module/calp/html/view/calendar/shared.scm | 96 | ||||
-rw-r--r-- | module/calp/html/view/calendar/week.scm | 121 | ||||
-rw-r--r-- | module/calp/html/view/search.scm | 38 | ||||
-rw-r--r-- | module/calp/html/view/small-calendar.scm | 19 | ||||
-rw-r--r-- | module/calp/server/routes.scm | 12 |
13 files changed, 1199 insertions, 10 deletions
diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index abaa5f13..b2f613ea 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -8,11 +8,11 @@ :use-module ((ice-9 regex) :select (string-match regexp-substitute)) :use-module ((srfi srfi-41) :select (stream-take stream-for-each)) - :use-module ((html view calendar) :select (html-generate)) - :use-module ((html view calendar week) + :use-module ((calp html view calendar) :select (html-generate)) + :use-module ((calp html view calendar week) :select (render-calendar) :renamer (lambda _ 'render-calendar-wide)) - :use-module ((html view calendar month) + :use-module ((calp html view calendar month) :select (render-calendar-table)) :use-module ((vcomponent instance methods) :select (get-calendars get-event-set)) @@ -144,7 +144,7 @@ (lambda () (sxml->xml (re-root-static - ((@ (html view small-calendar) render-small-calendar) + ((@ (calp html view small-calendar) render-small-calendar) start standalone))))))] [(wide) 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)) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 02bbd123..51e5acb2 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -17,7 +17,7 @@ :use-module (sxml namespace) - :use-module ((html util) :select (html-unattr)) + :use-module ((calp html util) :select (html-unattr)) :use-module (web http make-routes) @@ -28,8 +28,8 @@ :autoload (vcomponent instance) (global-event-object) - :use-module (html view calendar) - :use-module ((html view search) :select (search-result-page)) + :use-module (calp html view calendar) + :use-module ((calp html view search) :select (search-result-page)) ) @@ -109,7 +109,7 @@ end-date: (date+ start-date (date day: 6)) next-start: (lambda (d) (date+ d (date day: 7))) prev-start: (lambda (d) (date- d (date day: 7))) - render-calendar: (@ (html view calendar week) render-calendar) + render-calendar: (@ (calp html view calendar week) render-calendar) intervaltype: 'week ))))))) @@ -127,7 +127,7 @@ (date day: 1)) next-start: month+ prev-start: month- - render-calendar: (@ (html view calendar month) + render-calendar: (@ (calp html view calendar month) render-calendar-table) pre-start: (start-of-week start-date) post-end: (end-of-week (end-of-month start-date)) @@ -156,7 +156,7 @@ ;; TODO this fails when dtstart is <date>. ;; @var{cal} should be the name of the calendar encoded with - ;; modified base64. See (html util). + ;; modified base64. See (calp html util). (POST "/insert" (cal data) (unless (and cal data) |