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

explicit definitions for service and root-service classes, using async and blocking task classes

Browse source
This commit is contained in:
Helmut Merz 2025-03-10 15:00:10 +01:00
parent 5cd84f356c
commit fb33a65d54
2 changed files with 32 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

29
core/core.lisp
View file

@ -76,21 +76,17 @@
(defclass service (context)
((task :accessor task :initform nil)))
(defgeneric do-start (ctx &key wait)
(:method ((ctx context) &key wait))
(:method ((ctx service) &key wait)
(defclass root-service (service) ())
(defgeneric do-start (ctx)
(:method ((ctx context)))
(:method ((ctx service))
(setf (task ctx) (async:make-task :handle-message #'handle-message))
(async:start (task ctx :wait wait))))
(defgeneric do-listen (ctx)
(:method ((ctx service))
(do ((r (do-step ctx) (do-step ctx)))
((eql r '(:quit))))))
(defgeneric do-step (ctx)
(:method ((ctx service))
(let ((msg (lpq:pop-queue (mailbox ctx))))
(handle-message ctx msg))))
(async:start (task ctx)))
(:method ((ctx root-service))
(setf (task ctx)
(async:make-task :cls 'async:async-task :handle-message #'handle-message))
(async:start (task ctx :blocking t))))
(defgeneric send (rcvr msg)
(:method ((rcvr base-context) msg)
@ -107,7 +103,7 @@
(gethash name services))))
(defun setup-services (&optional (cfg config:*root*))
(setf *root* (make-instance 'service :config cfg))
(setf *root* (make-instance 'root-service :config cfg))
;(setf (trivial-signal:signal-handler :int) #'quit-handler)
(dolist (c (reverse (config:children cfg)))
(add-service *root* c)))
@ -122,8 +118,7 @@
(unwind-protect
(progn
(setup-services cfg)
;(do-listen *root*)
(do-start *root* :wait t))
(do-start *root*))
(shutdown)))
(defun add-action (ctx pat hdlr)

27
util/async.lisp
View file

@ -5,7 +5,8 @@
(:local-nicknames (:util :scopes/util)
(:lp :lparallel)
(:lpq :lparallel.queue))
(:export #:task #:make-task #:start #:stop #:status #:data #:send))
(:export #:task #:async-task
#:make-task #:start #:stop #:status #:data #:send))
(in-package :scopes/util/async)
@ -38,13 +39,16 @@
(defclass task ()
((job :accessor job)
(taskid :reader taskid :initform (gensym "TSK"))
(channel :reader channel :initform (lp:make-channel))
(mailbox :accessor mailbox :initform nil)
(status :accessor status :initform :new)
(data :accessor data :initform nil)))
(defun make-task (&key (startup #'noop) (teardown #'noop) handle-message)
(let ((tsk (make-instance 'task)))
(defclass async-task (task)
((channel :reader channel :initform (lp:make-channel))))
(defun make-task (&key (startup #'noop) (teardown #'noop) handle-message
(cls 'async-task))
(let ((tsk (make-instance cls)))
(setf (job tsk)
(lambda () (standard-job tsk :startup startup :teardown teardown
:handle-message handle-message)))
@ -52,19 +56,28 @@
(setf (mailbox tsk) (lpq:make-queue)))
tsk))
(defun start (tsk &key (wait nil))
(defun start (tsk)
(when (eq (status tsk) :running)
(util:lgw "task already running" (taskid tsk))
(return-from start))
(setf (status tsk) :running)
(if wait
(funcall (job tsk))
(submit tsk))
(defgeneric submit (tsk)
(:method ((tsk task))
(funcall (job tsk)))
(:method ((tsk async-task))
(lp:submit-task (channel tsk) (job tsk))))
(defun stop (tsk &key (wait t))
(when (mailbox tsk)
(send tsk +quit-message+))
(when wait
(wait-result tsk)))
(defgeneric wait-result (tsk)
(:method ((tsk task)))
(:method ((tsk async-task))
(lp:receive-result (channel tsk))))
(defun send (tsk msg)