aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--config.scm12
-rw-r--r--module/calp/entry-points/server.scm5
-rw-r--r--module/calp/html/config.scm9
-rw-r--r--module/calp/html/filter.scm9
-rw-r--r--module/calp/html/vcomponent.scm13
-rw-r--r--module/calp/html/view/calendar.scm2
-rw-r--r--module/calp/main.scm56
-rw-r--r--module/calp/server/routes.scm6
-rw-r--r--module/calp/util/config.scm173
-rw-r--r--module/calp/util/exceptions.scm3
-rw-r--r--module/datetime.scm5
-rw-r--r--module/datetime/instance.scm2
-rw-r--r--module/vcomponent.scm19
-rw-r--r--module/vcomponent/config.scm16
-rw-r--r--module/vcomponent/datetime/output.scm6
-rw-r--r--module/vcomponent/util/instance.scm5
-rwxr-xr-xscripts/get-config.scm6
-rwxr-xr-xstart4
-rw-r--r--system/config.scm10
19 files changed, 126 insertions, 235 deletions
diff --git a/config.scm b/config.scm
index 606384e9..8a24bc6a 100644
--- a/config.scm
+++ b/config.scm
@@ -7,7 +7,7 @@
(sxml xpath)
)
-(set-config! 'calendar-files (glob "~/.local/var/cal/*"))
+((@ (vcomponent config) calendar-files) (glob "~/.local/var/cal/*"))
(define my-courses
'((TSEA82 . "Datorteknik")
@@ -20,7 +20,7 @@
(define* (aref alist key optional: default)
(or (assoc-ref alist key) default key))
-(set-config! 'summary-filter
+((@ (calp html filter) summary-filter)
(lambda (ev str)
(regexp-substitute/global
#f "T[A-Z]{3}[0-9]{2}" str
@@ -83,7 +83,7 @@
"LiTHe kod"
"Klassfadder 2020"))
-(set-config! 'description-filter
+((@ (calp html filter) description-filter)
(lambda (ev str)
(cond [(member (prop (parent ev) 'NAME)
html-cals)
@@ -92,6 +92,6 @@
(parse-teams-description str)]
[else (parse-links str)])))
-(set-config! 'week-start mon)
-(set-config! 'default-calendar "Calendar")
-(set-config! 'path-prefix (car (glob "~/.local")))
+((@ (datetime) week-start) mon)
+((@ (vcomponent config) default-calendar) "Calendar")
+;; (set-config! 'path-prefix (car (glob "~/.local")))
diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm
index 1888a8a7..a4e8137a 100644
--- a/module/calp/entry-points/server.scm
+++ b/module/calp/entry-points/server.scm
@@ -38,9 +38,8 @@ and <i>[::]</i> for IPv6</group>"))))
(define opts (getopt-long args (getopt-opt options)))
(define addr (option-ref opts 'addr #f))
- (define port (or (and=> (option-ref opts 'port #f)
- string->number)
- (get-config 'port)))
+ (define port (cond ((option-ref opts 'port #f) => string->number)
+ (else (port))))
(define family
(cond [(option-ref opts 'six #f) AF_INET6]
[(option-ref opts 'four #f) AF_INET]
diff --git a/module/calp/html/config.scm b/module/calp/html/config.scm
index 08a4b2e8..c5a4e4c0 100644
--- a/module/calp/html/config.scm
+++ b/module/calp/html/config.scm
@@ -4,16 +4,11 @@
:use-module (calp translation)
)
-(define-public debug (make-parameter #f))
(define-config debug #f
- description: (_ "Places the generated thingy in debug mode")
- post: debug)
+ description: (_ "Places the generated thingy in debug mode"))
;;; NOTE edit mode should preferably depend on login-status of the user
;;; but this works for the time being.
-(define-public edit-mode (make-parameter #t))
(define-config edit-mode #t
- description: (_ "Makes the document editable")
- post: edit-mode)
-
+ description: (_ "Makes the document editable"))
diff --git a/module/calp/html/filter.scm b/module/calp/html/filter.scm
new file mode 100644
index 00000000..a3ef6209
--- /dev/null
+++ b/module/calp/html/filter.scm
@@ -0,0 +1,9 @@
+(define-module (calp html filter)
+ :use-module (calp util config)
+ )
+
+(define-config summary-filter (lambda (_ a) a)
+ pre: (ensure procedure?))
+
+(define-config description-filter (lambda (_ a) a)
+ pre: (ensure procedure?))
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm
index 16189dff..91db44e6 100644
--- a/module/calp/html/vcomponent.scm
+++ b/module/calp/html/vcomponent.scm
@@ -25,22 +25,17 @@
:use-module ((base64) :select (base64encode))
:use-module (ice-9 format)
:use-module (calp translation)
+ :use-module (calp html filter)
)
-(define-config summary-filter (lambda (_ a) a)
- pre: (ensure procedure?))
-
-(define-config description-filter (lambda (_ a) a)
- pre: (ensure procedure?))
-
(define-public (format-summary ev str)
- ((get-config 'summary-filter) ev str))
+ ((summary-filter) ev str))
;; NOTE this should have information about context (html/term/...)
;; And then be moved somewhere else.
(define-public (format-description ev str)
- (catch* (lambda () ((get-config 'description-filter) ev str))
+ (catch* (lambda () ((description-filter) ev str))
(configuration-error
(lambda (key subr msg args data)
(format (current-error-port)
@@ -396,7 +391,7 @@
(select (@ (class "calendar-selection"))
;; NOTE flytta "muffarna" utanför
(option ,(_ "- Choose a Calendar -"))
- ,@(let ((dflt (get-config 'default-calendar)))
+ ,@(let ((dflt ((@ (vcomponent) default-calendar))))
(map (lambda (calendar)
(define name (prop calendar 'NAME))
`(option (@ (value ,(base64encode name))
diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index d4ad2977..aef33f36 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -107,7 +107,7 @@
EDIT_MODE=~:[false~;true~];
window.default_calendar='~a';"
(edit-mode)
- (base64encode (get-config 'default-calendar))))
+ (base64encode ((@ (vcomponent) default-calendar)))))
(style ,(format #f "html {
diff --git a/module/calp/main.scm b/module/calp/main.scm
index e5388ae0..9b3676dd 100644
--- a/module/calp/main.scm
+++ b/module/calp/main.scm
@@ -6,7 +6,6 @@
:use-module (srfi srfi-1)
:use-module (srfi srfi-88) ; keyword syntax
- :use-module ((calp util config) :select (set-config! get-config get-configuration-documentation))
:use-module (hnh util options)
:use-module ((calp util hooks) :select (shutdown-hook))
@@ -50,16 +49,13 @@ contain all events.
(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
- ,(xml->sxml (_ "<group>Set configuration options, on the form <i>key</i>=<i>value</i>
-as if they were set in the config file. These options have priority over those
-from the file. Can <i>not</i> be given with an equal after --option. <br/>Can
-be given multiple times.</group>"))))
+ (debug (single-char #\d)
+ (description
+ ,(_ "Turns on debug mode for HTML output")))
+
+ (edit-mode
+ (description
+ ,(_ "Makes generated HTML user editable (through JS)")))
(version (single-char #\v)
(description ,(format #f (_ "Display version, which is ~a btw.")
@@ -70,10 +66,7 @@ be given multiple times.</group>"))))
(help (single-char #\h)
(description ,(_ "Print this help")))
- (printconf (description ,(xml->sxml (_ "<group>Print known configuration variables.
-<br/><b>NOTE</b>:
-Only those configuration variables which are loaded will be shown, more might be
-available</group>"))))))
+ ))
(define module-help
(xml->sxml
@@ -176,22 +169,12 @@ the same code as <b>ical</b>.</p>")
args
)))
+ (awhen (option-ref opts 'edit-mode #f)
+ ((@ (calp html config) edit-mode) #t))
+ (awhen (option-ref opts 'debug #f)
+ ((@ (calp html config) debug) #t))
- ;; 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.
@@ -201,16 +184,6 @@ the same code as <b>ical</b>.</p>")
(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))
@@ -230,8 +203,9 @@ the same code as <b>ical</b>.</p>")
((@ (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)))))
+ (write `((@ (datetime instance) 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")))
diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm
index e3237914..8c416585 100644
--- a/module/calp/server/routes.scm
+++ b/module/calp/server/routes.scm
@@ -111,12 +111,8 @@
-(define static-dir (make-parameter "static"))
-
(define-config static-dir "static"
- description: "Where static files for the web server are located"
- post: static-dir
- )
+ description: (_ "Where static files for the web server are located"))
diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm
index 3bc55d92..b2a46ea7 100644
--- a/module/calp/util/config.scm
+++ b/module/calp/util/config.scm
@@ -7,143 +7,58 @@
(define-module (calp util config)
:use-module (hnh util)
:use-module (srfi srfi-1)
- :use-module (ice-9 format) ; for format-procedure
:use-module (ice-9 curried-definitions) ; for ensure
:use-module (calp translation)
:export (define-config)
)
-(define-once config-values (make-hash-table))
-
-;; properties declared before being bound into hash-map
-;; to allow nicer scripting in this file.
-
-(define-once config-properties (make-hash-table))
-(define description (make-object-property))
-(define source-module (make-object-property))
-(define pre (make-object-property))
-(define post (make-object-property))
-(hashq-set! config-properties #:description description)
-(hashq-set! config-properties #:source-module source-module)
-(hashq-set! config-properties #:pre pre)
-(hashq-set! config-properties #:post post)
-
-
-;; Config cells "are" immutable. @var{set-property!} is
-;; therefore intentionally unwritten.
-
-(define-public (get-property config-name property-key)
- ((hashq-ref config-properties property-key) config-name))
-
-
-(define (define-config% name default-value kwargs)
- (for (key value) in (group kwargs 2)
- (aif (hashq-ref config-properties key)
- (set! (it name) value)
- (scm-error 'configuration-error
- "define-config"
- (_ "No configuration slot named ~s, when defining ~s")
- (list key name)
- #f)))
- (set-config! name (get-config name default-value)))
-
-(define-syntax define-config
- (syntax-rules ()
- ((_ name default kwargs ...)
- (define-config% (quote name) default
- (list source-module: (current-module)
- kwargs ...)))))
-
-(define-public (set-config! name value)
- (hashq-set! config-values name
- (aif (pre name)
- (or (it value)
- (scm-error 'configuration-error
- "set-config!"
- ;; first slot is property name, second is new
- ;; property value.
- (_ "Pre-property failed when setting ~s to ~s")
- (list name value)
- #f))
- value))
-
- (awhen (post name) (it value)))
-
-;; unique symbol here since #f is a valid configuration value.
-(define %uniq (gensym))
-(define*-public (get-config key optional: (default %uniq))
- (if (eq? default %uniq)
- (let ((v (hashq-ref config-values key %uniq)))
- (when (eq? v %uniq)
- (scm-error 'configuration-error
- "get-config"
- (_ "No configuration item named ~s")
- (list key) #f))
- v)
- (hashq-ref config-values key default)))
+(define (fix-keywords args)
+ (map (lambda (arg)
+ (if (keyword? (syntax->datum arg))
+ (syntax->datum arg)
+ arg))
+ args))
+
+(define %configuration-error
+ (_ "Pre-property failed when setting ~s to ~s"))
+
+(define-syntax (define-config stx)
+ (syntax-case stx ()
+ ((_ name default kw ...)
+ (let ((pre (cond ((memv pre: (fix-keywords #'(kw ...))) => cadr) (else #f)))
+ (post (cond ((memv post: (fix-keywords #'(kw ...))) => cadr) (else #f))))
+ #`(begin
+ (define-once name
+ (make-parameter
+ default
+ #,@(cond ((and pre post)
+ #`((lambda (new-value)
+ (cond ((#,pre new-value)
+ => (lambda (translated)
+ (#,post translated)
+ translated))
+ (else
+ (scm-error 'configuration-error
+ "set-config!"
+ %configuration-error
+ (list (quote name) new-value)))))))
+ (pre
+ #`((lambda (new-value)
+ (or (#,pre new-value)
+ (scm-error 'configuration-error
+ "set-config!"
+ %configuration-error
+ (list (quote name) new-value))))))
+ (post
+ #`((lambda (new-value)
+ (#,post new-value)
+ new-value))
+ )
+ (else #'()))))
+ (export name))))))
(define-public ((ensure predicate) value)
(if (predicate value)
value #f))
-
-
-
-;; (format-procedure (lambda (x y) ...)) => λx, y
-;; (define (f x) ...)
-;; (format-procedure f) => f(x)
-(define (format-procedure proc)
- ((aif (procedure-name proc)
- (lambda (s) (string-append (symbol->string it) "(" s ")"))
- (lambda (s) (string-append "λ" s)))
- (let ((args ((@ (ice-9 session) procedure-arguments)
- proc)))
- (string-join
- (remove null?
- (list
- (awhen ((ensure (negate null?))
- (assoc-ref args 'required))
- (format #f "~{~a~^, ~}" it))
- (awhen ((ensure (negate null?))
- (assoc-ref args 'optional))
- (format #f "[~{~a~^, ~}]" it))
- (awhen ((ensure (negate null?))
- (assoc-ref args 'keyword))
- (format #f "key: ~{~a~^, ~}"
- (map keyword->symbol
- (map car it))))
- (awhen ((ensure (negate null?))
- (assoc-ref args 'rest))
- (format #f "~a ..." it))))
- ", "))))
-
-(export format-procedure)
-
-;; TODO break this up into separate `get-all-configuration-items' and
-;; `format-configuration-items' procedures
-(define-public (get-configuration-documentation)
- (define groups
- (group-by (compose source-module car)
- (hash-map->list list config-values)))
-
- `(*TOP*
- (header ,(_ "Configuration variables"))
- (dl
- ,@(concatenate
- (for (module values) in groups
- `((dt "") (dd (header ,(aif module
- (->str (module-name it))
- #f)))
- ,@(concatenate
- (for (key value) in values
- `((dt ,key)
- (dd (p (@ (inline))
- ,(or (description key) "")))
- ;; Configuration variable value indicator
- (dt ,(_ "V:"))
- (dd ,(if (procedure? value)
- (format-procedure value)
- `(scheme ,value))
- (br)))))))))))
-
diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm
index 0588840e..5d6a71e8 100644
--- a/module/calp/util/exceptions.scm
+++ b/module/calp/util/exceptions.scm
@@ -5,4 +5,5 @@
(define-config warnings-are-errors #f
description: (_ "Crash on warnings.")
- post: warnings-are-errors)
+ post: (@ (hnh util exceptions) warnings-are-errors)
+ )
diff --git a/module/datetime.scm b/module/datetime.scm
index 478fc479..adff669a 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -48,11 +48,10 @@
;;; Configuration
-(define-public week-start (make-parameter sun))
+;; (define-public week-start (make-parameter sun))
(define-config week-start sun
description: "First day of week"
- pre: (ensure (lambda (x) (<= sun x sat)))
- post: week-start)
+ pre: (ensure (lambda (x) (<= sun x sat))))
;;; RECORD TYPES
diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm
index 2b060204..d9a304b2 100644
--- a/module/datetime/instance.scm
+++ b/module/datetime/instance.scm
@@ -23,7 +23,7 @@
(label self
(case-lambda
(()
- (define tz-list (get-config 'tz-list))
+ (define tz-list (tz-list))
(if (null? tz-list)
(warning (_ "Default zoneinfo only available when tz-dir and tz-list are configured"))
(self tz-list)))
diff --git a/module/vcomponent.scm b/module/vcomponent.scm
index 7618084c..0f000ba5 100644
--- a/module/vcomponent.scm
+++ b/module/vcomponent.scm
@@ -1,26 +1,17 @@
(define-module (vcomponent)
:use-module (hnh util)
- :use-module (calp util config)
:use-module (vcomponent base)
+ :use-module (vcomponent config)
;; :use-module ((vcomponent util instance methods)
;; :select (make-vcomponent))
:use-module ((vcomponent util parse-cal-path)
:select (parse-cal-path))
- :re-export (make-vcomponent parse-cal-path))
+ :re-export (make-vcomponent
+ parse-cal-path
+ ;; configuration items
+ calendar-files default-calendar))
(define cm (module-public-interface (current-module)))
(module-use! cm (resolve-interface '(vcomponent base)))
(module-use! cm (resolve-interface '(vcomponent util instance methods)))
-
-(define-config calendar-files '()
- description: "Which files to parse. Takes a list of paths or a single string which will be globbed."
- pre: (lambda (v)
- (cond [(list? v) v]
- [(string? v) ((@ (glob) glob) v)]
- [else #f])))
-
-(define-config default-calendar ""
- description: "Default calendar to use for operations. Set to empty string to unset"
- pre: (ensure string?))
-
diff --git a/module/vcomponent/config.scm b/module/vcomponent/config.scm
new file mode 100644
index 00000000..b2598207
--- /dev/null
+++ b/module/vcomponent/config.scm
@@ -0,0 +1,16 @@
+(define-module (vcomponent config)
+ :use-module (hnh util)
+ :use-module (calp translation)
+ :use-module (calp util config))
+
+(define-config calendar-files '()
+ description: (_ "Which files to parse. Takes a list of paths or a single string which will be globbed.")
+ pre: (lambda (v)
+ (cond [(list? v) v]
+ [(string? v) ((@ (glob) glob) v)]
+ [else #f])))
+
+(define-config default-calendar ""
+ description: (_ "Default calendar to use for operations. Set to empty string to unset")
+ pre: (ensure string?))
+
diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm
index fe909ebb..8cb55782 100644
--- a/module/vcomponent/datetime/output.scm
+++ b/module/vcomponent/datetime/output.scm
@@ -4,6 +4,7 @@
:use-module (vcomponent base)
:use-module (text util)
:use-module (calp translation)
+ :use-module ((hnh util exceptions) :select (warning))
:use-module ((vcomponent recurrence display) :select (format-recurrence-rule))
)
@@ -38,11 +39,12 @@
"."))
(define-public (format-summary ev str)
- ((get-config 'summary-filter) ev str))
+ ((@ (calp html filter) summary-filter) ev str))
;; NOTE this should have information about context (html/term/...)
(define-public (format-description ev str)
- (catch #t (lambda () ((get-config 'description-filter) ev str))
+ (catch #t (lambda () ((@ (calp html filter) description-filter)
+ ev str))
(lambda (err . args)
;; Warning message for failure to format description.
;; First argument is name of warning/error,
diff --git a/module/vcomponent/util/instance.scm b/module/vcomponent/util/instance.scm
index d17b672a..038c6505 100644
--- a/module/vcomponent/util/instance.scm
+++ b/module/vcomponent/util/instance.scm
@@ -1,6 +1,5 @@
(define-module (vcomponent util instance)
:use-module (hnh util)
- :use-module ((calp util config) :select (get-config))
:use-module ((oop goops) :select (make))
:use-module (calp translation)
:export (global-event-object)
@@ -14,10 +13,10 @@
;; evaluate this to early.
(define-once global-event-object
(make (@@ (vcomponent util instance methods) <events>)
- calendar-files: (get-config 'calendar-files)))
+ calendar-files: ((@ (vcomponent config) calendar-files))))
(define-public (reload)
(let ((new-value (make (@@ (vcomponent util instance methods) <events>)
- calendar-files: (get-config 'calendar-files))))
+ calendar-files: ((@ (vcomponent config) calendar-files)))))
(format (current-error-port) (_ "Reload done~%"))
(set! global-event-object new-value)))
diff --git a/scripts/get-config.scm b/scripts/get-config.scm
index 0351b768..f1088c8e 100755
--- a/scripts/get-config.scm
+++ b/scripts/get-config.scm
@@ -10,9 +10,9 @@
(add-to-load-path "module")
-(use-modules
- (hnh util)
- (ice-9 ftw)
+(use-modules
+ (hnh util)
+ (ice-9 ftw)
(ice-9 match)
(srfi srfi-1)
)
diff --git a/start b/start
index b8d48cc4..2363d428 100755
--- a/start
+++ b/start
@@ -20,9 +20,9 @@ port=`find_port {8080..9000}`
echo "Starting on $port"
$(dirname $(realpath $0))/main \
- -o debug=#t \
- -o edit-mode=#t \
--repl=$XDG_RUNTIME_DIR/calp \
+ --debug \
+ --edit-mode \
server \
--port "$port" \
--sigusr
diff --git a/system/config.scm b/system/config.scm
index 6e765fcb..6e6defe6 100644
--- a/system/config.scm
+++ b/system/config.scm
@@ -3,7 +3,7 @@
((datetime) :select (mon))
(glob))
-(set-config! 'calendar-files (glob "/var/lib/calp/.local/var/cal/*"))
+((@ (vcomponent) calendar-files) (glob "/var/lib/calp/.local/var/cal/*"))
(define (parse-links str)
(define regexp (make-regexp "https?://\\S+"))
@@ -15,11 +15,11 @@
(a (match:substring m))
(recur (match:suffix m)))))))
-(set-config! 'description-filter
+((@ (calp html vcomponent) description-filter)
(lambda (ev str) (parse-links str)))
-(set-config! 'week-start mon)
+((@ (datetime) week-start) mon)
;; (set-config! 'default-calendar "Calendar")
-(set-config! 'port 8082)
-(set-config! 'edit-mode #t)
+((@ (calp entry-points server) port) 8082)
+((@ (calp html config) edit-mode) #t)
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 19:59:57 +0200