steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Daniel Ehrenberg 2009-03-15 20:28:43 -05:00
parent 2fc74f67df dacf1910dc
commit 03684713c9
24 changed files with 174 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/db/db.factor
View File

@ -149,4 +149,4 @@ M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
t in-transaction [
begin-transaction
[ ] [ rollback-transaction ] cleanup commit-transaction
] with-variable ;
] with-variable ; inline

4
basis/furnace/actions/actions-docs.factor
View File

@ -1,6 +1,6 @@
USING: assocs classes help.markup help.syntax io.streams.string
http http.server.dispatchers http.server.responses
furnace.redirection strings multiline ;
furnace.redirection strings multiline html.forms ;
IN: furnace.actions
HELP: <action>
@ -74,6 +74,8 @@ HELP: validate-params
}
} ;
{ validate-params validate-values } related-words
HELP: validation-failed
{ $description "Stops processing the current request and takes action depending on the type of the current request:"
{ $list

16
basis/furnace/actions/actions.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators
validators http hashtables namespaces fry continuations locals
io arrays math boxes splitting urls
io arrays math boxes splitting urls call
xml.entities
http.server
http.server.responses
@ -52,10 +52,10 @@ TUPLE: action rest init authorize display validate submit ;
'[
_ dup display>> [
{
[ init>> call ]
[ authorize>> call ]
[ init>> call( -- ) ]
[ authorize>> call( -- ) ]
[ drop restore-validation-errors ]
[ display>> call ]
[ display>> call( -- response ) ]
} cleave
] [ drop <400> ] if
] with-exit-continuation ;
@ -81,9 +81,9 @@ CONSTANT: revalidate-url-key "__u"
: handle-post ( action -- response )
'[
_ dup submit>> [
[ validate>> call ]
[ authorize>> call ]
[ submit>> call ]
[ validate>> call( -- ) ]
[ authorize>> call( -- ) ]
[ submit>> call( -- response ) ]
tri
] [ drop <400> ] if
] with-exit-continuation ;

2
basis/furnace/auth/login/login.factor
View File

@ -53,7 +53,7 @@ M: login-realm modify-form ( responder -- )
\ successful-login DEBUG add-input-logging
: logout ( -- )
: logout ( -- response )
permit-id get [ delete-permit ] when*
URL" $realm" end-aside ;

