;; At Fri, 21 May 2004 00:13:03 -1000 (HST), Shiro Kawai wrote:
;; >> 
;; >> I finally managed to fix the generic function application MOP,
;; >> so you don't need object-apply to use user-defined generic.
;; >> Also :class keyword is added to define-generic.
;;
;; Thanks, Shiro, I needed this!
;;
;; I'm trying to use generic functions to implement a capability-based
;; security model.  The idea is you run untrusted code in an restricted
;; environment, which among other things excludes access to slot-ref and
;; slot-set!.  Thus objects become truly opaque and the only way to
;; access them is through whatever generic functions (capabilities)
;; you've been given.
;;
;; So far I have the following [long]:

(define-class <access-generic> (<generic>) ())

(define-method apply-generic ((gf <access-generic>) args)
  (if (apply has-permission? gf args)
      (next-method)
      (error "access denied")))

(define-method has-permission? (gf . rest)
  #f)

;; Then for given generic functions and argument combinations you can
;; return #t for has-permission? thus granting the capability.  For
;; example, consider a kill command:

(define-generic kill :class <access-generic>)

(define-method kill ((killer <user>) (victim <program>))
  (format #t "~S has been slain\n" victim))

;; As is this would always raise an "access denied" error, so we can
;; specify some allowed cases:

(define-method has-permission?
  ((gf <access-generic>) (u <user>) (p <program>))
  (equal? (slot-ref p 'owner) u))

;; Now if we setup our sample classes and objects:

(define-class <user> () ())
(define-class <super-user> (<user>) ())
(define-class <program> () ((owner :init-keyword :owner)))

(define root (make <super-user>))
(define fred (make <user>))
(define wilma (make <user>))
(define wilmas-job (make <program> :owner wilma))

;; (kill fred wilmas-job)
;; *** ERROR: access denied
;; (kill root wilmas-job)
;; *** ERROR: access denied
;; (kill wilma wilmas-job)
;; #<<program> 0x8221c98> has been slain
;;
;; Notice root was also prevented from killing wilma's job, which is good
;; since the whole point of a capability system is there is no "root" and
;; users only get the permissions they need.  However, if we wanted to
;; add support for unix-style root that's easy enough:

(define-method has-permission?
  ((gf <access-generic>) (u <super-user>) (p <program>))
  #t)

;; (kill root wilmas-job)
;; #<<program> 0x8221c98> has been slain
;;
;; [presumably wilmas-job is a cat with nine lives]
;;
;; In this example all capabilities of the form
;;
;;   (gf user program)
;;
;; are grouped together, so a user has all or nothing access to a given
;; program.  However, we can subclass <access-generic> and distinguish
;; different types of access.

(define-class <access-generic/system> (<access-generic>) ())

(define-generic reboot :class <access-generic/system>)

(define-method reboot ((u <user>) (p <program>))
  (format #t "rebooting ~S\n" p))

(define-method has-permission?
  ((gf <access-generic/system>) (u <super-user>) (p <program>)
   #t))

(define-method has-permission?
  ((gf <access-generic/system>) (u <user>) (p <program>)
   #f))

;; which prevents reboot for a normal user even if they're the owner.
;;
;; This style can get tedious for a lot of permissions and moreover it
;; doesn't work (well) for runtime changing of permissions.  So one thing
;; we can do is implement acl's as lookup tables.

(define-class <accessee-base> () ())
(define-class <accessee/reader> (<accessee-base>)
  ((read-perms :init-keyword :read-perms :init-value #f)))
(define-class <accessee/writer> (<accessee-base>)
  ((write-perms :init-keyword :write-perms :init-value #f)))
(define-class <accessee/appender> (<accessee-base>)
  ((append-perms :init-keyword :append-perms :init-value #f)))
(define-class <accessee>
  (<accessee/reader> <accessee/writer> <accessee/appender>)
  ())

(define-method has-permission? ((gf <access-generic/reader>)
                                accessor (accessee <accessee/reader>) . rest)
  (and-let* ((perms (slot-ref accessee 'read-perms)))
    (hash-table-get perms accessor #f)))

(define-method has-permission? ((gf <access-generic/writer>)
                                accessor (accessee <accessee/reader>) . rest)
  (and-let* ((perms (slot-ref accessee 'read-perms)))
    (hash-table-get perms accessor #f)))

(define-method has-permission? ((gf <access-generic/appender>)
                                accessor (accessee <accessee/reader>) . rest)
  (and-let* ((perms (slot-ref accessee 'read-perms)))
    (hash-table-get perms accessor #f)))

(define-method grant-read-access ((a <accessee/reader>) b)
  (let ((perms (or (slot-ref a 'read-perms) (make-hash-table))))
    (hash-table-put! perms b #t)
    (slot-set! a 'read-perms perms)))

(define-method grant-write-access ((a <accessee/writer>) b)
  (let ((perms (or (slot-ref a 'write-perms) (make-hash-table))))
    (hash-table-put! perms b #t)
    (slot-set! a 'write-perms perms)))

(define-method grant-append-access ((a <accessee/appender>) b)
  (let ((perms (or (slot-ref a 'append-perms) (make-hash-table))))
    (hash-table-put! perms b #t)
    (slot-set! a 'append-perms perms)))

(define-class <hacker> (<accessee>) ())

(define alice (make <hacker>))
(define bob (make <hacker>))

(define-generic finger :class <access-generic/reader>)

(define-method finger ((a <hacker>) (b <hacker>))
  (format #t "No Plan.\n"))

;; (finger bob alice)
;; *** ERROR: access denied
;; (grant-read-access alice bob)
;; (finger bob alice)
;; No Plan.
;;
;; Bob can't finger Alice without her permission.
;;
;; The safe environment in these cases should do two things: first is
;; restrict access to slot-ref and slot-set! as well as any procedures by
;; which those can be obtained (e.g. with-module), and of course
;; sys-system.  Second we need to control access to the generics, since
;; they base security on the param list and we don't want Bob to do
;; something like
;;
;;   (finger alice alice)
;;
;; So instead we define the above finger as %finger, and give only access
;; to something like

(define (finger user)
  (%finger me user))

;; for some "me".  If "me" can be computed dynamically with something
;; like (current-user) then we could simplify this by removing the
;; accessor parameter from all methods above and looking up
;; (current-user) on demand, thereby removing the need for this extra
;; wrapper.
;;
;; -- Alex -------------------------------------------------------