Merge branch 'calchooser' into master

3 files changed, 104 insertions, 44 deletions

diff --git a/module/html/util.scm b/module/html/util.scm
index 36b1d929..edbcf756 100644
--- a/module/html/util.scm
+++ b/module/html/util.scm
@@ -1,10 +1,37 @@
 (define-module (html util)
+  :use-module ((util 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)
-  (define cs (char-set-adjoin char-set:letter+digit #\- #\_))
-  (string-filter (lambda (c) (char-set-contains? cs c)) 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"))
diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm
index 9189b59e..5e7b4ba8 100644
--- a/module/html/vcomponent.scm
+++ b/module/html/vcomponent.scm
@@ -44,18 +44,21 @@
           ;; TODO better format, add show in calendar button
           ,(fmt-single-event event)))))
 
-;; For sidebar, just text
+;; 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))
   `(article (@ ,@(assq-merge
                   attributes
-                  `((class "eventtext CAL_bg_"
-                      ,(html-attr (or (prop (parent ev) 'NAME) "unknown"))
+                  `((class " eventtext "
                       ,(when (and (prop ev 'PARTSTAT)
                                   (eq? 'TENTATIVE (prop ev 'PARTSTAT)))
-                         " tentative")))))
+                         " tentative ")))))
             (h3 ,(fmt-header
                   (when (prop ev 'RRULE)
                     `(span (@ (class "repeating")) "↺"))
@@ -79,8 +82,9 @@
                       (div (@ (class "location"))
                            ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
                                         (prop ev 'LOCATION)))))
-             ,(and=> (prop ev 'DESCRIPTION)
-                     (lambda (str) (format-description ev str)))
+             ,(awhen (prop ev 'DESCRIPTION)
+                     `(span (@ (class "description"))
+                            ,(format-description ev it)))
              ,(awhen (prop ev 'RRULE)
                      `(span (@ (class "rrule"))
                             ,@(format-recurrence-rule ev)))
@@ -100,13 +104,15 @@
                                     (class "hidelink")) ,s))))
               ,@(stream->list
                  (stream-map
-                  (lambda (ev) (fmt-single-event
-                           ev `((id ,(html-id ev)))
-                           fmt-header:
-                           (lambda body
-                             `(a (@ (href "#" ,(date-link (as-date (prop ev 'DTSTART))))
-                                    (class "hidelink"))
-                                 ,@body))))
+                  (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 "#" ,(date-link (as-date (prop ev 'DTSTART))))
+                               (class "hidelink"))
+                            ,@body))))
                   (stream-filter
                    (lambda (ev)
                      ;; If start was an earlier day
@@ -119,16 +125,14 @@
 
 (define-public (calendar-styles calendars)
   `(style
-       ,(format
-         #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%.CAL_bg_~a { border-color: ~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)
-                        name (or bg-color 'black))))
-              calendars))))
+     ,(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 '()))
@@ -138,6 +142,7 @@
        (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)
@@ -165,28 +170,34 @@
 
 
 (define-public (popup ev id)
-  `(div (@ (class "popup-container") (id ,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 CAL_"
-                       ,(html-attr (or (prop (parent ev) 'NAME)
-                                       "unknown"))))
+             (nav (@ (class "popup-control"))
                   ,(btn "×"
                         title: "Stäng"
                         onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))"
                         class: '("close-tooltip"))
                   ,(when (edit-mode)
-                     (btn "🗑"
-                          title: "Ta bort"
-                          onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")))
+                     (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 (@ (style "font-family:sans"))
-                       (p "Ladda ner")
-                       (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics"))
-                                  "som iCal"))
-                           (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs"))
-                                  "som xCal"))))))))))
+                `(("📅" title: "Översikt"
+                   ,(fmt-single-event ev))
+                  ("⤓" title: "Nedladdning"
+                   (div (@ (style "font-family:sans"))
+                        (p "Ladda ner")
+                        (ul (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".ics"))
+                                   "som iCal"))
+                            (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs"))
+                                   "som xCal"))))))))))
diff --git a/module/html/view/calendar.scm b/module/html/view/calendar.scm
index a15b5c1d..a0de3551 100644
--- a/module/html/view/calendar.scm
+++ b/module/html/view/calendar.scm
@@ -16,10 +16,14 @@
                                           ))
   :use-module (html config)
   :use-module (html util)
+
+  :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))
   :use-module ((git)
@@ -292,10 +296,22 @@
                         (summary "Calendar list")
                         (ul ,@(map
                                (lambda (calendar)
-                                 `(li (@ (class "CAL_bg_"
+                                 `(li (@ (class "CAL_"
                                            ,(html-attr (prop calendar 'NAME))))
                                       ,(prop calendar 'NAME)))
-                               calendars))))
+                               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")
@@ -304,6 +320,8 @@
                ;; 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
@@ -325,7 +343,11 @@
                                      ;; cloned mulitple times.
                                      dtstart: (datetime)
                                      dtend: (datetime)
-                                     summary: "New Event"))))
+                                     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