basis/furnace/sessions/sessions-tests.factor

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