Changeset 5250 in project


Ignore:
Timestamp:
07/30/07 03:55:24 (13 years ago)
Author:
Alaric Snell-Pym
Message:

Fixed a wee bug with how I was handling alists of query arguments...

Then implemented a crude Spiffy request faker, and used it to unit-test
wings:handler-wrap.

Location:
wings/trunk
Files:
2 added
2 edited

Legend:

Unmodified
Added
Removed
  • wings/trunk/tests/run.scm

    r5237 r5250  
    33
    44(require-extension test)
    5 
    6 (match-error-control fail:) ; Don't mess up beautiful test egg output
     5(require-extension web-scheme-handler)
     6
     7(require-extension spiffy)
     8(require-extension uri)
     9(require-extension http-utils)
     10(define (call-with-fake-spiffy-request method string-url-without-pathinfo string-pathinfo client-ip attributes body thunk) 
     11  (let*
     12    ((url-without-pathinfo (uri string-url-without-pathinfo))
     13    (complete-path (append (uri-path url-without-pathinfo)
     14                           (string-split (uri-decode string-pathinfo) "/")))
     15    (url (*make-uri
     16      'http
     17      (list (uri-authority url-without-pathinfo) complete-path (uri-query url-without-pathinfo))
     18      #f)))
     19    (parameterize
     20      ((current-request
     21        (http:make-request method (uri->string url) attributes '() body 'HTTP/1.1 client-ip))
     22      (current-urlencoded-arguments
     23        (if (uri-query url)
     24          (map
     25            (lambda (x)
     26              (cons (uri-encode (car x)) (uri-encode (cdr x))))
     27            (uri-query url))
     28          '()))
     29      (current-response-code '(200 . "OK"))
     30      (current-response-headers '(("content-type" . "text/html")))
     31      (current-hostname (uri-host url))
     32      (current-pathinfo string-pathinfo)
     33      (current-path (uri->string (*make-uri
     34        'http
     35        (list (uri-authority url) (uri-path url) '())
     36        #f))))
     37      (thunk))))
     38
     39(match-error-procedure (lambda (failure)
     40  (signal '(exn match)))) ; Don't mess up beautiful test egg output
    741
    842(test-begin "wings")
     
    120154    "abc"
    121155    (process-named-atom-arg "arg"
    122       '(("bob" "fish")
    123         ("arg" "abc")
    124         ("asdf" "sdg"))))
     156      '(("bob" . "fish")
     157        ("arg" . "abc")
     158        ("asdf" . "sdg"))))
    125159
    126160  (test-error "Extract a missing argument"
    127161    (process-named-atom-arg "arg"
    128       '(("bob" "fish")
    129         ("arg2" "abc")
    130         ("asdf" "sdg")))))
     162      '(("bob" . "fish")
     163        ("arg2" . "abc")
     164        ("asdf" . "sdg")))))
    131165
    132166(test-group "build-vector-from-indexed-alist"
     
    151185    (process-named-list-arg "test" '(set string)
    152186      '(
    153       ("a" "1")
    154       ("b" "2")
    155       ("test" "unrelated")
    156       ("test[0]" "elem1a")
    157       ("test[1]" "elem2")
    158       ("test[0]" "elem1b")
    159       ("test[2]" "elem3"))))) 
     187      ("a" . "1")
     188      ("b" . "2")
     189      ("test" . "unrelated")
     190      ("test[0]" . "elem1a")
     191      ("test[1]" . "elem2")
     192      ("test[0]" . "elem1b")
     193      ("test[2]" . "elem3"))))) 
    160194
    161195(test-group "process-named-alist-arg"
     
    164198    (process-named-alist-arg "test" '(set string)
    165199      '(
    166       ("a" "1")
    167       ("b" "2")
    168       ("test" "unrelated")
    169       ("test[bob]" "elem1a")
    170       ("test[dave]" "elem2")
    171       ("test[bob]" "elem1b")
    172       ("test[charles]" "elem3"))))) 
     200      ("a" . "1")
     201      ("b" . "2")
     202      ("test" . "unrelated")
     203      ("test[bob]" . "elem1a")
     204      ("test[dave]" . "elem2")
     205      ("test[bob]" . "elem1b")
     206      ("test[charles]" . "elem3"))))) 
    173207
    174208(test-group "process-named-hash-table-arg"
     
    177211    (process-named-hash-table-arg "test" '(set string)
    178212      '(
    179       ("a" "1")
    180       ("b" "2")
    181       ("test" "unrelated")
    182       ("test[bob]" "elem1a")
    183       ("test[dave]" "elem2")
    184       ("test[bob]" "elem1b")
    185       ("test[charles]" "elem3"))))) 
     213      ("a" . "1")
     214      ("b" . "2")
     215      ("test" . "unrelated")
     216      ("test[bob]" . "elem1a")
     217      ("test[dave]" . "elem2")
     218      ("test[bob]" . "elem1b")
     219      ("test[charles]" . "elem3"))))) 
    186220
    187221
     
    191225    (process-named-set-arg "test" '(symbol)
    192226      '(
    193       ("a" "1")
    194       ("b" "2")
    195       ("test" "unrelated")
    196       ("test" "elem1a")
    197       ("test" "elem2")
    198       ("test" "elem1b")
    199       ("test" "elem3"))))) 
     227      ("a" . "1")
     228      ("b" . "2")
     229      ("test" . "unrelated")
     230      ("test" . "elem1a")
     231      ("test" . "elem2")
     232      ("test" . "elem1b")
     233      ("test" . "elem3"))))) 
    200234
    201235(test-begin "process-named")
     
    229263      '( ; No "a", but it's optional, so we get #f not an error
    230264     
    231         ("b" "foo")
    232      
    233         ("c" "c")
     265        ("b" . "foo")
     266     
     267        ("c" . "c")
    234268       
    235         ("d" "1.3")
     269        ("d" . "1.3")
    236270       
    237         ("e" "1")
     271        ("e" . "1")
    238272       
    239         ("f" "anything")
     273        ("f" . "anything")
    240274       
    241         ("g" "t")
     275        ("g" . "t")
    242276       
    243         ("h" "yeah")
     277        ("h" . "yeah")
    244278       
    245279        ; No "i", but it's optional too
    246280       
    247         ("j" "garbage")
    248         ("k" "garbage")
     281        ("j" . "garbage")
     282        ("k" . "garbage")
    249283      )))
    250284     
     
    253287    (process-named
    254288      `((a "a" (? ,even?) integer))
    255       '(("a" "10"))))
     289      '(("a" . "10"))))
    256290
    257291  (test-error "Custom predicate failure"
    258292    (process-named
    259293      `((a "a" (? ,even?) integer))
    260       '(("a" "11"))))
     294      '(("a" . "11"))))
    261295
    262296  (test-error "Optional does not mask out syntax errors"
    263297    (process-named
    264298      `((a "a" optional (? ,even?) integer))
    265       '(("a" "11"))))
     299      '(("a" . "11"))))
    266300
    267301  (test "Permissive does mask out syntax errors"
     
    269303    (process-named
    270304      `((a "a" permissive (? ,even?) integer))
    271       '(("a" "11"))))
     305      '(("a" . "11"))))
    272306
    273307  (test "Sets"
     
    276310      '((d "d" set symbol a b c))
    277311      '(
    278         ("d" "a")
    279         ("d" "c")
     312        ("d" . "a")
     313        ("d" . "c")
    280314      )))
    281315
     
    285319      '((e "e" list set string))
    286320      '(
    287       ("e[3]" "bam")
    288       ("e[0]" "foo")
    289       ("e[1]" "baz")
    290       ("e[0]" "bar")
     321      ("e[3]" . "bam")
     322      ("e[0]" . "foo")
     323      ("e[1]" . "baz")
     324      ("e[0]" . "bar")
    291325      )))
    292326
     
    296330      '((e "e" list list string))
    297331      '(
    298       ("e[3][0]" "bam")
    299       ("e[0][0]" "foo")
    300       ("e[1][0]" "baz")
    301       ("e[0][1]" "bar")
     332      ("e[3][0]" . "bam")
     333      ("e[0][0]" . "foo")
     334      ("e[1][0]" . "baz")
     335      ("e[0][1]" . "bar")
    302336      )))
    303337
     
    311345      )
    312346      '(
    313         ("f[a]" "1")
    314         ("f[b]" "2")
    315         ("f[c]" "3")
     347        ("f[a]" . "1")
     348        ("f[b]" . "2")
     349        ("f[c]" . "3")
    316350      )))
    317351
     
    325359      )
    326360      '(
    327         ("f[a][0]" "1")
    328         ("f[a][1]" "2")
    329         ("f[a][2]" "3")
    330         ("f[b][2]" "4")
    331         ("f[b][1]" "5")
    332         ("f[b][0]" "6")
     361        ("f[a][0]" . "1")
     362        ("f[a][1]" . "2")
     363        ("f[a][2]" . "3")
     364        ("f[b][2]" . "4")
     365        ("f[b][1]" . "5")
     366        ("f[b][0]" . "6")
    333367      )))
    334368(test-end "process-named")
     
    499533    '(; a is default, so disappears
    500534   
    501       ("b" "foo")
    502    
    503       ("c" "c")
    504      
    505       ("d" "1.3")
    506      
    507       ("e" "1")
    508      
    509       ("f" "anything")
    510      
    511       ("g" "1")
    512      
    513       ("h" "yeah")
    514      
    515       ("i" "fish")
     535      ("b" . "foo")
     536   
     537      ("c" . "c")
     538     
     539      ("d" . "1.3")
     540     
     541      ("e" . "1")
     542     
     543      ("f" . "anything")
     544     
     545      ("g" . "1")
     546     
     547      ("h" . "yeah")
     548     
     549      ("i" . "fish")
    516550     
    517551      ; j and k are default, so disappear
     
    548582  (test "Sets"
    549583    '(
    550       ("d" "c")
    551       ("d" "a")
     584      ("d" . "c")
     585      ("d" . "a")
    552586    )
    553587    (make-query-string
     
    558592  (test "Lists of sets"
    559593    '(
    560     ("e[3]" "bam")
    561     ("e[1]" "baz")
    562     ("e[0]" "bar")
    563     ("e[0]" "foo")
     594    ("e[3]" . "bam")
     595    ("e[1]" . "baz")
     596    ("e[0]" . "bar")
     597    ("e[0]" . "foo")
    564598    )
    565599    (make-query-string
     
    570604  (test "Lists of lists"
    571605    '(
    572     ("e[3][0]" "bam")
    573     ("e[1][0]" "baz")
    574     ("e[0][1]" "bar")
    575     ("e[0][0]" "foo")
     606    ("e[3][0]" . "bam")
     607    ("e[1][0]" . "baz")
     608    ("e[0][1]" . "bar")
     609    ("e[0][0]" . "foo")
    576610    )
    577611   
     
    583617  (test "Alists"
    584618    '(
    585       ("f[c]" "3")
    586       ("f[b]" "2")
    587       ("f[a]" "1")
     619      ("f[c]" . "3")
     620      ("f[b]" . "2")
     621      ("f[a]" . "1")
    588622    )
    589623   
     
    598632  (test "Alists of lists"
    599633    '(
    600       ("f[b][2]" "4")
    601       ("f[b][1]" "5")
    602       ("f[b][0]" "6")
    603       ("f[a][2]" "3")
    604       ("f[a][1]" "2")
    605       ("f[a][0]" "1")
     634      ("f[b][2]" . "4")
     635      ("f[b][1]" . "5")
     636      ("f[b][0]" . "6")
     637      ("f[a][2]" . "3")
     638      ("f[a][1]" . "2")
     639      ("f[a][0]" . "1")
    606640    )
    607641   
     
    621655(test-end "URL processing")
    622656
     657(test-begin "Spiffy wrapper")
     658
     659(test "call-with-fake-spiffy-request"
     660  "HTTP/1.1 200 OK\r\nServer: #f\r\nLocation: #f\r\ncontent-type: text/html\r\nContent-Length: 164\r\n\r\n((\"e\" . \"12\") (\"d\" . \"foo%20bar\"))\n\"/1/my%20stuff\"\n\"http://www.example.com/test.ws/1/my%20stuff\"\n\"bar\"\n((d . \"foo bar\") (e . 12) (a . 1) (b . \"my stuff\") (c . #f))\n"
     661  (call-with-fake-spiffy-request
     662    'GET
     663    "http://www.example.com/test.ws?d=foo%20bar&e=12"
     664    "/1/my%20stuff"
     665    "127.0.0.1" '() ""
     666    (lambda ()
     667      (with-output-to-string (lambda ()
     668        ((wings:handler-wrap web-scheme-handler) "test.ws"))))))
     669
     670(test-end "Spiffy wrapper")
     671
    623672(test-end "wings")
  • wings/trunk/wings-base.scm

    r5237 r5250  
    3232(require-extension srfi-69) ; Hash tables
    3333(require-extension utils) ; Pathname tools
     34(require-extension uri) ; url-encode and url-decode
    3435
    3536;; Environment management
     
    104105        (thunk)
    105106      (wrapper thunk))))))
    106  
    107  
    108107
    109108;; Spiffy handler
     
    114113      (wings:call-with-wrappers
    115114        (lambda ()
    116           (wings:let (('parsed-arguments (wings:parse-url
     115          (let*
     116           ((urldecoded-pathinfo
     117              (map uri-decode (string-split (current-pathinfo) "/")))
     118            (urldecoded-arguments
     119              (map
     120                (lambda (x) (cons (uri-decode (car x)) (uri-decode (cdr x))))
     121                (current-urlencoded-arguments))))
     122          (let
     123            ((parsed-arguments (wings:parse-url
    117124              (wings:get 'arguments)
    118               (string-split (current-pathinfo) "/")
    119               (current-urlencoded-arguments))))
    120             (handler filename)))))))
     125              urldecoded-pathinfo
     126              urldecoded-arguments)))
     127
     128            (wings:let (('parsed-arguments parsed-arguments))
     129              (handler filename)))))))))
    121130   
    122131;; HTTP request argument parsing
     
    200209  (let ((l (assoc arg-name query-args)))
    201210    (if l
    202       (cadr l)
     211      (cdr l)
    203212      (wings:abort-not-found arg-name))))
    204213
     
    431440  ; FIXME: Add derived params
    432441  (append
    433     (process-if-present argdef 'named process-named path-info)
    434     (process-if-present argdef 'positional process-positional query-string)))
     442    (process-if-present argdef 'named process-named query-string)
     443    (process-if-present argdef 'positional process-positional path-info)))
    435444
    436445;; Path info generator
     
    510519    (('string)
    511520      (if (equal? value default) '()
    512         (list (list prefix value))))
     521        (list (cons prefix value))))
    513522    (('integer)
    514523      (if (equal? value default) '()
    515         (list (list prefix (number->string value)))))
     524        (list (cons prefix (number->string value)))))
    516525    (('number)
    517526      (if (equal? value default) '()
    518         (list (list prefix (number->string value)))))
     527        (list (cons prefix (number->string value)))))
    519528    (('symbol . options)
    520529      (if (equal? value default) '()
    521         (list (list prefix (symbol->string value)))))
     530        (list (cons prefix (symbol->string value)))))
    522531    (('boolean)
    523532      (if (equal? value default) '()
    524         (list (list prefix (if value "1" "0")))))
     533        (list (cons prefix (if value "1" "0")))))
    525534    (('boolean (yes . yeses) (no . noes))
    526535      (if (equal? value default) '()
    527         (list (list prefix (if value yes no)))))
     536        (list (cons prefix (if value yes no)))))
    528537    (('boolean yes no)
    529538      (if (equal? value default) '()
    530         (list (list prefix (if value yes no)))))
     539        (list (cons prefix (if value yes no)))))
    531540
    532541    ;; Compound types
Note: See TracChangeset for help on using the changeset viewer.