Commits

David Krentzlin  committed c1cf18f

initial import

  • Participants
  • Tags 1.0

Comments (0)

Files changed (7)

File tests/.svn/entries

+10
+
+dir
+23658
+https://code.call-cc.org/svn/chicken-eggs/release/4/uri-dispatch/trunk/tests
+https://code.call-cc.org/svn/chicken-eggs
+
+
+
+2010-10-25T18:46:53.519473Z
+21030
+certainty
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+fca3e652-9b03-0410-8d7b-ac86a6ce46c4
+
+run.scm
+file
+
+
+
+
+2010-10-25T18:44:14.282661Z
+564837529c192476ad7bf907b63e5e73
+2010-10-25T18:46:53.519473Z
+21030
+certainty
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+6260
+

File tests/.svn/text-base/run.scm.svn-base

+;; Description: 
+;; Author: David Krentzlin <david@lisp-unleashed.de>
+;; Created: Mi Jul 15 19:33:46 2009 (CEST)
+;; Last-Updated: So Aug  9 18:42:53 2009 (CEST)
+;;           By: David Krentzlin <david@lisp-unleashed.de>
+;;     Update #: 36
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 
+;; Copyright (c) <2009> David Krentzlin <david@lisp-unleashed.de>
+;; 
+;;   Permission is hereby granted, free of charge, to any person
+;;   obtaining a copy of this software and associated documentation
+;;   files (the "Software"), to deal in the Software without
+;;   restriction, including without limitation the rights to use,
+;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;   copies of the Software, and to permit persons to whom the
+;;   Software is furnished to do so, subject to the following
+;;   conditions:
+;; 
+;;   The above copyright notice and this permission notice shall be
+;;   included in all copies or substantial portions of the Software.
+;; 
+;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;   OTHER DEALINGS IN THE SOFTWARE.
+;; 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use test uri-common environments)
+
+(load "../uri-dispatch")
+(import uri-dispatch)
+
+(module test-module
+  (test1 test2 echo)
+  (import scheme chicken)
+
+  (define (echo . args) args)
+  (define (test1 . args) #t)
+  (define (test2 . args) #t))
+
+(define (test3 . args) #t)
+(define (echo2 . args) args)
+
+(define test-environment (make-environment))
+(environment-extend! test-environment 'test4 (constantly #t))
+(environment-extend! test-environment 'echo3 (lambda args args))
+
+(whitelist #f)
+
+(test-begin "uri-dispatch")
+
+(test "find procedure in module"
+      #t
+      (let ((uri (uri-reference "http://example.com/test-module/test1")))
+        (dispatch-uri uri)))
+
+(test "find procedure outside module"
+      #t
+      (let ((uri (uri-reference "http://example.com/test3")))
+        (dispatch-uri uri)))
+
+(test "find procedure outside module in custom environment"
+      #t
+      (let ((uri (uri-reference "http://example.com/test4")))
+        (parameterize ((dispatch-environment test-environment))
+          (dispatch-uri uri))))
+
+(test "find procedure outside module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/nonexistent")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
+          (dispatch-uri uri))))
+
+(test "find procedure outside module in custom env (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/test3")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (dispatch-environment test-environment))
+          (dispatch-uri uri))))
+
+(test "find procedure in module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/nomod/nonexistent")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
+          (dispatch-uri uri))))
+
+
+(test "whitelist procedure outside module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/test3")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '()))
+          (dispatch-uri uri))))
+
+(test "whitelist module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/test-module/test1")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '()))
+          (dispatch-uri uri))))
+
+(test "whitelist procedure outside module (positive)"
+      #t
+      (let ((uri (uri-reference "http://example.com/test3")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '(test3)))
+          (dispatch-uri uri))))
+
+(test "whitelist procedure inside module (positive)"
+      #t
+      (let ((uri (uri-reference "http://example.com/test-module/test1")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '((test-module . (test1)))))
+          (dispatch-uri uri))))
+
+(test "whitelist procedure inside module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/test-module/test2")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '((test-module . (test1)))))
+          (dispatch-uri uri))))
+
+(test "whitelist procedure inside fully whitelisted module"
+      #t
+      (let ((uri (uri-reference "http://example.com/test-module/test2")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '((test-module . *))))
+          (dispatch-uri uri))))
+      
+(test "default-dispatch-target"
+      #t
+      (let ((uri (uri-reference "http://example.com")))
+        (parameterize ((default-dispatch-target (lambda args  #t)))
+          (dispatch-uri uri))))
+
+(test "dispatch-error"
+      'custom-error
+      (let ((uri (uri-reference "http://example.com/i/dont/exist")))
+        (parameterize ((dispatch-error (lambda  args 'custom-error)))
+          (dispatch-uri uri))))
+
+(test "pass arguments (in module)"
+      (list "this" "is" "a" "test")
+      (let ((uri (uri-reference "http://example.com/test-module/echo/this/is/a/test")))
+        (dispatch-uri uri)))
+
+(test "pass arguments"
+      (list "this" "is" "a" "test")
+      (let ((uri (uri-reference "http://example.com/echo2/this/is/a/test")))
+        (dispatch-uri uri)))
+
+(test "pass arguments (in environment)"
+      (list "this" "is" "a" "test")
+      (let ((uri (uri-reference "http://example.com/echo3/this/is/a/test")))
+        (parameterize ((dispatch-environment test-environment))
+          (dispatch-uri uri))))
+
+(test-end "uri-dispatch")
+
+
+(unless (zero? (test-failure-count)) (exit 1))

File tests/run.scm

+;; Description: 
+;; Author: David Krentzlin <david@lisp-unleashed.de>
+;; Created: Mi Jul 15 19:33:46 2009 (CEST)
+;; Last-Updated: So Aug  9 18:42:53 2009 (CEST)
+;;           By: David Krentzlin <david@lisp-unleashed.de>
+;;     Update #: 36
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 
+;; Copyright (c) <2009> David Krentzlin <david@lisp-unleashed.de>
+;; 
+;;   Permission is hereby granted, free of charge, to any person
+;;   obtaining a copy of this software and associated documentation
+;;   files (the "Software"), to deal in the Software without
+;;   restriction, including without limitation the rights to use,
+;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;   copies of the Software, and to permit persons to whom the
+;;   Software is furnished to do so, subject to the following
+;;   conditions:
+;; 
+;;   The above copyright notice and this permission notice shall be
+;;   included in all copies or substantial portions of the Software.
+;; 
+;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;   OTHER DEALINGS IN THE SOFTWARE.
+;; 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use test uri-common environments)
+
+(load "../uri-dispatch")
+(import uri-dispatch)
+
+(module test-module
+  (test1 test2 echo)
+  (import scheme chicken)
+
+  (define (echo . args) args)
+  (define (test1 . args) #t)
+  (define (test2 . args) #t))
+
+(define (test3 . args) #t)
+(define (echo2 . args) args)
+
+(define test-environment (make-environment))
+(environment-extend! test-environment 'test4 (constantly #t))
+(environment-extend! test-environment 'echo3 (lambda args args))
+
+(whitelist #f)
+
+(test-begin "uri-dispatch")
+
+(test "find procedure in module"
+      #t
+      (let ((uri (uri-reference "http://example.com/test-module/test1")))
+        (dispatch-uri uri)))
+
+(test "find procedure outside module"
+      #t
+      (let ((uri (uri-reference "http://example.com/test3")))
+        (dispatch-uri uri)))
+
+(test "find procedure outside module in custom environment"
+      #t
+      (let ((uri (uri-reference "http://example.com/test4")))
+        (parameterize ((dispatch-environment test-environment))
+          (dispatch-uri uri))))
+
+(test "find procedure outside module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/nonexistent")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
+          (dispatch-uri uri))))
+
+(test "find procedure outside module in custom env (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/test3")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (dispatch-environment test-environment))
+          (dispatch-uri uri))))
+
+(test "find procedure in module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/nomod/nonexistent")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
+          (dispatch-uri uri))))
+
+
+(test "whitelist procedure outside module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/test3")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '()))
+          (dispatch-uri uri))))
+
+(test "whitelist module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/test-module/test1")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '()))
+          (dispatch-uri uri))))
+
+(test "whitelist procedure outside module (positive)"
+      #t
+      (let ((uri (uri-reference "http://example.com/test3")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '(test3)))
+          (dispatch-uri uri))))
+
+(test "whitelist procedure inside module (positive)"
+      #t
+      (let ((uri (uri-reference "http://example.com/test-module/test1")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '((test-module . (test1)))))
+          (dispatch-uri uri))))
+
+(test "whitelist procedure inside module (negative)"
+      'dispatch-error
+      (let ((uri (uri-reference "http://example.com/test-module/test2")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '((test-module . (test1)))))
+          (dispatch-uri uri))))
+
+(test "whitelist procedure inside fully whitelisted module"
+      #t
+      (let ((uri (uri-reference "http://example.com/test-module/test2")))
+        (parameterize ((dispatch-error (lambda args 'dispatch-error))
+                       (whitelist '((test-module . *))))
+          (dispatch-uri uri))))
+      
+(test "default-dispatch-target"
+      #t
+      (let ((uri (uri-reference "http://example.com")))
+        (parameterize ((default-dispatch-target (lambda args  #t)))
+          (dispatch-uri uri))))
+
+(test "dispatch-error"
+      'custom-error
+      (let ((uri (uri-reference "http://example.com/i/dont/exist")))
+        (parameterize ((dispatch-error (lambda  args 'custom-error)))
+          (dispatch-uri uri))))
+
+(test "pass arguments (in module)"
+      (list "this" "is" "a" "test")
+      (let ((uri (uri-reference "http://example.com/test-module/echo/this/is/a/test")))
+        (dispatch-uri uri)))
+
+(test "pass arguments"
+      (list "this" "is" "a" "test")
+      (let ((uri (uri-reference "http://example.com/echo2/this/is/a/test")))
+        (dispatch-uri uri)))
+
+(test "pass arguments (in environment)"
+      (list "this" "is" "a" "test")
+      (let ((uri (uri-reference "http://example.com/echo3/this/is/a/test")))
+        (parameterize ((dispatch-environment test-environment))
+          (dispatch-uri uri))))
+
+(test-end "uri-dispatch")
+
+
+(unless (zero? (test-failure-count)) (exit 1))

File uri-dispatch.meta

+((egg "uri-dispatch.egg")
+ (author "David Krentzlin")
+ (synopsis "Simple dispatch based on the supplied uri")
+ (category web)
+ (license "MIT")
+ (doc-from-wiki)
+ (test-depends test)
+ (depends uri-common environments)
+ (files "uri-dispatch.setup" "uri-dispatch.release-info" "uri-dispatch.scm" "uri-dispatch.meta" "tests/run.scm")) 

File uri-dispatch.release-info

+(repo svn "http://anonymous@code.call-cc.org/svn/chicken-eggs/release/4/{egg-name}")
+(uri meta-file "http://anonymous@code.call-cc.org/svn/chicken-eggs/release/4/{egg-name}/tags/{egg-release}/{egg-name}.meta")
+(release "1.0")

File uri-dispatch.scm

+;; Author: David Krentzlin <david@lisp-unleashed.de>
+;; Created: Mi Jul 15 18:58:29 2009 (CEST)
+;; Version: $Id$
+;; Version: 
+;; Last-Updated: So Sep 20 14:41:10 2009 (CEST)
+;;           By: David Krentzlin <david@lisp-unleashed.de>
+;;     Update #: 148
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 
+;; Copyright (c) <2009> David Krentzlin <david@lisp-unleashed.de>
+;; 
+;;   Permission is hereby granted, free of charge, to any person
+;;   obtaining a copy of this software and associated documentation
+;;   files (the "Software"), to deal in the Software without
+;;   restriction, including without limitation the rights to use,
+;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;   copies of the Software, and to permit persons to whom the
+;;   Software is furnished to do so, subject to the following
+;;   conditions:
+;; 
+;;   The above copyright notice and this permission notice shall be
+;;   included in all copies or substantial portions of the Software.
+;; 
+;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+;;   OTHER DEALINGS IN THE SOFTWARE.
+;; 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(module uri-dispatch
+  (dispatch-error dispatch-environment invoke-handler
+   whitelist default-dispatch-target dispatch-uri)
+  (import scheme chicken)
+  (require-library uri-common environments srfi-13 srfi-1 data-structures)
+  (import (only uri-common uri-reference? uri-path)
+          (only srfi-13 string-append)
+          (only srfi-1 find)
+          (only data-structures alist-ref conc constantly)
+          (only environments environment-ref environment-has-binding?))
+
+  (define dispatch-error (make-parameter (constantly #f)))
+  (define whitelist (make-parameter #f))
+  (define dispatch-environment (make-parameter (interaction-environment)))
+  (define default-dispatch-target (make-parameter #f))
+
+  (define (default-invoker procedure  arguments)
+    (condition-case
+     (apply procedure arguments)
+     (exn () (dispatch-error exn))))
+
+  (define invoke-handler (make-parameter default-invoker))
+
+  (define (dispatch-uri uri)
+    (unless (uri-reference? uri)
+      (error "Supplied argument must be an uri"))
+    (let ((path (cdr (uri-path uri))))
+      (cond
+       ((null? path)
+        (apply (or (default-dispatch-target)
+                   (dispatch-error)) '()))
+       ((null? (cdr path))
+        (if (equal? (car path) "")
+            (apply (or (default-dispatch-target) (dispatch-error)) '())
+            (let ((handler (handler-ref (string->symbol (car path)))))
+              (if handler
+                  ((invoke-handler) handler (cdr path))
+                  (apply (dispatch-error) path)))))
+       (else
+        (let ((mod/proc (handler-ref (string->symbol (cadr path)) (string->symbol (car path)))))
+          (if mod/proc
+              (apply mod/proc (cddr path))
+              (let ((handler (handler-ref (string->symbol (car path)))))
+                (if handler
+                    ((invoke-handler) handler (cdr path))
+                    (apply (dispatch-error) path)))))))))
+
+  (define (handler-ref symbol #!optional (mod #f))
+    (and-let* ((name (if mod (string->symbol (conc mod "#" symbol)) symbol))
+               ((environment-has-binding? (or (dispatch-environment)
+                                              (interaction-environment)) name))
+               (binding (environment-ref (or (dispatch-environment)
+                                             (interaction-environment)) name))
+               ((procedure? binding))
+               ((whitelisted? symbol mod)))
+      binding))
+
+  (define (whitelisted? symbol mod)
+    (or (not (whitelist))
+        (if (not mod)
+            (memq symbol (whitelist))
+            (let ((module.symbols (find (lambda (p)
+                                          (and (pair? p)
+                                               (eq? mod (car p))))
+                                        (whitelist))))
+              (and module.symbols
+                   (or (eq? (cdr module.symbols) '*)
+                       (memq symbol (cdr module.symbols))))))))
+
+)           

File uri-dispatch.setup

+(compile -s -O2 -d0 uri-dispatch.scm -j uri-dispatch)
+(compile -s -O2 -d0 uri-dispatch.import.scm)
+
+(install-extension
+  'uri-dispatch
+  '("uri-dispatch.import.so" "uri-dispatch.so")
+  '((version 1.0)))
+