Commits

David Krentzlin committed 3dad839 Draft

more hacking on the command infrastructure

Comments (0)

Files changed (8)

mira.channels/src/irc.lisp

 (in-package :cl-user)
 (defpackage :mira.channels.irc
-  (:use :cl :cl-annot :mira.core.utils :mira.core.channel)
+  (:use :cl :cl-annot :mira.core.debug :mira.core.utils :mira.core.channel :mira.core.logging)
   (:import-from :mira.core.message
                 :<message>
                 :data))
          (receiver (first data))
          (receiver-in-response (if (self-p channel (first data)) sender-nick (first data))))
     (make-instance '<message>
-                   :sender-identity (virtual-identity-map channel full-source) 
+                   :sender-identity (virtual-identity-map channel (list full-source sender-nick))
                    :sender sender-nick 
                    :receiver receiver 
                    :data (second data)

mira.core/mira.core.asd

     :components ((:static-file "mira.core.asd")
                  (:module "src"
                           :components
-                          ((:file "debug")
+                          ((:file "logging")
+			   (:file "debug" :depends-on ("logging"))
                            (:file "utils" :depends-on ("debug"))
                            (:file "bootable" :depends-on ("debug"))
                            (:file "acl")
-                           (:file "logging" :depends-on ("debug"))
                            (:file "message-passing" :depends-on ("utils"))
                            (:file "message" :depends-on ("utils" "logging"))
                            (:file "channel" :depends-on ("message" "message-passing" "bootable" "logging"))

mira.core/src/channel.lisp

 (in-package :cl-user)
 
 (defpackage :mira.core.channel
-  (:use :cl :cl-annot :mira.core.debug :mira.core.utils :mira.core.bootable :mira.core.message-passing)
+  (:use :cl :cl-annot :mira.core.debug :mira.core.utils :mira.core.bootable :mira.core.message-passing :mira.core.logging)
   (:import-from :mira.core.message
                 :<message>))
 
   (:method (messages shutdown)
     (dolist (message messages)
       (with-slots (mira.core.message:data) message
+	(log5:log-for (channel debug) "received system message")
         ; simply shutdown if we receive the shutdown message
         (if (eql mira.core.message:data 'shutdown)
             (funcall shutdown))))))
 (defgeneric handle-channel-messages (channel messages)
   (:documentation "Handle messages that come from the channels input")
   (:method ((channel <channel>) messages)
+    (log5:log-for (channel debug) "pushing ~A messages to the kernel" (length messages))
     (push-messages (kernel channel) messages)))
 
 @export

mira.core/src/debug.lisp

 (in-package :cl-user)
 (defpackage :mira.core.debug
-  (:use :cl :cl-annot))
+  (:use :cl :cl-annot :mira.core.logging))
 
 
 (in-package :mira.core.debug)
 @export
 (defun dbg (fmt &rest arguments)
   (when *debug*
-    (format t "[DEBUG]: ")
-    (apply #'format t fmt arguments)))
+    (let ((msg (apply #'format nil fmt arguments)))
+      (log5:log-for (debug) msg)
+      (format t "[DEBUG]: ")
+      (format t msg)
+      (format t "~%"))))

mira.core/src/kernel.lisp

 ;;       (format stream "channels: ~{~a~^ ~}~% spec-procs: ~{~a~^ ~}~% gen-procs: ~{~a~^ ~}~%" (mapcar  (lambda (o) (slot-value o 'id)) (channels object)) spec-procs gen-procs))))
 
 
+
 @export
 (defgeneric bind-channels (kernel new-channels)
   (:documentation "Add a channel to the kernel. The channel will be started by the kernel on startup")
     (with-slots (channels channels-mutex) self
       (bordeaux-threads:with-lock-held (channels-mutex)
         (dolist (channel new-channels)
-          (log5:log-for (notice kernel) "Binding channel ~A" (mira.core.channel::id channel))
+          (log5:log-for (notice mira.core.logging::kernel) "Binding channel ~A" (mira.core.channel::id channel))
           (setf (mira.core.channel::kernel channel) self)
           (setf channels (cons channel channels)))))))
 
     (if channel-id
         (with-slots (specific-handlers-mutex) kernel
           (bordeaux-threads:with-lock-held (specific-handlers-mutex)
-            (log5:log-for (info kernel) "Prepending processor: ~A to channel: ~A" (slot-value processor 'mira.core.processor::id) channel-id)
+            (log5:log-for (info mira.core.logging::kernel) "Prepending processor: ~A to channel: ~A" (slot-value processor 'mira.core.processor::id) channel-id)
+	    (setf (mira.core.processor::kernel processor) kernel)
             (push processor (gethash channel-id (specific-handlers kernel) (list)))))
         (with-slots (generic-handlers-mutex) kernel
           (bordeaux-threads:with-lock-held (generic-handlers-mutex)
-            (log5:log-for (info kernel) "Prepending processor: ~A for all channels" (slot-value processor 'mira.core.processor::id))
+            (log5:log-for (info mira.core.logging::kernel) "Prepending processor: ~A for all channels" (slot-value processor 'mira.core.processor::id))
+	    (setf (mira.core.processor::kernel processor) kernel)
             (push processor (generic-handlers kernel)))))))
 
 @export
         (with-slots (specific-handlers-mutex) kernel
             (bordeaux-threads:with-lock-held (specific-handlers-mutex)
               (let ((ht (specific-handlers kernel)))
-                (log5:log-for (info kernel) "Appending processor: ~A to channel: ~A" (slot-value processor 'mira.core.processor::id) channel-id)
+                (log5:log-for (info mira.core.logging::kernel) "Appending processor: ~A to channel: ~A" (slot-value processor 'mira.core.processor::id) channel-id)
+		(setf (mira.core.processor::kernel processor) kernel)
                 (setf (gethash channel-id ht)
                       (append (gethash channel-id ht (list)) (ensure-list processor))))))
         (with-slots (generic-handlers-mutex) kernel
           (bordeaux-threads:with-lock-held (generic-handlers-mutex)
             (log5:log-for (info kernel) "Appending processor: ~A for all channels" (slot-value processor 'mira.core.processor::id))
+	    (setf (mira.core.processor::kernel processor) kernel)
             (setf (generic-handlers kernel) (append (generic-handlers kernel) (ensure-list processor))))))))
 
+
 ;; TODO implement specific handlers
 (defgeneric apply-processors (kernel messages stop-processing)
   (:documentation "Apply all processors to the messages and generate answers if apropriate")
               (when answer
                 (write-answer-to-channels kernel answer)
                 (return-from apply-processors))))
+      (log5:log-for (info kernel) "messages received ~A" messages)
       (dolist (message messages)
         (dolist (processor (generic-handlers kernel))
+	  (log5:log-for (debug mira.core.logging::kernel) "running processor ~A" (mira.core.processor::id processor))
           (let ((answers (ensure-list (process-message processor message #'skip stop-processing))))
+	    (log5:log-for (debug mira.core.logging::kernel) "answers are ~A" answers)
             (when answers
               (dolist (answer answers)
                 (write-answer-to-channels kernel answer)))))))))
   (:documentation "Send the answer to all or selected channels of the kernel")
   (:method ((kernel <kernel>) (message <message>))
     (dolist (channel (find-destination-channels message (channels kernel)))
+      (log5:log-for (debug mira.core.logging::kernel) "pushing messages to channel")
       (push-messages channel (list message)))))
 
 
 @export
 (defmethod halt ((kernel <kernel>))
   (declare (ignore args))
-  (log5:log-for (kernel info) "Halting the system")
+  (log5:log-for (mira.core.logging::kernel info) "Halting the system")
   (dolist (channel (channels kernel))
     (mira.core.channel:halt channel)))
 
   (setup-logging)
   (log5:log-for (kernel info) "Booting the system")
   (dolist (channel (channels kernel))
-    (log5:log-for (kernel notice) "Booting channel ~A" (mira.core.channel::id channel))
+    (log5:log-for (mira.core.logging::kernel notice) "Booting channel ~A" (mira.core.channel::id channel))
     (boot channel))
-  (log5:log-for (kernel notice) "Booted successfully")
+  (log5:log-for (mira.core.logging::kernel notice) "Booted successfully")
   (pump kernel))

mira.core/src/logging.lisp

 (in-package :cl-user)
 
 (defpackage :mira.core.logging
-  (:use :cl :mira.core.debug)
+  (:use :cl)
   (:import-from :log5
                 :defcategory
                 :start-sender

mira.core/src/message-passing.lisp

   (:documentation "Pull out any exiting messages and return a list of them.")
   (:method ((object <message-passable>))
     (with-slots (mailbox) object
-      (sb-concurrency:receive-pending-messages mailbox))))
+      (let ((messages (sb-concurrency:receive-pending-messages mailbox)))
+	(log5:log-for (debug) "have ~A messages received from the mailbox" (length messages))
+        messages))))
 
 @export
 (defgeneric pull-one-message (object)

mira.core/src/processor.lisp

 (in-package :cl-user)
 (defpackage :mira.core.processor
-  (:use :cl :cl-annot :mira.core.debug :mira.core.acl)
-  (:export id documentation)
-  (:import-from :mira.core.message
-                :<message>
-		:data))
+  (:use :cl :cl-annot :mira.core.debug :mira.core.acl :mira.core.message)
+  (:export id documentation))
 
 (in-package :mira.core.processor)
 (annot:enable-annot-syntax)
   ((commands :initform (make-hash-table :test #'equal)
              :accessor commands)
    (acl      :initarg :acl
+	     :initform *command-acl*
              :accessor acl
              :documentation "The access control list for this commands")))
 @export
 		  :initform  "basic-processor"
 		  :reader id
 		  :allocation :class)
+   (kernel        :documentation "The kernel we belong to"
+                  :initarg :kernel
+		  :accessor kernel)
    (documentation :documentation "Describe what your processor does"
 		  :initarg :documentation
 		  :initform "No documentation available"
   ((self         :documentation "The identity of this bot"
                  :accessor self
                  :initarg :self
-                 :initform (error "You need to supply a self if you want to use commands"))
+                 :initform nil)
+   (prefix       :documentation "The command prefix to use"
+		 :initarg :prefix
+		 :accessor prefix
+		 :initform *command-prefix*)
    (commands     :documentation "Commands that are associated with this processor"
 		 :accessor commands
-                 :initform (make-instance '<command-collection>))))
+                 :initform (make-instance '<command-collection> :acl *command-acl*))))
 
 @export
 (defun answer (&rest arguments)
   (and *current-answer-function*
-       (apply *current-answer-function* arguments)))
+       (apply #'*current-answer-function* arguments)))
+
 
 @export
-(defgeneric process-message (processor message skip-following quit)
-  (:documentation "Actually process the message")
-  (:method ((processor <processor>) (message <message>) skip-following quit)
-    (let* ((ident (sender-identity message))
-           (input (data message))
-           (self  (string-downcase (self processor)))
-           (commands (commands processor))
-           (*current-processor* processor)
-           (*current-kernel* (slot-value processor 'kernel))
-           (*current-answer-function*
-            (lambda (result &key (channels) (sender-id) (receiver (sender message)))
-	      (let ((messages (mapcar 
-			       (lambda (data)
-				 (make-instance '<message>
-						:receiver receiver
-						:data data
-						:sender-identity sender-id
-						:generator-id (slot-value message 'mira.core.message::generator-id)
-						:tag (tag message))
-				 (if (listp result) result (list result))))))
+(defgeneric process-message (processor message skip-following quit))
+
+(defmethod  process-message ((processor <commands-mixin>) (message <message>) skip-following quit)
+  (let* ((ident (sender-identity message))
+	 (input (data message))
+	 (self  (string-downcase (self processor)))
+	 (prefix (prefix processor))
+	 (commands (commands processor))
+	 (*current-processor* processor)
+	 (*current-kernel* (slot-value processor 'kernel))
+	 (*current-answer-function*
+	  (lambda (result &key (channels) (sender-id) (receiver (sender message)))
+	    (format t "Answering with ~A~%" result)
+	    (let ((messages (mapcar 
+			     (lambda (data)
+			       (make-instance '<message>
+					      :receiver receiver
+					      :data data
+					      :sender-identity sender-id
+					      :generator-id (slot-value message 'mira.core.message::generator-id)
+					      :tag (tag message))
+			       (if (listp result) result (list result))))))
 		
-		(funcall
-		 #'skip-following
-		 messages)))))
-      
-      (when (command-syntax? input self)
-        (multiple-value-bind (command arguments) (destructure-command (strip-sender input))
-          (let ((cmd (find-command commands ident)))
-            (case cmd
-              ((:access-denied) (answer *access-denied-message*))
-              ((nil) nil)
-              (t (apply-command cmd arguments message quit skip-following kernel)))))))))
+	      (funcall
+	       #'skip-following
+	       messages)))))
+    
+    (when (command-syntax? input prefix)
+      (format t "Have command syantx ~A with self ~A~%" input self)
+      (multiple-value-bind (command arguments) (destructure-command input prefix)
+	(format t "Have destructured ~%")
+	(let ((cmd (find-command command commands ident)))
+	  (format t "Have found the command ~%")
+	  (case cmd
+	    ((:access-denied) (answer *access-denied-message*))
+	    ((nil) nil)
+	    (t (apply-command cmd arguments message quit skip-following))))))))
 
 (defgeneric apply-command (command argument-string message quit skip)
   (:documentation "Applies the command to the given input")
   (:method ((command <command>) arguments (message <message>) quit skip)
+
     (let ((argument-list (argument-string->argument-list arguments))
           (cmd-closure (body command)))
       (if (equal (string-downcase (car argument-list)) "help")
           (answer (help command))
           (handler-case 
-              (apply cmd-closure argument-list)
+	      (progn
+		(format t "Applying command to ~A~%" argument-list)
+		(apply cmd-closure argument-list))
             (error ()
+	      (format t "Have an error ~A ~%" (usage command))
               (answer (usage command))))))))
 
 (defmethod print-object ((object <processor>) stream)
 					 (destructuring-bind (,@command-lambda-list) ,arguments
 					   ,@body))))))
 
-
-
 @export
 (defmacro defusage (processor command-name banner usage-text &rest options)
   `(add-usage ,processor (string ',command-name) ,banner ,usage-text '(,@options)))
   (let ((cmd (get-command (slot-value processor 'commands) (string command))))
     (when cmd
       (with-slots (usage help) cmd
-	(setf usage usage-text
+	(setf usage (format nil "Usage: ~A~A~A" *command-prefix* (string command) usage-text)
 	      help (generate-help (string command) banner usage-text options))))))
 
-(defun command-syntax? (input self-ident)
-  (cl-ppcre:scan (format nil "^~A:? +~A(.+?)"
-                         (cl-ppcre:quote-meta-chars self-ident)
-                         *command-prefix*) input))
+(defun command-syntax? (input prefix)
+  (cl-ppcre:scan (format nil "^\s*~A(.+?)" (cl-ppcre:quote-meta-chars prefix)) input))
 
 (defgeneric find-command (cmd collection issuer)
   (:documentation "Lookup a command and return if it is found an the issuer has enough privileges. Returns the command or the keyword :access-denied")
         command)
        :access-denied))))
 
-(defun strip-sender (str)
-  (let ((ws (position #\Space str)))
-    (string-trim " " (subseq str (1+ ws)))))
+(defun destructure-command (str prefix)
+  (let* ((stripped (string-trim '(#\Space #\Tab #\Newline) str))
+	 (ws (position #\Space stripped)))
+    (if ws
+	(values (string-trim prefix (subseq stripped 0 ws))
+		(string-trim " " (subseq stripped (1+ ws))))
+	(values (string-trim prefix stripped) ""))))
 
-(defun destructure-command (str)
-  "Destructures the input into two values
-   1) The command
-   2) The arguments"
-  (let ((prefix (format nil " ~A" *command-prefix*))
-        (ws (position #\Space str)))
-    (if ws
-	(values (string-trim prefix (subseq str 0 ws))
-                (string-trim " " (subseq str (1+ ws))))
-	(values (string-trim prefix str) ""))))
 
 ;; foo bar baz -> (list "foo" "bar" "baz")
 ;; foo :bar 0  -> (list "foo" :bar 0)