diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-11-05 23:45:48 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-11-05 23:45:48 +0100 |
commit | 0e429de91e57c2445df4fdf2227f65af3e396d9c (patch) | |
tree | 9151ec03d773a70944e363855c5b9c296e6fce17 /module/c | |
parent | Fix tidsrapport --output flag. (diff) | |
parent | Add comment about freeform fields. (diff) | |
download | calp-0e429de91e57c2445df4fdf2227f65af3e396d9c.tar.gz calp-0e429de91e57c2445df4fdf2227f65af3e396d9c.tar.xz |
Merge branch 'front'
Diffstat (limited to '')
-rw-r--r-- | module/calp/html/components.scm | 50 | ||||
-rw-r--r-- | module/calp/html/vcomponent.scm | 179 | ||||
-rw-r--r-- | module/calp/html/view/calendar.scm | 27 | ||||
-rw-r--r-- | module/calp/main.scm | 63 | ||||
-rw-r--r-- | module/calp/server/routes.scm | 66 | ||||
-rw-r--r-- | module/calp/util/config.scm | 4 |
6 files changed, 318 insertions, 71 deletions
diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index ebc359b8..03e1cef1 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -1,6 +1,8 @@ (define-module (calp html components) :use-module (calp util) :use-module (calp util exceptions) + :use-module (ice-9 curried-definitions) + :use-module (ice-9 match) :export (xhtml-doc) ) @@ -112,6 +114,54 @@ ,key) (div (@ (class "content")) ,body))))) +(define ((set-attribute attr) el) + (match el + [(tagname ('@ params ...) inner-body ...) + `(,tagname (@ ,@(assq-merge params attr)) + ,@inner-body)] + [(tagname inner-body ...) + `(,tagname (@ ,attr) + ,@inner-body)])) + + +(define-public (with-label lbl . forms) + + (define id (gensym "label")) + + (cons `(label (@ (for ,id)) ,lbl) + (let recurse ((forms forms)) + (map (lambda (form) + (cond [(not (list? form)) form] + [(null? form) '()] + [(eq? 'input (car form)) + ((set-attribute `((id ,id))) form)] + [(list? (car form)) + (cons (recurse (car form)) + (recurse (cdr form)))] + [else + (cons (car form) + (recurse (cdr form)))])) + forms)))) + + +(define-public (form elements) + `(form + ,@(map (label self + (lambda (el) + (match el + ((name ('@ tags ...) body ...) + (let ((id (gensym "formelement"))) + (cons + `(label (@ (for ,id)) ,name) + (map + (set-attribute `((name ,name))) + (cons + ((set-attribute `((id ,id))) (car body)) + (cdr body)))))) + ((name body ...) + (self `(,name (@) ,@body)))))) + elements))) + (define-public (include-css path . extra-attributes) `(link (@ (type "text/css") diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index c4e15374..fbf344b0 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -5,9 +5,10 @@ :use-module (srfi srfi-41) :use-module (datetime) :use-module ((text util) :select (add-enumeration-punctuation)) + :use-module ((web uri-query) :select (encode-query-parameters)) :use-module (calp html util) :use-module ((calp html config) :select (edit-mode)) - :use-module ((calp html components) :select (btn tabset)) + :use-module ((calp html components) :select (btn tabset form with-label)) :use-module ((calp util color) :select (calculate-fg-color)) :use-module ((vcomponent datetime output) :select (fmt-time-span @@ -56,18 +57,21 @@ ;; (format (current-error-port) "fmt-single-event: ~a~%" (prop ev 'X-HNH-FILENAME)) `(div (@ ,@(assq-merge attributes - `((class " eventtext " + `((class " eventtext summary-tab " ,(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)))) + `(span (@ (class "bind summary") + (data-property "summary")) + ,(prop ev 'SUMMARY)))) (div ,(call-with-values (lambda () (fmt-time-span ev)) (case-lambda [(start) - `(div (time (@ (class "dtstart") + `(div (time (@ (class "bind dtstart") + (data-property "dtstart") (data-fmt ,(string-append "~L" start)) (datetime ,(datetime->string (as-datetime (prop ev 'DTSTART)) @@ -76,7 +80,8 @@ (as-datetime (prop ev 'DTSTART)) start)))] [(start end) - `(div (time (@ (class "dtstart") + `(div (time (@ (class "bind dtstart") + (data-property "dtstart") (data-fmt ,(string-append "~L" start)) (datetime ,(datetime->string (as-datetime (prop ev 'DTSTART)) @@ -84,31 +89,170 @@ ,(datetime->string (as-datetime (prop ev 'DTSTART)) start)) " — " - (time (@ (class "dtend") + (time (@ (class "bind dtend") + (data-property "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)))])) + + ;; TODO add optional fields when added in frontend + ;; Possibly by always having them here, just hidden. + (div (@ (class "fields")) ,(when (and=> (prop ev 'LOCATION) (negate string-null?)) `(div (b "Plats: ") - (div (@ (class "location")) + (div (@ (class "bind location") (data-property "location")) ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) (prop ev 'LOCATION))))) ,(awhen (prop ev 'DESCRIPTION) - `(span (@ (class "description")) + `(div (@ (class "bind description") + (data-property "description")) ,(format-description ev it))) + + ;; TODO add bind once I figure out how to bind lists + ,(awhen (prop ev 'CATEGORIES) + `(div (@ (class "categories")) + ,@(map (lambda (c) + `(a (@ (class "category") + ;; TODO centralize search terms + (href + "/search/?" + ,(encode-query-parameters + `((q . (member + ,(->quoted-string c) + (or (prop event 'CATEGORIES) + '()))))))) + ,c)) + it))) + + ;; TODO bind ,(awhen (prop ev 'RRULE) - `(span (@ (class "rrule")) - ,@(format-recurrence-rule ev))) + `(div (@ (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")))) + `(div (@ (class "last-modified")) "Senast ändrad " + ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M")))) ))) +(define*-public (fmt-for-edit ev + optional: (attributes '()) + key: (fmt-header list)) + `(div (@ (class " eventtext edit-tab ")) + (form (@ (class "edit-form")) + (div (@ (class "dropdown-goes-here"))) + (h3 (input (@ (type "text") + (placeholder "Sammanfattning") + (name "summary") (required) + (class "bind") (data-property "summary") + (value ,(prop ev 'SUMMARY))))) + + ,(let ((start (prop ev 'DTSTART)) + (end (prop ev 'DTEND))) + `(div (@ (class "timeinput")) + + (input (@ (type "date") + (name "dtstart-date") + (style "grid-column:1;grid-row:2") + (class "bind") + (data-property "--dtstart-date") + (value ,(date->string (as-date start))))) + + (input (@ (type "date") + (name "dtend-date") + (style "grid-column:1;grid-row:3") + (class "bind") + (data-property "--dtend-date") + ,@(when end `((value ,(date->string (as-date end))))))) + + ,@(with-label + "Heldag?" + `(input (@ (type "checkbox") (style "display:none") + (name "wholeday")))) + + (input (@ (type "time") + (name "dtstart-time") + (class "bind") + (data-property "--dtstart-time") + (style "grid-column:3;grid-row:2;" + ,(when (date? start) "display:none")) + (value ,(time->string (as-time start))))) + + (input (@ (type "time") + (name "dtend-time") + (class "bind") + (data-property "--dtend-time") + (style "grid-column:3;grid-row:3;" + ,(when (date? end) "display:none")) + ,@(when end `((value ,(time->string (as-time end))))) + )))) + + ,@(with-label + "Plats" + `(input (@ (placeholder "Plats") + (name "location") + (type "text") + (class "bind") (data-property "location") + (value ,(or (prop ev 'LOCATION) ""))))) + + ,@(with-label + "Beskrivning" + `(textarea (@ (placeholder "Beskrivning") + (class "bind") (data-property "description") + (name "description")) + ,(prop ev 'DESCRIPTION))) + + ,@(with-label + "Kategorier" + ;; It would be better if these input-list's worked on the same + ;; class=bind system as the fields above. The problem with that + ;; is however that each input-list requires different search + ;; and join procedures. Currently this is bound in the JS, see + ;; [CATEGORIES_BIND]. + ;; It matches on ".input-list[data-property='categories']". + `(div (@ (class "input-list") + (data-property "categories")) + ,@(awhen (prop ev 'CATEGORIES) + (map (lambda (c) + `(input (@ (size 2) + (class "unit") + (value ,c)))) + it)) + + (input (@ (class "unit final") + (size 2) + (type "text") + )))) + + (hr) + + ;; For custom user fields + ;; TODO these are currently not bound to anything, so entering data + ;; here does nothing. Bigest hurdle to overcome is supporting arbitrary + ;; fields which will come and go in the JavaScript. + ;; TODO also, all (most? maybe not LAST-MODIFIED) remaining properties + ;; should be exposed here. + (div (@ (class "input-list")) + (div (@ (class "unit final newfield")) + (input (@ (type "text") + (list "known-fields") + (placeholder "Nytt fält"))) + (select (@ (name "TYPE")) + (option (@ (value "TEXT")) "Text")) + (span + (input (@ (type "text") + (placeholder "Värde")))))) + + (hr) + + + (input (@ (type "submit"))) + ))) + ;; Single event in side bar (text objects) (define-public (fmt-day day) @@ -176,10 +320,12 @@ (div (@ (class "event-body")) ,(when (prop ev 'RRULE) `(span (@ (class "repeating")) "↺")) - (span (@ (class "summary")) + (span (@ (class "bind summary") + (data-property "summary")) ,(format-summary ev (prop ev 'SUMMARY))) ,(when (prop ev 'LOCATION) - `(span (@ (class "location")) + `(span (@ (class "bind location") + (data-property "location")) ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) (prop ev 'LOCATION))))) (div (@ (style "display:none !important;")) @@ -238,6 +384,10 @@ ,(tabset `(("📅" title: "Översikt" ,(fmt-single-event ev)) + + ("📅" title: "Redigera" + ,(fmt-for-edit ev)) + ("⤓" title: "Nedladdning" (div (@ (class "eventtext") (style "font-family:sans")) (h2 "Ladda ner") @@ -245,6 +395,7 @@ "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 index a583d82b..0e90e5d4 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -104,7 +104,9 @@ ,(include-alt-css "/static/dark.css" '(title "Dark")) ,(include-alt-css "/static/light.css" '(title "Light")) + (script (@ (defer) (src "/static/types.js"))) (script (@ (defer) (src "/static/lib.js"))) + (script (@ (defer) (src "/static/input_list.js"))) (script (@ (defer) (src "/static/script.js"))) ,(calendar-styles calendars)) @@ -296,4 +298,27 @@ ;; 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))))))))) + ,(popup event (string-append "popup" (html-id event)))))) + + ;; Auto-complets when adding new fields to a component + ;; Any string is however still valid. + (datalist (@ (id "known-fields")) + ,@(map (lambda (f) + `(option (@ (value ,f)))) + '(CALSCALE + METHOD PRODID VERSION ATTACH + CATEGORIES CLASS COMMENT + DESCRIPTION GEO LOCATION + PERCENT-COMPLETE PRIORITY + RESOURCES STATUS SUMMARY + COMPLETED DTEND DUE DTSTART + DURATION FREEBUSY + TRANSP TZID TZNAME + TZOFFSETFROM TZOFFSETTO + TZURL ATTENDEE CONTACT + ORGANIZER RECURRENCE-ID + RELATED-TO URL EXDATE + RDATE RRULE ACTION REPEAT + TRIGGER CREATED DTSTAMP LAST-MODIFIED + SEQUENCE REQUEST-STATUS + )))))) diff --git a/module/calp/main.scm b/module/calp/main.scm index 33da1554..c93ae795 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -15,6 +15,8 @@ :use-module (ice-9 getopt-long) :use-module (ice-9 regex) :use-module ((ice-9 popen) :select (open-input-pipe)) + :use-module ((ice-9 sandbox) :select + (make-sandbox-module all-pure-and-impure-bindings)) :use-module (statprof) :use-module (calp repl) @@ -99,13 +101,26 @@ (if (null? a) b a)) - (define (wrapped-main args) (define opts (getopt-long args (getopt-opt options) #:stop-at-first-non-option #t)) (define stprof (option-ref opts 'statprof #f)) (define repl (option-ref opts 'repl #f)) (define altconfig (option-ref opts 'config #f)) + (define config-file + (cond [altconfig + (if (file-exists? altconfig) + altconfig + (throw 'option-error + "Configuration file ~a missing" altconfig))] + ;; altconfig could be placed in the list below. But I want to raise an error + ;; if an explicitly given config is missing. + [(find file-exists? + (list + (path-append (xdg-config-home) "/calp/config.scm") + (path-append (xdg-sysconfdir) "/calp/config.scm"))) + => identity])) + (when stprof (statprof-start)) (cond [(eqv? #t repl) (repl-start (format #f "~a/calp-~a" @@ -113,18 +128,40 @@ (getpid)))] [repl => repl-start]) - (if altconfig - (begin - (if (file-exists? altconfig) - (primitive-load altconfig) - (throw 'option-error "Configuration file ~a missing" altconfig))) - ;; if not altconfig, then regular config - - (awhen (find file-exists? - (list - (path-append (xdg-config-home) "/calp/config.scm") - (path-append (xdg-sysconfdir) "/calp/config.scm"))) - (primitive-load it))) + + ;; Load config + ;; Sandbox and "stuff" not for security from the user. The config script is + ;; assumed to be "safe". Instead it's so we can control the environment in + ;; which it is executed. + (catch #t + (lambda () + (eval + `(begin + (use-modules (srfi srfi-1) + (srfi srfi-88) + (datetime) + (vcomponent) + (calp util config) + (glob)) + ,@(with-input-from-file config-file + (lambda () + (let loop ((done '())) + (let ((form (read))) + (if (eof-object? form) + (reverse done) + (loop (cons form done)))))))) + (make-sandbox-module + `(((guile) use-modules) + ,@all-pure-and-impure-bindings + )) + )) + (lambda args + (format (current-error-port) + "Failed loading config file ~a~%~s~%" + config-file + args + ))) + ;; NOTE this doesn't stop at first non-option, meaning that -o flags diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 184b4481..276513f5 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -218,55 +218,43 @@ [(get-event-by-uid global-event-object (prop event 'UID)) => (lambda (old-event) - ;; procedure to run after save. - ;; used as hook to remove old event from disk below - (define after-save (const #f)) - - (if (eq? calendar (parent old-event)) - (begin (vcomponent-update! old-event event) - ;; for save below - (set! event old-event)) - - ;; change calendar - (begin - - (format (current-error-port) - "Calendar change~%") - - ;; remove from runtime - ((@ (vcomponent instance methods) remove-event) - global-event-object old-event) - - ;; Actually puring the old event should be safe, - ;; since we first make sure we write the new event to disk. - ;; Currently the whole transaction isn't atomic, so a duplicate - ;; event can still be created. - (set! after-save - ;; remove from disk - (lambda () - (format (current-error-port) - "Unlinking old event from ~a~%" - (prop old-event '-X-HNH-FILENAME)) - ((@ (vcomponent vdir save-delete) remove-event) old-event))) - - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))))) + ;; remove old instance of event from runtime + ((@ (vcomponent instance methods) remove-event) + global-event-object old-event) + + ;; Add new event to runtime, + ;; MUST be done after since the two events SHOULD share UID. + (parameterize ((warnings-are-errors #t)) + (catch 'warning + (lambda () (add-event global-event-object calendar event)) + (lambda (err fmt args) + (return (build-response code: 400) + (format #f "~?~%" fmt args))))) (set! (prop event 'LAST-MODIFIED) (current-datetime)) - ;; NOTE Posibly defer save to a later point. ;; That would allow better asyncronous preformance. + + ;; save-event sets -X-HNH-FILENAME from the UID. This is fine + ;; since the two events are guaranteed to have the same UID. (unless ((@ (vcomponent vdir save-delete) save-event) event) (return (build-response code: 500) "Saving event to disk failed.")) - (after-save) + + (unless (eq? calendar (parent old-event)) + ;; change to a new calendar + (format (current-error-port) + "Unlinking old event from ~a~%" + (prop old-event '-X-HNH-FILENAME)) + ;; NOTE that this may fail, leading to a duplicate event being + ;; created (since we save beforehand). This is just a minor problem + ;; which either a better atomic model, or a propper error + ;; recovery log would solve. + ((@ (vcomponent vdir save-delete) remove-event) old-event)) + (format (current-error-port) "Event updated ~a~%" (prop event 'UID)))] diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm index 32dabb69..fbe35d59 100644 --- a/module/calp/util/config.scm +++ b/module/calp/util/config.scm @@ -106,10 +106,6 @@ (export format-procedure) -(define (->str any) - (with-output-to-string - (lambda () (display any)))) - (define-public (get-configuration-documentation) (define groups (group-by (compose source-module car) |