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 <dispatcher>
  23     "foo" <mock-responder> "foo" add-responder
  24     "bar" <mock-responder> "bar" add-responder
  25     <dispatcher>
  26         "123" <mock-responder> "123" add-responder
  27         "default" <mock-responder> >>default
  28     "baz" add-responder
  29 main-responder [
  30
  31     [ "foo" ] [
  32         { "foo" } main-responder get find-responder path>> nip
  33     ] unit-test
  34
  35     [ "bar" ] [
  36         { "bar" } main-responder get find-responder path>> nip
  37     ] unit-test
  38
  39     [ t ] [ "foo" "foo" check-dispatch ] unit-test
  40     [ f ] [ "foo" "bar" check-dispatch ] unit-test
  41     [ t ] [ "bar" "bar" check-dispatch ] unit-test
  42     [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
  43     [ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
  44     [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
  45     [ t ] [ "123" "baz/123" check-dispatch ] unit-test
  46     [ t ] [ "123" "baz///123" check-dispatch ] unit-test
  47
  48 ] with-variable
  49
  50 <dispatcher>
  51     "default" <mock-responder> >>default
  52 main-responder [
  53
  54     [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
  55 ] with-variable
  56
  57 ! Make sure path for default responder isn't chopped
  58 TUPLE: path-check-responder ;
  59
  60 C: <path-check-responder> path-check-responder
  61
  62 M: path-check-responder call-responder*
  63     drop
  64     >array "text/plain" <content> ;
  65
  66 [ { "c" } ] [
  67     V{ } clone responder-nesting set
  68
  69     { "b" "c" }
  70     <dispatcher>
  71         <dispatcher>
  72             <path-check-responder> >>default
  73         "b" add-responder
  74     call-responder
  75     body>>
  76 ] unit-test
  77
  78 ! Test that "" dispatcher works with default>>
  79 [ ] [
  80     <dispatcher>
  81         "" <mock-responder> "" add-responder
  82         "bar" <mock-responder> "bar" add-responder
  83         "baz" <mock-responder> >>default
  84     main-responder set
  85
  86     [ t ] [ "" "" check-dispatch ] unit-test
  87     [ f ] [ "" "quux" check-dispatch ] unit-test
  88     [ t ] [ "baz" "quux" check-dispatch ] unit-test
  89     [ f ] [ "foo" "bar" check-dispatch ] unit-test
  90     [ t ] [ "bar" "bar" check-dispatch ] unit-test
  91     [ t ] [ "baz" "xxx" check-dispatch ] unit-test
  92 ] unit-test