123 lines
3.6 KiB
Common Lisp
123 lines
3.6 KiB
Common Lisp
;;;; cl-scopes/core - here comes the real action
|
|
|
|
(defpackage :scopes/core
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:config :scopes/config)
|
|
(:message :scopes/core/message)
|
|
(:shape :scopes/shape)
|
|
(:util :scopes/util)
|
|
(:alx :alexandria))
|
|
(:export #:action-spec
|
|
#:*root* #:default-setup #:default-actions
|
|
#:find-service #:setup-services
|
|
#:base-context #:context #:add-action #:config #:name #:send #:shutdown
|
|
#:handle-message
|
|
#:do-print #:echo))
|
|
|
|
(in-package :scopes/core)
|
|
|
|
;;;; actions
|
|
|
|
(defclass action-spec ()
|
|
((pattern :reader pattern :initarg :pattern :initform nil)
|
|
(handlers :accessor handlers :initarg :handlers)))
|
|
|
|
(defun select (msg acts)
|
|
(let ((h (shape:head msg))
|
|
(hdlrs nil))
|
|
(dolist (a acts)
|
|
(if (match (pattern a) h)
|
|
(dolist (hdlr (handlers a))
|
|
(push hdlr hdlrs))))
|
|
hdlrs))
|
|
;(nreverse hdlrs)))
|
|
|
|
(defun match (pat h)
|
|
(dolist (item pat)
|
|
(if (and item (not (eq item (pop h))))
|
|
(return-from match nil)))
|
|
t)
|
|
|
|
(defun find-action (pat acts)
|
|
(dolist (a acts)
|
|
(if (equal (pattern a) pat)
|
|
(return-from find-action a))))
|
|
|
|
;;;; context
|
|
|
|
(defvar *root* nil)
|
|
|
|
(defclass base-context ()
|
|
((actions :accessor actions :initform nil)
|
|
(default-actions :reader default-actions :initform nil)))
|
|
|
|
(defclass context (base-context)
|
|
((config :reader config :initarg :config)
|
|
(name :reader name :initarg :name)
|
|
(services :reader services :initform (make-hash-table))))
|
|
|
|
(defun default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys)
|
|
(apply #'make-instance cls :config cfg :name (config:name cfg) args))
|
|
|
|
(defun find-service (name &optional (parent *root*))
|
|
(with-slots (services) parent
|
|
(when services
|
|
(gethash name services))))
|
|
|
|
(defun setup-services (&optional (cfg config:*root*))
|
|
(setf *root* (make-instance 'context :config cfg))
|
|
(dolist (c (reverse (config:children cfg)))
|
|
(add-service *root* c)))
|
|
|
|
(defun shutdown ()
|
|
(dolist (ctx (alx:hash-table-values (services *root*)))
|
|
(funcall (config:shutdown (config ctx)) ctx)))
|
|
|
|
(defun add-action (ctx pat hdlr)
|
|
(let* ((acts (actions ctx))
|
|
(act (find-action pat acts)))
|
|
(if act
|
|
(push hdlr (handlers act))
|
|
(push (make-instance 'action-spec :pattern pat :handlers (list hdlr))
|
|
(actions ctx)))))
|
|
|
|
(defun add-service (ctx cfg)
|
|
(with-slots (services) ctx
|
|
(let ((child (funcall (config:setup cfg) cfg)))
|
|
(when child
|
|
(dolist (a (config:actions cfg))
|
|
(add-action child (car a) (cadr a)))
|
|
(setf (gethash (config:name cfg) services) child)))))
|
|
|
|
(defgeneric send (rcvr msg)
|
|
(:method ((rcvr base-context) msg)
|
|
(handle-message rcvr msg)))
|
|
|
|
(defgeneric handle-message (ctx msg)
|
|
(:method ((ctx base-context) msg)
|
|
(cond
|
|
((do-actions ctx msg) t)
|
|
((do-actions ctx msg #'default-actions) t)
|
|
(t (util:lgw "no action selected" 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)))
|
|
|
|
;;;; some simple predefined actions
|
|
|
|
(defun echo (ctx msg)
|
|
(let ((sndr (message:sender msg)))
|
|
(if sndr
|
|
(let* ((h (shape:head msg))
|
|
(new-msg (message:create `(:scopes :echo ,@(cddr h))
|
|
:data (shape:data msg))))
|
|
(send sndr new-msg))
|
|
(util:lgw "sender missing" msg))))
|
|
|
|
(defun do-print (ctx msg)
|
|
(declare (ignore ctx))
|
|
(format t "~&~s~%" msg))
|