96 lines
3.1 KiB
Common Lisp
96 lines
3.1 KiB
Common Lisp
;;;; cl-scopes/config
|
|
|
|
;;;; Utilities for configuration of scopes services.
|
|
|
|
(defpackage :scopes/config
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:util :scopes/util))
|
|
(:export #:base #:root #:*root* #:*current*
|
|
#:env-data #:env-keys #:env-prefix #:env-path #:from-env
|
|
#:actions #:add #:add-action #:add-actions #:children
|
|
#:name #:setup #:parent #:shutdown))
|
|
|
|
(in-package :scopes/config)
|
|
|
|
;;;; common base class for all config classes
|
|
|
|
(defclass common ()
|
|
((children :accessor children
|
|
:initarg children
|
|
:initform nil)))
|
|
|
|
(defgeneric parent (cfg)
|
|
(:method ((cfg common)) nil))
|
|
|
|
;;;; config root (top-level) class with no parent
|
|
|
|
(defvar *root* nil)
|
|
(defvar *current* nil)
|
|
|
|
(defclass root (common)
|
|
((env-keys :reader env-keys :initarg :env-keys :initform nil)
|
|
(env-prefix :reader env-prefix :initarg :env-prefix :initform "SCOPES_")
|
|
(env-path :reader env-path :initarg :env-path :initform nil)
|
|
(env-data :accessor env-data :initform (make-hash-table))))
|
|
|
|
(defmethod initialize-instance :after ((cfg root) &key &allow-other-keys)
|
|
(let* ((data (env-data cfg))
|
|
(prefix (env-prefix cfg))
|
|
(ep (env-path cfg))
|
|
(dotenv-data (if ep (dotenv:read-env ep))))
|
|
(dolist (sl (env-keys cfg))
|
|
(let* ((key (str:concat prefix (string sl)))
|
|
(env-val (uiop:getenv key))
|
|
(dotenv-val (if dotenv-data (gethash key dotenv-data))))
|
|
(if env-val
|
|
(setf (gethash sl data) env-val)
|
|
(when dotenv-val
|
|
(setf (uiop:getenv key) dotenv-val)
|
|
(setf (gethash sl data) dotenv-val)))))))
|
|
|
|
(defun root (&rest params &key (class 'root) &allow-other-keys)
|
|
(setf *root* (apply #'make-instance class params)))
|
|
|
|
;;;; config base class
|
|
|
|
(defclass base (common)
|
|
((name :reader name :initarg :name)
|
|
(parent :accessor parent :initarg :parent)
|
|
(setup :reader setup :initarg :setup :initform #'(lambda (cfg)))
|
|
(shutdown :reader shutdown :initarg :shutdown :initform #'(lambda (ctx)))
|
|
(actions :accessor actions :initarg :actions :initform nil)))
|
|
|
|
(defmethod initialize-instance :after ((cfg base) &key parent &allow-other-keys)
|
|
(if parent
|
|
(push cfg (children parent))))
|
|
|
|
(defmethod (setf parent) ((cfg base) (parent common))
|
|
(setf (parent cfg) parent)
|
|
(push cfg (children parent)))
|
|
|
|
(defun add (name &rest params
|
|
&key (class 'base) (parent *root*)
|
|
&allow-other-keys)
|
|
(setf *current* (apply #'make-instance class :parent parent :name name params)))
|
|
|
|
(defun add-action (pattern handler &rest params &key (cfg *current*))
|
|
(if params
|
|
(setf handler #'(lambda (ctx msg) (apply handler ctx msg params))))
|
|
(push (list pattern handler) (actions cfg)))
|
|
|
|
(defun add-actions (&rest acts)
|
|
(dolist (act acts)
|
|
(apply #'add-action (car act) (cadr act) (cddr act))))
|
|
|
|
;;;; utility functions
|
|
|
|
(defun from-env (key &optional (default ""))
|
|
(or (gethash key (env-data *root*)) default))
|
|
|
|
(defun hash-to-slots (ht obj slots)
|
|
(if ht
|
|
(dolist (sl slots)
|
|
(let* ((key (intern (string sl) :keyword))
|
|
(val (gethash key ht)))
|
|
(if val
|
|
(setf (slot-value obj sl) val))))))
|