basis/http/server/dispatchers/dispatchers-tests.factor

   1 USING: http.server http.server.dispatchers http.server.responses
   2 tools.test kernel namespaces accessors io http math sequences
   3 assocs arrays classes words urls ;
   4 IN: http.server.dispatchers.tests
   5
   6 TUPLE: mock-responder path ;
   7
   8 C: <mock-responder> mock-responder
   9
  10 M: mock-responder call-responder*
  11     nip
  12     path>> on
  13     [ ] "text/plain" <content> ;
  14
  15 : check-dispatch ( tag path -- ? )
  16     V{ } clone responder-nesting set
  17     over off
  18     split-path
  19     main-responder get call-responder
  20     write-response get ;
  21
  22 [
  23     <dispatcher>
  24         "foo" <mock-responder> "foo" add-responder
  25         "bar" <mock-responder> "bar" add-responder
  26         <dispatcher>
  27             "123" <mock-responder> "123" add-responder
  28             "default" <mock-responder> >>default
  29         "baz" add-responder
  30     main-responder set
  31
  32     [ "foo" ] [
  33         { "foo" } main-responder get find-responder path>> nip
  34     ] unit-test
  35
  36     [ "bar" ] [
  37         { "bar" } main-responder get find-responder path>> nip
  38     ] unit-test
  39
  40     [ t ] [ "foo" "foo" check-dispatch ] unit-test
  41     [ f ] [ "foo" "bar" check-dispatch ] unit-test
  42     [ t ] [ "bar" "bar" check-dispatch ] unit-test
  43     [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
  44     [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
  45     [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
  46     [ t ] [ "123" "baz/123" check-dispatch ] unit-test
  47     [ t ] [ "123" "baz///123" check-dispatch ] unit-test
  48
  49 ] with-scope
  50
  51 [
  52     <dispatcher>
  53         "default" <mock-responder> >>default
  54     main-responder set
  55
  56     [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
  57 ] with-scope
  58
  59 ! Make sure path for default responder isn't chopped
  60 TUPLE: path-check-responder ;
  61
  62 C: <path-check-responder> path-check-responder
  63
  64 M: path-check-responder call-responder*
  65     drop
  66     >array "text/plain" <content> ;
  67
  68 [ { "c" } ] [
  69     V{ } clone responder-nesting set
  70
  71     { "b" "c" }
  72     <dispatcher>
  73         <dispatcher>
  74             <path-check-responder> >>default
  75         "b" add-responder
  76     call-responder
  77     body>>
  78 ] unit-test
  79
  80 ! Test that "" dispatcher works with default>>
  81 [ ] [
  82     <dispatcher>
  83         "" <mock-responder> "" add-responder
  84         "bar" <mock-responder> "bar" add-responder
  85         "baz" <mock-responder> >>default
  86     main-responder set
  87
  88     [ t ] [ "" "" check-dispatch ] unit-test
  89     [ f ] [ "" "quux" check-dispatch ] unit-test
  90     [ t ] [ "baz" "quux" check-dispatch ] unit-test
  91     [ f ] [ "foo" "bar" check-dispatch ] unit-test
  92     [ t ] [ "bar" "bar" check-dispatch ] unit-test
  93     [ t ] [ "baz" "xxx" check-dispatch ] unit-test
  94 ] unit-test