#lang scheme
(require (planet schematics/schemeunit:3)
         web-server/http
         web-server/dispatchers/dispatch
         net/url
         scheme/stxparam
         web-server/dispatch/coercion
         web-server/dispatch/bidi-match
         web-server/dispatch/http-expanders
         web-server/dispatch/pattern
         web-server/dispatch/url-patterns
         web-server/dispatch/syntax
         web-server/dispatch/serve)
(provide all-dispatch-tests)

(define (test-request url)
  (make-request #"GET" url null null #f "1.2.3.4" 123 "4.3.2.1"))

(define all-dispatch-tests
  (test-suite
   "Dispatch"
   
   #;(local
     [(define-syntax test-match=>
        (syntax-rules ()
          [(_ val pat res)
           (test-equal? (format "~S" 'pat)
                        (match=> val [pat => (lambda x x)])
                        res)]))]
     (test-suite
      "match"
      
      (test-match=> (list 1 2) (list a b) (list 1 2))
      (test-match=> (list 1 2) (list _ b) (list 2))))   
   
   (test-suite
    "coercion"
    
    (test-suite "make-coerce-safe?"
                (local [(define string->number? (make-coerce-safe? string->number))]
                  (test-not-false "1" (string->number? "1"))
                  (test-not-false "1.2" (string->number? "1.2"))
                  (test-not-false "+inf.0" (string->number? "+inf.0"))
                  (test-false "a" (string->number? "a"))))
    
    
    (test-suite "define-coercion-match-expander"
                (local [(define string->number? (make-coerce-safe? string->number))
                        (define-coercion-match-expander string->number/m string->number? string->number)
                        (define (test i r)
                          (test-equal? i (match i [(string->number/m a) a] [_ #f]) r))]
                  (test "1" 1)
                  (test "1.2" 1.2)
                  (test "+inf.0" +inf.0)
                  (test "a" #f))))
   
   (local [(define string->number? (make-coerce-safe? string->number))
           (define-coercion-match-expander string->number/m string->number? string->number)
           (define-coercion-match-expander number->string/m number? number->string)
           (define-bidi-match-expander number-arg string->number/m number->string/m)
           (define (test i r)
             (cond
               [(and i r)
                (test-suite (format "~S" (list i r))
                            (test-equal? (format "~S" i)
                                         (syntax-parameterize ([bidi-match-going-in? #t])
                                                              (match i [(number-arg a) a] [_ #f]))
                                         r)
                            (test-equal? (format "~S" r)
                                         (syntax-parameterize ([bidi-match-going-in? #f])
                                                              (match r [(number-arg a) a] [_ #f]))
                                         i))]
               
               [i
                (test-equal? (format "~S" i)
                             (syntax-parameterize ([bidi-match-going-in? #t])
                                                  (match i [(number-arg a) a] [_ #f]))
                             r)]
               [r
                (test-equal? (format "~S" r)
                             (syntax-parameterize ([bidi-match-going-in? #f])
                                                  (match r [(number-arg a) a] [_ #f]))
                             i)]))]
     (test-suite
      "bidi-match"
      (test "1" 1)
      (test "1.2" 1.2)
      (test "+inf.0" +inf.0)
      (test "a" #f)
      (test #f "a")))
   
   (test-suite
    "http-expanders"
    
    (test-not-false "http://www.example.com/new"    
                    (match (string->url "http://www.example.com/new")
                      [(url/paths "new")
                       #t]
                      [else
                       #f]))
    
    (test-not-false "http://www.example.com/"    
                    (match (string->url "http://www.example.com/")
                      [(url/paths "")
                       #t]
                      [else
                       #f]))
    
    (test-not-false "http://www.example.com"    
                    (match (string->url "http://www.example.com")
                      [(url/paths)
                       #t]
                      [else
                       #f]))
    
    (test-false "http://www.example.com/foo"    
                (match (string->url "http://www.example.com/foo")
                  [(url/paths "new")
                   #t]
                  [else
                   #f]))
    
    (test-equal? "http://www.example.com/new/50"
                 (match (string->url "http://www.example.com/new/50")
                   [(url/paths "new" (integer-arg a))
                    a]
                   [else
                    #f])
                 50)
    
    (test-false "http://www.example.com/new"
                (match (string->url "http://www.example.com/new")
                  [(url/paths "new" (integer-arg a))
                   a]
                  [else
                   #f]))
    
    (test-not-false "http://www.example.com/new"
                    (match (test-request (string->url "http://www.example.com/new"))
                      [(request/url (url/paths "new"))
                       #t]
                      [else
                       #f]))
    
    (test-equal? "http://www.example.com/new/50"
                 (match (test-request (string->url "http://www.example.com/new/50"))
                   [(request/url (url/paths "new" (integer-arg a)))
                    a]
                   [else
                    #f])
                 50))
   
   (test-suite
    "pattern"
    
    (test-false "string-syntax?" (string-syntax? #'a))
    (test-false "string-syntax?" (string-syntax? #'(a b)))
    (test-not-false "string-syntax?" (string-syntax? #'"foo"))
    
    (test-equal? "dispatch-pattern-next-...?"
                 (dispatch-pattern-next-...? #'(a))
                 (list #f))
    (test-equal? "dispatch-pattern-next-...?"
                 (dispatch-pattern-next-...? #'(a b))
                 (list #f #f))
    (test-equal? "dispatch-pattern-next-...?"
                 (dispatch-pattern-next-...? #'(a (... ...)))
                 (list #t))
    
    (test-equal? "dispatch-pattern-not-..."
                 (map syntax->datum (dispatch-pattern-not-... #'(a)))
                 '(a))
    (test-equal? "dispatch-pattern-not-..."
                 (map syntax->datum (dispatch-pattern-not-... #'(a b)))
                 '(a b))
    (test-equal? "dispatch-pattern-not-..."
                 (map syntax->datum (dispatch-pattern-not-... #'(a (... ...))))
                 '(a))
    
    (local
      [(define (test in out)
         (test-equal? "dispatch-pattern->dispatch-pattern/ids"
                      (map syntax->datum (dispatch-pattern->dispatch-pattern/ids in))
                      out))]
      (test-suite
       "dispatch-pattern->dispatch-pattern/ids"
       (test #'() empty)
       (test #'("string") (list "string"))
       (test #'((... ...)) (list '...))
       
       (test-case "arg"
                  (check-equal? (first (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg))))))
                                'string-arg)
                  (check-pred symbol? (second (first (map syntax->datum (dispatch-pattern->dispatch-pattern/ids #'((string-arg))))))))))    
    
    (test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((... ...)))))
    (test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'("foo" (... ...)))))
    (test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((integer-arg a) (... ...)))))
    (test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((integer-arg a)))))
    (test-exn "dispatch-pattern?" exn? (lambda () (dispatch-pattern? #'((list a b) (... ...)))))
    (test-not-false "dispatch-pattern?" (dispatch-pattern? #'((integer-arg) (... ...))))
    (test-not-false "dispatch-pattern?" (dispatch-pattern? #'((integer-arg))))
    (test-not-false "dispatch-pattern?" (dispatch-pattern? #'("foo")))
    
    (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((... ...)))))
    (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'("foo" (... ...)))))
    (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a) (... ...))))
    (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'((integer-arg a))))
    (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((list a b) (... ...)))))
    (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((integer-arg) (... ...)))))
    (test-exn "dispatch-pattern/ids?" exn? (lambda () (dispatch-pattern/ids? #'((integer-arg)))))
    (test-not-false "dispatch-pattern/ids?" (dispatch-pattern/ids? #'("foo"))))    
   
   (local [(define-syntax test-arg
             (syntax-rules ()
               [(_ arg
                   ([in-expr out-expr] ...)
                   [in-fail-expr ...]
                   [out-fail-expr ...])
                (test-suite (format "~S" 'arg)
                            (test-equal? (format "in ~S" in-expr)
                                         (syntax-parameterize ([bidi-match-going-in? #t])
                                                              (match in-expr [(arg a) a]))
                                         out-expr)
                            ...
                            (test-equal? (format "out ~S" out-expr)
                                         (syntax-parameterize ([bidi-match-going-in? #f])
                                                              (match out-expr [(arg a) a]))
                                         in-expr)
                            ...
                            (test-false (format "in-fail ~S" in-fail-expr)
                                        (syntax-parameterize ([bidi-match-going-in? #t])
                                                             (match in-fail-expr [(arg a) a] [_ #f])))
                            ...
                            (test-false (format "out-fail ~S" out-fail-expr)
                                        (syntax-parameterize ([bidi-match-going-in? #f])
                                                             (match out-fail-expr [(arg a) a] [_ #f])))
                            ...)]))]
     (test-suite
      "url-patterns"
      
      (test-arg number-arg
                (["1" 1]
                 ["2.3" 2.3]
                 ["+inf.0" +inf.0])
                ["a"]
                ['a #t])
      
      (test-arg integer-arg
                (["1" 1])
                ["a" "2.3" "+inf.0"]
                ['a #t 2.3 +inf.0])
      
      (test-arg real-arg
                (["1" 1]
                 ["2.3" 2.3]
                 ["+inf.0" +inf.0])
                ["a"]
                ['a #t])
      
      (test-arg string-arg
                (["1" "1"]
                 ["foo" "foo"]
                 ["/" "/"])
                []
                ['a #t 5])
      
      (test-arg symbol-arg
                (["1" '|1|]
                 ["foo" 'foo]
                 ["/" '/])
                []
                ["a" #t 5])))
   
   (test-suite
    "syntax"
    
    (local
      [(define (list-posts req) `(list-posts))
       (define (review-post req p) `(review-post ,p))
       (define (review-archive req y m) `(review-archive ,y ,m))
       (define-values (blog-dispatch blog-url)
         (dispatch-rules
          [("") list-posts]
          [() list-posts]
          [("posts" (string-arg)) review-post]
          [("archive" (integer-arg) (integer-arg)) review-archive]))
       (define (test-blog-dispatch url res)
         (test-equal? url (blog-dispatch (test-request (string->url url))) res))
       (define (test-blog-url url . args)
         (test-equal? (format "~S" args)
                      (apply blog-url args)
                      url))
       (define (test-blog-url/exn . args)
         (test-exn (format "~S" args)
                   exn?
                   (lambda ()
                     (apply blog-url args))))
       (define (test-blog-dispatch/exn url)
         (test-exn url exn:dispatcher? (lambda () (blog-dispatch (test-request (string->url url))))))]
      
      (test-suite
       "blog"
       
       (test-blog-dispatch "http://www.example.com" `(list-posts))
       (test-blog-dispatch "http://www.example.com/" `(list-posts))
       (test-blog-dispatch "http://www.example.com/posts/hello-world" `(review-post "hello-world"))
       (test-blog-dispatch "http://www.example.com/archive/2008/02" `(review-archive 2008 02))
       (test-blog-dispatch/exn "http://www.example.com/posts")
       (test-blog-dispatch/exn "http://www.example.com/archive/post/02")
       (test-blog-dispatch/exn "http://www.example.com/archive/2008/post")
       (test-blog-dispatch/exn "http://www.example.com/foo")
       
       (test-blog-url "/" list-posts)
       (test-blog-url "/posts/hello-world" review-post "hello-world")
       (test-blog-url "/archive/2008/2" review-archive 2008 02)
       (test-blog-url/exn list-posts 50)
       (test-blog-url/exn +)
       (test-blog-url/exn review-post 50)
       (test-blog-url/exn review-post "hello" "world")
       (test-blog-url/exn review-archive 2008 02 1)
       (test-blog-url/exn review-archive "2008" 02)
       (test-blog-url/exn review-archive 2008 "02")))
    
    (local
      [(define (sum req as) (apply + as))
       (define-values (rest-dispatch rest-url)
         (dispatch-rules
          [((integer-arg) ...) sum]))
       (define (test-rest-dispatch url res)
         (test-equal? url (rest-dispatch (test-request (string->url url))) res))
       (define (test-rest-url url . args)
         (test-equal? (format "~S" args)
                      (apply rest-url args)
                      url))
       (define (test-rest-url/exn . args)
         (test-exn (format "~S" args)
                   exn?
                   (lambda ()
                     (apply rest-url args))))
       (define (test-rest-dispatch/exn url)
         (test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))]
      (test-suite
       "rest args"
       
       (test-rest-dispatch "http://www.sum.com" 0)
       (test-rest-dispatch "http://www.sum.com/1" 1)
       (test-rest-dispatch "http://www.sum.com/1/2" 3)
       (test-rest-dispatch "http://www.sum.com/1/2/3" 6)
       (test-rest-dispatch/exn "http://www.sum.com/1/2/3/bar")
       (test-rest-dispatch/exn "http://www.sum.com/1/bar")
       (test-rest-dispatch/exn "http://www.sum.com/bar")
       
       (test-rest-url "/" sum empty)
       (test-rest-url "/1" sum (list 1))
       (test-rest-url "/1/2" sum (list 1 2))
       (test-rest-url "/1/2/3" sum (list 1 2 3))
       (test-rest-url/exn sum "foo")
       (test-rest-url/exn sum 'bar)
       (test-rest-url/exn sum 1)
       (test-rest-url/exn sum #t)))
    
    (local
      [(define (sum req as ss) (list* (apply + as) ss))
       (define-values (rest-dispatch rest-url)
         (dispatch-rules
          [((integer-arg) ... (string-arg) ...) sum]))
       (define (test-rest-dispatch url res)
         (test-equal? url (rest-dispatch (test-request (string->url url))) res))
       (define (test-rest-url url . args)
         (test-equal? (format "~S" args)
                      (apply rest-url args)
                      url))
       (define (test-rest-url/exn . args)
         (test-exn (format "~S" args)
                   exn?
                   (lambda ()
                     (apply rest-url args))))
       (define (test-rest-dispatch/exn url)
         (test-exn url exn:dispatcher? (lambda () (rest-dispatch (test-request (string->url url))))))]
      (test-suite
       "rest args (2)"
       
       (test-rest-dispatch "http://www.sum.com" (list 0))
       (test-rest-dispatch "http://www.sum.com/1" (list 1))
       (test-rest-dispatch "http://www.sum.com/1/2" (list 3))
       (test-rest-dispatch "http://www.sum.com/1/2/3" (list 6))
       (test-rest-dispatch "http://www.sum.com/1/2/3/bar" (list 6 "bar"))
       (test-rest-dispatch "http://www.sum.com/1/bar" (list 1 "bar"))
       (test-rest-dispatch "http://www.sum.com/1/bar/zog" (list 1 "bar" "zog"))
       (test-rest-dispatch "http://www.sum.com/bar/zog" (list 0 "bar" "zog"))
       
       (test-rest-url "/" sum empty empty)
       (test-rest-url "/1" sum (list 1) empty)
       (test-rest-url "/1/2" sum (list 1 2) empty)
       (test-rest-url "/1/2/3" sum (list 1 2 3) empty)
       (test-rest-url "/bar" sum empty (list "bar"))
       (test-rest-url "/bar/zog" sum empty (list "bar" "zog"))
       (test-rest-url "/1/2/bar" sum (list 1 2) (list "bar"))
       (test-rest-url/exn sum "foo")
       (test-rest-url/exn sum 'bar)
       (test-rest-url/exn sum 1)
       (test-rest-url/exn sum #t))))
   
   (test-suite
    "serve")))

(define (test-serve/dispatch)
  (define-values (start url)
    (dispatch-rules
     [("") get-first-number]
     [("/2nd" (number-arg)) get-second-number]
     [("sum" (number-arg) (number-arg)) display-sum]))
  (define (get-first-number req)
    `(html (head (title "First number"))
           (a ([href ,(url get-second-number 50)]) (h1 "+ 50"))))
  (define (get-second-number req fst)
    `(html (head (title "Second number"))
           (a ([href ,(url display-sum fst 100)]) (h1 "+ 100"))))
  (define (display-sum req fst snd)
    `(html (head (title "Sum"))
           (h1 ,(number->string (+ fst snd)))))
  
  (serve/dispatch start))

#;(test-serve/dispatch)

#;(require (planet schematics/schemeunit:3/text-ui))
#;(run-tests all-dispatch-tests)