allow to specify custom mbox type per dispatcher and via actor-of.

additional test for if mbox class is not known.

allow specifying custom mbox-type via `actor-of`.

sbcl fix

docstring changes

Author: mdbergmann

src/actor-context-api.lisp

@@ -23,7 +23,7 @@
   (:documentation "Interface for creating an actor.
 
 **!!! Attention:** this factory function wraps the `act:make-actor` functionality to something more simple to use. 
-Using this function there is no need to use both `act:make-actor`.
+Using this function there is no need to use `act:make-actor`.
 
 `context` is either an `asys:actor-system`, an `ac:actor-context`, or an `act:actor` (any type of actor).
 The new actor is created in the given context.
@@ -43,6 +43,8 @@ This function allows to unsubsribe from event-stream or such.
 Additional options:
 
 - `:queue-size` limits the message-box's size. By default, it is unbounded.
+- `:mbox-type` specify a custom message-box type similar as can be done is dispatcher config.
+  It must be a subtype of `mesgb:message-box/dp`.
 "))
 
 (defgeneric find-actors (context path &key test key)

src/actor-context.lisp

@@ -27,6 +27,12 @@ The `actor-system` and the `actor` itself are composed of an `actor-context`."))
 (defun %get-shared-dispatcher (system identifier)
   (getf (asys:dispatchers system) identifier))
 
+(defun %get-dispatcher-config (config dispatcher-id)
+  (let* ((disp-config (config:retrieve-section config :dispatchers))
+         (dispatcher-keys (config:retrieve-keys disp-config)))
+    (when (find dispatcher-id dispatcher-keys)
+      (config:retrieve-section disp-config dispatcher-id))))
+
 (defun %add-actor (context actor)
   (let ((atomic-actors (slot-value context 'actors)))
     (atomic:atomic-swap atomic-actors (lambda (old-actors)
@@ -43,16 +49,23 @@ The `actor-system` and the `actor` itself are composed of an `actor-context`."))
                                                     (act-cell:name actor))))
                                      old-actors)))))
 
-(defun %message-box-for-dispatcher-id (context dispatcher-id queue-size)
+(defun %message-box-for-dispatcher-id (context dispatcher-id queue-size mbox-type)
   (case dispatcher-id
     (:pinned (make-instance 'mesgb:message-box/bt
                             :max-queue-size queue-size))
-    (otherwise (let ((dispatcher (%get-shared-dispatcher (system context) dispatcher-id)))
+    (otherwise (let* ((asys (system context))
+                      (sys-config (asys:config asys))
+                      (disp-config (%get-dispatcher-config sys-config dispatcher-id))
+                      (dispatcher (%get-shared-dispatcher asys dispatcher-id)))
                  (unless dispatcher
                    (error (format nil "No such dispatcher identifier '~a' exists!" dispatcher-id)))
-                 (make-instance 'mesgb:message-box/dp
-                                :dispatcher dispatcher
-                                :max-queue-size queue-size)))))
+                 ;; if dispatcher exists, the config does, too.
+                 (let ((eff-mbox-type (if mbox-type
+                                          mbox-type
+                                          (getf disp-config :mbox-type 'mesgb:message-box/dp))))
+                   (make-instance eff-mbox-type
+                                  :dispatcher dispatcher
+                                  :max-queue-size queue-size))))))
 
 (defun %find-actor-by-name (context name)
   (find-if (lambda (a)
@@ -75,19 +88,19 @@ The `actor-system` and the `actor` itself are composed of an `actor-context`."))
       (log:error "Actor with name '~a' already exists!" actor-name)
       (error (make-condition 'actor-name-exists :name actor-name)))))
 
-(defun %create-actor (context create-fun dispatcher-id queue-size)
+(defun %create-actor (context create-fun dispatcher-id queue-size mbox-type)
   (let ((actor (funcall create-fun)))
     (when actor
       (%verify-actor context actor)
       (act::finalize-initialization actor
-       (%message-box-for-dispatcher-id context dispatcher-id queue-size)
+       (%message-box-for-dispatcher-id context dispatcher-id queue-size mbox-type)
        (make-actor-context (system context)
                            (miscutils:mkstr (id context) "/" (act-cell:name actor)))))
     actor))
 
-(defun %actor-of (context create-fun &key (dispatcher :shared) (queue-size 0))
+(defun %actor-of (context create-fun &key (dispatcher :shared) (queue-size 0) mbox-type)
   "See `ac:actor-of`"
-  (let ((created (%create-actor context create-fun dispatcher queue-size)))
+  (let ((created (%create-actor context create-fun dispatcher queue-size mbox-type)))
     (when created
       (act:watch created context)
       (%add-actor context created))))
@@ -122,19 +135,22 @@ An `act:actor` contains an `actor-context`."
   "See `ac:actor-of`."
   (check-type receive function "a function!")
 
-  (alexandria:remove-from-plistf rest
-                                 :queue-size
-                                 :dispatcher)
-  (%actor-of context
-             (lambda () (apply #'act:make-actor receive
-                               :init init
-                               :destroy destroy
-                               :state state
-                               :type type
-                               :name name
-                               rest))
-             :dispatcher dispatcher
-             :queue-size queue-size))
+  (let ((mbox-type (getf rest :mbox-type)))
+    (alexandria:remove-from-plistf rest
+                                   :queue-size
+                                   :dispatcher
+                                   :mbox-type)
+    (%actor-of context
+               (lambda () (apply #'act:make-actor receive
+                            :init init
+                            :destroy destroy
+                            :state state
+                            :type type
+                            :name name
+                            rest))
+               :dispatcher dispatcher
+               :queue-size queue-size
+               :mbox-type mbox-type)))
 
 
 ;; test 2-arity function with 'path' and 'act-cell-name' (default)

src/actor-system-api.lisp

@@ -6,6 +6,7 @@
            #:dispatchers
            #:evstream
            #:scheduler
+           #:config
            #:register-dispatcher
            #:register-new-dispatcher
            #:*default-config*))
@@ -14,12 +15,39 @@
 
 (defparameter *default-config*
   '(:dispatchers
-    (:shared (:workers 4 :strategy :random))
+    (:shared (:workers 4 :strategy :random :mbox-type mesgb:message-box/dp))
     :timeout-timer
     (:resolution 100 :max-size 500)
     :eventstream
     (:dispatcher-id :shared)
     :scheduler
     (:enabled :true :resolution 100 :max-size 500))
   "The default config used when creating an `asys:actor-system`.
-The actor-system constructor allows to provide custom config options that override the default.")
+The actor-system constructor allows to provide custom config options that override the defaults.
+
+The constructor provided configuration does not need to specify all parts of the config,
+rather, what is provided is merged with `*default-config*`.  
+That means e.g. specifying an additional dispatcher, one just has to provide this to the constructor:
+
+```
+'(:dispatchers
+    (:my-disp (:workers 4)))
+```
+
+For all other parameters the defaults will be used, even `:workers` does not need to be there.
+The defaults, when omitted, are:  
+- workers = 2
+- strategy = :random
+- mbox-type = 'mesgb:message-box/dp'
+
+If you want to just modify parts of the config, i.e. the strategy, then one can do:
+
+```
+'(:dispatchers
+    (:shared (:strategy :round-robin)))
+```
+
+This will just change the strategy to `:round-robin`.
+
+Note that `mbox-type` must be a subtype of `mesgb:message-box/dp`.
+")

tests/actor-context-test.lisp

@@ -67,6 +67,14 @@
       (is (not (eq cut (act:context actor))))
       (is (not (null (ac:system (act:context actor))))))))
 
+(defclass my-mbox-type (mesgb:message-box/dp) ())
+(test actor-of--shared--custom-mbox-type
+  (with-fixture test-system ()
+    (let* ((cut (make-actor-context system))
+           (actor (actor-of cut :receive (lambda ())
+                                :mbox-type 'sento.actor-context-test::my-mbox-type)))
+      (is (typep (act-cell:msgbox actor) 'my-mbox-type)))))
+
 (test actor-of--pinned
   "Tests creating a new actor in the context with pinned dispatcher"
   (with-fixture test-system ()
@@ -95,6 +103,42 @@
              ))
       (ac:shutdown system))))
 
+(test actor-of--custom-dispatcher-with-custom-mbox-type
+  "Tests creating an actor with a custom shared dispatcher."
+  (let ((system))
+    (unwind-protect
+         (progn
+           (setf system (asys:make-actor-system '(:dispatchers
+                                                  (:foo
+                                                   (:workers 0
+                                                    :mbox-type sento.actor-context-test::my-mbox-type)))))
+           (let* ((cut (make-actor-context system))
+                  (actor (actor-of cut :receive (lambda ()) :dispatcher :foo)))
+             (is (not (null actor)))
+             (is (typep (act-cell:msgbox actor) 'my-mbox-type))
+             (is (eq :foo (slot-value (mesgb::dispatcher (act-cell:msgbox actor)) 'disp::identifier)))
+             ))
+      (ac:shutdown system))))
+
+(test actor-of--err-custom-dispatcher--unknown-mbox-type
+  "Tests creating an actor with a custom shared dispatcher."
+  (let ((system))
+    (unwind-protect
+         (progn
+           (setf system (asys:make-actor-system '(:dispatchers
+                                                  (:foo
+                                                   (:mbox-type foombox)))))
+           (let ((cut (make-actor-context system)))
+             (handler-case
+                 (progn
+                   (actor-of cut :receive (lambda ()) :dispatcher :foo)
+                   (fail()))
+               (error (c)
+                 (format t "cond: ~a" c)
+                 (is (str:containsp "FOOMBOX"
+                                    (format nil "~a" c)))))))
+      (ac:shutdown system))))
+
 (test actor-of--err-unknown-dispatcher
   "Tests creating a new actor on an unknown dispatcher."
   (with-fixture test-system ()

tests/actor-system-test.lisp

@@ -79,7 +79,7 @@
     (unwind-protect
          (progn
            (is (equal (asys::%get-dispatcher-config (asys::config system))
-                      '(:shared (:workers 4 :strategy :random))))
+                      '(:shared (:workers 4 :strategy :random :mbox-type mesgb:message-box/dp))))
            (is (equal (asys::%get-timeout-timer-config (asys::config system))
                       '(:resolution 100
                         :max-size 500)))