diff options
Diffstat (limited to 'module/main.scm')
-rw-r--r-- | module/main.scm | 202 |
1 files changed, 0 insertions, 202 deletions
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)))) |