cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

provide code for supplying and selecting default-actions (like (:system :stop))

Browse source
This commit is contained in:
Helmut Merz 2024-07-05 10:09:48 +02:00
parent 012999fc22
commit 9dbc637955
4 changed files with 21 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
core/core.lisp
View file

@ -46,13 +46,14 @@
((config :reader config :initarg :config) ((config :reader config :initarg :config)
(name :reader name :initarg :name) (name :reader name :initarg :name)
(actions :accessor actions :initform nil) (actions :accessor actions :initform nil)
(default-actions :reader default-actions :initform nil)
(services :reader services :initform (make-hash-table)))) (services :reader services :initform (make-hash-table))))
(defun default-setup (cfg &optional (cls 'context)) (defun default-setup (cfg &optional (cls 'context))
(make-instance cls :config cfg :name (config:name cfg))) (make-instance cls :config cfg :name (config:name cfg)))
(defun find-service (name) (defun find-service (name &optional (parent *root*))
(with-slots (services) *root* (with-slots (services) parent
(when services (when services
(gethash name services)))) (gethash name services))))
@ -84,13 +85,21 @@
(defgeneric send (rcvr msg) (defgeneric send (rcvr msg)
(:method ((rcvr context) msg) (:method ((rcvr context) msg)
(let* ((acts (actions rcvr)) (handle-message rcvr msg)))
(hdlrs (select msg acts)))
(if hdlrs (defgeneric handle-message (ctx msg)
(dolist (hdlr hdlrs) (:method ((ctx context) msg)
(funcall hdlr rcvr msg)) (if (not (do-actions ctx msg))
(if (not (do-actions ctx msg #'default-actions))
(log:warn "no action selected for ~s" msg))))) (log:warn "no action selected for ~s" msg)))))
(defun do-actions (ctx msg &optional (acts #'actions))
(let ((hdlrs (select msg (funcall acts ctx))))
(when hdlrs
(dolist (hdlr hdlrs)
(funcall hdlr ctx msg))
t)))
;;;; simple printer service ;;;; simple printer service
(defun do-print (ctx msg) (defun do-print (ctx msg)

2
logging.lisp
View file

@ -17,7 +17,7 @@
(defun setup(cfg) (defun setup(cfg)
(let ((loglevel (config:from-env :loglevel (loglevel cfg))) (let ((loglevel (config:from-env :loglevel (loglevel cfg)))
(logfile (config:from-env :logfile (logfile cfg))) (logfile (config:from-env :logfile (logfile cfg)))
(pat "%&%<%I%;<;;>;-5p [%D{%H:%M:%S}] %g{}{}{:downcase}:%2.2N%C{1}{}{:downcase} - %:_%m%>%n") (pat "%&%<%I%;<;;>;-5p [%D{%H:%M:%S}] %g{}{}{:downcase}:%2.2N%c{1}{}{:downcase} - %:_%m%>%n")
params) params)
(if (stringp loglevel) (if (stringp loglevel)
(setf loglevel (util:to-keyword loglevel))) (setf loglevel (util:to-keyword loglevel)))

2
test/etc/config-web.lisp
View file

@ -7,7 +7,7 @@
(config:add :logger :class 'logging:config (config:add :logger :class 'logging:config
:loglevel :info :loglevel :info
:logfile (t:test-path "scopes-test.log" "log") :logfile (t:test-path "scopes-test.log" "log")
:console t) :console nil)
(config:add :server :class 'server:config (config:add :server :class 'server:config
:port "8899" :port "8899"

4
web/server.lisp
View file

@ -23,6 +23,8 @@
(defun app (ctx env) (defun app (ctx env)
;(print env) ;(print env)
(log:info "request: ~a ~a" (getf env :request-method) (getf env :request-uri))
(log:info "headers: ~s" (alx:hash-table-plist (getf env :headers)))
(funcall (select-app ctx env))) (funcall (select-app ctx env)))
(defun start (ctx) (defun start (ctx)
@ -33,7 +35,7 @@
:address (address cfg) :address (address cfg)
;:server :woo ;:server :woo
:silent t)) :silent t))
(log:info "server started on port ~a." (port cfg)))) (log:info "port: ~a." (port cfg))))
(defun stop (ctx) (defun stop (ctx)
(clack:stop (listener ctx))) (clack:stop (listener ctx)))