basis/furnace/sessions/sessions-tests.factor

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