diff options
Diffstat (limited to 'module/html')
-rw-r--r-- | module/html/caltable.scm | 89 | ||||
-rw-r--r-- | module/html/components.scm | 127 | ||||
-rw-r--r-- | module/html/config.scm | 18 | ||||
-rw-r--r-- | module/html/util.scm | 46 | ||||
-rw-r--r-- | module/html/vcomponent.scm | 229 | ||||
-rw-r--r-- | module/html/view/calendar.scm | 289 | ||||
-rw-r--r-- | module/html/view/calendar/month.scm | 117 | ||||
-rw-r--r-- | module/html/view/calendar/shared.scm | 96 | ||||
-rw-r--r-- | module/html/view/calendar/week.scm | 121 | ||||
-rw-r--r-- | module/html/view/search.scm | 38 | ||||
-rw-r--r-- | module/html/view/small-calendar.scm | 19 |
11 files changed, 0 insertions, 1189 deletions
diff --git a/module/html/caltable.scm b/module/html/caltable.scm deleted file mode 100644 index fb2cbe02..00000000 --- a/module/html/caltable.scm +++ /dev/null @@ -1,89 +0,0 @@ -(define-module (html caltable) - :use-module (util) - :use-module (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/html/components.scm b/module/html/components.scm deleted file mode 100644 index 2580ea55..00000000 --- a/module/html/components.scm +++ /dev/null @@ -1,127 +0,0 @@ -(define-module (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/html/config.scm b/module/html/config.scm deleted file mode 100644 index 03e18db7..00000000 --- a/module/html/config.scm +++ /dev/null @@ -1,18 +0,0 @@ -(define-module (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/html/util.scm b/module/html/util.scm deleted file mode 100644 index 4e15356a..00000000 --- a/module/html/util.scm +++ /dev/null @@ -1,46 +0,0 @@ -(define-module (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/html/vcomponent.scm b/module/html/vcomponent.scm deleted file mode 100644 index c0bbe8e1..00000000 --- a/module/html/vcomponent.scm +++ /dev/null @@ -1,229 +0,0 @@ -(define-module (html vcomponent) - :use-module (util) - :use-module (vcomponent) - :use-module (srfi srfi-1) - :use-module (srfi srfi-41) - :use-module (datetime) - :use-module (html util) - :use-module ((html config) :select (edit-mode)) - :use-module ((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/html/view/calendar.scm b/module/html/view/calendar.scm deleted file mode 100644 index aa67220c..00000000 --- a/module/html/view/calendar.scm +++ /dev/null @@ -1,289 +0,0 @@ -(define-module (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 (html components) - :use-module ((html vcomponent) - :select (popup - calendar-styles - fmt-day - make-block - fmt-single-event - )) - :use-module (html config) - :use-module (html util) - :use-module ((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/html/view/calendar/month.scm b/module/html/view/calendar/month.scm deleted file mode 100644 index 99640a22..00000000 --- a/module/html/view/calendar/month.scm +++ /dev/null @@ -1,117 +0,0 @@ -(define-module (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 (html view calendar shared) - :use-module (html config) - :use-module (vcomponent) - :use-module ((vcomponent datetime) - :select (really-long-event? - events-between)) - :use-module ((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)) - ((@ (html vcomponent) popup) event - (string-append "popup" ((@ (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/html/view/calendar/shared.scm b/module/html/view/calendar/shared.scm deleted file mode 100644 index d1f58460..00000000 --- a/module/html/view/calendar/shared.scm +++ /dev/null @@ -1,96 +0,0 @@ -(define-module (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 (html config) - :use-module ((html components) - :select (btn tabset)) - :use-module ((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/html/view/calendar/week.scm b/module/html/view/calendar/week.scm deleted file mode 100644 index 34e8eeb4..00000000 --- a/module/html/view/calendar/week.scm +++ /dev/null @@ -1,121 +0,0 @@ -(define-module (html view calendar week) - :use-module (util) - :use-module (srfi srfi-1) - :use-module (srfi srfi-41) - :use-module (datetime) - :use-module (html view calendar shared) - :use-module (html config) - :use-module (html util) - :use-module (vcomponent) - :use-module ((vcomponent datetime) - :select (long-event? - event-length/day - event-zero-length? - events-between)) - :use-module ((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)) - ((@ (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/html/view/search.scm b/module/html/view/search.scm deleted file mode 100644 index 12d8399f..00000000 --- a/module/html/view/search.scm +++ /dev/null @@ -1,38 +0,0 @@ -(define-module (html view search) - :use-module (util) - :use-module (vcomponent) - :use-module (vcomponent search) - :use-module ((ice-9 pretty-print) :select (pretty-print)) - :use-module ((html components) - :select (xhtml-doc include-css)) - :use-module ((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/html/view/small-calendar.scm b/module/html/view/small-calendar.scm deleted file mode 100644 index e6378176..00000000 --- a/module/html/view/small-calendar.scm +++ /dev/null @@ -1,19 +0,0 @@ -(define-module (html view small-calendar) - :use-module ((html components) :select (xhtml-doc include-css)) - :use-module ((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)) |