Source / 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))

(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!")
(defvar *current-answer-function* nil)
(defvar *current-kernel* nil)
(defvar *current-processor* nil)

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

(defun answer (&rest arguments)
  (and *current-answer-function*
       (apply #'*current-answer-function* arguments)))

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