1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
;; -*- 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."))
(version (single-char #\v)
(description "Display version, which is " ,(@ (calp) version) " btw."))
(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") " " (i "module") (br)
"Runs the procedure 'run-benchmark' from the module (calp benchmark " (i "module") ").")
(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 'version #f)
(format #t "Calp version ~a~%" (@ (calp) version))
(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 line ((@ (ice-9 rdelim) read-line) pipe))
(define names (string-split line #\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.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))
((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))))
|
