7 files changed, 398 insertions, 0 deletions
diff --git a/module/calp/entry-points/benchmark.scm b/module/calp/entry-points/benchmark.scm
new file mode 100644
index 00000000..0814c44c
--- /dev/null
+++ b/module/calp/entry-points/benchmark.scm
@@ -0,0 +1,33 @@
+(define-module (calp entry-points benchmark)
+  :use-module (util)
+
+  :use-module (ice-9 getopt-long)
+  :use-module (util options)
+  :use-module ((srfi srfi-41) :select (stream->list))
+
+  :use-module ((vcomponent instance methods) :select (get-event-set))
+  :autoload (vcomponent instance) (global-event-object)
+
+  :export (main)
+  )
+
+
+(define opt-spec
+  `((enable-output (single-char #\o)
+                   (description
+                    "Output is be default supressed, since many fields contain way to much data "
+                    "to read. This turns it on again."))
+    (help (single-char #\h) (description "Print this help."))))
+
+
+(define (main args)
+  (define opts (getopt-long args (getopt-opt opt-spec)))
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help opt-spec)
+    (throw 'return))
+
+  (let ((strm (get-event-set global-event-object)))
+    (if (option-ref opts 'enable-output #f)
+        (write (stream->list 1000 strm))
+        (stream->list 1000 strm))))
diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm
new file mode 100644
index 00000000..7f7dc8a5
--- /dev/null
+++ b/module/calp/entry-points/html.scm
@@ -0,0 +1,150 @@
+(define-module (calp entry-points html)
+  :export (main)
+  :use-module (util)
+  :use-module (util time)
+  :use-module (util options)
+  :use-module (datetime)
+  :use-module (ice-9 getopt-long)
+  :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)
+               :select (render-calendar)
+               :renamer (lambda _ 'render-calendar-wide))
+  :use-module ((html view calendar month)
+               :select (render-calendar-table))
+  :use-module ((vcomponent instance methods)
+                :select (get-calendars get-event-set))
+
+  :use-module ((sxml simple) :select (sxml->xml))
+  :use-module ((sxml transformations) :select (href-transformer))
+
+  :autoload (vcomponent instance) (global-event-object)
+  )
+
+
+(define opt-spec
+  `((from (value #t) (single-char #\F)
+          (description "Start date of output.")
+          )
+    (count (value #t)
+           (description "How many pages should be rendered."
+                        "If --style=" (b "week") " and --from=" (b "2020-04-27")
+                        " then --count=" (b 4) " would render the four pages "
+                        "2020-04-27, 2020-05-04, 2020-05-11, and 2020-05-25. "
+                        "Defaults to 12 to give a whole year when --style=" (b "month") "."
+                        ))
+
+    (style (value #t) (predicate ,(lambda (v) (memv (string->symbol v)
+                                            '(wide week table))))
+           (description "How the body of the HTML page should be layed out. "
+                        (br) (b "week")
+                        " gives a horizontally scrolling page with 7 elements, "
+                        "where each has events graphically laid out hour by hour."
+                        (br) (b "table")
+                        " gives a month in overview as a table. Each block contains "
+                        "the events for the given day, in order of start time. They are "
+                        "however not graphically sized. "
+                        (br) (b "wide")
+                        " is the same as week, but gives a full month.")
+           )
+
+    (help (single-char #\h) (description "Print this help."))))
+
+
+
+;; file existing but is of wrong type,
+(define (create-files)
+  (let* ((dir (dirname (or (@ (global) basedir) ".")))
+         (html (string-append dir "/html"))
+         (link (string-append html "/static")))
+    (unless (file-exists? html)
+      (mkdir html))
+    (unless (file-exists? link)
+      (symlink "../static" link))))
+
+
+(define (get-filename start-date)
+  (format #f "~a/html/~a.xml"
+          (dirname (or (@ (global) basedir) "."))
+          (date->string start-date "~1")))
+
+(define (re-root-static tree)
+  (href-transformer
+   tree
+   (lambda (str)
+     (aif (string-match "^/static" str)
+          (regexp-substitute #f it 'pre "static" 'post)
+          str))))
+
+(define (common count start-date chunk-length
+                render-calendar . extra-args)
+
+  (define calendars (get-calendars global-event-object))
+  (define events (get-event-set global-event-object))
+
+  ((@ (util time) report-time!) "html start")
+
+  (create-files)
+
+  (stream-for-each
+   (lambda (start-date)
+     (define fname (get-filename start-date))
+     (format (current-error-port) "Writing to [~a]~%" fname)
+     (with-output-to-file fname
+       (lambda () (sxml->xml (re-root-static
+                         (apply html-generate
+                                calendars: calendars
+                                events: events
+                                next-start: (lambda (d) (date+ d chunk-length))
+                                prev-start: (lambda (d) (date- d chunk-length))
+                                start-date: start-date
+                                end-date: (remove-day (date+ start-date chunk-length))
+                                render-calendar: render-calendar
+                                extra-args))))))
+   (stream-take count (date-stream chunk-length start-date))
+   ))
+
+
+
+
+(define (main args)
+  (define opts (getopt-long args (getopt-opt opt-spec)))
+  (define start (cond [(option-ref opts 'from #f) => parse-freeform-date]
+                      [else (start-of-month (current-date))]))
+  (define count (string->number (option-ref opts 'count "12")))
+
+  (define style (string->symbol (option-ref opts 'style "wide")))
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help opt-spec)
+    (throw 'return)
+    )
+
+  ;; TODO a number of links are wrong, since they point to .html files,
+  ;; while we save the documents as .xml.
+
+  (case style
+    [(wide)
+     (common count start (date month: 1) render-calendar-wide)]
+
+    [(week)
+
+     ;; TODO The small calendar is always centered on months, it might
+     ;; be a good idea to instead center it on the current week, meaning
+     ;; that the active row is always in the center
+     (common count (start-of-week start)
+             (date day: 7)
+             render-calendar-wide)]
+    [(table)
+
+     (common count (start-of-month start) (date month: 1)
+             render-calendar-table
+             pre-start: (start-of-week start)
+             post-end: (end-of-week (end-of-month start)))]
+    [else
+     (error "Unknown html style: ~a" style)])
+
+  ((@ (util time) report-time!) "all done")
+  )
diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm
new file mode 100644
index 00000000..3bf211df
--- /dev/null
+++ b/module/calp/entry-points/ical.scm
@@ -0,0 +1,31 @@
+(define-module (calp entry-points ical)
+  :export (main)
+  :use-module (util)
+  :use-module (util options)
+  :use-module (output ical)
+  :use-module (ice-9 getopt-long)
+  :use-module (datetime)
+  )
+
+(define opt-spec
+  '((from (value #t) (single-char #\F))
+    (to (value #t) (single-char #\T)
+        (description "Returns all elements between these two dates."))
+    (help (single-char #\h)
+          (description "Print this help."))))
+
+(define (main args)
+  (define opts (getopt-long args (getopt-opt opt-spec)))
+
+  (define start (cond [(option-ref opts 'from #f) => parse-freeform-date]
+                      [else (start-of-month (current-date))]))
+  (define end   (cond [(option-ref opts 'to  #f) => parse-freeform-date]
+                      ;; [else (normalize-date* (set (month start) = (+ 1)))]
+                      [(date+ start (date month: 1))]
+                      ))
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help opt-spec)
+    (throw 'return))
+
+  (print-events-in-interval start end))
diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm
new file mode 100644
index 00000000..b13832cc
--- /dev/null
+++ b/module/calp/entry-points/import.scm
@@ -0,0 +1,61 @@
+(define-module (calp entry-points import)
+  :export (main)
+  :use-module (util)
+  :use-module (util options)
+  :use-module (ice-9 getopt-long)
+  :use-module (ice-9 rdelim)
+  :use-module (srfi srfi-1)
+  :use-module (output vdir)
+  :use-module (vcomponent)
+  :autoload (vcomponent instance) (global-event-object)
+  )
+
+(define options
+  '((calendar (value #t) (single-char #\c)
+              (description "Name of calendar to import into"))
+    (file (value #t) (single-char #\f)
+          (description "ics file to import"))
+    (help (single-char #\h)
+          (description "Print this help."))))
+
+(define (main args)
+  (define opts (getopt-long args (getopt-opt options)))
+
+  (define cal-name (option-ref opts 'calendar #f))
+  (define fname (option-ref opts 'file "/dev/stdin"))
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help options)
+    (throw 'return))
+
+  (let* ((calendars (get-calendars global-event-object))
+         (calendar
+          (and cal-name
+               (find (lambda (c) (string=? cal-name (prop c 'NAME)))
+                     (get-calendars global-event-object)))))
+
+    (unless calendar
+      (format (current-error-port) "No calendar named ~s~%" cal-name)
+      (throw 'return))
+
+    (let ((new-events (parse-cal-path fname)))
+
+      (format #t "About to the following ~a events into ~a~%~{~a~^~%~}~%"
+              (length (children new-events))
+              (prop calendar 'NAME)
+              (map (extract 'SUMMARY) (children new-events)))
+
+      (format #t "Continue? [Y/n] ")
+
+      (let loop ((c #\space))
+        (case c
+          [(#\n #\N) (throw 'return)]
+          [(#\y #\Y) (map (lambda (e)
+                            (add-event calendar e)
+                            (save-event e))
+                          (children new-events))]
+          [else
+           (let ((line (read-line)))
+             (loop (if (string-null? line)
+                       #\Y (string-ref line 0))))]))
+      )))
diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm
new file mode 100644
index 00000000..97397e5d
--- /dev/null
+++ b/module/calp/entry-points/server.scm
@@ -0,0 +1,66 @@
+(define-module (calp entry-points server)
+  :use-module (util)
+  :use-module (util options)
+  :use-module (util exceptions)
+
+  :use-module (srfi srfi-1)
+
+  :use-module (ice-9 getopt-long)
+  ;; :use-module (ice-9 regex) #| regex here due to bad macros |#
+
+  :use-module ((server server) :select (start-server))
+
+  :export (main))
+
+
+(define options
+  '((port (value #t) (single-char #\p)
+          (description "Bind to TCP port, defaults to " (i 8080) "."))
+    (addr (value #t)
+          (description "Address to use, defaults to " (i "0.0.0.0")
+                       " for IPv4, and " (i "::") " for IPv6.")
+          )
+    ;; numbers as single-char doesn't work.
+    (six (description "Use IPv6."))
+    (four (description "Use IPv4."))
+    (help (single-char #\h)
+          (description "Print this help."))))
+
+
+(define-public (main args)
+
+  (define opts (getopt-long args (getopt-opt options)))
+  (define port (string->number (option-ref opts 'port "8080")))
+  (define addr (option-ref opts 'addr #f))
+  (define family
+    (cond [(option-ref opts 'six  #f) AF_INET6]
+          [(option-ref opts 'four #f) AF_INET]
+          [(and addr (string-contains addr ":")) AF_INET6]
+          [(and addr (string-contains addr ".")) AF_INET]
+          [else AF_INET6]))
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help options)
+    (throw 'return))
+
+  ;; update address if it was left blank. A bit clumsy since
+  ;; @var{addr} & @var{family} depend on each other.
+  ;; placed after load-calendars to keep Guile 2.2 compability.
+  (set! addr
+    (if addr addr
+        (if (eqv? family AF_INET6)
+            "::" "0.0.0.0")))
+
+
+  (format #t "Starting server on ~a:~a~%I'm ~a, runing from ~a~%"
+          addr port
+          (getpid) (getcwd))
+
+  (catch 'system-error
+    (lambda ()
+      (start-server `(family: ,family port: ,port host: ,addr)))
+
+    ;; probably address already in use
+    (lambda (err proc fmt args errno)
+      (format (current-error-port) "~a: ~?~%"
+              proc fmt args))))
diff --git a/module/calp/entry-points/terminal.scm b/module/calp/entry-points/terminal.scm
new file mode 100644
index 00000000..5a9b2588
--- /dev/null
+++ b/module/calp/entry-points/terminal.scm
@@ -0,0 +1,28 @@
+(define-module (calp entry-points terminal)
+  :export (main)
+  :use-module (output terminal)
+  :use-module (vcomponent)
+  :use-module (ice-9 getopt-long)
+  :use-module (datetime)
+  :use-module (vulgar)
+  :use-module (util options)
+  )
+
+(define options
+  '((date (value #t) (single-char #\d)
+          (description "Which date to start on."))
+    (help (single-char #\t) (description "Print this help."))
+    ))
+
+(define (main args)
+  (define opts (getopt-long args (getopt-opt options)))
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help options)
+    (throw 'return))
+
+  (let ((date (or (and=> (option-ref opts 'date #f) parse-freeform-date)
+                  (current-date))))
+    (with-vulgar
+     (lambda () (main-loop date))))
+)
diff --git a/module/calp/entry-points/text.scm b/module/calp/entry-points/text.scm
new file mode 100644
index 00000000..04f57a31
--- /dev/null
+++ b/module/calp/entry-points/text.scm
@@ -0,0 +1,29 @@
+(define-module (calp entry-points text)
+  :export (main)
+  :use-module (text flow)
+  :use-module (ice-9 getopt-long)
+  :use-module (util io)
+  :use-module (util options)
+  )
+
+
+(define options
+  '((width (value #t) (single-char #\w)
+           (description "Width of written text, defaults to 70 chars."))
+    (file (value #t) (single-char #\f)
+          (description "Read from " (i "file") " instead of standard input."))
+    (help (single-char #\h)
+          (description "Prints this help."))))
+
+(define (main args)
+  (define opts (getopt-long args (getopt-opt options)))
+
+  (when (option-ref opts 'help #f)
+    (print-arg-help options)
+    (throw 'return))
+
+  (for-each (lambda (l) (display l) (newline))
+            (flow-text
+             (with-input-from-port (open-input-port (option-ref opts 'file "-"))
+               (@ (ice-9 rdelim) read-string))
+             #:width (or (string->number (option-ref opts 'width "")) 70))))