Exploring capabilities.

capa.lisp

(defpackage "COM.INFORMATIMAGO.CAPABILITY"
  (:use "COMMON-LISP"))
(in-package "COM.INFORMATIMAGO.CAPABILITY")


;;;---------------------------------------------------------------------
;;; Conditions

(define-condition capability-access-error (error)
  ((capability :initarg :capability :reader capability-access-error-capability)
   (operation  :initarg :operation  :reader capability-access-error-operation))
  (:report (lambda (condition stream)
             (format stream "The operation ~S is not accessible with the capability ~S"
                     (capability-access-error-operation condition)
                     (capability-access-error-capability condition)))))

;;;---------------------------------------------------------------------
;;; Capability

(defclass capability ()
  ((object          :initarg :object          :reader capability-object)
   (operations      :initarg :operations      :reader capability-operations)
   (meta-operations :initarg :meta-operations :reader capability-meta-operations)))

(defmethod print-object ((capability capability) stream)
  (print-unreadable-object (capability stream :type t :identity t)
    (format stream ":object ~S :operations ~S :meta-operations ~S"
            (capability-object capability)
            (capability-operations capability)
            (capability-meta-operations capability)))
  capability)

(defgeneric operate (capability operation &rest arguments))

(defmethod operate ((capability capability) (operation symbol) &rest arguments)
  (cond
    ((member operation (capability-meta-operations capability))
     (apply operation capability arguments))
    ((member operation (capability-operations capability))
     (apply operation (capability-object capability) arguments))
    (t
     (error 'capability-access-error
            :capability capability
            :operation operation))))



