From 5c2126805d5131d2c69f0efb55fad379663a0c73 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Sun, 16 Mar 2025 11:09:53 +0100
Subject: [PATCH] fix async stuff: kernels, interrupt handlinng

---
 core/core.lisp               | 12 +++++++-----
 lib/auth/test/test-auth.lisp | 10 ++++++----
 test/test-core.lisp          |  5 +++--
 util/async.lisp              | 27 ++++++++++++++++++---------
 4 files changed, 34 insertions(+), 20 deletions(-)

diff --git a/core/core.lisp b/core/core.lisp
index dc72449..13458af 100644
--- a/core/core.lisp
+++ b/core/core.lisp
@@ -79,8 +79,8 @@
     (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))))
+          (async:make-task :cls 'async:task :handle-message #'handle-message))
+    (async:start (task ctx))))
 
 (defgeneric send (rcvr msg)
   (:method ((rcvr base-context) msg)
@@ -97,15 +97,17 @@
       (gethash name services))))
 
 (defun setup-services (&optional (cfg config:*root*))
+  (async:init)
   (setf *root* (make-instance 'root-service :config cfg))
   (dolist (c (reverse (config:children cfg)))
     (add-service *root* c)))
 
 (defun shutdown ()
-  (if (task *root*) 
-    (async:stop (task *root*)))
   (dolist (ctx (alx:hash-table-values (services *root*)))
-    (funcall (config:shutdown (config ctx)) ctx)))
+    (funcall (config:shutdown (config ctx)) ctx))
+  (if (and (task *root*)) 
+    (async:stop (task *root*)))
+  (async:finish))
  
  (defun run-services (&optional (cfg config:*root*))
    (unwind-protect
diff --git a/lib/auth/test/test-auth.lisp b/lib/auth/test/test-auth.lisp
index d8a0606..ecc0669 100644
--- a/lib/auth/test/test-auth.lisp
+++ b/lib/auth/test/test-auth.lisp
@@ -44,7 +44,9 @@
     (== (shape:head-value pr1 :name) :admin)))
 
 (deftest test-client (client)
-  (let ((msg (message:create 
-               '(:auth :login) 
-               :data '(:org "system" :name "admin" :password "sc0pes"))))
-    (client:send-message client msg)))
+  (let (msg rsp)
+    (setf msg (message:create '(:auth :login) 
+               :data '(:org "system" :name "admin" :password "sc0pes")))
+    (setf rsp (client:send-message client msg))
+    (print rsp)
+    ))
diff --git a/test/test-core.lisp b/test/test-core.lisp
index 5aa1c7a..cecf6a7 100644
--- a/test/test-core.lisp
+++ b/test/test-core.lisp
@@ -85,6 +85,7 @@
     (== pl '(:b 1 :a 0))))
 
 (deftest test-util-async ()
+  (async:init)
   (let ((tsk (async:make-task)))
     (== (async:status tsk) :new)
     (async:start tsk) 
@@ -98,8 +99,8 @@
     (== (async:status tsk) :running)
     (async:send tsk :hello)
     (== (async:stop tsk) '(:hello))
-    (== (async:status tsk) :done) 
-    ))
+    (== (async:status tsk) :done) )
+  (async:finish))
 
 (deftest test-util-crypt ()
   (let ((s1 (crypt:create-secret))
diff --git a/util/async.lisp b/util/async.lisp
index 2382694..680b883 100644
--- a/util/async.lisp
+++ b/util/async.lisp
@@ -5,7 +5,7 @@
   (:local-nicknames (:util :scopes/util)
                     (:lp :lparallel)
                     (:lpq :lparallel.queue))
-  (:export #:task #:async-task
+  (:export #:init #:finish #:task #:async-task
            #:make-task #:start #:stop #:status #:data #:send))
 
 (in-package :scopes/util/async)
@@ -15,9 +15,15 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (progn
     (when (not (boundp '+quit-message+)) 
-      (defconstant +quit-message+ (gensym "QUIT")))
-    (when (null lp:*kernel*)
-      (setf lp:*kernel* (lp:make-kernel (serapeum:count-cpus))))))
+      (defconstant +quit-message+ (gensym "QUIT")))))
+
+(defun init ()
+  (when (null lp:*kernel*)
+    (setf lp:*kernel* (lp:make-kernel (serapeum:count-cpus)))))
+
+(defun finish ()
+  (when lp:*kernel*
+    (lp:end-kernel)))
 
 (defun noop (&rest params))
 
@@ -27,12 +33,15 @@
       (progn
         (funcall startup tsk)
         (when mb
-          (loop for msg = (lpq:pop-queue mb)
+          (handler-case
+              (loop for msg = (lpq:pop-queue mb)
                 until (eq msg +quit-message+)
-                do (funcall handle-message tsk msg)))
-        (funcall teardown tsk)
-        (data tsk))
-      (setf (status tsk) :done))))
+                do (funcall handle-message tsk msg))
+            (sb-sys:interactive-interrupt (e)
+              (format t "~&async:standard-job: ~a~%" e)))))
+      (setf (status tsk) :done)
+      (funcall teardown tsk)
+      (data tsk))))
 
 ;;;; task class and related functions / methods