diff options
Diffstat (limited to '')
-rw-r--r-- | module/calp/entry-points/server.scm | 5 | ||||
-rw-r--r-- | module/calp/html/config.scm | 9 | ||||
-rw-r--r-- | module/calp/html/filter.scm | 9 | ||||
-rw-r--r-- | module/calp/html/vcomponent.scm | 13 | ||||
-rw-r--r-- | module/calp/html/view/calendar.scm | 2 | ||||
-rw-r--r-- | module/calp/main.scm | 56 | ||||
-rw-r--r-- | module/calp/server/routes.scm | 6 | ||||
-rw-r--r-- | module/calp/util/config.scm | 173 | ||||
-rw-r--r-- | module/calp/util/exceptions.scm | 3 | ||||
-rw-r--r-- | module/datetime.scm | 5 | ||||
-rw-r--r-- | module/datetime/instance.scm | 2 | ||||
-rw-r--r-- | module/vcomponent.scm | 19 | ||||
-rw-r--r-- | module/vcomponent/config.scm | 16 | ||||
-rw-r--r-- | module/vcomponent/datetime/output.scm | 6 | ||||
-rw-r--r-- | module/vcomponent/util/instance.scm | 5 |
15 files changed, 110 insertions, 219 deletions
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))) |