aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2020-08-14 00:32:45 +0200
committerHugo Hörnquist <hugo@lysator.liu.se>2020-08-14 00:32:45 +0200
commitea111ad961d1a90e0008575bd9713992db553506 (patch)
tree9a906b67b63461e3ca73ca81777a907436cae86e
parentSimplify (output html). (diff)
downloadcalp-ea111ad961d1a90e0008575bd9713992db553506.tar.gz
calp-ea111ad961d1a90e0008575bd9713992db553506.tar.xz
Html-generate now returns sxml.
Diffstat
-rw-r--r--module/html/view/calendar.scm432
-rw-r--r--module/output/html.scm4
-rw-r--r--module/server/routes.scm46
3 files changed, 242 insertions, 240 deletions
diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm
index a0de3551..c7aa17a3 100644
--- a/module/html/view/calendar.scm
+++ b/module/html/view/calendar.scm
@@ -30,6 +30,7 @@
:select (get-git-version))
)
+
;; 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.
@@ -137,226 +138,223 @@
(unless prev-start
(error 'html-generate "Prev-start needs to be a procedure"))
- ;; (display "<!doctype HTML>\n")
- (;;(@ (ice-9 pretty-print) pretty-print)
- (@ (sxml simple) sxml->xml)
- (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=true;")
-
- (style ,(format #f "html {
+ (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=true;")
+
+ (style ,(format #f "html {
--editmode: 1.0;
--event-font-size: 8pt;
--gray: #757575;
--btn-height: 0.5ex;
}"))
- ,(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"))
- ,(let* ((long-hash short-hash (get-git-version))
- (url (format #f "~a/calparse/commit/?id=~a"
- (repo-url) long-hash)))
- `(span "Version " (a (@ (href ,url)) ,short-hash))))
-
- ;; 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))))))))))
+ ,(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"))
+ ,(let* ((long-hash short-hash (get-git-version))
+ (url (format #f "~a/calparse/commit/?id=~a"
+ (repo-url) long-hash)))
+ `(span "Version " (a (@ (href ,url)) ,short-hash))))
+
+ ;; 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/output/html.scm b/module/output/html.scm
index d3a5b8be..f3ed6dc8 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -21,6 +21,8 @@
#:use-module ((vcomponent instance methods)
:select (get-calendars get-event-set))
+ #:use-module ((sxml simple) :select (sxml->xml))
+
#:autoload (vcomponent instance) (global-event-object)
)
@@ -56,7 +58,7 @@
(lambda (start-date)
(define fname (get-filename start-date))
(format (current-error-port) "Writing to [~a]~%" fname)
- (with-output-to-file fname (lambda () (proc calendars events)) ))
+ (with-output-to-file fname (lambda () (sxml->xml (proc calendars events))) ))
(stream-take count (date-stream chunk-length start-date))
))
diff --git a/module/server/routes.scm b/module/server/routes.scm
index 8d51fc22..6c1d1fcd 100644
--- a/module/server/routes.scm
+++ b/module/server/routes.scm
@@ -106,15 +106,16 @@
(return `((content-type application/xhtml+xml))
(with-output-to-string
(lambda ()
- (html-generate calendars: (get-calendars global-event-object)
- events: (get-event-set global-event-object)
- start-date: start-date
- 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)
- intervaltype: 'week
- ))))))
+ (sxml->xml
+ (html-generate calendars: (get-calendars global-event-object)
+ events: (get-event-set global-event-object)
+ start-date: start-date
+ 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)
+ intervaltype: 'week
+ )))))))
(GET "/month/:start-date.html" (start-date)
(let* ((start-date (start-of-month (parse-iso-date start-date))))
@@ -122,19 +123,20 @@
(return '((content-type application/xhtml+xml))
(with-output-to-string
(lambda ()
- (html-generate calendars: (get-calendars global-event-object)
- events: (get-event-set global-event-object)
- start-date: start-date
- end-date: (date- (month+ start-date)
- (date day: 1))
- next-start: month+
- prev-start: month-
- render-calendar: (@ (html view calendar month)
- render-calendar-table)
- pre-start: (start-of-week start-date)
- post-end: (end-of-week (end-of-month start-date))
- intervaltype: 'month
- ))))))
+ (sxml->xml
+ (html-generate calendars: (get-calendars global-event-object)
+ events: (get-event-set global-event-object)
+ start-date: start-date
+ end-date: (date- (month+ start-date)
+ (date day: 1))
+ next-start: month+
+ prev-start: month-
+ render-calendar: (@ (html view calendar month)
+ render-calendar-table)
+ pre-start: (start-of-week start-date)
+ post-end: (end-of-week (end-of-month start-date))
+ intervaltype: 'month
+ )))))))
(POST "/remove" (uid)
(unless uid
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-18 05:56:44 +0200