(defgeneric profiles (object)
  (:documentation "An a-list mapping a profile name to a list of operations.
The first profile must be the default profile for the creator/owner of the object."))

(defgeneric profile-operations (object profile-name)
  (:method (object (profile-name (eql :default)))
    (cdr (first (profiles object))))
  (:method (object profile-name)
    (cdr (assoc profile-name (profiles object)))))



(defgeneric capability-with-profile (capability new-profile)
  (:method ((capability capability) new-profile)
    (make-instance (class-of capability)
                   :object (capability-object capability)
                   :operations (profile-operations (capability-object capability) new-profile)
                   :meta-operations (remove 'capability-with-profile
                                            (capability-meta-operations capability)))))

(defgeneric capability-terminate (capabilty)
  (:method ((capability capability))
    (setf (slot-value capability 'object) nil
          (slot-value capability 'operations) nil
          (slot-value capability 'meta-operations) nil)))

;;;---------------------------------------------------------------------
;;; Manager = a creator of capability.

(defclass manager ()
  ())

(defgeneric create-object (manager object-class &optional profile &rest arguments)
  (:method ((manager manager) object-class &optional (profile :default) &rest arguments)
    (let ((object (apply (function make-instance) object-class arguments)))
      (make-instance 'capability
                     :object object
                     :operations (profile-operations object profile)
                     :meta-operations '(capability-with-profile
                                        capability-terminate)))))


(defmethod profiles ((manager manager))
  '((creator . (create-object))))

(defparameter *manager*
  (let ((object (make-instance 'manager)))
    (make-instance 'capability
                   :object object
                   :operations (profile-operations object :default)
                   :meta-operations '(capability-terminate))))

(defun cap (object-class &optional (profile :default) &rest arguments)
  (apply (function operate) *manager* 'create-object object-class profile arguments))

;;;---------------------------------------------------------------------
;;; Directory

(defclass directory ()
  ((entries :initform (make-hash-table))))

(defgeneric directory-entry-count (directory))
(defgeneric directory-entry-names (directory))
(defgeneric directory-get-entry (directory name))
(defgeneric directory-put-entry (directory name capability))

(defmethod directory-entry-count ((directory directory))
  (hash-table-count (slot-value directory 'entries)))

(defmethod directory-entry-names ((directory directory))
  (let ((names '()))
    (maphash (lambda (name capability)
               (declare (ignore capability))
               (push name names))
             (slot-value directory 'entries))
    names))

(defmethod directory-get-entry ((directory directory) name)
  (gethash name (slot-value directory 'entries)))

(defmethod directory-put-entry ((directory directory) name capability)
  (setf (gethash name (slot-value directory 'entries)) capability))

(defmethod profiles ((object directory))
  '((read-write . (directory-entry-count
                   directory-entry-names
                   directory-get-entry
                   directory-put-entry))
    (read-only . (directory-entry-count
                  directory-entry-names
                  directory-get-entry))))

;;;---------------------------------------------------------------------
;;;

(defclass account ()
  ((owner :initarg :owner :reader account-owner)
   (number :initarg :number :reader account-number)
   (balance :initform 0 :reader account-balance)))

(defgeneric deposit (account amount)
  (:method ((account account) (amount real))
    (unless (plusp amount)
      (error "Account ~S: Deposit amount must be positive, not ~A"
             (account-number account) amount))
    (incf (slot-value account 'balance) amount)
    (values)))

(defgeneric withdraw (account amount)
  (:method ((account account) (amount real))
    (unless (plusp amount)
      (error "Account ~S: Withdraw amount must be positive, not ~A"
             (account-number account) amount))
    (unless (<= amount (account-balance account))
      (error "Account ~S: Withdraw amount is to big."
             (account-number account)))
    (decf (slot-value account 'balance) amount)
    (values)))

(defmethod profiles ((account account))
  '((owner    . (account-owner account-number account-balance withdraw deposit))
    (employer . (account-owner account-number deposit))
    (visitor  . (account-owner account-number account-balance))))


(defparameter *dir*

  (let ((account-dir (cap 'directory)))
  
   ;; Owner opens an account and deposits some amount:
   (let ((account (cap 'account 'owner :owner "John" :number "10092001")))
    
     (operate account-dir 'directory-put-entry 'owner account)
    
     (format t "~@(~A~) deposits on account ~A:~%"
             (operate account 'account-owner)
             (operate account 'account-number))
     (operate account 'deposit 1000.00)

     (flet ((process (who account)

              (operate account-dir 'directory-put-entry who account)
             
              (format t "~@(~A~) trying to see how rich ~A is:~%"
                      who (operate account 'account-owner))
              (handler-case
                  (progn
                    (format t "Account balance is: ")
                    (princ (operate account 'account-balance)))
                (error (err)
                  (princ err)))
              (terpri)
             
              (format t "~@(~A~) paying a salary to ~A:~%"
                      who (operate account 'account-owner))
              (handler-case
                  (princ (operate account 'deposit 5000.00))
                (error (err)
                  (princ err)))
              (terpri)

              (format t "~@(~A~) trying to take money from ~A:~%"
                      who (operate account 'account-owner))
              (handler-case
                  (princ (operate account 'withdraw 2000.00))
                (error (err)
                  (princ err)))
              (terpri)))
       (process 'visitor  (operate account 'capability-with-profile 'visitor))
       (process 'employer (operate account 'capability-with-profile 'employer))))

    (operate account-dir 'capability-with-profile 'read-only)))

;; John deposits on account 10092001:
;; Visitor trying to see how rich John is:
;; Account balance is: 1000.0
;; Visitor paying a salary to John:
;; The operation deposit is not accessible with the capability #<capability :object #<account #x302007EBED3D> :operations (account-owner account-number account-balance) :meta-operations (capability-terminate) #x302007EBEA1D>
;; Visitor trying to take money from John:
;; The operation withdraw is not accessible with the capability #<capability :object #<account #x302007EBED3D> :operations (account-owner account-number account-balance) :meta-operations (capability-terminate) #x302007EBEA1D>
;; Employer trying to see how rich John is:
;; Account balance is: The operation account-balance is not accessible with the capability #<capability :object #<account #x302007EBED3D> :operations (account-owner account-number deposit) :meta-operations (capability-terminate) #x302007EBBFAD>
;; Employer paying a salary to John:
;; nil
;; Employer trying to take money from John:
;; The operation withdraw is not accessible with the capability #<capability :object #<account #x302007EBED3D> :operations (account-owner account-number deposit) :meta-operations (capability-terminate) #x302007EBBFAD>
;; *dir*

(list (operate *dir* 'directory-entry-count)
      (operate *dir* 'directory-entry-names))
;; --> (3 (owner visitor employer))

(list (operate (operate *dir* 'directory-get-entry 'owner)
               'withdraw 200)
      (operate (operate *dir* 'directory-get-entry 'owner)
               'account-balance))
;; --> (nil 5800.0)