Hash :
a424f6a3
Author :
Thomas de Grivel
Date :
2017-06-21T11:14:26
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
;;
;; 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))))))