Changeset 15645 in project


Ignore:
Timestamp:
08/30/09 11:54:12 (10 years ago)
Author:
certainty
Message:

applied peter's whitelist/environment-patch

Location:
release/4/uri-dispatch/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/uri-dispatch/trunk/tests/run.scm

    r15381 r15645  
    5555;;
    5656;;; Code:
    57 (use test uri-common uri-dispatch)
     57(use test uri-common environments)
     58
     59(load "../uri-dispatch")
    5860(import uri-dispatch)
    5961
     
    6971(define (echo2 . args) args)
    7072
    71 (enable-whitelisting #f)
     73(define test-environment (make-environment))
     74(environment-extend! test-environment 'test4 (constantly #t))
     75(environment-extend! test-environment 'echo3 (lambda args args))
    7276
     77(whitelist #f)
    7378
    7479(test-begin "uri-dispatch")
     
    8489        (dispatch-uri uri)))
    8590
     91(test "find procedure outside module in custom environment"
     92      #t
     93      (let ((uri (uri-reference "http://example.com/test4")))
     94        (parameterize ((dispatch-environment test-environment))
     95          (dispatch-uri uri))))
     96
    8697(test "find procedure outside module (negative)"
    8798      'dispatch-error
    8899      (let ((uri (uri-reference "http://example.com/nonexistent")))
    89100        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
     101          (dispatch-uri uri))))
     102
     103(test "find procedure outside module in custom env (negative)"
     104      'dispatch-error
     105      (let ((uri (uri-reference "http://example.com/test3")))
     106        (parameterize ((dispatch-error (lambda args 'dispatch-error))
     107                       (dispatch-environment test-environment))
    90108          (dispatch-uri uri))))
    91109
     
    101119      (let ((uri (uri-reference "http://example.com/test3")))
    102120        (parameterize ((dispatch-error (lambda args 'dispatch-error))
    103                        (enable-whitelisting #t))
     121                       (whitelist '()))
    104122          (dispatch-uri uri))))
    105123
     
    108126      (let ((uri (uri-reference "http://example.com/test-module/test1")))
    109127        (parameterize ((dispatch-error (lambda args 'dispatch-error))
    110                        (enable-whitelisting #t))
     128                       (whitelist '()))
    111129          (dispatch-uri uri))))
    112130
     
    115133      (let ((uri (uri-reference "http://example.com/test3")))
    116134        (parameterize ((dispatch-error (lambda args 'dispatch-error))
    117                        (enable-whitelisting #t))
    118           (whitelist! '(test3))
     135                       (whitelist '(test3)))
    119136          (dispatch-uri uri))))
    120137
     
    123140      (let ((uri (uri-reference "http://example.com/test-module/test1")))
    124141        (parameterize ((dispatch-error (lambda args 'dispatch-error))
    125                        (enable-whitelisting #t))
    126           (whitelist! '((module test-module)))
     142                       (whitelist '((test-module . (test1)))))
     143          (dispatch-uri uri))))
     144
     145(test "whitelist procedure inside module (negative)"
     146      'dispatch-error
     147      (let ((uri (uri-reference "http://example.com/test-module/test2")))
     148        (parameterize ((dispatch-error (lambda args 'dispatch-error))
     149                       (whitelist '((test-module . (test1)))))
     150          (dispatch-uri uri))))
     151
     152(test "whitelist procedure inside fully whitelisted module"
     153      #t
     154      (let ((uri (uri-reference "http://example.com/test-module/test2")))
     155        (parameterize ((dispatch-error (lambda args 'dispatch-error))
     156                       (whitelist '((test-module . *))))
    127157          (dispatch-uri uri))))
    128158     
     
    149179        (dispatch-uri uri)))
    150180
     181(test "pass arguments (in environment)"
     182      (list "this" "is" "a" "test")
     183      (let ((uri (uri-reference "http://example.com/echo3/this/is/a/test")))
     184        (parameterize ((dispatch-environment test-environment))
     185          (dispatch-uri uri))))
     186
    151187(test-end "uri-dispatch")
    152188
  • release/4/uri-dispatch/trunk/uri-dispatch.scm

    r15381 r15645  
    5858(module uri-dispatch
    5959  (dispatch-error dispatch-environment
    60    enable-whitelisting  whitelist! default-dispatch-target
    61    dispatch-uri)
     60   whitelist default-dispatch-target dispatch-uri)
    6261  (import scheme chicken)
    63   (require-library uri-common environments srfi-13)
     62  (require-library uri-common environments srfi-13 srfi-1 data-structures)
    6463  (import (only uri-common uri-reference? uri-path)
    6564          (only srfi-13 string-append)
     65          (only srfi-1 find)
     66          (only data-structures alist-ref conc constantly)
    6667          (only environments environment-ref environment-has-binding?))
    6768
    68   (define dispatch-error (make-parameter (lambda args #f)))
    69   (define procedure-whitelist (list))
    70   (define module-whitelist  (list))
    71   (define dispatch-environment interaction-environment)
    72   (define enable-whitelisting (make-parameter #f))
     69  (define dispatch-error (make-parameter (constantly #f)))
     70  (define whitelist (make-parameter #f))
     71  (define dispatch-environment (make-parameter (interaction-environment)))
    7372  (define default-dispatch-target (make-parameter #f))
    7473
     
    8988                  (apply (dispatch-error) path)))))
    9089       (else
    91         (let ((mod/proc (handler-ref (string->symbol (string-append (car path) "#" (cadr path))) (string->symbol (car path)))))
     90        (let ((mod/proc (handler-ref (string->symbol (cadr path)) (string->symbol (car path)))))
    9291          (if mod/proc
    9392              (apply mod/proc (cddr path))
     
    9897
    9998  (define (handler-ref symbol #!optional (mod #f))
    100     (and (environment-has-binding? (dispatch-environment) symbol)
    101          (let ((binding (environment-ref (dispatch-environment) symbol)))
    102             (and (procedure? binding) (whitelisted? symbol mod) binding))))
    103  
    104   (define (whitelisted? symbol mod)   
    105     (or (not (enable-whitelisting))
    106         (and (not mod) (member symbol procedure-whitelist))
    107         (and mod (member mod module-whitelist))))
     99    (and-let* ((name (if mod (string->symbol (conc mod "#" symbol)) symbol))
     100               ((environment-has-binding? (or (dispatch-environment)
     101                                              (interaction-environment)) name))
     102               (binding (environment-ref (or (dispatch-environment)
     103                                             (interaction-environment)) name))
     104               ((procedure? binding))
     105               ((whitelisted? symbol mod)))
     106      binding))
    108107
    109   (define (whitelist! def)
    110     (let loop ((def def) (pwl procedure-whitelist) (mwl module-whitelist))
    111       (cond
    112        ((null? def)
    113         (set! procedure-whitelist pwl)
    114         (set! module-whitelist mwl))
    115        ((and (list? (car def)) (eq? (caar def) 'module) (positive? (length (cdar def))))
    116         (loop (cdr def) pwl (append mwl (cdar def))))
    117        (else
    118         (loop (cdr def) (cons (car def) pwl) mwl)))))
     108  (define (whitelisted? symbol mod)
     109    (or (not (whitelist))
     110        (if (not mod)
     111            (memq symbol (whitelist))
     112            (let ((module.symbols (find (lambda (p)
     113                                          (and (pair? p)
     114                                               (eq? mod (car p))))
     115                                        (whitelist))))
     116              (and module.symbols
     117                   (or (eq? (cdr module.symbols) '*)
     118                       (memq symbol (cdr module.symbols))))))))
     119
    119120)           
    120121
Note: See TracChangeset for help on using the changeset viewer.