Merge branch 'master' of git://factorcode.org/git/factor into c-type-words
Joe Groff
commit
cbebaada2f
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors db.sqlite furnace.actions furnace.alloy
|
||||
furnace.conversations furnace.recaptcha furnace.redirection
|
||||
html.templates.chloe.compiler http.server
|
||||
http.server.dispatchers http.server.responses io.streams.string
|
||||
kernel urls xml.syntax ;
|
||||
IN: furnace.recaptcha.example
|
||||
|
||||
TUPLE: recaptcha-app < dispatcher recaptcha ;
|
||||
|
||||
: recaptcha-db ( -- obj ) "recaptcha-example" <sqlite-db> ;
|
||||
|
||||
: <recaptcha-challenge> ( -- obj )
|
||||
<page-action>
|
||||
[
|
||||
begin-conversation
|
||||
validate-recaptcha
|
||||
recaptcha-valid? cget
|
||||
"?good" "?bad" ? >url <continue-conversation>
|
||||
] >>submit
|
||||
{ recaptcha-app "example" } >>template ;
|
||||
|
||||
: <recaptcha-app> ( -- obj )
|
||||
\ recaptcha-app new-dispatcher
|
||||
<recaptcha-challenge> "" add-responder
|
||||
<recaptcha>
|
||||
"concatenative.org" >>domain
|
||||
"6LeJWQgAAAAAAFlYV7SuBClE9uSpGtV_ZS-qVON7" >>public-key
|
||||
"6LeJWQgAAAAAALh-XJgSSQ6xKygRgJ8-029Ip2Xv" >>private-key
|
||||
recaptcha-db <alloy> ;
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
<?xml version='1.0' ?>
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<html><body><form submit="" method="post"><t:recaptcha/></form></body></html>
|
||||
</t:chloe>
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! 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
|
||||
multiline furnace.actions furnace.alloy furnace.conversations ;
|
||||
IN: furnace.recaptcha
|
||||
|
||||
HELP: <recaptcha>
|
||||
{ $values
|
||||
|
|
@ -24,43 +24,21 @@ ARTICLE: "recaptcha-example" "Recaptcha example"
|
|||
"There are several steps to using the Recaptcha library."
|
||||
{ $list
|
||||
{ "Wrap the responder in a " { $link <recaptcha> } }
|
||||
{ "Wrap the responder in a " { $link <conversations> } " if it is not already" }
|
||||
{ "Ensure that there is a database connected, with the " { $link <alloy> } " word" }
|
||||
{ "Start a conversation to move values between requests" }
|
||||
{ "Add a handler calling " { $link validate-recaptcha } " in the " { $slot "submit" } " of the " { $link page-action } }
|
||||
{ "Put the chloe tag " { $snippet "<recaptcha/>" } " in the template for your " { $link action } }
|
||||
{ "Pass the conversation from your submit action using " { $link <continue-conversation> } }
|
||||
{ "Put the chloe tag " { $snippet "<recaptcha/>" } " inside a form tag in the template for your " { $link page-action } }
|
||||
}
|
||||
"An example follows:"
|
||||
$nl
|
||||
"Run this example vocabulary:"
|
||||
{ $code
|
||||
HEREDOC: RECAPTCHA-TUTORIAL
|
||||
TUPLE: recaptcha-app < dispatcher recaptcha ;
|
||||
"USE: furnace.recaptcha.example"
|
||||
"<recaptcha-app> main-responder set-global"
|
||||
} ;
|
||||
|
||||
: <recaptcha-challenge> ( -- obj )
|
||||
<action>
|
||||
[
|
||||
validate-recaptcha
|
||||
recaptcha-valid? get "?good" "?bad" ? <redirect>
|
||||
] >>submit
|
||||
[
|
||||
<response>
|
||||
{" <?xml version='1.0' ?>
|
||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<html><body><t:recaptcha/></body></html>
|
||||
</t:chloe>"} >>body
|
||||
] >>display ;
|
||||
|
||||
: <recaptcha-app> ( -- obj )
|
||||
\ recaptcha-app new-dispatcher
|
||||
<recaptcha-challenge> "" add-responder
|
||||
<recaptcha>
|
||||
"concatenative.org" >>domain
|
||||
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" >>public-key
|
||||
"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" >>private-key ;
|
||||
|
||||
<recaptcha-app> main-responder set-global
|
||||
RECAPTCHA-TUTORIAL
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
ARTICLE: "furnace.chloe-tags.recaptcha" "Recaptcha chloe tag"
|
||||
ARTICLE: "furnace.recaptcha" "Recaptcha"
|
||||
"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
|
||||
|
|
@ -74,4 +52,4 @@ ARTICLE: "furnace.chloe-tags.recaptcha" "Recaptcha chloe tag"
|
|||
{ $subsection recaptcha-error }
|
||||
{ $subsection "recaptcha-example" } ;
|
||||
|
||||
ABOUT: "furnace.chloe-tags.recaptcha"
|
||||
ABOUT: "furnace.recaptcha"
|
||||
|
|
@ -4,8 +4,8 @@ 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
|
||||
xml.syntax furnace.conversations ;
|
||||
IN: furnace.recaptcha
|
||||
|
||||
TUPLE: recaptcha < filter-responder domain public-key private-key ;
|
||||
|
||||
|
|
@ -38,8 +38,9 @@ M: recaptcha call-responder*
|
|||
XML] ;
|
||||
|
||||
: recaptcha-url ( secure? -- ? )
|
||||
[ "https://api.recaptcha.net/challenge" >url ]
|
||||
[ "http://api.recaptcha.net/challenge" >url ] if ;
|
||||
[ "https://api.recaptcha.net/challenge" ]
|
||||
[ "http://api.recaptcha.net/challenge" ] if
|
||||
recaptcha-error cget [ "?error=" glue ] when* >url ;
|
||||
|
||||
: render-recaptcha ( -- xml )
|
||||
secure-connection? recaptcha-url
|
||||
|
|
@ -72,4 +73,4 @@ PRIVATE>
|
|||
"recaptcha_challenge_field" value
|
||||
"recaptcha_response_field" value
|
||||
\ recaptcha get (validate-recaptcha)
|
||||
[ recaptcha-valid? set ] [ recaptcha-error set ] bi* ;
|
||||
[ recaptcha-valid? cset ] [ recaptcha-error cset ] bi* ;
|
||||
|
|
@ -24,7 +24,7 @@ HELP: compile-attr
|
|||
{ $description "Compiles code which pushes an attribute value previously extracted by " { $link required-attr } " or " { $link optional-attr } " on the stack. If the attribute value begins with " { $snippet "@" } ", compiles into code which pushes the a form value." } ;
|
||||
|
||||
HELP: CHLOE:
|
||||
{ $syntax "name definition... ;" }
|
||||
{ $syntax "CHLOE: name definition... ;" }
|
||||
{ $values { "name" "the tag name" } { "definition" { $quotation "( tag -- )" } } }
|
||||
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ load-help? off
|
|||
"bootstrap.layouts" require
|
||||
|
||||
[
|
||||
"vocab:bootstrap/stage2.factor"
|
||||
"resource:basis/bootstrap/stage2.factor"
|
||||
dup exists? [
|
||||
run-file
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Factor port of
|
||||
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
|
||||
USING: specialized-arrays kernel math math.functions
|
||||
math.vectors sequences sequences.private prettyprint words hints
|
||||
locals ;
|
||||
math.vectors sequences prettyprint words hints locals ;
|
||||
SPECIALIZED-ARRAY: double
|
||||
IN: benchmark.spectral-norm
|
||||
|
||||
|
|
@ -19,13 +18,13 @@ IN: benchmark.spectral-norm
|
|||
+ 1 + recip ; inline
|
||||
|
||||
: (eval-A-times-u) ( u i j -- x )
|
||||
tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline
|
||||
[ swap nth ] [ eval-A ] bi-curry bi* * ; inline
|
||||
|
||||
: eval-A-times-u ( n u -- seq )
|
||||
[ (eval-A-times-u) ] inner-loop ; inline
|
||||
|
||||
: (eval-At-times-u) ( u i j -- x )
|
||||
tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline
|
||||
[ swap nth ] [ swap eval-A ] bi-curry bi* * ; inline
|
||||
|
||||
: eval-At-times-u ( u n -- seq )
|
||||
[ (eval-At-times-u) ] inner-loop ; inline
|
||||
|
|
|
|||
|
|
@ -99,7 +99,13 @@ M: mb-writer dispose drop ;
|
|||
|
||||
! Test join
|
||||
[ { "JOIN #factortest" } [
|
||||
"#factortest" %join %pop-output-line
|
||||
"#factortest" %join %pop-output-line
|
||||
] unit-test
|
||||
] spawning-irc
|
||||
|
||||
[ { "PART #factortest" } [
|
||||
"#factortest" %join %pop-output-line drop
|
||||
"#factortest" chat> remove-chat %pop-output-line
|
||||
] unit-test
|
||||
] spawning-irc
|
||||
|
||||
|
|
|
|||
|
|
@ -172,7 +172,7 @@ M: irc-nick-chat remove-chat name>> unregister-chat ;
|
|||
M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
|
||||
|
||||
M: irc-channel-chat remove-chat
|
||||
[ part new annotate-message irc-send ]
|
||||
[ name>> "PART " prepend string>irc-message irc-send ]
|
||||
[ name>> unregister-chat ] bi ;
|
||||
|
||||
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue