Debugging validation

extra/html/components/components.factor

@@ -44,6 +44,12 @@ SYMBOL: values
 : with-each-tuple ( seq quot -- )
     '[ from-tuple @ ] with-each-index ; inline
 
+: with-assoc-values ( assoc quot -- )
+    '[ blank-values , from-assoc @ ] with-scope ; inline
+
+: with-tuple-values ( assoc quot -- )
+    '[ blank-values , from-tuple @ ] with-scope ; inline
+
 : nest-values ( name quot -- )
     swap [
         [
@@ -51,6 +57,13 @@ SYMBOL: values
         ] with-scope
     ] dip set-value ; inline
 
+: nest-tuple ( name quot -- )
+    swap [
+        [
+            H{ } clone [ <mirror> values set call ] keep
+        ] with-scope
+    ] dip set-value ; inline
+
 : object>string ( object -- string )
     {
         { [ dup real? ] [ number>string ] }

extra/html/templates/chloe/chloe.factor

@@ -217,6 +217,18 @@ STRING: button-tag-markup
 : each-assoc-tag ( tag -- )
     [ with-each-assoc ] (each-tag) ;
 
+: (bind-tag) ( tag quot -- )
+    [
+        [ "name" required-attr value ] keep
+        '[ , process-tag-children ]
+    ] dip call ; inline
+
+: bind-tuple-tag ( tag -- )
+    [ with-tuple-values ] (bind-tag) ;
+
+: bind-assoc-tag ( tag -- )
+    [ with-assoc-values ] (bind-tag) ;
+
 : error-message-tag ( tag -- )
     children>string render-error ;
 
@@ -280,6 +292,8 @@ STRING: button-tag-markup
         { "each" [ each-tag ] }
         { "each-assoc" [ each-assoc-tag ] }
         { "each-tuple" [ each-tuple-tag ] }
+        { "bind-assoc" [ bind-assoc-tag ] }
+        { "bind-tuple" [ bind-tuple-tag ] }
         { "comment" [ drop ] }
         { "call-next-template" [ drop call-next-template ] }
 

extra/webapps/pastebin/new-paste.xml

@@ -10,8 +10,8 @@
 			<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
 			<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
 			<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
-			<tr><th class="field-label big-field-label">Description: </th><td><t:textarea t:name="contents" /></td></tr>
+			<tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
-			<tr><th class="field-label">Captcha: </th><td><t:captcha t:name="captcha" /></td></tr>
+			<tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
 			<tr>
 			<td></td>
 			<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>

extra/webapps/pastebin/paste.xml

@@ -44,8 +44,8 @@
 				<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
 				<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
 				<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
-				<tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="contents" /></td></tr>
+				<tr><th class="field-label big-field-label">Body:</th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
-				<tr><th class="field-label">Captcha: </th><td><t:captcha t:name="captcha" /></td></tr>
+				<tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
 				<tr>
 				<td></td>
 				<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>

extra/webapps/pastebin/pastebin.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs sorting sequences kernel accessors
-hashtables sequences.lib db.types db.tuples db
+hashtables sequences.lib db.types db.tuples db combinators
 calendar calendar.format math.parser rss xml.writer
 xmode.catalog validators html.components html.templates.chloe
 http.server
@@ -121,7 +121,9 @@ M: annotation entity-link
             validate-integer-id
             "id" value paste from-tuple
 
+            "id" value
             "new-annotation" [
+                "id" set-value
                 mode-names "modes" set-value
                 "factor" "mode" set-value
             ] nest-values
@@ -145,6 +147,19 @@ M: annotation entity-link
         [ validate-integer-id ] >>init
         [ "id" value paste annotations>> paste-feed ] >>feed ;
 
+: validate-paste ( -- )
+    {
+        { "summary" [ v-one-line ] }
+        { "author" [ v-one-line ] }
+        { "mode" [ v-mode ] }
+        { "contents" [ v-required ] }
+        { "captcha" [ v-captcha ] }
+    } validate-params ;
+
+: deposit-paste-slots ( tuple -- )
+    now >>date
+    { "summary" "author" "mode" "contents" } deposit-slots ;
+
 : <new-paste-action> ( -- action )
     <page-action>
         [
@@ -155,19 +170,13 @@ M: annotation entity-link
         "new-paste" pastebin-template >>template
 
         [
-            {
+            validate-paste
-                { "summary" [ v-one-line ] }
-                { "author" [ v-one-line ] }
-                { "mode" [ v-mode ] }
-                { "contents" [ v-required ] }
-                { "captcha" [ v-captcha ] }
-            } validate-params
 
             f <paste>
-                now >>date
+            [ deposit-paste-slots ]
-                dup { "summary" "author" "mode" "contents" } deposit-slots
             [ insert-tuple ]
-            [ id>> "$pastebin/paste" <id-redirect> ] bi
+            [ id>> "$pastebin/paste" <id-redirect> ]
+            tri
         ] >>submit ;
 
 : <delete-paste-action> ( -- action )
@@ -185,26 +194,22 @@ M: annotation entity-link
 ! ! !
 
 : <new-annotation-action> ( -- action )
-    <action>
+    <page-action>
-        [
+        [ validate-paste ] >>validate
-            {
+
-                { "summary" [ v-one-line ] }
+        [ "id" param "$pastebin/paste" <id-redirect> ] >>display
-                { "author" [ v-one-line ] }
-                { "mode" [ v-mode ] }
-                { "contents" [ v-required ] }
-                { "captcha" [ v-captcha ] }
-            } validate-params
-        ] >>validate
 
         [
             f f <annotation>
-                now >>date
+            {
-                dup { "summary" "author" "mode" "contents" } deposit-slots
+                [ deposit-paste-slots ]
+                [ { "id" } deposit-slots ]
                 [ insert-tuple ]
                 [
                     ! Add anchor here
-                "id" value "$pastebin/paste" <id-redirect>
+                    id>> "$pastebin/paste" <id-redirect>
-            ] bi
+                ]
+            } cleave
         ] >>submit ;
 
 : <delete-annotation-action> ( -- action )

extra/webapps/pastebin/pastebin.xml

@@ -13,9 +13,9 @@
 
 		<t:each-tuple t:values="pastes">
 			<tr>
-				<td><t:a t:href="$pastebin/view-paste" t:query="id"><t:field t:name="summary" /></t:a></td>
+				<td><t:a t:href="$pastebin/paste" t:query="id"><t:label t:name="summary" /></t:a></td>
-				<td><t:field t:name="author" /></td>
+				<td><t:label t:name="author" /></td>
-				<td><t:field t:name="date" /></td>
+				<td><t:label t:name="date" /></td>
 			</tr>
 		</t:each-tuple>
 	</table>

extra/webapps/planet/planet.factor

@@ -132,6 +132,9 @@ posting "POSTINGS"
 : <id-redirect> ( id next -- response )
     swap "id" associate <standard-redirect> ;
 
+: deposit-blog-slots ( blog -- )
+    { "name" "www-url" "feed-url" } deposit-slots ;
+
 : <new-blog-action> ( -- action )
     <page-action>
         "new-blog" planet-template >>template
@@ -140,9 +143,10 @@ posting "POSTINGS"
 
         [
             f <blog>
-                dup { "name" "www-url" "feed-url" } deposit-slots
+            [ deposit-blog-slots ]
             [ insert-tuple ]
-            [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ] bi
+            [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ]
+            tri
         ] >>submit ;
     
 : <edit-blog-action> ( -- action )
@@ -161,9 +165,10 @@ posting "POSTINGS"
 
         [
             f <blog>
-                dup { "id" "name" "www-url" "feed-url" } deposit-slots
+            [ deposit-blog-slots ]
             [ update-tuple ]
-            [ id>> "$planet-factor/admin" <id-redirect> ] bi
+            [ id>> "$planet-factor/admin" <id-redirect> ]
+            tri
         ] >>submit ;
 
 TUPLE: planet-factor-admin < dispatcher ;