From 6a219c59e6506ee5326822a7ced0e6cd92b7b628 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 17 Aug 2020 17:52:01 +0200 Subject: Move a bunch of files into calp module. --- main | 2 +- module/calp/entry-points/benchmark.scm | 33 ++++++ module/calp/entry-points/html.scm | 150 ++++++++++++++++++++++++ module/calp/entry-points/ical.scm | 31 +++++ module/calp/entry-points/import.scm | 61 ++++++++++ module/calp/entry-points/server.scm | 66 +++++++++++ module/calp/entry-points/terminal.scm | 28 +++++ module/calp/entry-points/text.scm | 29 +++++ module/calp/main.scm | 202 +++++++++++++++++++++++++++++++++ module/entry-points/benchmark.scm | 33 ------ module/entry-points/html.scm | 150 ------------------------ module/entry-points/ical.scm | 31 ----- module/entry-points/import.scm | 61 ---------- module/entry-points/server.scm | 66 ----------- module/entry-points/terminal.scm | 28 ----- module/entry-points/text.scm | 29 ----- module/main.scm | 202 --------------------------------- 17 files changed, 601 insertions(+), 601 deletions(-) create mode 100644 module/calp/entry-points/benchmark.scm create mode 100644 module/calp/entry-points/html.scm create mode 100644 module/calp/entry-points/ical.scm create mode 100644 module/calp/entry-points/import.scm create mode 100644 module/calp/entry-points/server.scm create mode 100644 module/calp/entry-points/terminal.scm create mode 100644 module/calp/entry-points/text.scm create mode 100644 module/calp/main.scm delete mode 100644 module/entry-points/benchmark.scm delete mode 100644 module/entry-points/html.scm delete mode 100644 module/entry-points/ical.scm delete mode 100644 module/entry-points/import.scm delete mode 100644 module/entry-points/server.scm delete mode 100644 module/entry-points/terminal.scm delete mode 100644 module/entry-points/text.scm delete mode 100644 module/main.scm diff --git a/main b/main index af2f489a..67e30973 100755 --- a/main +++ b/main @@ -6,4 +6,4 @@ here=$(dirname $(realpath $0)) GUILE=${GUILE:-$(which guile)} # GUILE_LOAD_PATH=$here/module -exec $GUILE -c '((@ (main) main) (command-line))' "$@" +exec $GUILE -c '((@ (calp main) main) (command-line))' "$@" 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)))) diff --git a/module/calp/main.scm b/module/calp/main.scm new file mode 100644 index 00000000..2e08fd0f --- /dev/null +++ b/module/calp/main.scm @@ -0,0 +1,202 @@ +;; -*- geiser-scheme-implementation: guile -*- +(define-module (calp main) + :use-module (util) + + :use-module (srfi srfi-1) + :use-module (srfi srfi-88) ; keyword syntax + + :use-module ((util config) :select (set-config! get-config get-configuration-documentation)) + :use-module (util options) + :use-module ((util hooks) :select (shutdown-hook)) + :use-module (directories) + + :use-module ((text markup) :select (sxml->ansi-text)) + + :use-module (ice-9 getopt-long) + :use-module (ice-9 regex) + :use-module ((ice-9 popen) :select (open-input-pipe)) + + :use-module (statprof) + :use-module (repl) + + ) + + +(define options + '((statprof (value display-style) + (description "Run the program within Guile's built in statical " + "profiler. Display style is one of " + (b "flat") " or " (b "tree") ".")) + (repl (value address) + (description + "Start a Guile repl which can be connected to, defaults to the unix socket " + (i "/run/user/${UID}/calp-${PID}") ", but it can be bound to any unix or " + "TCP socket. ((@ (vcomponent instance) global-event-object)) " + "should contain all events." + (br) + (b "Should NOT be used in production."))) + + (config (value #t) + (description + "Path to alterantive configuration file to load instead of the default one. ")) + + ;; Techical note: + ;; Guile's getopt doesn't support repeating keys. Thereby the small jank, + ;; and my regex hack below. + (option (single-char #\o) + (value #t) + (description + "Set configuration options, on the form " + (i "key") "=" (i "value") + " as if they were set in the config file. These options have " + "priority over those from the file. " + "Can " (i "not") " be given with an equal after --option." + (br) "Can be given multiple times.")) + + (update-zoneinfo) + + (help (single-char #\h) + (description "Print this help")))) + +(define module-help + '(*TOP* (br) + (center (b "Calp")) (br) (br) + "Usage: " (b "calp") " [ " (i flags) " ] " (i mode) " [ " (i "mode flags") " ]" (br) + + (hr) + (center (b "Modes")) (br) (br) + + (p (b "html") " reads calendar files from disk, and writes them to static HTML files.") + + (p (b "terminal") " loads the calendars, and startrs an interactive terminal interface.") + + "[UNTESTED]" (br) + (p (b "import") "s an calendar object into the database.") + + (p (b "text") " formats and justifies what it's given on standard input, " + "and writes it to standard output. Similar to this text.") + + (p (b "ical") " loads the calendar database, and imideately " + "reserializes it back into ICAL format. " + "Useful for merging calendars.") + + (p (b "benchmark") " Forces a field from the current app. Preferably used together with " + (i "--statprof") " for some for profiling the code.") + + (p (b "server") " starts an HTTP server which dynamicly loads and displays event. The " + (i "/month/{date}.html") " & " (i "/week/{date}.html") " runs the same output code as " + (b "html") ". While the " (i "/calendar/{uid}.ics") " uses the same code as " (b "ical") ".") + + (hr) (br) + (center (b "Flags")) (br))) + +(define (ornull a b) + (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)) + + (when stprof (statprof-start)) + + (cond [(eqv? #t repl) (repl-start (format #f "~a/calp-~a" + runtime-directory (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 user-config-directory "/config.scm") + (path-append system-config-directory "/config.scm"))) + (primitive-load it))) + + + ;; NOTE this doesn't stop at first non-option, meaning that -o flags + ;; from sub-commands might be parsed. + (map (lambda (pair) + (let* (((key value) (string-split (cadr pair) #\=))) + (set-config! (string->symbol key) + (let ((form (call-with-input-string value read))) + (if (list? form) + (primitive-eval form) + form))))) + (filter (lambda (p) + ;; should match `--option', as well as a single flag with any + ;; number of other options, as long as the last one is `o'. + (string-match "^-(-option|[^-]*o)$" (car p))) + (zip args (cdr args)))) + + ;; help printing moved below some other stuff to allow + ;; print-configuration-and-return to show bound values. + (awhen (option-ref opts 'help #f) + (display (sxml->ansi-text module-help) + (current-output-port)) + (print-arg-help options) + (display (sxml->ansi-text + ;; NOTE that this can only display config + ;; items in loaded modules. + ;; See scripts/get-config.scm for finding + ;; all configuration items. + (get-configuration-documentation)) + (current-output-port)) + (throw 'return) + ) + + (when (option-ref opts 'update-zoneinfo #f) + (let ((pipe + (let-env ((PREFIX (get-config 'path-prefix))) + (open-input-pipe (path-append libexec "/tzget"))))) + + ;; (define path (read-line pipe)) + (define names (string-split ((@ (ice-9 rdelim) read-line) pipe) #\space)) + ((@ (util io) with-atomic-output-to-file) + (path-append data-directory "/zoneinfo.scm") + (lambda () + (write `(set-config! 'tz-list ',names)) (newline) + (write `(set-config! 'last-zoneinfo-upgrade ,((@ (datetime) current-date))) (newline)))))) + + ;; always load zoneinfo if available. + (let ((z (path-append data-directory "/zoneinfo"))) + (when (file-exists? z) + (primitive-load z))) + + + (let ((ropt (ornull (option-ref opts '() '()) + '("term")))) + ((case (string->symbol (car ropt)) + ((html) (@ (calp entry-points html) main)) + ((term) (@ (calp entry-points terminal) main)) + ((import) (@ (calp entry-points import) main)) + ((text) (@ (calp entry-points text) main)) + ((ical) (@ (calp entry-points ical) main)) + ((server) (@ (calp entry-points server) main)) + ((benchmark) (@ (calp entry-points benchmark) main)) + (else => (lambda (s) + (format (current-error-port) + "Unsupported mode of operation: ~a~%" + s) + (exit 1)))) + ropt)) + + (when stprof + (statprof-stop) + (statprof-display (current-error-port) + style: (if (boolean? stprof) + 'flat + (string->symbol stprof))))) + +(define-public (main args) + ((@ (util time) report-time!) "Program start") + (dynamic-wind (lambda () 'noop) + (lambda () (catch 'return (lambda () (wrapped-main args)) values)) + (lambda () (run-hook shutdown-hook)))) diff --git a/module/entry-points/benchmark.scm b/module/entry-points/benchmark.scm deleted file mode 100644 index fecc62f7..00000000 --- a/module/entry-points/benchmark.scm +++ /dev/null @@ -1,33 +0,0 @@ -(define-module (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/entry-points/html.scm b/module/entry-points/html.scm deleted file mode 100644 index de80f8d2..00000000 --- a/module/entry-points/html.scm +++ /dev/null @@ -1,150 +0,0 @@ -(define-module (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/entry-points/ical.scm b/module/entry-points/ical.scm deleted file mode 100644 index 997621b2..00000000 --- a/module/entry-points/ical.scm +++ /dev/null @@ -1,31 +0,0 @@ -(define-module (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/entry-points/import.scm b/module/entry-points/import.scm deleted file mode 100644 index 956ccc91..00000000 --- a/module/entry-points/import.scm +++ /dev/null @@ -1,61 +0,0 @@ -(define-module (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/entry-points/server.scm b/module/entry-points/server.scm deleted file mode 100644 index dfa94cc7..00000000 --- a/module/entry-points/server.scm +++ /dev/null @@ -1,66 +0,0 @@ -(define-module (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/entry-points/terminal.scm b/module/entry-points/terminal.scm deleted file mode 100644 index d44fb1e8..00000000 --- a/module/entry-points/terminal.scm +++ /dev/null @@ -1,28 +0,0 @@ -(define-module (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/entry-points/text.scm b/module/entry-points/text.scm deleted file mode 100644 index d6ebd72e..00000000 --- a/module/entry-points/text.scm +++ /dev/null @@ -1,29 +0,0 @@ -(define-module (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)))) diff --git a/module/main.scm b/module/main.scm deleted file mode 100644 index 4d3e01a6..00000000 --- a/module/main.scm +++ /dev/null @@ -1,202 +0,0 @@ -;; -*- geiser-scheme-implementation: guile -*- -(define-module (main) - :use-module (util) - - :use-module (srfi srfi-1) - :use-module (srfi srfi-88) ; keyword syntax - - :use-module ((util config) :select (set-config! get-config get-configuration-documentation)) - :use-module (util options) - :use-module ((util hooks) :select (shutdown-hook)) - :use-module (directories) - - :use-module ((text markup) :select (sxml->ansi-text)) - - :use-module (ice-9 getopt-long) - :use-module (ice-9 regex) - :use-module ((ice-9 popen) :select (open-input-pipe)) - - :use-module (statprof) - :use-module (repl) - - ) - - -(define options - '((statprof (value display-style) - (description "Run the program within Guile's built in statical " - "profiler. Display style is one of " - (b "flat") " or " (b "tree") ".")) - (repl (value address) - (description - "Start a Guile repl which can be connected to, defaults to the unix socket " - (i "/run/user/${UID}/calp-${PID}") ", but it can be bound to any unix or " - "TCP socket. ((@ (vcomponent instance) global-event-object)) " - "should contain all events." - (br) - (b "Should NOT be used in production."))) - - (config (value #t) - (description - "Path to alterantive configuration file to load instead of the default one. ")) - - ;; Techical note: - ;; Guile's getopt doesn't support repeating keys. Thereby the small jank, - ;; and my regex hack below. - (option (single-char #\o) - (value #t) - (description - "Set configuration options, on the form " - (i "key") "=" (i "value") - " as if they were set in the config file. These options have " - "priority over those from the file. " - "Can " (i "not") " be given with an equal after --option." - (br) "Can be given multiple times.")) - - (update-zoneinfo) - - (help (single-char #\h) - (description "Print this help")))) - -(define module-help - '(*TOP* (br) - (center (b "Calp")) (br) (br) - "Usage: " (b "calp") " [ " (i flags) " ] " (i mode) " [ " (i "mode flags") " ]" (br) - - (hr) - (center (b "Modes")) (br) (br) - - (p (b "html") " reads calendar files from disk, and writes them to static HTML files.") - - (p (b "terminal") " loads the calendars, and startrs an interactive terminal interface.") - - "[UNTESTED]" (br) - (p (b "import") "s an calendar object into the database.") - - (p (b "text") " formats and justifies what it's given on standard input, " - "and writes it to standard output. Similar to this text.") - - (p (b "ical") " loads the calendar database, and imideately " - "reserializes it back into ICAL format. " - "Useful for merging calendars.") - - (p (b "benchmark") " Forces a field from the current app. Preferably used together with " - (i "--statprof") " for some for profiling the code.") - - (p (b "server") " starts an HTTP server which dynamicly loads and displays event. The " - (i "/month/{date}.html") " & " (i "/week/{date}.html") " runs the same output code as " - (b "html") ". While the " (i "/calendar/{uid}.ics") " uses the same code as " (b "ical") ".") - - (hr) (br) - (center (b "Flags")) (br))) - -(define (ornull a b) - (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)) - - (when stprof (statprof-start)) - - (cond [(eqv? #t repl) (repl-start (format #f "~a/calp-~a" - runtime-directory (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 user-config-directory "/config.scm") - (path-append system-config-directory "/config.scm"))) - (primitive-load it))) - - - ;; NOTE this doesn't stop at first non-option, meaning that -o flags - ;; from sub-commands might be parsed. - (map (lambda (pair) - (let* (((key value) (string-split (cadr pair) #\=))) - (set-config! (string->symbol key) - (let ((form (call-with-input-string value read))) - (if (list? form) - (primitive-eval form) - form))))) - (filter (lambda (p) - ;; should match `--option', as well as a single flag with any - ;; number of other options, as long as the last one is `o'. - (string-match "^-(-option|[^-]*o)$" (car p))) - (zip args (cdr args)))) - - ;; help printing moved below some other stuff to allow - ;; print-configuration-and-return to show bound values. - (awhen (option-ref opts 'help #f) - (display (sxml->ansi-text module-help) - (current-output-port)) - (print-arg-help options) - (display (sxml->ansi-text - ;; NOTE that this can only display config - ;; items in loaded modules. - ;; See scripts/get-config.scm for finding - ;; all configuration items. - (get-configuration-documentation)) - (current-output-port)) - (throw 'return) - ) - - (when (option-ref opts 'update-zoneinfo #f) - (let ((pipe - (let-env ((PREFIX (get-config 'path-prefix))) - (open-input-pipe (path-append libexec "/tzget"))))) - - ;; (define path (read-line pipe)) - (define names (string-split ((@ (ice-9 rdelim) read-line) pipe) #\space)) - ((@ (util io) with-atomic-output-to-file) - (path-append data-directory "/zoneinfo.scm") - (lambda () - (write `(set-config! 'tz-list ',names)) (newline) - (write `(set-config! 'last-zoneinfo-upgrade ,((@ (datetime) current-date))) (newline)))))) - - ;; always load zoneinfo if available. - (let ((z (path-append data-directory "/zoneinfo"))) - (when (file-exists? z) - (primitive-load z))) - - - (let ((ropt (ornull (option-ref opts '() '()) - '("term")))) - ((case (string->symbol (car ropt)) - ((html) (@ (entry-points html) main)) - ((term) (@ (entry-points terminal) main)) - ((import) (@ (entry-points import) main)) - ((text) (@ (entry-points text) main)) - ((ical) (@ (entry-points ical) main)) - ((server) (@ (entry-points server) main)) - ((benchmark) (@ (entry-points benchmark) main)) - (else => (lambda (s) - (format (current-error-port) - "Unsupported mode of operation: ~a~%" - s) - (exit 1)))) - ropt)) - - (when stprof - (statprof-stop) - (statprof-display (current-error-port) - style: (if (boolean? stprof) - 'flat - (string->symbol stprof))))) - -(define-public (main args) - ((@ (util time) report-time!) "Program start") - (dynamic-wind (lambda () 'noop) - (lambda () (catch 'return (lambda () (wrapped-main args)) values)) - (lambda () (run-hook shutdown-hook)))) -- cgit v1.2.3