;; 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))