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