6
basis/furnace/boilerplate/boilerplate.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov
! Copyright (c) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math.order namespaces combinators.short-circuit
USING: accessors kernel math.order namespaces combinators.short-circuit call
html.forms
html.templates
html.templates.chloe
@ -23,7 +23,7 @@ TUPLE: boilerplate < filter-responder template init ;
M:: boilerplate call-responder* ( path responder -- )
begin-form
path responder call-next-method
responder init>> call
responder init>> call( -- )
dup wrap-boilerplate? [
clone [| body |
[

6
basis/furnace/referrer/referrer.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel http.server http.server.filters
http.server.responses furnace.utilities ;
http.server.responses furnace.utilities call ;
IN: furnace.referrer
TUPLE: referrer-check < filter-responder quot ;
@ -9,7 +9,7 @@ TUPLE: referrer-check < filter-responder quot ;
C: <referrer-check> referrer-check
M: referrer-check call-responder*
referrer over quot>> call
referrer over quot>> call( referrer -- ? )
[ call-next-method ]
[ 2drop 403 "Bad referrer" <trivial-response> ] if ;

2
basis/furnace/utilities/utilities.factor
View File

@ -135,4 +135,4 @@ SYMBOL: exit-continuation
exit-continuation get continue-with ;
: with-exit-continuation ( quot -- value )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
'[ exit-continuation set @ ] callcc1 exit-continuation off ; inline

6
basis/html/forms/forms.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables io
USING: kernel accessors strings namespaces assocs hashtables io call
mirrors math fry sequences words continuations
xml.entities xml.writer xml.syntax ;
IN: html.forms
@ -96,7 +96,7 @@ C: <validation-error> validation-error
>hashtable "validators" set-word-prop ;
: validate ( value quot -- result )
[ <validation-error> ] recover ; inline
'[ _ call( value -- validated ) ] [ <validation-error> ] recover ;
: validate-value ( name value quot -- )
validate

6
basis/html/templates/templates.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
arrays strings html io.streams.string assocs
arrays strings html io.streams.string assocs call
quotations xml.data xml.writer xml.syntax ;
IN: html.templates
@ -12,7 +12,7 @@ GENERIC: call-template* ( template -- )
M: string call-template* write ;
M: callable call-template* call ;
M: callable call-template* call( -- ) ;
M: xml call-template* write-xml ;

8
basis/http/server/server.factor
View File

@ -132,15 +132,15 @@ M: response write-full-response ( request response -- )
[ content-charset>> encode-output ]
[ write-response-body ]
bi
] unless ;
] unless drop ;
M: raw-response write-response ( respose -- )
write-response-line
write-response-body
drop ;
M: raw-response write-full-response ( response -- )
write-response ;
M: raw-response write-full-response ( request response -- )
nip write-response ;
: post-request? ( -- ? ) request get method>> "POST" = ;
@ -182,7 +182,7 @@ main-responder [ <404> <trivial-responder> ] initialize
swap development? get [ make-http-error >>body ] [ drop ] if ;
: do-response ( response -- )
[ request get swap write-full-response ]
'[ request get _ write-full-response ]
[
[ \ do-response log-error ]
[

2
basis/http/server/static/static-docs.factor
View File

@ -20,7 +20,7 @@ HELP: enable-fhtml
{ $side-effects "responder" } ;
ARTICLE: "http.server.static.extend" "Hooks for dynamic content"
"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "."
"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- response )" } "."
$nl
"A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
{ $subsection enable-fhtml }

10
basis/http/server/static/static.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar kernel math math.order math.parser namespaces
parser sequences strings assocs hashtables debugger mime.types
@ -6,7 +6,7 @@ sorting logging calendar.format accessors splitting io io.files
io.files.info io.directories io.pathnames io.encodings.binary
fry xml.entities destructors urls html xml.syntax
html.templates.fhtml http http.server http.server.responses
http.server.redirection xml.writer ;
http.server.redirection xml.writer call ;
IN: http.server.static
TUPLE: file-responder root hook special allow-listings ;
@ -42,7 +42,9 @@ TUPLE: file-responder root hook special allow-listings ;
: serve-static ( filename mime-type -- response )
over modified-since?
[ file-responder get hook>> call ] [ 2drop <304> ] if ;
[ file-responder get hook>> call( filename mime-type -- response ) ]
[ 2drop <304> ]
if ;
: serving-path ( filename -- filename )
[ file-responder get root>> trim-tail-separators "/" ] dip
@ -51,7 +53,7 @@ TUPLE: file-responder root hook special allow-listings ;
: serve-file ( filename -- response )
dup mime-type
dup file-responder get special>> at
[ call ] [ serve-static ] ?if ;
[ call( filename -- response ) ] [ serve-static ] ?if ;
\ serve-file NOTICE add-input-logging

4
basis/inverse/inverse.factor
View File

@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors splitting
combinators.short-circuit fry words.symbol generalizations ;
combinators.short-circuit fry words.symbol generalizations call ;
RENAME: _ fry => __
IN: inverse
@ -122,7 +122,7 @@ M: math-inverse inverse
M: pop-inverse inverse
[ "pop-length" word-prop cut-slice swap >quotation ]
[ "pop-inverse" word-prop ] bi compose call ;
[ "pop-inverse" word-prop ] bi compose call( -- quot ) ;
: (undo) ( revquot -- )
[ unclip-slice inverse % (undo) ] unless-empty ;

6
basis/io/servers/connection/connection.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint
@ -7,7 +7,7 @@ fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags
combinators.short-circuit ;
combinators.short-circuit call ;
IN: io.servers.connection
TUPLE: threaded-server
@ -69,7 +69,7 @@ GENERIC: handle-client* ( threaded-server -- )
[ [ remote-address set ] [ local-address set ] bi* ]
2bi ;
M: threaded-server handle-client* handler>> call ;
M: threaded-server handle-client* handler>> call( -- ) ;
: handle-client ( client remote local -- )
'[

2
basis/logging/analysis/analysis.factor
View File

@ -41,7 +41,7 @@ SYMBOL: message-histogram
[ >alist sort-values <reversed> ] dip [
[ swapd with-cell pprint-cell ] with-row
] curry assoc-each
] tabular-output ;
] tabular-output ; inline
: log-entry. ( entry -- )
"====== " write

2
basis/logging/logging.factor
View File

@ -80,7 +80,7 @@ ERROR: bad-log-message-parameters msg word level ;
PRIVATE>
: (define-logging) ( word level quot -- )
[ dup ] 2dip 2curry annotate ;
[ dup ] 2dip 2curry annotate ; inline
: call-logging-quot ( quot word level -- quot' )
[ "called" ] 2dip [ log-message ] 3curry prepose ;

7
core/bootstrap/primitives.factor
View File

@ -25,7 +25,8 @@ H{ } clone sub-primitives set
{ "linux-ppc" "ppc/linux" }
{ "macosx-ppc" "ppc/macosx" }
{ "arm" "arm" }
} at "/bootstrap.factor" 3append parse-file
} ?at [ "Bad architecture: " prepend throw ] unless
"/bootstrap.factor" 3append parse-file
"vocab:bootstrap/layouts/layouts.factor" parse-file
@ -45,10 +46,6 @@ init-caches
! Vocabulary for slot accessors
"accessors" create-vocab drop
! Trivial recompile hook. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
SINGLETON: dummy-compiler
M: dummy-compiler recompile drop { } ;
dummy-compiler compiler-impl set
call

10
core/classes/mixin/mixin-tests.factor
View File

