~ashton314/microKanren

0fd44c5d700631698d6cc334b98840e364258e45 — Ashton Wiersdorf 5 months ago e138296
Add access control example
2 files changed, 65 insertions(+), 0 deletions(-)

A access_control.rkt
M relations_playground.rkt
A access_control.rkt => access_control.rkt +60 -0
@@ 0,0 1,60 @@
#lang racket/base

(require "kanren.rkt")

(define-syntax simple-relation
  (syntax-rules ()
    [(_ (bindings ...) [(vals ...) ...])
     (conde [(== bindings vals) ...] ...)]
    [(_ (bindings ...) [(vals ...) ...] [litteral-conde-args ...] ...)
     (conde [(== bindings vals) ...] ... [litteral-conde-args ...] ...)]))

(define (access-role person company access-level)
  (simple-relation (person company access-level)
                   [('ashton  'spiff 'developer)
                    ('michael 'spiff 'admin)
                    ('jeron   'spiff 'admin)
                    ('ashton  'uofu  'guest)
                    ('kimball 'uofu  'grad)
                    ('eric    'uofu  'admin)
                    ('john    'uofu  'admin)
                    ('matthew 'uofu  'admin)
                    ('ashton  'byu   'grad)
                    ('kimball 'byu   'admin)]
                   [(== access-level 'guest)]))

(define (company-member company-name employee-name)
  (fresh (role) (access-role employee-name company-name role)))

(define (resource-access company role resource)
  (fresh (masquerade-role)
         (simple-relation (company role resource)
                          [('spiff 'developer 'directory)
                           ('spiff 'guest 'website)
                           ('spiff 'admin 'payroll)
                           ('uofu  'admin 'payroll)
                           ('byu   'admin 'payroll)
                           ('uofu  'grad  'directory)
                           ('byu   'grad  'directory)
                           ('uofu  'guest 'public-campus)
                           ('byu   'guest 'public-campus)
                           ('byu   'guest 'directory)]
                          [(== role 'admin) (resource-access company masquerade-role resource)]
                          [(disj (== company 'uofu) (== company 'byu))
                           (== role 'grad)
                           (resource-access company 'guest resource)])))

;; What rolls can access the u's public campus?
;; (run 3 (role) (resource-access 'uofu role 'public-campus))

;; Who can access the u's payroll?
;; (run 3 (person role) (resource-access 'uofu role 'payroll) (access-role person 'uofu role))

;; Who can access the directory?
;; (run 4 (person role) (resource-access 'uofu role 'directory) (access-role person 'uofu role))

;; Across all companies, what resources can Ashton see, and why?
;; (run* (resource/role resource role company) (access-role 'ashton company role) (resource-access company role resource) (== resource/role (list company role resource)))

;; The same for Kimball:
;; (run 10 (resource/role resource role company) (access-role 'kimball company role) (resource-access company role resource) (== resource/role (list company role resource)))

M relations_playground.rkt => relations_playground.rkt +5 -0
@@ 31,6 31,11 @@
(define (grandparent g s)
  (fresh (p) (parent g p) (parent p s)))

(define (cousin c1 c2)
  (fresh (gp)
         (grandparent c1 gp)
         (grandparent c2 gp)))

;; (run 20 (rel p c) (conj+ (grandparent c p) (== (cons c p) rel)))
;; (list->set (run 10 (gp) (grandparent 'andrew gp)))