core: use actor API: get rid of old send and do-start function definitions
This commit is contained in:
parent
9389edfc57
commit
bca410ea6b
5 changed files with 20 additions and 42 deletions
|
@ -4,7 +4,7 @@
|
||||||
(:use :common-lisp)
|
(:use :common-lisp)
|
||||||
(:local-nicknames (:async :scopes/util/async)
|
(:local-nicknames (:async :scopes/util/async)
|
||||||
(:util :scopes/util))
|
(:util :scopes/util))
|
||||||
(:export #:actor #:bg-actor #:fg-actor #:start #:stop
|
(:export #:actor #:bg-actor #:fg-actor #:make-actor #:start #:stop
|
||||||
#:become #:create #:send
|
#:become #:create #:send
|
||||||
#:message #:content #:customer
|
#:message #:content #:customer
|
||||||
#:*logger* #:*root*
|
#:*logger* #:*root*
|
||||||
|
@ -44,6 +44,9 @@
|
||||||
(:method ((ac bg-actor))
|
(:method ((ac bg-actor))
|
||||||
(async:stop (task ac))))
|
(async:stop (task ac))))
|
||||||
|
|
||||||
|
(defun make-actor (bhv &optional (cls 'actor) &rest args &key &allow-other-keys)
|
||||||
|
(apply #'make-instance cls :behavior bhv args))
|
||||||
|
|
||||||
(defun make-task (ac &optional (cls 'async:bg-task))
|
(defun make-task (ac &optional (cls 'async:bg-task))
|
||||||
(async:make-task :cls cls
|
(async:make-task :cls cls
|
||||||
:handle-message
|
:handle-message
|
||||||
|
@ -55,8 +58,8 @@
|
||||||
(setf (behavior ac) bhv))
|
(setf (behavior ac) bhv))
|
||||||
|
|
||||||
(defun create (bhv &optional (cls 'actor) &rest args &key &allow-other-keys)
|
(defun create (bhv &optional (cls 'actor) &rest args &key &allow-other-keys)
|
||||||
(let ((ac (apply #'make-instance cls :behavior bhv args)))
|
(let ((ac (apply #'make-actor bhv cls args)))
|
||||||
;(start ac)
|
(start ac)
|
||||||
ac))
|
ac))
|
||||||
|
|
||||||
(defgeneric send (addr content &key &allow-other-keys)
|
(defgeneric send (addr content &key &allow-other-keys)
|
||||||
|
|
|
@ -14,7 +14,7 @@
|
||||||
(:export #:action-spec #:define-actions
|
(:export #:action-spec #:define-actions
|
||||||
#:*root* #:default-setup #:actions
|
#:*root* #:default-setup #:actions
|
||||||
#:find-service #:run-services #:setup-services #:shutdown
|
#:find-service #:run-services #:setup-services #:shutdown
|
||||||
#:base-context #:context #:add-action #:config #:name #:send
|
#:base-context #:context #:add-action #:config #:name
|
||||||
#:handle-message
|
#:handle-message
|
||||||
#:do-print #:echo))
|
#:do-print #:echo))
|
||||||
|
|
||||||
|
@ -73,28 +73,6 @@
|
||||||
|
|
||||||
(defclass root-service (service actor:fg-actor) ())
|
(defclass root-service (service actor:fg-actor) ())
|
||||||
|
|
||||||
(defun do-start (ctx)
|
|
||||||
(actor:start ctx))
|
|
||||||
|
|
||||||
(defgeneric x-do-start (ctx)
|
|
||||||
(:method ((ctx context)))
|
|
||||||
(:method ((ctx service))
|
|
||||||
(setf (task ctx) (async:make-task :handle-message #'handle-message))
|
|
||||||
(async:start (task ctx)))
|
|
||||||
(:method ((ctx root-service))
|
|
||||||
(setf (task ctx)
|
|
||||||
(async:make-task :cls 'async:fg-task :handle-message #'handle-message))
|
|
||||||
(async:start (task ctx))))
|
|
||||||
|
|
||||||
(defun send (rcvr msg)
|
|
||||||
(actor:send rcvr msg))
|
|
||||||
|
|
||||||
(defgeneric x-send (rcvr msg)
|
|
||||||
(:method ((rcvr base-context) msg)
|
|
||||||
(handle-message rcvr msg))
|
|
||||||
(:method ((rcvr service) msg)
|
|
||||||
(async:send (task rcvr) msg)))
|
|
||||||
|
|
||||||
(defun default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys)
|
(defun default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys)
|
||||||
(apply #'actor:create #'handle-message cls :config cfg :name (config:name cfg) args))
|
(apply #'actor:create #'handle-message cls :config cfg :name (config:name cfg) args))
|
||||||
|
|
||||||
|
@ -105,23 +83,23 @@
|
||||||
|
|
||||||
(defun setup-services (&optional (cfg config:*root*))
|
(defun setup-services (&optional (cfg config:*root*))
|
||||||
(async:init)
|
(async:init)
|
||||||
(setf *root* (actor:create #'handle-message 'root-service :config cfg))
|
(setf *root* (actor:make-actor #'handle-message 'root-service :config cfg))
|
||||||
(dolist (c (reverse (config:children cfg)))
|
(dolist (c (reverse (config:children cfg)))
|
||||||
(add-service *root* c)))
|
(add-service *root* c)))
|
||||||
|
|
||||||
(defun shutdown ()
|
(defun run-services (&optional (cfg config:*root*))
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(setup-services cfg)
|
||||||
|
(actor:start *root*))
|
||||||
|
(shutdown)))
|
||||||
|
|
||||||
|
(defun shutdown ()
|
||||||
(dolist (ctx (alx:hash-table-values (services *root*)))
|
(dolist (ctx (alx:hash-table-values (services *root*)))
|
||||||
(funcall (config:shutdown (config ctx)) ctx))
|
(funcall (config:shutdown (config ctx)) ctx))
|
||||||
(if (task *root*)
|
(if (task *root*)
|
||||||
(actor:stop *root*))
|
(actor:stop *root*))
|
||||||
(async:finish))
|
(async:finish))
|
||||||
|
|
||||||
(defun run-services (&optional (cfg config:*root*))
|
|
||||||
(unwind-protect
|
|
||||||
(progn
|
|
||||||
(setup-services cfg)
|
|
||||||
(do-start *root*))
|
|
||||||
(shutdown)))
|
|
||||||
|
|
||||||
(defun add-action (ctx pat hdlr)
|
(defun add-action (ctx pat hdlr)
|
||||||
(let* ((acts (actions ctx))
|
(let* ((acts (actions ctx))
|
||||||
|
@ -137,8 +115,7 @@
|
||||||
(when child
|
(when child
|
||||||
(dolist (a (config:actions cfg))
|
(dolist (a (config:actions cfg))
|
||||||
(add-action child (car a) (cadr a)))
|
(add-action child (car a) (cadr a)))
|
||||||
(setf (gethash (config:name cfg) services) child)
|
(setf (gethash (config:name cfg) services) child)))))
|
||||||
(do-start child)))))
|
|
||||||
|
|
||||||
(defgeneric handle-message (ctx msg)
|
(defgeneric handle-message (ctx msg)
|
||||||
(:method ((ctx base-context) msg)
|
(:method ((ctx base-context) msg)
|
||||||
|
@ -158,7 +135,7 @@
|
||||||
(let* ((h (shape:head msg))
|
(let* ((h (shape:head msg))
|
||||||
(new-msg (message:create `(,domain ,action ,@(cddr h))
|
(new-msg (message:create `(,domain ,action ,@(cddr h))
|
||||||
:data (shape:data msg))))
|
:data (shape:data msg))))
|
||||||
(send cust new-msg))
|
(actor:send cust new-msg))
|
||||||
(util:lgw "customer missing" msg))))
|
(util:lgw "customer missing" msg))))
|
||||||
|
|
||||||
(defun do-print (ctx msg)
|
(defun do-print (ctx msg)
|
||||||
|
|
|
@ -132,7 +132,6 @@
|
||||||
(collector
|
(collector
|
||||||
(actor:create
|
(actor:create
|
||||||
#'(lambda (ac msg) (setf val (actor:content msg))))))
|
#'(lambda (ac msg) (setf val (actor:content msg))))))
|
||||||
(actor:start calc)
|
|
||||||
(actor:send calc '(actor:plus 2))
|
(actor:send calc '(actor:plus 2))
|
||||||
(actor:send calc '(actor:minus 3))
|
(actor:send calc '(actor:minus 3))
|
||||||
(actor:send calc '(actor:show))
|
(actor:send calc '(actor:show))
|
||||||
|
@ -147,4 +146,4 @@
|
||||||
(msg-exp (message:create '(:test :dummy) :data "dummy payload")))
|
(msg-exp (message:create '(:test :dummy) :data "dummy payload")))
|
||||||
(expect rcvr msg-exp)
|
(expect rcvr msg-exp)
|
||||||
(== (core:name rcvr) :test-receiver)
|
(== (core:name rcvr) :test-receiver)
|
||||||
(core:send rcvr msg)))
|
(actor:send rcvr msg)))
|
||||||
|
|
|
@ -37,7 +37,7 @@
|
||||||
(test-fileserver client)
|
(test-fileserver client)
|
||||||
(test-message client)
|
(test-message client)
|
||||||
(sleep 0.1)))
|
(sleep 0.1)))
|
||||||
;(core:shutdown)
|
(core:shutdown)
|
||||||
(t:show-result))))
|
(t:show-result))))
|
||||||
|
|
||||||
;;;; the tests
|
;;;; the tests
|
||||||
|
|
|
@ -91,7 +91,6 @@
|
||||||
(defun message-handler (ctx env &key html-responder)
|
(defun message-handler (ctx env &key html-responder)
|
||||||
(let* ((resp (response:setup ctx env :html-responder html-responder))
|
(let* ((resp (response:setup ctx env :html-responder html-responder))
|
||||||
(iact (actor:create #'core:handle-message 'response:interaction :response resp))
|
(iact (actor:create #'core:handle-message 'response:interaction :response resp))
|
||||||
;(iact (make-instance 'response:interaction :response resp))
|
|
||||||
(msg (message:create
|
(msg (message:create
|
||||||
(head env) :data (plist (post-data env)) :customer iact)))
|
(head env) :data (plist (post-data env)) :customer iact)))
|
||||||
(util:lgd msg)
|
(util:lgd msg)
|
||||||
|
|
Loading…
Add table
Reference in a new issue