diff options
Diffstat (limited to 'module/calp')
| -rw-r--r-- | module/calp/entry-points/benchmark.scm | 33 | ||||
| -rw-r--r-- | module/calp/entry-points/html.scm | 150 | ||||
| -rw-r--r-- | module/calp/entry-points/ical.scm | 31 | ||||
| -rw-r--r-- | module/calp/entry-points/import.scm | 61 | ||||
| -rw-r--r-- | module/calp/entry-points/server.scm | 66 | ||||
| -rw-r--r-- | module/calp/entry-points/terminal.scm | 28 | ||||
| -rw-r--r-- | module/calp/entry-points/text.scm | 29 | ||||
| -rw-r--r-- | module/calp/main.scm | 202 |
8 files changed, 600 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)))) 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)))) |