From 6d34ac7359c8d49e8890fb7dcad2c1bae5a55e7d Mon Sep 17 00:00:00 2001 From: Helmut Merz Date: Sat, 22 Jun 2024 10:56:31 +0200 Subject: [PATCH] move additional config functionality from core to config --- config.lisp | 31 +++++++++++++++++++++---------- core/core.lisp | 25 +++++++------------------ test/etc/config-core.lisp | 6 +++--- test/etc/config-web.lisp | 5 +++-- test/test-web.lisp | 6 +++--- web/client.lisp | 11 +++++++++-- web/server.lisp | 4 ++-- 7 files changed, 48 insertions(+), 40 deletions(-) diff --git a/config.lisp b/config.lisp index fb765c4..c63b690 100644 --- a/config.lisp +++ b/config.lisp @@ -4,9 +4,9 @@ (defpackage :scopes/config (:use :common-lisp) - (:export #:base #:root + (:export #:base #:root #:*root* #:env-data #:env-keys #:env-prefix #:env-path - #:add #:children #:env-slots #:parent)) + #:actions #:add #:add-action #:children #:env-slots #:name #:setup #:parent)) (in-package :scopes/config) @@ -22,6 +22,8 @@ ;;;; config root (top-level) class with no parent +(defvar *root* nil) + (defclass root (common) ((env-keys :reader env-keys :initarg :env-keys @@ -48,12 +50,17 @@ (setf (gethash sl data) env-val) (setf (gethash sl data) dotenv-val)))))) +(defun root (&rest params) + (apply #'make-instance 'root params)) + ;;;; config base class (defclass base (common) ((env-slots :reader env-slots :initform nil :allocation :class) - (parent :reader parent - :initarg :parent))) + (name :reader name :initarg :name) + (parent :reader parent :initarg :parent) + (setup :reader setup :initarg :setup :initform #'(lambda (cfg))) + (actions :accessor actions :initarg :actions :initform nil))) (defmethod initialize-instance :after ((cfg base) &key parent &allow-other-keys) (when parent @@ -64,15 +71,19 @@ (push cfg (children parent)) (env-override cfg)) -(defgeneric add (cfg child) - (:method ((cfg common) (child base)) - (push child (children cfg)) - (setf (parent child) cfg) - (env-override child))) - (defmethod env-data ((cfg base)) (env-data (parent cfg))) +(defun add (parent name &rest params + &key (class 'base) + &allow-other-keys) + (apply #'make-instance class :parent parent :name name params)) + +(defun add-action (cfg pattern handler &rest params) + (if params + (setf handler #'(lambda (ctx msg) (apply handler ctx msg params)))) + (push (list pattern handler) (actions cfg))) + ;;;; utility functions (defun hash-to-slots (ht obj slots) diff --git a/core/core.lisp b/core/core.lisp index 5de430c..9d9916b 100644 --- a/core/core.lisp +++ b/core/core.lisp @@ -4,7 +4,7 @@ (:use :common-lisp) (:local-nicknames (:config :scopes/config) (:message :scopes/core/message)) - (:export #:root-config #:service-config #:add-config #:add-action + (:export #:service-config #:add-config #:add-action #:default-setup #:setup-services #:context #:*root* #:find-service #:config #:name #:send #:printer)) @@ -13,25 +13,14 @@ ;;;; config -(defclass config (config:root) ()) - -(defun root-config (&rest params) - (apply #'make-instance 'config params)) - (defclass service-config (config:base) - ((name :reader name :initarg :name) - (setup :reader setup :initarg :setup :initform #'default-setup) - (actions :accessor actions :initarg :actions :initform nil))) + ((setup :initform #'default-setup))) (defun add-config (parent name &rest params &key (setup #'default-setup) (class 'service-config) &allow-other-keys) (apply #'make-instance class :parent parent :name name :setup setup params)) -(defgeneric add-action (container pattern handler) - (:method ((cfg service-config) pattern handler) - (push (list pattern handler) (actions cfg)))) - ;;;; actions (defclass action-spec () @@ -70,7 +59,7 @@ (services :initform (make-hash-table)))) (defun default-setup (cfg &optional (cls 'context)) - (make-instance cls :config cfg :name (name cfg))) + (make-instance cls :config cfg :name (config:name cfg))) (defun find-service (name) (with-slots (services) *root* @@ -82,7 +71,7 @@ (dolist (c (config:children cfg)) (add-service *root* c))) -(defmethod add-action ((ctx context) pat hdlr) +(defun add-action (ctx pat hdlr) (let* ((acts (actions ctx)) (act (find-action pat acts))) (if act @@ -92,10 +81,10 @@ (defun add-service (ctx cfg) (with-slots (services) ctx - (let ((child (funcall (setup cfg) cfg))) - (dolist (a (actions cfg)) + (let ((child (funcall (config:setup cfg) cfg))) + (dolist (a (config:actions cfg)) (add-action child (car a) (cadr a))) - (setf (gethash (name cfg) services) child)))) + (setf (gethash (config:name cfg) services) child)))) (defgeneric send (rcvr msg) (:method ((rcvr context) msg) diff --git a/test/etc/config-core.lisp b/test/etc/config-core.lisp index 2de4288..b8ecf93 100644 --- a/test/etc/config-core.lisp +++ b/test/etc/config-core.lisp @@ -2,7 +2,7 @@ (in-package :scopes/test-core) -(setf *config* (core:root-config)) +(setf *config* (config:root)) -(let ((cfg (core:add-config *config* :test-receiver :setup #'setup))) - (core:add-action cfg '(:test) #'check-message)) +(let ((cfg (config:add *config* :test-receiver :setup #'setup))) + (config:add-action cfg '(:test) #'check-message)) diff --git a/test/etc/config-web.lisp b/test/etc/config-web.lisp index 323476f..28040a1 100644 --- a/test/etc/config-web.lisp +++ b/test/etc/config-web.lisp @@ -2,7 +2,7 @@ (in-package :scopes/test-web) -(setf *config* (core:root-config :env-keys '(:address :port))) +(setf *config* (config:root :env-keys '(:address :port))) (let ((cfg (core:add-config *config* :server :class 'server:config @@ -10,4 +10,5 @@ :port "8899")))) (let ((cfg (core:add-config *config* :client - :class 'client:config)))) + :class 'client:config + :base-url "http://localhost:8899")))) diff --git a/test/test-web.lisp b/test/test-web.lisp index 372fd0e..e021555 100644 --- a/test/test-web.lisp +++ b/test/test-web.lisp @@ -32,6 +32,6 @@ (== (parse-integer (server:port cfg)) 8899))) (t:deftest test-client () - (let ((cfg (core:config (core:find-service :client)))) - (== (client:url cfg) "http://localhost:8899") - (== (dexador:get (client:url cfg)) "Hello World!"))) + (let ((ctx (core:find-service :client))) + (== (client:base-url (core:config ctx)) "http://localhost:8899") + (== (client:send-request ctx nil) "Hello World!"))) diff --git a/web/client.lisp b/web/client.lisp index ea4fc14..ef3ec60 100644 --- a/web/client.lisp +++ b/web/client.lisp @@ -4,10 +4,17 @@ (:use :common-lisp) (:local-nicknames (:config :scopes/config) (:core :scopes/core)) - (:export #:config #:url)) + (:export #:config #:base-url + #:send-request)) (in-package :scopes/web/client) (defclass config (core:service-config) - ((url :reader url :initarg :url :initform "http://localhost:8899"))) + ((base-url :reader base-url + :initarg :base-url + :initform "http://localhost:8135"))) +;;;; client context (= service) + +(defun send-request (ctx msg) + (dex:get (base-url (core:config ctx)))) diff --git a/web/server.lisp b/web/server.lisp index 2237500..0ae6d1f 100644 --- a/web/server.lisp +++ b/web/server.lisp @@ -31,11 +31,11 @@ (defun stop () (clack:stop *listener*)) -;;;; context = service +;;;; server context (= service) (defclass context (core:context) ()) (defun setup (cfg) (prog1 - (make-instance 'context :config cfg :name (core:name cfg)) + (make-instance 'context :config cfg :name (config:name cfg)) (start cfg)))