cl-scopes/core/core.lisp

;;;; cl-scopes/core - here comes the real action

(defpackage :scopes/core
  (:use :common-lisp)
  (:local-nicknames (:async :scopes/util/async)
                    (:config :scopes/config)
                    (:message :scopes/core/message)
                    (:shape :scopes/shape)
                    (:util :scopes/util)
                    (:alx :alexandria)
                    (:lp :lparallel) 
                    (:lpq :lparallel.queue))
  (:export #:action-spec #:define-actions
           #:*root* #:default-setup #:actions 
           #:find-service #:run-services #:setup-services #:shutdown
           #:base-context #:context #:add-action #:config #:name #:send
           #: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 define-action (pattern &rest handlers)
  (make-instance 'action-spec :pattern pattern :handlers handlers))

(defun define-actions (&rest acts)
  (mapcar #'(lambda (act) 
              (apply #'define-action (car act) (cdr act))) 
          acts))

(defun select (msg acts)
  (let ((h (shape:head msg)))
        ;(hdlrs nil))
    (dolist (a acts)
      (when (match (pattern a) h)
        (return-from select (handlers a))))))
#|        (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, services

(defvar *root* nil)

(defclass base-context ()
  ((actions :accessor actions :initform nil)))

(defclass context (base-context) 
  ((config :reader config :initarg :config)
   (name :reader name :initarg :name)
   (services :reader services :initform (make-hash-table))))

(defclass service (context)
  ((task :accessor task :initform nil)))

(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)))
  (:method ((ctx root-service)) 
    (setf (task ctx) 
          (async:make-task :cls 'async:fg-task :handle-message #'handle-message))
    (async:start (task ctx))))

(defgeneric 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)
  (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*))
  (async:init)
  (setf *root* (make-instance 'root-service :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))
  (if (and (task *root*)) 
    (async:stop (task *root*)))
  (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)
  (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)
        (do-start child)))))

(defgeneric handle-message (ctx msg)
  (:method ((ctx base-context) msg)
    (do-actions ctx msg)))

(defun do-actions (ctx msg &optional (acts #'actions))
  (let ((hdlrs (select msg (funcall acts ctx))))
    (if hdlrs
      (mapcar #'(lambda (hdlr) (funcall hdlr ctx msg)) hdlrs)
      (util:lgw "no action selected" msg))))

;;;; some simple predefined actions

(defun echo (ctx msg &key (domain :scopes) (action :echo))
  (let ((sndr (message:sender msg)))
    (if sndr
      (let* ((h (shape:head msg))
             (new-msg (message:create `(,domain ,action ,@(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))