basis/furnace/sessions/sessions-tests.factor

   1 USING: tools.test http furnace.sessions furnace.actions\r
   2 http.server http.server.responses math namespaces make kernel\r
   3 accessors io.sockets io.servers.connection prettyprint\r
   4 io.streams.string io.files io.files.temp io.directories\r
   5 splitting destructors sequences db db.tuples db.sqlite\r
   6 continuations urls math.parser furnace furnace.utilities ;\r
   7 IN: furnace.sessions.tests\r
   8 \r
   9 : with-session ( session quot -- )\r
  10     [\r
  11         [ [ save-session-after ] [ session set ] bi ] dip call\r
  12     ] with-destructors ; inline\r
  13 \r
  14 TUPLE: foo ;\r
  15 \r
  16 C: <foo> foo\r
  17 \r
  18 M: foo init-session* drop 0 "x" sset ;\r
  19 \r
  20 M: foo call-responder*\r
  21     2drop\r
  22     "x" [ 1 + ] schange\r
  23     "x" sget number>string "text/html" <content> ;\r
  24 \r
  25 : url-responder-mock-test ( -- string )\r
  26     [\r
  27         <request>\r
  28             "GET" >>method\r
  29             dup url>>\r
  30                 "id" get session-id-key set-query-param\r
  31                 "/" >>path drop\r
  32         init-request\r
  33         { } sessions get call-responder\r
  34         [ write-response-body drop ] with-string-writer\r
  35     ] with-destructors ;\r
  36 \r
  37 : sessions-mock-test ( -- string )\r
  38     [\r
  39         <request>\r
  40             "GET" >>method\r
  41             "cookies" get >>cookies\r
  42             dup url>> "/" >>path drop\r
  43         init-request\r
  44         { } sessions get call-responder\r
  45         [ write-response-body drop ] with-string-writer\r
  46     ] with-destructors ;\r
  47 \r
  48 : <exiting-action> ( -- action )\r
  49     <action>\r
  50         [ [ ] "text/plain" <content> exit-with ] >>display ;\r
  51 \r
  52 [ "auth-test.db" temp-file delete-file ] ignore-errors\r
  53 \r
  54 "auth-test.db" temp-file <sqlite-db> [\r
  55 \r
  56     <request> "GET" >>method init-request\r
  57     session ensure-table\r
  58 \r
  59     "127.0.0.1" 1234 <inet4> remote-address set\r
  60 \r
  61     [ ] [\r
  62         <foo> <sessions>\r
  63         sessions set\r
  64     ] unit-test\r
  65 \r
  66     [\r
  67         [ ] [\r
  68             empty-session\r
  69                 123 >>id session set\r
  70         ] unit-test\r
  71 \r
  72         [ ] [ 3 "x" sset ] unit-test\r
  73 \r
  74         [ 9 ] [ "x" sget sq ] unit-test\r
  75 \r
  76         [ ] [ "x" [ 1 - ] schange ] unit-test\r
  77 \r
  78         [ 4 ] [ "x" sget sq ] unit-test\r
  79 \r
  80         [ t ] [ session get changed?>> ] unit-test\r
  81     ] with-scope\r
  82 \r
  83     [ t ] [\r
  84         begin-session id>>\r
  85         get-session session?\r
  86     ] unit-test\r
  87 \r
  88     [ { 5 0 } ] [\r
  89         [\r
  90             begin-session\r
  91             dup [ 5 "a" sset ] with-session\r
  92             dup [ "a" sget , ] with-session\r
  93             dup [ "x" sget , ] with-session\r
  94             drop\r
  95         ] { } make\r
  96     ] unit-test\r
  97 \r
  98     [ 0 ] [\r
  99         begin-session id>>\r
 100         get-session [ "x" sget ] with-session\r
 101     ] unit-test\r
 102 \r
 103     [ { 5 0 } ] [\r
 104         [\r
 105             begin-session id>>\r
 106             dup get-session [ 5 "a" sset ] with-session\r
 107             dup get-session [ "a" sget , ] with-session\r
 108             dup get-session [ "x" sget , ] with-session\r
 109             drop\r
 110         ] { } make\r
 111     ] unit-test\r
 112 \r
 113     [ ] [\r
 114         <foo> <sessions>\r
 115         sessions set\r
 116     ] unit-test\r
 117 \r
 118     [\r
 119         <request>\r
 120             "GET" >>method\r
 121             dup url>> "/" >>path drop\r
 122         request set\r
 123         { "etc" } sessions get call-responder response set\r
 124         [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
 125         response get\r
 126     ] with-destructors\r
 127     response set\r
 128 \r
 129     [ ] [ response get cookies>> "cookies" set ] unit-test\r
 130 \r
 131     [ "2" ] [ sessions-mock-test ] unit-test\r
 132     [ "3" ] [ sessions-mock-test ] unit-test\r
 133     [ "4" ] [ sessions-mock-test ] unit-test\r
 134 \r
 135     [\r
 136         [ ] [\r
 137             <request>\r
 138                 "GET" >>method\r
 139                 dup url>>\r
 140                     "id" get session-id-key set-query-param\r
 141                     "/" >>path drop\r
 142             request set\r
 143 \r
 144             [\r
 145                 { } <exiting-action> <sessions>\r
 146                 call-responder\r
 147             ] with-destructors response set\r
 148         ] unit-test\r
 149 \r
 150         [ "text/plain" ] [ response get content-type>> ] unit-test\r
 151 \r
 152         [ f ] [ response get cookies>> empty? ] unit-test\r
 153     ] with-scope\r
 154 ] with-db\r