-USING: tools.test http furnace.sessions furnace.actions\r
-http.server http.server.responses math namespaces make kernel\r
-accessors io.sockets io.servers prettyprint\r
-io.streams.string io.files io.files.temp io.directories\r
-splitting destructors sequences db db.tuples db.sqlite\r
-continuations urls math.parser furnace furnace.utilities ;\r
-IN: furnace.sessions.tests\r
-\r
-: with-session ( session quot -- )\r
- [\r
- [ [ save-session-after ] [ session set ] bi ] dip call\r
- ] with-destructors ; inline\r
-\r
-TUPLE: foo ;\r
-\r
-C: <foo> foo\r
-\r
-M: foo init-session* drop 0 "x" sset ;\r
-\r
-M: foo call-responder*\r
- 2drop\r
- "x" [ 1 + ] schange\r
- "x" sget number>string <html-content> ;\r
-\r
-: url-responder-mock-test ( -- string )\r
- [\r
- <request>\r
- "GET" >>method\r
- dup url>>\r
- "id" get session-id-key set-query-param\r
- "/" >>path drop\r
- init-request\r
- { } sessions get call-responder\r
- [ write-response-body drop ] with-string-writer\r
- ] with-destructors ;\r
-\r
-: sessions-mock-test ( -- string )\r
- [\r
- <request>\r
- "GET" >>method\r
- "cookies" get >>cookies\r
- dup url>> "/" >>path drop\r
- init-request\r
- { } sessions get call-responder\r
- [ write-response-body drop ] with-string-writer\r
- ] with-destructors ;\r
-\r
-: <exiting-action> ( -- action )\r
- <action>\r
- [ [ ] <text-content> exit-with ] >>display ;\r
-\r
-[ "auth-test.db" temp-file delete-file ] ignore-errors\r
-\r
-"auth-test.db" temp-file <sqlite-db> [\r
-\r
- <request> "GET" >>method init-request\r
- session ensure-table\r
-\r
- "127.0.0.1" 1234 <inet4> remote-address set\r
-\r
- [ ] [\r
- <foo> <sessions>\r
- sessions set\r
- ] unit-test\r
-\r
- [\r
- [ ] [\r
- empty-session\r
- 123 >>id session set\r
- ] unit-test\r
-\r
- [ ] [ 3 "x" sset ] unit-test\r
-\r
- [ 9 ] [ "x" sget sq ] unit-test\r
-\r
- [ ] [ "x" [ 1 - ] schange ] unit-test\r
-\r
- [ 4 ] [ "x" sget sq ] unit-test\r
-\r
- [ t ] [ session get changed?>> ] unit-test\r
- ] with-scope\r
-\r
- [ t ] [\r
- begin-session id>>\r
- get-session session?\r
- ] unit-test\r
-\r
- [ { 5 0 } ] [\r
- [\r
- begin-session\r
- dup [ 5 "a" sset ] with-session\r
- dup [ "a" sget , ] with-session\r
- dup [ "x" sget , ] with-session\r
- drop\r
- ] { } make\r
- ] unit-test\r
-\r
- [ 0 ] [\r
- begin-session id>>\r
- get-session [ "x" sget ] with-session\r
- ] unit-test\r
-\r
- [ { 5 0 } ] [\r
- [\r
- begin-session id>>\r
- dup get-session [ 5 "a" sset ] with-session\r
- dup get-session [ "a" sget , ] with-session\r
- dup get-session [ "x" sget , ] with-session\r
- drop\r
- ] { } make\r
- ] unit-test\r
-\r
- [ ] [\r
- <foo> <sessions>\r
- sessions set\r
- ] unit-test\r
-\r
- [\r
- <request>\r
- "GET" >>method\r
- dup url>> "/" >>path drop\r
- request set\r
- { "etc" } sessions get call-responder response set\r
- [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
- response get\r
- ] with-destructors\r
- response set\r
-\r
- [ ] [ response get cookies>> "cookies" set ] unit-test\r
-\r
- [ "2" ] [ sessions-mock-test ] unit-test\r
- [ "3" ] [ sessions-mock-test ] unit-test\r
- [ "4" ] [ sessions-mock-test ] unit-test\r
-\r
- [\r
- [ ] [\r
- <request>\r
- "GET" >>method\r
- dup url>>\r
- "id" get session-id-key set-query-param\r
- "/" >>path drop\r
- request set\r
-\r
- [\r
- { } <exiting-action> <sessions>\r
- call-responder\r
- ] with-destructors response set\r
- ] unit-test\r
-\r
- [ "text/plain" ] [ response get content-type>> ] unit-test\r
-\r
- [ f ] [ response get cookies>> empty? ] unit-test\r
- ] with-scope\r
-] with-db\r
+USING: tools.test http furnace.sessions furnace.actions
+http.server http.server.responses math namespaces make kernel
+accessors io.sockets io.servers prettyprint
+io.streams.string io.files io.files.temp io.directories
+splitting destructors sequences db db.tuples db.sqlite
+continuations urls math.parser furnace furnace.utilities ;
+IN: furnace.sessions.tests
+
+: with-session ( session quot -- )
+ [
+ [ [ save-session-after ] [ session set ] bi ] dip call
+ ] with-destructors ; inline
+
+TUPLE: foo ;
+
+C: <foo> foo
+
+M: foo init-session* drop 0 "x" sset ;
+
+M: foo call-responder*
+ 2drop
+ "x" [ 1 + ] schange
+ "x" sget number>string <html-content> ;
+
+: url-responder-mock-test ( -- string )
+ [
+ <request>
+ "GET" >>method
+ dup url>>
+ "id" get session-id-key set-query-param
+ "/" >>path drop
+ init-request
+ { } sessions get call-responder
+ [ write-response-body drop ] with-string-writer
+ ] with-destructors ;
+
+: sessions-mock-test ( -- string )
+ [
+ <request>
+ "GET" >>method
+ "cookies" get >>cookies
+ dup url>> "/" >>path drop
+ init-request
+ { } sessions get call-responder
+ [ write-response-body drop ] with-string-writer
+ ] with-destructors ;
+
+: <exiting-action> ( -- action )
+ <action>
+ [ [ ] <text-content> exit-with ] >>display ;
+
+[ "auth-test.db" temp-file delete-file ] ignore-errors
+
+"auth-test.db" temp-file <sqlite-db> [
+
+ <request> "GET" >>method init-request
+ session ensure-table
+
+ "127.0.0.1" 1234 <inet4> remote-address set
+
+ [ ] [
+ <foo> <sessions>
+ sessions set
+ ] unit-test
+
+ [
+ [ ] [
+ empty-session
+ 123 >>id session set
+ ] unit-test
+
+ [ ] [ 3 "x" sset ] unit-test
+
+ [ 9 ] [ "x" sget sq ] unit-test
+
+ [ ] [ "x" [ 1 - ] schange ] unit-test
+
+ [ 4 ] [ "x" sget sq ] unit-test
+
+ [ t ] [ session get changed?>> ] unit-test
+ ] with-scope
+
+ [ t ] [
+ begin-session id>>
+ get-session session?
+ ] unit-test
+
+ [ { 5 0 } ] [
+ [
+ begin-session
+ dup [ 5 "a" sset ] with-session
+ dup [ "a" sget , ] with-session
+ dup [ "x" sget , ] with-session
+ drop
+ ] { } make
+ ] unit-test
+
+ [ 0 ] [
+ begin-session id>>
+ get-session [ "x" sget ] with-session
+ ] unit-test
+
+ [ { 5 0 } ] [
+ [
+ begin-session id>>
+ dup get-session [ 5 "a" sset ] with-session
+ dup get-session [ "a" sget , ] with-session
+ dup get-session [ "x" sget , ] with-session
+ drop
+ ] { } make
+ ] unit-test
+
+ [ ] [
+ <foo> <sessions>
+ sessions set
+ ] unit-test
+
+ [
+ <request>
+ "GET" >>method
+ dup url>> "/" >>path drop
+ request set
+ { "etc" } sessions get call-responder response set
+ [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
+ response get
+ ] with-destructors
+ response set
+
+ [ ] [ response get cookies>> "cookies" set ] unit-test
+
+ [ "2" ] [ sessions-mock-test ] unit-test
+ [ "3" ] [ sessions-mock-test ] unit-test
+ [ "4" ] [ sessions-mock-test ] unit-test
+
+ [
+ [ ] [
+ <request>
+ "GET" >>method
+ dup url>>
+ "id" get session-id-key set-query-param
+ "/" >>path drop
+ request set
+
+ [
+ { } <exiting-action> <sessions>
+ call-responder
+ ] with-destructors response set
+ ] unit-test
+
+ [ "text/plain" ] [ response get content-type>> ] unit-test
+
+ [ f ] [ response get cookies>> empty? ] unit-test
+ ] with-scope
+] with-db
projects / factor.git / blobdiff