1. David Krentzlin
  2. mira.cl


mira.cl / mira.core / src / processor.lisp

(in-package :cl-user)
(defpackage :mira.core.processor
  (:use :cl :cl-annot :mira.core.debug :mira.core.acl :mira.core.message)
  (:export id documentation command-environment-issuer command-environment-answer-fn command-environment-skip-fn command-environment-quit-fn command-environment-processor))

(in-package :mira.core.processor)

;; every processor can define commands that
;; are related to that processors. This way
;; the logic to process commands from users
;; can be used by all processors

(defvar *command-prefix* "!")
(defvar *command-acl* (make-instance '<acl>))
(defvar *access-denied-message* "Heh, nice try. You are not allowed to do that, dude!")

(defclass <command-collection> ()
  ((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")))
(defclass <command> ()
    :initarg :usage
    :reader usage
    :initform "")
    :initarg :help
    :reader help
    :initform "")
    :initarg :required-access-level
    :initform 0
    :reader  required-access-level)
    :initarg :body
    :reader body)))

(defclass <processor> ()
  ((id            :documentation "The identifier of this processor"
		  :initarg :id
		  :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"
		  :allocation :class)))

(defclass <commands-mixin> ()
  ((self         :documentation "The identity of this bot"
                 :accessor self
                 :initarg :self
                 :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> :acl *command-acl*))))
(defstruct command-environment issuer processor answer-fn skip-fn quit-fn)

(defun cmd-answer (env &rest arguments)
  (let ((answer-fn (command-environment-answer-fn env)))
    (apply answer-fn arguments)))

(defun answer (message result &key (channels) (sender-id) (receiver (sender message))
  (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))

(defun make-answer-function (message skip)
  (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)))))
      (funcall skip messages))))

(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))
	 (command-env (make-command-environment :issuer ident 
						:processor processor 
						:answer-fn (make-answer-function message skip-following) 
						:skip-fn skip-following 
						:quit-fn quit)))
    (when (command-syntax? input prefix)
      (multiple-value-bind (command arguments) (destructure-command input prefix)
	(let ((cmd (find-command command commands ident)))
	  (case cmd
	    ((:access-denied) (cmd-answer command-env *access-denied-message*))
	    ((nil) nil)
	    (t (apply-command cmd arguments command-env))))))))

(defgeneric apply-command (command argument-string command-env)
  (:documentation "Applies the command to the given input")
  (:method ((command <command>) arguments command-env)
    (let* ((argument-list (argument-string->argument-list arguments))
	   (cmd-closure   (body command))
	   (first-arg     (car argument-list)))
      (if (and first-arg (stringp first-arg) (equal (string-downcase (car argument-list)) "help"))
          (cmd-answer command-env (help command))
	 ;; (apply cmd-closure (cons command-env argument-list))
	   	(apply cmd-closure (cons command-env argument-list)))
	    (error ()
	      (cmd-answer command-env (usage command))))

(defmethod print-object ((object <processor>) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "~A" (id object))))

(defgeneric add-command (proc command-name command)
  (:method ((proc <commands-mixin>) command-name (command <command>))
    (add-command (commands proc) command-name command)))

(defmethod add-command ((collection <command-collection>) name command)
  (with-slots (commands) collection
    (setf (gethash (string-downcase (string name)) commands) command)))

(defmethod get-command ((collection <command-collection>) name)
  (with-slots (commands) collection
    (gethash (string-downcase (string name)) commands)))

(defgeneric setup-commands (processor)
  (:documentation "Template method to be implemented by every processor that wants to use commands"))

(defmethod initialize-instance :after ((processor <commands-mixin>) &rest args)
  (declare (ignore args))
  (setup-commands processor))

;; (defcommand processor 0 (echo (content &key (foo  1))
;; (defmethod setup-commands ((proc <my-procssor>))
;;   (defcommand proc 0 (echo (content &key (foo  1))
;;                           (do-sth-with content)))))

;; (defusage processor echo
;;     :banner "echo content"
;;     (foo :required "Sets the frooble")
;;     (bar :optional "Set the barble"))
;;   Usage: echo content [options]
;;    :foo=BAR "Sets the froobl"
;;    :bar     "Sets the barble"

(defmacro defcommand (proc level (command-name (&rest command-lambda-list) &body body))
  (let ((arguments (gensym)))
    `(add-command ,proc
		  (string ',command-name)
		  (make-instance '<command>
				 :required-access-level ,level
				 :body (lambda (&rest ,arguments)
					 (destructuring-bind (,@command-lambda-list) ,arguments

(defmacro defusage (processor command-name banner usage-text &rest options)
  `(add-usage ,processor (string ',command-name) ,banner ,usage-text '(,@options)))

(defmethod add-usage ((processor <commands-mixin>) command banner usage-text options)
  (let ((cmd (get-command (slot-value processor 'commands) (string command))))
    (when cmd
      (with-slots (usage help) cmd
	(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 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")
  (:method (cmd (collection <command-collection>) issuer)
    (let ((command (get-command collection cmd))
          (acl     (acl collection)))
        (access-allowed? acl issuer (required-access-level command))

(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) ""))))

;; foo bar baz -> (list "foo" "bar" "baz")
;; foo :bar 0  -> (list "foo" :bar 0)
(defun argument-string->argument-list (argument-string)
  "Converts an argument string into a argument list, that can be fed into the command."
       (lambda (elt)
           ((keywordp elt) elt)
           ((symbolp elt) (string elt))
           (t elt)))
       (read-from-string (concatenate 'string "(" argument-string ")")))
    (error () (list))))

(defun generate-help (command banner usage options)
  (let ((help-string (format nil "~A: ~A" command banner))
	(usage-string (format nil "Usage: ~A~A ~A" *command-prefix* command usage))
	(options-start "Options: ")
	(options-strings (format-options options)))
    (if options
	(append  (list help-string usage-string options-start) options-strings)
	(list help-string usage-string))))

(defun format-options (options)
   (lambda (option)
     (format nil "~A: ~A" (string (car option)) (string (car (last option)))))