diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 2fad0e4c2e..1e08896e8d 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -174,6 +174,8 @@ M: no-method error. M: bad-slot-value summary drop "Bad store to specialized slot" ; +M: bad-slot-name summary drop "Bad slot name in object literal" ; + M: no-math-method summary drop "No suitable arithmetic method" ; diff --git a/basis/furnace/chloe-tags/recaptcha/authors.txt b/basis/furnace/chloe-tags/recaptcha/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/furnace/chloe-tags/recaptcha/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/furnace/chloe-tags/recaptcha/recaptcha-docs.factor b/basis/furnace/chloe-tags/recaptcha/recaptcha-docs.factor new file mode 100644 index 0000000000..0d93949f53 --- /dev/null +++ b/basis/furnace/chloe-tags/recaptcha/recaptcha-docs.factor @@ -0,0 +1,77 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax http.server.filters kernel +multiline furnace.actions ; +IN: furnace.chloe-tags.recaptcha + +HELP: +{ $values + { "responder" "a responder" } + { "obj" object } +} +{ $description "A " { $link filter-responder } " wrapping another responder. Set the domain, public, and private keys using the key you get by registering with Recaptcha." } ; + +HELP: recaptcha-error +{ $var-description "Set to the error string returned by the Recaptcha server." } ; + +HELP: recaptcha-valid? +{ $var-description "Set to " { $link t } " if the user solved the last Recaptcha correctly." } ; + +HELP: validate-recaptcha +{ $description "Validates a Recaptcha using the Recaptcha web service API." } ; + +ARTICLE: "recaptcha-example" "Recaptcha example" +"There are several steps to using the Recaptcha library." +{ $list + { "Wrap the responder in a " { $link } } + { "Add a handler calling " { $link validate-recaptcha } " in the " { $slot "submit" } " of the " { $link page-action } } + { "Put the chloe tag " { $snippet "" } " in the template for your " { $link action } } +} +"An example follows:" +{ $code +HEREDOC: RECAPTCHA-TUTORIAL +TUPLE: recaptcha-app < dispatcher recaptcha ; + +: ( -- obj ) + + [ + validate-recaptcha + recaptcha-valid? get "?good" "?bad" ? + ] >>submit + [ + +{" + + +"} >>body + ] >>display ; + +: ( -- obj ) + \ recaptcha-app new-dispatcher + "" add-responder + + "concatenative.org" >>domain + "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" >>public-key + "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" >>private-key ; + + main-responder set-global +RECAPTCHA-TUTORIAL +} + +; + +ARTICLE: "furnace.chloe-tags.recaptcha" "Recaptcha chloe tag" +"The " { $vocab-link "furnace.chloe-tags.recaptcha" } " vocabulary implements support for the Recaptcha. Recaptcha is a web service that provides the user with a captcha, a test that is easy to solve by visual inspection, but hard to solve by writing a computer program. Use a captcha to protect forms from abusive users." $nl + +"The recaptcha responder is a " { $link filter-responder } " that wraps another responder. Set the " { $slot "domain" } ", " { $slot "public-key" } ", and " { $slot "private-key" } " slots of this responder to your Recaptcha account information." $nl + +"Wrapping a responder with Recaptcha:" +{ $subsection } +"Validating recaptcha:" +{ $subsection validate-recaptcha } +"Symbols set after validation:" +{ $subsection recaptcha-valid? } +{ $subsection recaptcha-error } +{ $subsection "recaptcha-example" } ; + +ABOUT: "furnace.chloe-tags.recaptcha" diff --git a/basis/furnace/chloe-tags/recaptcha/recaptcha.factor b/basis/furnace/chloe-tags/recaptcha/recaptcha.factor new file mode 100644 index 0000000000..81744dc0e0 --- /dev/null +++ b/basis/furnace/chloe-tags/recaptcha/recaptcha.factor @@ -0,0 +1,75 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors furnace.actions furnace.redirection html.forms +html.templates.chloe.compiler html.templates.chloe.syntax +http.client http.server http.server.filters io.sockets kernel +locals namespaces sequences splitting urls validators +xml.syntax ; +IN: furnace.chloe-tags.recaptcha + +TUPLE: recaptcha < filter-responder domain public-key private-key ; + +SYMBOLS: recaptcha-valid? recaptcha-error ; + +: ( responder -- obj ) + recaptcha new + swap >>responder ; + +M: recaptcha call-responder* + dup \ recaptcha set + responder>> call-responder ; + +> + + + +XML] ; + +: recaptcha-url ( secure? -- ? ) + [ "https://api.recaptcha.net/challenge" >url ] + [ "http://api.recaptcha.net/challenge" >url ] if ; + +: render-recaptcha ( -- xml ) + secure-connection? recaptcha-url + recaptcha get public-key>> "k" set-query-param (render-recaptcha) ; + +: parse-recaptcha-response ( string -- valid? error ) + "\n" split first2 [ "true" = ] dip ; + +:: (validate-recaptcha) ( challenge response recaptcha -- valid? error ) + recaptcha private-key>> :> private-key + remote-address get host>> :> remote-ip + H{ + { "challenge" challenge } + { "response" response } + { "privatekey" private-key } + { "remoteip" remote-ip } + } URL" http://api-verify.recaptcha.net/verify" + http-request nip parse-recaptcha-response ; + +CHLOE: recaptcha + drop [ render-recaptcha ] [xml-code] ; + +PRIVATE> + +: validate-recaptcha ( -- ) + { + { "recaptcha_challenge_field" [ v-required ] } + { "recaptcha_response_field" [ v-required ] } + } validate-params + "recaptcha_challenge_field" value + "recaptcha_response_field" value + \ recaptcha get (validate-recaptcha) + [ recaptcha-valid? set ] [ recaptcha-error set ] bi* ; diff --git a/basis/furnace/chloe-tags/recaptcha/recaptcha.xml b/basis/furnace/chloe-tags/recaptcha/recaptcha.xml new file mode 100644 index 0000000000..6cbf795310 --- /dev/null +++ b/basis/furnace/chloe-tags/recaptcha/recaptcha.xml @@ -0,0 +1,7 @@ + + + + + + + diff --git a/basis/furnace/chloe-tags/recaptcha/summary.txt b/basis/furnace/chloe-tags/recaptcha/summary.txt new file mode 100644 index 0000000000..909566f3cc --- /dev/null +++ b/basis/furnace/chloe-tags/recaptcha/summary.txt @@ -0,0 +1 @@ +Recaptcha library diff --git a/basis/furnace/chloe-tags/recaptcha/tags.txt b/basis/furnace/chloe-tags/recaptcha/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/basis/furnace/chloe-tags/recaptcha/tags.txt @@ -0,0 +1 @@ +web diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 0a57ad34f3..626cbd63df 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -99,9 +99,17 @@ GENERIC# boa>object 1 ( class slots -- tuple ) M: tuple-class boa>object swap prefix >tuple ; +ERROR: bad-slot-name class slot ; + +: check-slot-exists ( class initials slot-spec/f index/f name -- class initials slot-spec index ) + over [ drop ] [ nip nip nip bad-slot-name ] if ; + +: slot-named-checked ( class initials name slots -- class initials slot-spec ) + over [ slot-named* ] dip check-slot-exists drop ; + : assoc>object ( class slots values -- tuple ) [ [ [ initial>> ] map ] keep ] dip - swap [ [ slot-named* drop ] curry dip ] curry assoc-map + swap [ [ slot-named-checked ] curry dip ] curry assoc-map [ dup ] dip update boa>object ; : parse-tuple-literal-slots ( class slots -- tuple )