source: project/release/4/uri-dispatch/trunk/tests/run.scm @ 15381

Last change on this file since 15381 was 15381, checked in by certainty, 10 years ago

renamed enable-checks to enable-whitelisting

File size: 5.0 KB
Line 
1;;; run.scm ---
2;;
3;; Filename: run.scm
4;; Description:
5;; Author: David Krentzlin <david@lisp-unleashed.de>
6;; Maintainer:
7;; Created: Mi Jul 15 19:33:46 2009 (CEST)
8;; Version: $Id$
9;; Version:
10;; Last-Updated: So Aug  9 18:42:53 2009 (CEST)
11;;           By: David Krentzlin <david@lisp-unleashed.de>
12;;     Update #: 36
13;; URL:
14;; Keywords:
15;; Compatibility:
16;;
17;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18;;
19;;; Commentary:
20;;
21;;
22;;
23;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
24;;
25;;; Change log:
26;;
27;;
28;; RCS $Log$
29;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30;;
31;; Copyright (c) <2009> David Krentzlin <david@lisp-unleashed.de>
32;;
33;;   Permission is hereby granted, free of charge, to any person
34;;   obtaining a copy of this software and associated documentation
35;;   files (the "Software"), to deal in the Software without
36;;   restriction, including without limitation the rights to use,
37;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
38;;   copies of the Software, and to permit persons to whom the
39;;   Software is furnished to do so, subject to the following
40;;   conditions:
41;;
42;;   The above copyright notice and this permission notice shall be
43;;   included in all copies or substantial portions of the Software.
44;;
45;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
46;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
47;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
48;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
49;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
50;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
51;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
52;;   OTHER DEALINGS IN THE SOFTWARE.
53;;
54;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55;;
56;;; Code:
57(use test uri-common uri-dispatch)
58(import uri-dispatch)
59
60(module test-module
61  (test1 test2 echo)
62  (import scheme chicken)
63
64  (define (echo . args) args)
65  (define (test1 . args) #t)
66  (define (test2 . args) #t))
67
68(define (test3 . args) #t)
69(define (echo2 . args) args)
70
71(enable-whitelisting #f)
72
73
74(test-begin "uri-dispatch")
75
76(test "find procedure in module"
77      #t
78      (let ((uri (uri-reference "http://example.com/test-module/test1")))
79        (dispatch-uri uri)))
80
81(test "find procedure outside module"
82      #t
83      (let ((uri (uri-reference "http://example.com/test3")))
84        (dispatch-uri uri)))
85
86(test "find procedure outside module (negative)"
87      'dispatch-error
88      (let ((uri (uri-reference "http://example.com/nonexistent")))
89        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
90          (dispatch-uri uri))))
91
92(test "find procedure in module (negative)"
93      'dispatch-error
94      (let ((uri (uri-reference "http://example.com/nomod/nonexistent")))
95        (parameterize ((dispatch-error (lambda args 'dispatch-error)))
96          (dispatch-uri uri))))
97
98
99(test "whitelist procedure outside module (negative)"
100      'dispatch-error
101      (let ((uri (uri-reference "http://example.com/test3")))
102        (parameterize ((dispatch-error (lambda args 'dispatch-error))
103                       (enable-whitelisting #t))
104          (dispatch-uri uri))))
105
106(test "whitelist module (negative)"
107      'dispatch-error
108      (let ((uri (uri-reference "http://example.com/test-module/test1")))
109        (parameterize ((dispatch-error (lambda args 'dispatch-error))
110                       (enable-whitelisting #t))
111          (dispatch-uri uri))))
112
113(test "whitelist procedure outside module (positive)"
114      #t
115      (let ((uri (uri-reference "http://example.com/test3")))
116        (parameterize ((dispatch-error (lambda args 'dispatch-error))
117                       (enable-whitelisting #t))
118          (whitelist! '(test3))
119          (dispatch-uri uri))))
120
121(test "whitelist procedure inside module (positive)"
122      #t
123      (let ((uri (uri-reference "http://example.com/test-module/test1")))
124        (parameterize ((dispatch-error (lambda args 'dispatch-error))
125                       (enable-whitelisting #t))
126          (whitelist! '((module test-module)))
127          (dispatch-uri uri))))
128     
129(test "default-dispatch-target"
130      #t
131      (let ((uri (uri-reference "http://example.com")))
132        (parameterize ((default-dispatch-target (lambda args  #t)))
133          (dispatch-uri uri))))
134
135(test "dispatch-error"
136      'custom-error
137      (let ((uri (uri-reference "http://example.com/i/dont/exist")))
138        (parameterize ((dispatch-error (lambda  args 'custom-error)))
139          (dispatch-uri uri))))
140
141(test "pass arguments (in module)"
142      (list "this" "is" "a" "test")
143      (let ((uri (uri-reference "http://example.com/test-module/echo/this/is/a/test")))
144        (dispatch-uri uri)))
145
146(test "pass arguments"
147      (list "this" "is" "a" "test")
148      (let ((uri (uri-reference "http://example.com/echo2/this/is/a/test")))
149        (dispatch-uri uri)))
150
151(test-end "uri-dispatch")
152
153
154
155
156
157;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
158;;; run.scm ends here
Note: See TracBrowser for help on using the repository browser.