@ -109,3 +109,13 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
MIXIN: empty-mixin
[ f ] [ "hi" empty-mixin? ] unit-test
MIXIN: move-instance-declaration-mixin
[ ] [ "IN: classes.mixin.tests.a USE: strings USE: classes.mixin.tests INSTANCE: string move-instance-declaration-mixin" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
[ ] [ "IN: classes.mixin.tests.b USE: strings USE: classes.mixin.tests INSTANCE: string move-instance-declaration-mixin" <string-reader> "move-mixin-test-2" parse-stream drop ] unit-test
[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
[ { string } ] [ move-instance-declaration-mixin members ] unit-test

7
core/compiler/units/units.factor
View File

@ -40,8 +40,15 @@ SYMBOL: compiler-impl
HOOK: recompile compiler-impl ( words -- alist )
! Non-optimizing compiler
M: f recompile [ f ] { } map>assoc ;
! Trivial compiler. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
SINGLETON: dummy-compiler
M: dummy-compiler recompile drop { } ;
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
SYMBOL: definition-observers

14
core/generic/generic-tests.factor
View File

@ -2,7 +2,8 @@ USING: accessors alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
quotations classes classes.algebra classes.tuple continuations
layouts classes.union sorting compiler.units eval multiline ;
layouts classes.union sorting compiler.units eval multiline
io.streams.string ;
IN: generic.tests
GENERIC: foobar ( x -- y )
@ -236,3 +237,14 @@ M: number c-n-m-cache ;
[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
[ 2 ] [ 2 c-n-m-cache ] unit-test
! Moving a method from one vocab to another doesn't always work
GENERIC: move-method-generic ( a -- b )
[ ] [ "IN: generic.tests.a USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
[ ] [ "IN: generic.tests.b USE: strings USE: generic.tests M: string move-method-generic ;" <string-reader> "move-method-test-2" parse-stream drop ] unit-test
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
[ { string } ] [ move-method-generic order ] unit-test

5
extra/webapps/pastebin/pastebin.factor
View File

@ -83,8 +83,7 @@ annotation "ANNOTATIONS"
! LINKS, ETC
! ! !
: pastebin-url ( -- url )
URL" $pastebin/list" ;
CONSTANT: pastebin-url URL" $pastebin/"
: paste-url ( id -- url )
"$pastebin/paste" >url swap "id" set-query-param ;
@ -187,7 +186,7 @@ M: annotation entity-url
"id" value <paste> delete-tuples
"id" value f <annotation> delete-tuples
] with-transaction
URL" $pastebin/list" <redirect>
pastebin-url <redirect>
] >>submit
<protected>

1
extra/webapps/site-watcher/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

41
extra/webapps/site-watcher/site-list.xml Normal file
View File

@ -0,0 +1,41 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<head>
<title>SiteWatcher</title>
</head>
<body>
<h1>SiteWatcher</h1>
<h2>It tells you if your web site goes down.</h2>
<table>
<t:bind-each t:name="sites">
<tr>
<td> <t:label t:name="url" /> </td>
<td> <t:button t:action="$site-watcher-app/remove" t:for="url">Remove</t:button> </td>
</tr>
</t:bind-each>
</table>
<p>
<t:button t:action="$site-watcher-app/check">Check now</t:button>
</p>
<hr />
<h3>Add a new site</h3>
<t:form t:action="$site-watcher-app/add">
<table>
<tr>
<th>URL:</th>
<td> <t:field t:name="url" t:size="80" /> </td>
</tr>
<tr>
<th>E-mail:</th>
<td> <t:field t:name="email" t:size="80" /> </td>
</tr>
</table>
<p> <button type="submit">Done</button> </p>
</t:form>
</body>
</html>
</t:chloe>

54
extra/webapps/site-watcher/site-watcher.factor Normal file
View File

@ -0,0 +1,54 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions furnace.alloy furnace.redirection
html.forms http.server http.server.dispatchers namespaces site-watcher
site-watcher.private kernel urls validators db.sqlite assocs ;
IN: webapps.site-watcher
TUPLE: site-watcher-app < dispatcher ;
CONSTANT: site-list-url URL" $site-watcher-app/"
: <site-list-action> ( -- action )
<page-action>
{ site-watcher-app "site-list" } >>template
[
begin-form
sites get values "sites" set-value
] >>init ;
: <add-site-action> ( -- action )
<action>
[
{ { "url" [ v-url ] } { "email" [ v-email ] } } validate-params
] >>validate
[
"email" value "url" value watch-site
site-list-url <redirect>
] >>submit ;
: <remove-site-action> ( -- action )
<action>
[
{ { "url" [ v-url ] } } validate-params
] >>validate
[
"url" value delete-site
site-list-url <redirect>
] >>submit ;
: <check-sites-action> ( -- action )
<action>
[
sites get [ check-sites ] [ report-sites ] bi
site-list-url <redirect>
] >>submit ;
: <site-watcher-app> ( -- dispatcher )
site-watcher-app new-dispatcher
<site-list-action> "" add-responder
<add-site-action> "add" add-responder
<remove-site-action> "remove" add-responder
<check-sites-action> "check" add-responder ;
<site-watcher-app> "resource:test.db" <sqlite-db> <alloy> main-responder set-global