Re: [Logs-devel] rule macro attempt #1

[Jim Prewett]

Hi Vijay,

I've had fun playing with your code today (unfortunately, some yard work, 
etc. kept me busy for too much of it :).  I've made a few minor 
modifications, and generally think your code has a nice feel to it :)  
kudos!

Here is an example using some of the new things I've added:

(rule 
        name 'foo
        match regexp ".+" 
        ;; set variable var1 to 42
        setenv var1 = 42
        ;; first action
        doing (lambda (x) (format t "message: ~A var1: ~A~%" (message x) 
var1))
        ;; second action
        doing #'print-message
        ;; set continuep slot to t
        continue)

;;; Paul Graham, On Lisp, p191
(defmacro aif (test-form then-form &optional else-form)
  `(let ((it ,test-form))
    (if it ,then-form ,else-form)))

;;; an 'accessor' for the handle-fns
(defmacro handle-fn (keyword)
  `(get ,keyword 'handle-fn))

;;; Influenced by Peter Norvig's LOOP implementation

(defstruct rool
  (name '())
  (match '())
  (timeout '()) 
  (relative-timeout '())
  (delete-rule '()) 
  (continuep '())
  (actions '())
  (environment '()))

(defmacro rule (&rest exprs)
  (let ((r (make-rool)))
    (parse-rule r exprs)
    (fill-rule-template r)))

(defun fill-rule-template (rool)
  `(make-instance
    'logs::rule
    :environment ',(rool-environment rool)
    :actions (rool-actions ,rool)
    ,@(loop as (key fn) in '((:match rool-match)
                             (:name rool-name)
                             (:timeout rool-timeout)
                             (:continuep rool-continuep)
                             (:relative-timeout rool-relative-timeout))
            as res = (funcall fn rool)
            if res append `(,key ,res))))

(defun parse-rule (rool exprs)
  (unless (null exprs)
    (parse-rule rool (parse-keyword rool (car exprs) (cdr exprs)))))

(defun parse-keyword (rool keyword exprs)
  (aif (handle-fn keyword)
       (funcall it rool exprs)
       (error "Unknown keyword ~S" keyword)))

(defun handle-name (rool exprs)
  (destructuring-bind (name . cdr) exprs
    ;; rule names don't have to be symbols
    ;; symbols are (obviously) a pretty good idea, but 
    ;; strings, etc. should work as well
    (if (null (rool-name rool))
        (setf (rool-name rool) `,name)
        (error "Invalid name ~S" name))
    cdr))

(defun handle-match (rool exprs)
  (let ((matches (rool-match rool)))
    ;; For now, we ignore.  Later we add or something
    (declare (ignore matches))
    (destructuring-bind (car . cdr) exprs
      (case car
        (regexp (let ((msg (gensym "MESSAGE"))
                      (matches (gensym))
                      (sub-matches (gensym))
                      (regex (pop cdr)))
                  (setf (rool-match rool)
                        `(lambda (,msg)
                          (multiple-value-bind (,matches ,sub-matches)
                              (cl-ppcre:scan-to-strings ,regex (message ,msg))
                            (when ,matches
                              (values t
                                      '((sub-matches ,sub-matches)))))))
                  cdr))
        (message-length (let ((msg (gensym "MESSAGE"))
                              (relop (pop cdr))
                              (num (pop cdr)))
                          (setf (rool-match rool)
                                `(lambda (,msg)
                                  (,relop (length (message ,msg)) ,num)))
                          cdr))
        (t (setf (rool-match rool) car) cdr)))))

(defun handle-timeout (rool exprs)
  (destructuring-bind (preposition . (time . cdr)) exprs
    (case preposition
      (in (setf (rool-relative-timeout rool) time))
      (at (setf (rool-timeout rool) time)))
    cdr))

(defun handle-setenv (rool exprs)
  (destructuring-bind (variable equal value &rest rest) exprs
    (pushnew (list variable value) 
             (rool-environment rool)
             :test
              (lambda (x y) (equal (car x) (car y))))
    rest))

;; add the given function to the actions list
(defun handle-do (rool exprs)
  (destructuring-bind (todo &rest rest) exprs
    (format t "rool: ~A todo: ~A rest: ~A~%" 
            rool todo rest)
    (append (rool-actions rool) (list (eval todo)))
    rest))

;; set the continue slot to t
(defun handle-continue (rool exprs)
  (setf (rool-continuep rool) t)
  exprs)

(setf (handle-fn 'match) #'handle-match)
(setf (handle-fn 'name) #'handle-name)
(setf (handle-fn 'timeout) #'handle-timeout)

;; new
(setf (handle-fn 'continue) #'handle-continue)
(setf (handle-fn 'setenv) #'handle-setenv)
(setf (handle-fn 'doing) #'handle-do)


Jim

James E. Prewett                    address@hidden address@hidden 
Systems Team Leader           LoGS: http://www.hpc.unm.edu/~download/LoGS/ 
Designated Security Officer         OpenPGP key: pub 1024D/31816D93    
HPC Systems Engineer III   UNM HPC  505.277.8210

On Sun, 4 Jun 2006, Vijay Lakshminarayanan wrote:

> On 6/4/06, Jim Prewett <address@hidden> wrote:
> > > > I was wondering how you're envisioning this working for rules that
> > create
> > > > rules ... that create rules?
> > > >
> > > > (make-instance 'rule
> > > >         :actions
> > > >         (list
> > > >           (lambda (message)
> > > >              (enqueue *root-ruleset* (make-instance 'rule ...)))))
> > >
> > > We just use the macro again, I guess.
> > >
> > > (rule performing (lambda (message) (enqueue *root-ruleset* (rule
> > ...))))
> > >
> > 
> > I was hoping that was the answer :)
> 
> Oh so it's a Good Thing?  That's a relief :-)
> 
> > > In time we should have a single function which does the enqueing.
> > 
> > I don't think you're quite understanding the ruleset tree structure.
> > rulesets contain rules and other rulesets.  You may want to have a rule
> > that creates a new rule on a completely different part of the tree.
> 
> You're right.  I completely forgot about this -- I was totally
> immersed into defining the macro's behavior itself.
> 
> > In other words, I don't see specifying the ruleset you're adding the rule
> > to to be a loss.
> > 
> > Jim
> > 
> 
> Will come up with more and better quality code soon, Jim.
> 
> Thanks
> Vijay
>