From a239304b0db8d2a02bf1469c53561b64e1bf60e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 3 Mar 2008 05:40:29 -0500
Subject: [PATCH] Improving http.server's db support and actions

---
 extra/bootstrap/image/upload/upload.factor    |  2 +-
 .../http/server/actions/actions-tests.factor  | 37 +++++++++++++++++++
 extra/http/server/actions/actions.factor      | 22 ++++++++++-
 extra/http/server/db/db.factor                |  9 +++--
 extra/http/server/server.factor               |  6 ++-
 extra/http/server/static/static.factor        |  2 -
 6 files changed, 68 insertions(+), 10 deletions(-)
 create mode 100644 extra/http/server/actions/actions-tests.factor

diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor
index 084f30a103..3c0b464dbf 100755
--- a/extra/bootstrap/image/upload/upload.factor
+++ b/extra/bootstrap/image/upload/upload.factor
@@ -8,7 +8,7 @@ SYMBOL: upload-images-destination
 
 : destination ( -- dest )
   upload-images-destination get
-  "slava@/var/www/factorcode.org/newsite/images/latest/"
+  "slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
   or ;
 
 : checksums "checksums.txt" temp-file ;
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
new file mode 100644
index 0000000000..2d74e92e86
--- /dev/null
+++ b/extra/http/server/actions/actions-tests.factor
@@ -0,0 +1,37 @@
+IN: http.server.actions.tests
+USING: http.server.actions tools.test math math.parser
+multiline namespaces http io.streams.string http.server
+sequences ;
+
+[ + ]
+{ { "a" [ string>number ] } { "b" [ string>number ] } }
+"GET" <action> "action-1" set
+
+STRING: action-request-test-1
+GET http://foo/bar?a=12&b=13 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+    action-request-test-1 [ read-request ] with-string-reader
+    "/blah"
+    "action-1" get call-responder
+] unit-test
+
+[ "X" <repetition> concat append ]
+{ { +path+ [ ] } { "xxx" [ string>number ] } }
+"POST" <action> "action-2" set
+
+STRING: action-request-test-2
+POST http://foo/bar/baz HTTP/1.1
+content-length: 5
+
+xxx=4
+;
+
+[ "/blahXXXX" ] [
+    action-request-test-2 [ read-request ] with-string-reader
+    "/blah"
+    "action-2" get call-responder
+] unit-test
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 4396c7a9da..feb16a4488 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -1,12 +1,30 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: accessors new-slots sequences kernel assocs combinators
+http.server http hashtables namespaces ;
 IN: http.server.actions
 
+SYMBOL: +path+
+
 TUPLE: action quot params method ;
 
 C: <action> action
 
-: extract-params ( assoc action -- ... )
+: extract-params ( request path -- assoc )
+    >r dup method>> {
+        { "GET" [ query>> ] }
+        { "POST" [ post-data>> query>assoc ] }
+    } case r> +path+ associate union ;
+
+: push-params ( assoc action -- ... )
     params>> [ first2 >r swap at r> call ] with each ;
 
-: call-action ;
+M: action call-responder ( request path action -- response )
+    pick request set
+    pick method>> over method>> = [
+        >r extract-params r>
+        [ push-params ] keep
+        quot>> call
+    ] [
+        3drop <400>
+    ] if ;
diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor
index ab45570b88..4baee5f02b 100755
--- a/extra/http/server/db/db.factor
+++ b/extra/http/server/db/db.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: db http.server kernel new-slots accessors ;
+USING: db http.server kernel new-slots accessors
+continuations namespaces ;
 IN: http.server.db
 
 TUPLE: db-persistence responder db params ;
@@ -8,6 +9,6 @@ TUPLE: db-persistence responder db params ;
 C: <db-persistence> db-persistence
 
 M: db-persistence call-responder
-    dup db>> over params>> [
-        responder>> call-responder
-    ] with-db ;
+    dup db>> over params>> make-db dup db-open [
+        db set responder>> call-responder
+    ] with-disposal ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index f71b1d3ec6..f397b280d0 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -28,6 +28,9 @@ M: trivial-responder call-responder nip response>> call ;
     swap >>message
     swap >>code ;
 
+: <400> ( -- response )
+    400 "Bad request" <trivial-response> ;
+
 : <404> ( -- response )
     404 "Not Found" <trivial-response> ;
 
@@ -66,7 +69,7 @@ TUPLE: dispatcher default responders ;
     404-responder H{ } clone dispatcher construct-boa ;
 
 : set-main ( dispatcher name -- dispatcher )
-    [ <temporary-redirect> ] curry
+    [ <permanent-redirect> ] curry
     <trivial-responder> >>default ;
 
 : split-path ( path -- rest first )
@@ -102,6 +105,7 @@ M: dispatcher call-responder
 
 : <webapp> ( class -- dispatcher )
     <dispatcher> swap construct-delegate ; inline
+
 SYMBOL: virtual-hosts
 SYMBOL: default-host
 
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 10a3df4de8..8d47d38eb1 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -87,8 +87,6 @@ TUPLE: file-responder root hook special ;
         drop <404>
     ] if ;
 
-: <400> 400 "Bad request" <trivial-response> ;
-
 M: file-responder call-responder ( request path responder -- response )
     over [
         ".." pick subseq? [