" "Calp" "
" (_ "Usage: calp [ flags ] mode [ mode flags ]") "
"
;; Header for following list of modes of operation
"" (_ "Modes") "
"
(_ "html reads calendar files from disk, and writes them to static HTML files.
")
(_ "terminal loads the calendars, and starts an interactive terminal interface.
")
(_ "[UNTESTED]
imports a calendar object into the database.
")
(_ "text formats and justifies what it's given on standard input,
and writes it to standard output. Similar to this text.
")
(_ "ical loads the calendar database, and immediately
re-serializes it back into iCAL format. Useful for merging calendars.
")
(_ "benchmark module
Runs the procedure 'run-benchmark'
from the module (calp benchmark module).
")
(_ "server starts an HTTP server which dynamically loads and
displays events. The /month/{date}.html & /week/{date}.html runs
the same output code as html. While the /calendar/{uid}.ics uses
the same code as ical.
")
"
"
;; Header for list of available flags.
;; Actual list is auto generated elsewhere.
"" (_ "Flags") "
")))
(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))
(define config-file
(cond [altconfig
(if (file-exists? altconfig)
altconfig
(throw 'option-error
(_ "Configuration file ~a missing") altconfig))]
;; altconfig could be placed in the list below. But I want to raise an error
;; if an explicitly given config is missing.
[(find file-exists?
(list
(path-append (xdg-config-home) "calp" "config.scm")
(path-append (xdg-sysconfdir) "calp" "config.scm")))
=> identity]))
(when stprof (statprof-start))
(cond [(eqv? #t repl) (repl-start (format #f "~a/calp-~a"
(xdg-runtime-dir)
(getpid)))]
[repl => repl-start])
;; Load config
;; Sandbox and "stuff" not for security from the user. The config script is
;; assumed to be "safe". Instead it's so we can control the environment in
;; which it is executed.
(catch #t
(lambda ()
(eval
`(begin
(use-modules (srfi srfi-1)
(srfi srfi-88)
(datetime)
(vcomponent)
(calp util config)
(glob))
,@(with-input-from-file config-file
(lambda ()
(let loop ((done '()))
(let ((form (read)))
(if (eof-object? form)
(reverse done)
(loop (cons form done))))))))
(make-sandbox-module
`(((guile) use-modules)
,@all-pure-and-impure-bindings
))
))
(lambda args
(format (current-error-port)
;; Two arguments:
;; Configuration file path,
;; thrown error arguments
(_ "Failed loading config file ~a~%~s~%")
config-file
args
)))
;; 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)
(throw 'return))
(awhen (option-ref opts 'printconf #f)
(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 'version #f)
(format #t (_ "Calp version ~a~%") (@ (calp) version))
(throw 'return))
(when (option-ref opts 'update-zoneinfo #f)
(let* ((locations (list "/usr/libexec/calp/tzget" (path-append (xdg-data-home) "tzget")))
(filename (or (find file-exists? locations)
(error (_ "tzget not installed, please put it in one of ~a") locations)))
(pipe (open-input-pipe filename)))
;; (define path (read-line pipe))
(define line ((@ (ice-9 rdelim) read-line) pipe))
(define names (string-split line #\space))
((@ (hnh util io) with-atomic-output-to-file)
(path-append (xdg-data-home) "calp" "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 (xdg-data-home) "calp" "zoneinfo.scm")))
(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))
((convert) (@ (calp entry-points convert) main))
((tidsrapport) (@ (calp entry-points tidsrapport) 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)
((@ (calp util time) report-time!) (_ "Program start"))
(with-throw-handler #t
(lambda ()
(dynamic-wind (lambda () 'noop)
(lambda () (catch 'return (lambda () (wrapped-main args)) values))
(lambda () (run-hook shutdown-hook))))
(lambda _
;; Finds any direct vcomponents (not in lists or similar) on the stack
;; and prints them.
(map (lambda (it)
(with-output-to-port (current-error-port)
(lambda () ((@ (vcomponent util describe) describe) it))))
(filter-stack (@ (vcomponent) vcomponent?) (make-stack #t))))))