RailsOnLisp/can/can.lisp

Branch - branch -master

• Show log

  Commit

• Hash : a424f6a3
  Author : Thomas de Grivel
  Date : 2017-06-21T11:14:26
  

  untabify
  

Download

• can.lisp

• ;;
  ;;  can - semantic rule-based access control library.
  ;;
  ;;  Copyright 2013,2014 Thomas de Grivel <billitch@gmail.com>
  ;;
  ;;  Permission to use, copy, modify, and distribute this software for any
  ;;  purpose with or without fee is hereby granted, provided that the above
  ;;  copyright notice and this permission notice appear in all copies.
  ;;
  ;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  ;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  ;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  ;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  ;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  ;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  ;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  ;;
  
  (in-package #:can)
  
  (defvar *rules*)
  
  (defun reset-rules ()
    (setq *rules* nil))
  
  #+nil
  (reset-rules)
  
  (defmacro define-permission ((subject permission action object) &body specs)
    `(push '((,subject ,permission ,action ,object) . ,specs)
           *rules*))
  
  #+nil
  (define-permission (?user :can :edit ?module)
    (?user :is-a 'user
           'user.status :active)
    (?module :is-a 'module
             'module.owner ?user))
  #+nil
  (define-permission (:everyone :can :view :all))
  #+nil
  (rule-bindings '?s '?a '?o (first *rules*))
  
  (defun can/rule (subject action object rule)
    (destructuring-bind ((s p a o) &body specs) rule
      (let (bindings constants)
        (flet ((unify (r x wild)
                 (if (facts:binding-p r)
                     (push (cons r x) bindings)
                     (if (keywordp r)
                         (unless (eq r wild)
                           (push `(lessp:lessp-equal ,r ,x)
                                 constants))
                         (push `(or (eq ,r ,wild)
                                    (lessp:lessp-equal ,r ,x))
                               constants))))
               (join (prefix list)
                 (when list
                   (if (cdr list)
                       `((,prefix ,@list))
                       list))))
          (unify o object :all)
          (unify a action :admin)
          (unify s subject :everyone)
          (car
           (join 'when
                 `(,@(join 'and
                           `(,@constants ,@(join 'progn
                                                 (sublis bindings specs))))
                     ,p)))))))
  
  #+nil
  (can/rule 'user ':edit 'object (second *rules*))
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
    (let (can-lambda)
  
      (defun can (action &optional (object :all) (user :anonymous))
        (if can-lambda
            (funcall can-lambda action object (or user :anonymous))
            (error "Please call CAN:COMPILE-RULES.")))
  
      (defun can-rules-lambda ()
        (let ((action (gensym "ACTION-"))
              (object (gensym "OBJECT-"))
              (user (gensym "USER-")))
          `(lambda (,action ,object ,user)
             (declare (ignorable ,action ,object ,user))
             (eq :can
                 (or ,@(mapcar (lambda (rule)
                                 (can/rule user action
                                           object rule))
                               *rules*))))))
  
      (defun compile-rules ()
        (setq can-lambda
              (compile nil (can-rules-lambda))))))
  

Download