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

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

db4
Eduardo Cavazos 2008-06-06 19:51:22 -05:00
parent 39d3769df8 460ce213af
commit e6295a2d54
220 changed files with 5728 additions and 2866 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/assocs/assocs-docs.factor
View File

@ -139,7 +139,7 @@ HELP: new-assoc
HELP: assoc-find
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "key" "the successful key, or f" } { "value" "the successful value, or f" } { "?" "a boolean" } }
{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key or value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found." }
{ $contract "Applies a predicate quotation to each entry in the assoc. Returns the key and value that the quotation succeeds on, or " { $link f } " for both if the quotation fails. It also returns a boolean describing whether there was anything found; this can be used to distinguish between a key and a value equal to " { $link f } ", or nothing being found." }
{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which first converts the assoc to an association list, then iterates over that with the " { $link find } " combinator for sequences." } ;
HELP: clear-assoc

3
core/io/files/files.factor
View File

@ -147,6 +147,9 @@ PRIVATE>
] if
] unless ;
: file-extension ( filename -- extension )
"." last-split1 nip ;
! File info
TUPLE: file-info type size permissions modified ;

15
core/kernel/kernel-docs.factor
View File

@ -219,6 +219,16 @@ $nl
{ $example "t \\ t eq? ." "t" }
"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
$nl
"The following two lines are equivalent:"
{ $code "[ drop f ] unless" "swap and" }
"The following two lines are equivalent:"
{ $code "[ ] [ ] ?if" "swap or" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
{ $subsection if }
@ -238,6 +248,7 @@ ARTICLE: "conditionals" "Conditionals and logic"
{ $subsection and }
{ $subsection or }
{ $subsection xor }
{ $subsection "conditionals-boolean-equivalence" }
"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
@ -720,9 +731,7 @@ HELP: unless*
{ $description "Variant of " { $link if* } " with no true quotation." }
{ $notes
"The following two lines are equivalent:"
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
{ $code "[ L ] unless*" "L or" } } ;
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
HELP: ?if
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }

5
core/syntax/syntax-docs.factor
View File

@ -346,7 +346,7 @@ HELP: \
{ $syntax "\\ word" }
{ $values { "word" "a word" } }
{ $description "Reads the next word from the input and appends a wrapper holding the word to the parse tree. When the evaluator encounters a wrapper, it pushes the wrapped word literally on the data stack." }
{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } } ;
{ $examples "The following two lines are equivalent:" { $code "0 \\ <vector> execute\n0 <vector>" } "If " { $snippet "foo" } " is a symbol, the following two lines are equivalent:" { $code "foo" "\\ foo" } } ;
HELP: DEFER:
{ $syntax "DEFER: word" }
@ -526,6 +526,9 @@ HELP: PREDICATE:
"it satisfies the predicate"
}
"Each predicate must be defined as a subclass of some other class. This ensures that predicates inheriting from disjoint classes do not need to be exhaustively tested during method dispatch."
}
{ $examples
{ $code "USING: math ;" "PREDICATE: positive < integer 0 > ;" }
} ;
HELP: TUPLE:

36
extra/cairo/gadgets/gadgets.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math opengl.gadgets kernel
byte-arrays cairo.ffi cairo io.backend
opengl.gl arrays ;
ui.gadgets accessors opengl.gl
arrays ;
IN: cairo.gadgets
@ -12,11 +13,23 @@ IN: cairo.gadgets
>r first2 over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
r> with-cairo-from-surface ;
r> with-cairo-from-surface ; inline
: <cairo-gadget> ( dim quot -- )
over 2^-bounds swap copy-cairo
GL_BGRA rot <texture-gadget> ;
TUPLE: cairo-gadget < texture-gadget dim quot ;
: <cairo-gadget> ( dim quot -- gadget )
cairo-gadget construct-gadget
swap >>quot
swap >>dim ;
M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
: render-cairo ( dim quot -- bytes format )
>r 2^-bounds r> copy-cairo GL_BGRA ; inline
! M: cairo-gadget render*
! [ dim>> dup ] [ quot>> ] bi
! render-cairo render-bytes* ;
! maybe also texture>png
! : cairo>png ( gadget path -- )
@ -29,11 +42,16 @@ IN: cairo.gadgets
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
: <png-gadget> ( path -- gadget )
normalize-path cairo_image_surface_create_from_png
TUPLE: png-gadget < texture-gadget path ;
: <png> ( path -- gadget )
png-gadget construct-gadget
swap >>path ;
M: png-gadget render*
path>> normalize-path cairo_image_surface_create_from_png
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height 2array dup 2^-bounds ]
[ [ copy-surface ] curry copy-cairo ] tri
GL_BGRA rot <texture-gadget> ;
GL_BGRA render-bytes* ;
M: png-gadget cache-key* path>> ;

3
extra/db/tuples/tuples.factor
View File

@ -149,6 +149,9 @@ M: retryable execute-statement* ( statement type -- )
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> do-select ;
: count-tuples ( tuple -- n )
select-tuples length ;
: select-tuple ( tuple -- tuple/f )
dup dup class f f f 1 <advanced-select-statement>
do-select ?first ;

20
extra/freetype/freetype.factor
View File

@ -155,6 +155,16 @@ C-STRUCT: face
{ "face-size*" "size" }
{ "void*" "charmap" } ;
C-STRUCT: FT_Bitmap
{ "int" "rows" }
{ "int" "width" }
{ "int" "pitch" }
{ "void*" "buffer" }
{ "short" "num_grays" }
{ "char" "pixel_mode" }
{ "char" "palette_mode" }
{ "void*" "palette" } ;
FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ;
FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ;
@ -170,6 +180,15 @@ C-ENUM:
FT_RENDER_MODE_LCD
FT_RENDER_MODE_LCD_V ;
C-ENUM:
FT_PIXEL_MODE_NONE
FT_PIXEL_MODE_MONO
FT_PIXEL_MODE_GRAY
FT_PIXEL_MODE_GRAY2
FT_PIXEL_MODE_GRAY4
FT_PIXEL_MODE_LCD
FT_PIXEL_MODE_LCD_V ;
FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ;
FUNCTION: void FT_Done_Face ( face* face ) ;
@ -177,3 +196,4 @@ FUNCTION: void FT_Done_Face ( face* face ) ;
FUNCTION: void FT_Done_FreeType ( void* library ) ;
FUNCTION: FT_Long FT_MulFix ( FT_Long a, FT_Long b ) ;

25
extra/http/server/actions/actions-tests.factor → extra/furnace/actions/actions-tests.factor
View File

@ -1,7 +1,7 @@
USING: kernel http.server.actions validators
USING: kernel furnace.actions validators
tools.test math math.parser multiline namespaces http
io.streams.string http.server sequences splitting accessors ;
IN: http.server.actions.tests
IN: furnace.actions.tests
<action>
[ "a" param "b" param [ string>number ] bi@ + ] >>display
@ -16,9 +16,26 @@ blah
;
[ 25 ] [
init-request
action-request-test-1 lf>crlf
[ read-request ] with-string-reader
request set
init-request
{ } "action-1" get call-responder
] unit-test
<action>
"a" >>rest
[ "a" param string>number sq ] >>display
"action-2" set
STRING: action-request-test-2
GET http://foo/bar/123 HTTP/1.1
blah
;
[ 25 ] [
action-request-test-2 lf>crlf
[ read-request ] with-string-reader
init-request
{ "5" } "action-2" get call-responder
] unit-test

123
extra/furnace/actions/actions.factor Executable file
View File

@ -0,0 +1,123 @@
! Copyright (C) 2008 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
xml.entities
http.server
http.server.responses
furnace
furnace.flash
html.elements
html.components
html.components
html.templates.chloe
html.templates.chloe.syntax ;
IN: furnace.actions
SYMBOL: params
SYMBOL: rest
: render-validation-messages ( -- )
validation-messages get
dup empty? [ drop ] [
<ul "errors" =class ul>
[ <li> message>> escape-string write </li> ] each
</ul>
] if ;
CHLOE: validation-messages drop render-validation-messages ;
TUPLE: action rest init display validate submit ;
: new-action ( class -- action )
new
[ ] >>init
[ <400> ] >>display
[ ] >>validate
[ <400> ] >>submit ;
: <action> ( -- action )
action new-action ;
: flashed-variables ( -- seq )
{ validation-messages named-validation-messages } ;
: handle-get ( action -- response )
'[
,
[ init>> call ]
[ drop flashed-variables restore-flash ]
[ display>> call ]
tri
] with-exit-continuation ;
: validation-failed ( -- * )
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
: (handle-post) ( action -- response )
[ validate>> call ] [ submit>> call ] bi ;
: param ( name -- value )
params get at ;
: revalidate-url-key "__u" ;
: check-url ( url -- ? )
request get url>>
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
: revalidate-url ( -- url/f )
revalidate-url-key param dup [ >url dup check-url swap and ] when ;
: handle-post ( action -- response )
'[
form-nesting-key params get at " " split
[ , (handle-post) ]
[ swap '[ , , nest-values ] ] reduce
call
] with-exit-continuation
[
revalidate-url
[ flashed-variables <flash-redirect> ] [ <403> ] if*
] unless* ;
: handle-rest ( path action -- assoc )
rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;
: init-action ( path action -- )
blank-values
init-validation
handle-rest
request get request-params assoc-union params set ;
M: action call-responder* ( path action -- response )
[ init-action ] keep
request get method>> {
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case ;
M: action modify-form
drop request get url>> revalidate-url-key hidden-form-field ;
: check-validation ( -- )
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
params get swap validate-values from-object
check-validation ;
: validate-integer-id ( -- )
{ { "id" [ v-number ] } } validate-params ;
TUPLE: page-action < action template ;
: <chloe-content> ( path -- response )
resolve-template-path <chloe> "text/html" <content> ;
: <page-action> ( -- page )
page-action new-action
dup '[ , template>> <chloe-content> ] >>display ;

73
extra/furnace/asides/asides.factor Normal file
View File

@ -0,0 +1,73 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces sequences arrays kernel
assocs assocs.lib hashtables math.parser urls combinators
furnace http http.server http.server.filters furnace.sessions
html.elements html.templates.chloe.syntax ;
IN: furnace.asides
TUPLE: asides < filter-responder ;
C: <asides> asides
: begin-aside* ( -- id )
request get
[ url>> ] [ post-data>> ] [ method>> ] tri 3array
asides sget set-at-unique
session-changed ;
: end-aside-post ( url post-data -- response )
request [
clone
swap >>post-data
swap >>url
] change
request get url>> path>> split-path
asides get responder>> call-responder ;
ERROR: end-aside-in-get-error ;
: end-aside* ( url id -- response )
request get method>> "POST" = [ end-aside-in-get-error ] unless
asides sget at [
first3 {
{ "GET" [ drop <redirect> ] }
{ "HEAD" [ drop <redirect> ] }
{ "POST" [ end-aside-post ] }
} case
] [ <redirect> ] ?if ;
SYMBOL: aside-id
: aside-id-key "__a" ;
: begin-aside ( -- )
begin-aside* aside-id set ;
: end-aside ( default -- response )
aside-id [ f ] change end-aside* ;
M: asides call-responder*
dup asides set
aside-id-key request get request-params at aside-id set
call-next-method ;
M: asides init-session*
H{ } clone asides sset
call-next-method ;
M: asides link-attr ( tag -- )
drop
"aside" optional-attr {
{ "none" [ aside-id off ] }
{ "begin" [ begin-aside ] }
{ "current" [ ] }
{ f [ ] }
} case ;
M: asides modify-query ( query responder -- query' )
drop
aside-id get [ aside-id-key associate assoc-union ] when* ;
M: asides modify-form ( responder -- )
drop aside-id get aside-id-key hidden-form-field ;

8
extra/http/server/auth/auth.factor → extra/furnace/auth/auth.factor
View File

@ -2,9 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel sequences sets
http.server
http.server.sessions
http.server.auth.providers ;
IN: http.server.auth
http.server.filters
http.server.dispatchers
furnace.sessions
furnace.auth.providers ;
IN: furnace.auth
SYMBOL: logged-in-user

8
extra/http/server/auth/basic/basic.factor → extra/furnace/auth/basic/basic.factor
View File

@ -1,10 +1,10 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.login
http sequences ;
IN: http.server.auth.basic
base64 html.elements io combinators sequences
http http.server.filters http.server.responses http.server
furnace.auth.providers furnace.auth.login ;
IN: furnace.auth.basic
TUPLE: basic-auth < filter-responder realm provider ;

0
extra/http/server/auth/login/boilerplate.xml → extra/furnace/auth/login/boilerplate.xml
View File

0
extra/http/server/auth/login/edit-profile.xml → extra/furnace/auth/login/edit-profile.xml
View File

4
extra/http/server/auth/login/login-tests.factor → extra/furnace/auth/login/login-tests.factor
View File

@ -1,5 +1,5 @@
IN: http.server.auth.login.tests
USING: tools.test http.server.auth.login ;
IN: furnace.auth.login.tests
USING: tools.test furnace.auth.login ;
\ <login> must-infer
\ allow-registration must-infer

117
extra/http/server/auth/login/login.factor → extra/furnace/auth/login/login.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
combinators sequences namespaces hashtables sets
fry arrays threads qualified random validators
fry arrays threads qualified random validators words
io
io.sockets
io.encodings.utf8
@ -15,22 +15,40 @@ checksums.sha2
validators
html.components
html.elements
html.templates
html.templates.chloe
urls
http
http.server
http.server.auth
http.server.auth.providers
http.server.auth.providers.db
http.server.actions
http.server.flows
http.server.sessions
http.server.boilerplate ;
http.server.dispatchers
http.server.filters
http.server.responses
furnace
furnace.auth
furnace.auth.providers
furnace.auth.providers.db
furnace.actions
furnace.asides
furnace.flash
furnace.sessions
furnace.boilerplate ;
QUALIFIED: smtp
IN: http.server.auth.login
IN: furnace.auth.login
: word>string ( word -- string )
[ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;
: words>strings ( seq -- seq' )
[ word>string ] map ;
: string>word ( string -- word )
":" split1 swap lookup ;
: strings>words ( seq -- seq' )
[ string>word ] map ;
TUPLE: login < dispatcher users checksum ;
TUPLE: protected < filter-responder description capabilities ;
: users ( -- provider )
login get users>> ;
@ -59,21 +77,24 @@ M: user-saver dispose
: save-user-after ( user -- )
<user-saver> &dispose drop ;
: login-template ( name -- template )
"resource:extra/http/server/auth/login/" swap ".xml"
3append <chloe> ;
! ! ! Login
: successful-login ( user -- response )
username>> set-uid "$login" end-flow ;
username>> set-uid URL" $login" end-aside ;
: login-failed ( -- * )
"invalid username or password" validation-error
validation-failed ;
: <login-action> ( -- action )
<action>
[ "login" login-template <html-content> ] >>display
<page-action>
[
protected fget [
[ description>> "description" set-value ]
[ capabilities>> words>strings "capabilities" set-value ] bi
] when*
] >>init
{ login "login" } >>template
[
{
@ -102,7 +123,7 @@ M: user-saver dispose
: <register-action> ( -- action )
<page-action>
"register" login-template >>template
{ login "register" } >>template
[
{
@ -134,7 +155,7 @@ M: user-saver dispose
! ! ! Editing user profile
: <edit-profile-action> ( -- action )
<action>
<page-action>
[
logged-in-user get
[ username>> "username" set-value ]
@ -143,7 +164,7 @@ M: user-saver dispose
tri
] >>init
[ "edit-profile" login-template <html-content> ] >>display
{ login "edit-profile" } >>template
[
uid "username" set-value
@ -178,7 +199,7 @@ M: user-saver dispose
drop
"$login" end-flow
URL" $login" end-aside
] >>submit ;
! ! ! Password recovery
@ -186,10 +207,10 @@ M: user-saver dispose
SYMBOL: lost-password-from
: current-host ( -- string )
request get host>> host-name or ;
request get url>> host>> host-name or ;
: new-password-url ( user -- url )
"new-password"
"recover-3"
swap [
[ username>> "username" set ]
[ ticket>> "ticket" set ]
@ -223,8 +244,8 @@ SYMBOL: lost-password-from
"E-mail send thread" spawn drop ;
: <recover-action-1> ( -- action )
<action>
[ "recover-1" login-template <html-content> ] >>display
<page-action>
{ login "recover-1" } >>template
[
{
@ -240,11 +261,15 @@ SYMBOL: lost-password-from
send-password-email
] when*
"recover-2" login-template <html-content>
URL" $login/recover-2" <redirect>
] >>submit ;
: <recover-action-2> ( -- action )
<page-action>
{ login "recover-2" } >>template ;
: <recover-action-3> ( -- action )
<action>
<page-action>
[
{
{ "username" [ v-username ] }
@ -252,7 +277,7 @@ SYMBOL: lost-password-from
} validate-params
] >>init
[ "recover-3" login-template <html-content> ] >>display
{ login "recover-3" } >>template
[
{
@ -272,34 +297,38 @@ SYMBOL: lost-password-from
"new-password" value >>encoded-password
users update-user
"recover-4" login-template <html-content>
URL" $login/recover-4" <redirect>
] [
<400>
<403>
] if*
] >>submit ;
: <recover-action-4> ( -- action )
<page-action>
{ login "recover-4" } >>template ;
! ! ! Logout
: <logout-action> ( -- action )
<action>
[
f set-uid
"$login/login" end-flow
URL" $login" end-aside
] >>submit ;
! ! ! Authentication logic
TUPLE: protected < filter-responder capabilities ;
C: <protected> protected
: <protected> ( responder -- protected )
protected new
swap >>responder ;
: show-login-page ( -- response )
begin-flow
"$login/login" f <standard-redirect> ;
begin-aside
URL" $login/login" { protected } <flash-redirect> ;
: check-capabilities ( responder user -- ? )
[ capabilities>> ] bi@ subset? ;
M: protected call-responder* ( path responder -- response )
dup protected set
uid dup [
users get-user 2dup check-capabilities [
[ logged-in-user set ] [ save-user-after ] bi
@ -317,7 +346,7 @@ M: login call-responder* ( path responder -- response )
: <login-boilerplate> ( responder -- responder' )
<boilerplate>
"boilerplate" login-template >>template ;
{ login "boilerplate" } >>template ;
: <login> ( responder -- auth )
login new-dispatcher
@ -330,7 +359,9 @@ M: login call-responder* ( path responder -- response )
! ! ! Configuration
: allow-edit-profile ( login -- login )
<edit-profile-action> f <protected> <login-boilerplate>
<edit-profile-action> <protected>
"edit your profile" >>description
<login-boilerplate>
"edit-profile" add-responder ;
: allow-registration ( login -- login )
@ -340,8 +371,12 @@ M: login call-responder* ( path responder -- response )
: allow-password-recovery ( login -- login )
<recover-action-1> <login-boilerplate>
"recover-password" add-responder
<recover-action-2> <login-boilerplate>
"recover-2" add-responder
<recover-action-3> <login-boilerplate>
"new-password" add-responder ;
"recover-3" add-responder
<recover-action-4> <login-boilerplate>
"recover-4" add-responder ;
: allow-edit-profile? ( -- ? )
login get responders>> "edit-profile" swap key? ;

17
extra/http/server/auth/login/login.xml → extra/furnace/auth/login/login.xml
View File

@ -4,6 +4,19 @@
<t:title>Login</t:title>
<t:if t:value="description">
<p>You must log in to <t:label t:name="description" />.</p>
</t:if>
<t:if t:value="capabilities">
<p>Your user must have the following capabilities:</p>
<ul>
<t:each t:name="capabilities">
<li><t:label t:name="value" /></li>
</t:each>
</ul>
</t:if>
<t:form t:action="login">
<table>
@ -30,11 +43,11 @@
</t:form>
<p>
<t:if code="http.server.auth.login:login-failed?">
<t:if t:code="furnace.auth.login:allow-registration?">
<t:a t:href="register">Register</t:a>
</t:if>
|
<t:if code="http.server.auth.login:allow-password-recovery?">
<t:if t:code="furnace.auth.login:allow-password-recovery?">
<t:a t:href="recover-password">Recover Password</t:a>
</t:if>
</p>

0
extra/http/server/auth/login/recover-1.xml → extra/furnace/auth/login/recover-1.xml
View File

0
extra/http/server/auth/login/recover-2.xml → extra/furnace/auth/login/recover-2.xml
View File

0
extra/http/server/auth/login/recover-3.xml → extra/furnace/auth/login/recover-3.xml
View File

0
extra/http/server/auth/login/recover-4.xml → extra/furnace/auth/login/recover-4.xml
View File

0
extra/http/server/auth/login/register.xml → extra/furnace/auth/login/register.xml
View File

6
extra/http/server/auth/providers/assoc/assoc-tests.factor → extra/furnace/auth/providers/assoc/assoc-tests.factor
View File

@ -1,6 +1,6 @@
IN: http.server.auth.providers.assoc.tests
USING: http.server.actions http.server.auth.providers
http.server.auth.providers.assoc http.server.auth.login
IN: furnace.auth.providers.assoc.tests
USING: furnace.actions furnace.auth.providers
furnace.auth.providers.assoc furnace.auth.login
tools.test namespaces accessors kernel ;
<action> <login>

5
extra/http/server/auth/providers/assoc/assoc.factor → extra/furnace/auth/providers/assoc/assoc.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.auth.providers.assoc
USING: accessors assocs kernel
http.server.auth.providers ;
IN: furnace.auth.providers.assoc
USING: accessors assocs kernel furnace.auth.providers ;
TUPLE: users-in-memory assoc ;

10
extra/http/server/auth/providers/db/db-tests.factor → extra/furnace/auth/providers/db/db-tests.factor
View File

@ -1,8 +1,8 @@
IN: http.server.auth.providers.db.tests
USING: http.server.actions
http.server.auth.login
http.server.auth.providers
http.server.auth.providers.db tools.test
IN: furnace.auth.providers.db.tests
USING: furnace.actions
furnace.auth.login
furnace.auth.providers
furnace.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ;

4
extra/http/server/auth/providers/db/db.factor → extra/furnace/auth/providers/db/db.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.tuples db.types accessors
http.server.auth.providers kernel continuations
furnace.auth.providers kernel continuations
classes.singleton ;
IN: http.server.auth.providers.db
IN: furnace.auth.providers.db
user "USERS"
{

4
extra/http/server/auth/providers/null/null.factor → extra/furnace/auth/providers/null/null.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.server.auth.providers kernel ;
IN: http.server.auth.providers.null
USING: furnace.auth.providers kernel ;
IN: furnace.auth.providers.null
TUPLE: no-users ;

2
extra/http/server/auth/providers/providers.factor → extra/furnace/auth/providers/providers.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors random math.parser locals
sequences math ;
IN: http.server.auth.providers
IN: furnace.auth.providers
TUPLE: user
username realname

16
extra/http/server/boilerplate/boilerplate.factor → extra/furnace/boilerplate/boilerplate.factor
View File

@ -1,8 +1,12 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces http.server html.templates
locals ;
IN: http.server.boilerplate
USING: accessors kernel namespaces
html.templates html.templates.chloe
locals
http.server
http.server.filters
furnace ;
IN: furnace.boilerplate
TUPLE: boilerplate < filter-responder template ;
@ -12,6 +16,10 @@ M:: boilerplate call-responder* ( path responder -- )
path responder call-next-method
dup content-type>> "text/html" = [
clone [| body |
[ body responder template>> with-boilerplate ]
[
body
responder template>> resolve-template-path <chloe>
with-boilerplate
]
] change-body
] when ;

4
extra/furnace/db/db-tests.factor Normal file
View File

@ -0,0 +1,4 @@
IN: furnace.db.tests
USING: tools.test furnace.db ;
\ <db-persistence> must-infer

7
extra/http/server/db/db.factor → extra/furnace/db/db.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.pools io.pools http.server http.server.sessions
kernel accessors continuations namespaces destructors ;
IN: http.server.db
USING: kernel accessors continuations namespaces destructors
db db.pools io.pools http.server http.server.filters
furnace.sessions ;
IN: furnace.db
TUPLE: db-persistence < filter-responder pool ;

38
extra/furnace/flash/flash.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs assocs.lib kernel sequences urls
http http.server http.server.filters http.server.redirection
furnace furnace.sessions ;
IN: furnace.flash
: flash-id-key "__f" ;
TUPLE: flash-scopes < filter-responder ;
C: <flash-scopes> flash-scopes
SYMBOL: flash-scope
: fget ( key -- value ) flash-scope get at ;
M: flash-scopes call-responder*
flash-id-key
request get request-params at
flash-scopes sget at flash-scope set
call-next-method ;
M: flash-scopes init-session*
H{ } clone flash-scopes sset
call-next-method ;
: make-flash-scope ( seq -- id )
[ dup get ] H{ } map>assoc flash-scopes sget set-at-unique
session-changed ;
: <flash-redirect> ( url seq -- response )
make-flash-scope
[ clone ] dip flash-id-key set-query-param
<redirect> ;
: restore-flash ( seq -- )
[ flash-scope get key? ] filter [ [ fget ] keep set ] each ;

35
extra/furnace/furnace-tests.factor Normal file
View File

@ -0,0 +1,35 @@
IN: furnace.tests
USING: http.server.dispatchers http.server.responses
http.server furnace tools.test kernel namespaces accessors
io.streams.string ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
TUPLE: base-path-check-responder ;
C: <base-path-check-responder> base-path-check-responder
M: base-path-check-responder call-responder*
2drop
"$funny-dispatcher" resolve-base-path
"text/plain" <content> ;
[ ] [
<dispatcher>
<dispatcher>
<funny-dispatcher>
<base-path-check-responder> "c" add-responder
"b" add-responder
"a" add-responder
main-responder set
] unit-test
[ "/a/b/" ] [
V{ } responder-nesting set
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;'/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test

192
extra/furnace/furnace.factor Normal file
View File

@ -0,0 +1,192 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
continuations namespaces sequences splitting words
vocabs.loader classes strings
fry urls multiline present
xml
xml.data
xml.entities
xml.writer
html.components
html.elements
html.templates
html.templates.chloe
html.templates.chloe.syntax
http
http.server
http.server.redirection
http.server.responses
qualified ;
QUALIFIED-WITH: assocs a
EXCLUDE: xml.utilities => children>string ;
IN: furnace
: nested-responders ( -- seq )
responder-nesting get a:values ;
: each-responder ( quot -- )
nested-responders swap each ; inline
: base-path ( string -- pair )
dup responder-nesting get
[ second class word-name = ] with find nip
[ first ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
[
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
: vocab-path ( vocab -- path )
dup vocab-dir vocab-append-path ;
: resolve-template-path ( pair -- path )
[
first2 [ word-vocabulary vocab-path % ] [ "/" % % ] bi*
] "" make ;
GENERIC: modify-query ( query responder -- query' )
M: object modify-query drop ;
GENERIC: adjust-url ( url -- url' )
M: url adjust-url
clone
[ [ modify-query ] each-responder ] change-query
[ resolve-base-path ] change-path
relative-to-request ;
M: string adjust-url ;
: <redirect> ( url -- response )
adjust-url request get method>> {
{ "GET" [ <temporary-redirect> ] }
{ "HEAD" [ <temporary-redirect> ] }
{ "POST" [ <permanent-redirect> ] }
} case ;
GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
{ "POST" [
post-data>>
dup content-type>> "application/x-www-form-urlencoded" =
[ content>> ] [ drop f ] if
] }
} case ;
SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
! Chloe tags
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
CHLOE: atom
[ children>string ]
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ] tri
<url>
swap >>query
swap >>path
adjust-url relative-to-request
add-atom-feed ;
CHLOE: write-atom drop write-atom-feeds ;
GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ;
: link-attrs ( tag -- )
'[ , _ link-attr ] each-responder ;
: a-start-tag ( tag -- )
[
<a
dup link-attrs
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if
<url>
swap >>query
swap >>path
adjust-url relative-to-request =href
a>
] with-scope ;
CHLOE: a
[ a-start-tag ]
[ process-tag-children ]
[ drop </a> ]
tri ;
: hidden-form-field ( value name -- )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
: form-nesting-key "__n" ;
: form-magic ( tag -- )
[ modify-form ] each-responder
nested-values get " " join f like form-nesting-key hidden-form-field
"for" optional-attr [ "," split [ hidden render ] each ] when* ;
: form-start-tag ( tag -- )
[
[
<form
"POST" =method
[ link-attrs ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
tri
form>
]
[ form-magic ] bi
] with-scope ;
CHLOE: form
[ form-start-tag ]
[ process-tag-children ]
[ drop </form> ]
tri ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<button type="submit"></button>
</t:form>
;
: add-tag-attrs ( attrs tag -- )
tag-attrs swap update ;
CHLOE: button
button-tag-markup string>xml delegate
{
[ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
[ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
[ nip ]
} 2cleave process-chloe-tag ;

7
extra/furnace/json/json.factor Normal file
View File

@ -0,0 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: json.writer http.server.responses ;
IN: furnace.json
: <json-content> ( body -- response )
>json "application/json" <content> ;

0
extra/http/server/sessions/authors.txt → extra/furnace/sessions/authors.txt
View File

36
extra/http/server/sessions/sessions-tests.factor → extra/furnace/sessions/sessions-tests.factor
View File

@ -1,8 +1,10 @@
IN: http.server.sessions.tests
USING: tools.test http http.server.sessions
http.server.actions http.server math namespaces kernel accessors
IN: furnace.sessions.tests
USING: tools.test http furnace.sessions
furnace.actions http.server http.server.responses
math namespaces kernel accessors
prettyprint io.streams.string io.files splitting destructors
sequences db db.sqlite continuations ;
sequences db db.sqlite continuations urls math.parser
furnace ;
: with-session
[
@ -18,15 +20,16 @@ M: foo init-session* drop 0 "x" sset ;
M: foo call-responder*
2drop
"x" [ 1+ ] schange
[ "x" sget pprint ] <html-content> ;
"x" sget number>string "text/html" <content> ;
: url-responder-mock-test
[
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
request set
dup url>>
"id" get session-id-key set-query-param
"/" >>path drop
init-request
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
@ -36,21 +39,21 @@ M: foo call-responder*
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
dup url>> "/" >>path drop
init-request
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: <exiting-action>
<action>
[ [ ] <text-content> exit-with ] >>display ;
[ [ ] "text/plain" <content> exit-with ] >>display ;
[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
"auth-test.db" temp-file sqlite-db [
init-request
<request> init-request
init-sessions-table
[ ] [
@ -112,8 +115,8 @@ M: foo call-responder*
[
<request>
"GET" >>method
"/" >>path
"GET" >>method
dup url>> "/" >>path drop
request set
{ "etc" } sessions get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
@ -131,8 +134,9 @@ M: foo call-responder*
[ ] [
<request>
"GET" >>method
"id" get session-id-key set-query-param
"/" >>path
dup url>>
"id" get session-id-key set-query-param
"/" >>path drop
request set
[

18
extra/http/server/sessions/sessions.factor → extra/furnace/sessions/sessions.factor
View File

@ -4,8 +4,9 @@ USING: assocs kernel math.intervals math.parser namespaces
random accessors quotations hashtables sequences continuations
fry calendar combinators destructors alarms
db db.tuples db.types
http http.server html.elements ;
IN: http.server.sessions
http http.server http.server.dispatchers http.server.filters
html.elements furnace ;
IN: furnace.sessions
TUPLE: session id expires uid namespace changed? ;
@ -108,14 +109,14 @@ M: session-saver dispose
[ session set ] [ save-session-after ] bi
sessions get responder>> call-responder ;
: session-id-key "factorsessid" ;
: session-id-key "__s" ;
: cookie-session-id ( request -- id/f )
session-id-key get-cookie
dup [ value>> string>number ] when ;
: post-session-id ( request -- id/f )
session-id-key swap post-data>> at string>number ;
session-id-key swap request-params at string>number ;
: request-session-id ( -- id/f )
request get dup method>> {
@ -136,15 +137,10 @@ M: session-saver dispose
: put-session-cookie ( response -- response' )
session get id>> number>string <session-cookie> put-cookie ;
: session-form-field ( -- )
<input
"hidden" =type
session-id-key =name
session get id>> number>string =value
input/> ;
M: sessions modify-form ( responder -- )
drop session get id>> session-id-key hidden-form-field ;
M: sessions call-responder* ( path responder -- response )
[ session-form-field ] add-form-hook
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;

53
extra/furnace/syndication/syndication.factor Normal file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences fry sequences.lib
combinators syndication
http.server.responses http.server.redirection
furnace furnace.actions ;
IN: furnace.syndication
GENERIC: feed-entry-title ( object -- string )
GENERIC: feed-entry-date ( object -- timestamp )
GENERIC: feed-entry-url ( object -- url )
GENERIC: feed-entry-description ( object -- description )
M: object feed-entry-description drop f ;
GENERIC: >entry ( object -- entry )
M: entry >entry ;
M: object >entry
<entry>
swap {
[ feed-entry-title >>title ]
[ feed-entry-date >>date ]
[ feed-entry-url >>url ]
[ feed-entry-description >>description ]
} cleave ;
: process-entries ( seq -- seq' )
20 short head-slice [
>entry clone
[ adjust-url relative-to-request ] change-url
] map ;
: <feed-content> ( body -- response )
feed>xml "application/atom+xml" <content> ;
TUPLE: feed-action < action title url entries ;
: <feed-action> ( -- action )
feed-action new-action
dup '[
feed new
,
[ title>> call >>title ]
[ url>> call adjust-url relative-to-request >>url ]
[ entries>> call process-entries >>entries ]
tri
<feed-content>
] >>display ;

2
extra/globs/globs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators regexp lazy-lists sequences kernel
USING: parser-combinators regexp lists sequences kernel
promises strings unicode.case ;
IN: globs

5
extra/help/html/html.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: help.html

8
extra/html/components/components-tests.factor
View File

@ -1,7 +1,7 @@
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
html.components namespaces ;
html.elements html.components namespaces ;
[ ] [ blank-values ] unit-test
@ -11,14 +11,12 @@ html.components namespaces ;
TUPLE: color red green blue ;
[ ] [ 1 2 3 color boa from-tuple ] unit-test
[ ] [ 1 2 3 color boa from-object ] unit-test
[ 1 ] [ "red" value ] unit-test
[ ] [ "jimmy" "red" set-value ] unit-test
[ "123.5" ] [ 123.5 object>string ] unit-test
[ "jimmy" ] [
[
"red" label render
@ -107,7 +105,7 @@ TUPLE: color red green blue ;
[ ] [ t "delivery" set-value ] unit-test
[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
[ "<input type='checkbox' name='delivery' checked='true'>Delivery</input>" ] [
[
"delivery"
<checkbox>

91
extra/html/components/components.factor
View File

@ -5,7 +5,7 @@ classes.tuple words arrays sequences sequences.lib splitting
mirrors hashtables combinators continuations math strings
fry locals calendar calendar.format xml.entities validators
html.elements html.streams xmode.code2html farkup inspector
lcs.diff2html ;
lcs.diff2html urls present ;
IN: html.components
SYMBOL: values
@ -19,9 +19,9 @@ SYMBOL: values
: prepare-value ( name object -- value name object )
[ [ value ] keep ] dip ; inline
: from-assoc ( assoc -- ) values get swap update ;
: from-tuple ( tuple -- ) <mirror> from-assoc ;
: from-object ( object -- )
dup assoc? [ <mirror> ] unless
values get swap update ;
: deposit-values ( destination names -- )
[ dup value ] H{ } map>assoc update ;
@ -29,27 +29,36 @@ SYMBOL: values
: deposit-slots ( destination names -- )
[ <mirror> ] dip deposit-values ;
: with-each-index ( seq quot -- )
'[
: with-each-value ( name quot -- )
[ value ] dip '[
[
blank-values 1+ "index" set-value @
values [ clone ] change
1+ "index" set-value
"value" set-value
@
] with-scope
] each-index ; inline
: with-each-value ( seq quot -- )
'[ "value" set-value @ ] with-each-index ; inline
: with-each-object ( name quot -- )
[ value ] dip '[
[
blank-values
1+ "index" set-value
from-object
@
] with-scope
] each-index ; inline
: with-each-assoc ( seq quot -- )
'[ from-assoc @ ] with-each-index ; inline
SYMBOL: nested-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
: with-values ( name quot -- )
'[
,
[ nested-values [ swap prefix ] change ]
[ value blank-values from-object ]
bi
@
] with-scope ; inline
: nest-values ( name quot -- )
swap [
@ -58,22 +67,6 @@ 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 ] }
{ [ dup timestamp? ] [ timestamp>string ] }
{ [ dup string? ] [ ] }
{ [ dup word? ] [ word-name ] }
{ [ dup not ] [ drop "" ] }
} cond ;
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
@ -88,13 +81,13 @@ GENERIC: render* ( value name render -- )
<PRIVATE
: render-input ( value name type -- )
<input =type =name object>string =value input/> ;
<input =type =name present =value input/> ;
PRIVATE>
SINGLETON: label
M: label render* 2drop object>string escape-string write ;
M: label render* 2drop present escape-string write ;
SINGLETON: hidden
@ -103,9 +96,9 @@ M: hidden render* drop "hidden" render-input ;
: render-field ( value name size type -- )
<input
=type
[ object>string =size ] when*
[ present =size ] when*
=name
object>string =value
present =value
input/> ;
TUPLE: field size ;
@ -132,11 +125,11 @@ TUPLE: textarea rows cols ;
M: textarea render*
<textarea
[ rows>> [ object>string =rows ] when* ]
[ cols>> [ object>string =cols ] when* ] bi
[ rows>> [ present =rows ] when* ]
[ cols>> [ present =cols ] when* ] bi
=name
textarea>
object>string escape-string write
present escape-string write
</textarea> ;
! Choice
@ -147,7 +140,7 @@ TUPLE: choice size multiple choices ;
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
object>string escape-string write
present escape-string write
</option> ;
: render-options ( options selected -- )
@ -156,7 +149,7 @@ TUPLE: choice size multiple choices ;
M: choice render*
<select
swap =name
dup size>> [ object>string =size ] when*
dup size>> [ present =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
[ choices>> value ] [ multiple>> ] bi
@ -174,7 +167,7 @@ M: checkbox render*
<input
"checkbox" =type
swap =name
swap [ "true" =selected ] when
swap [ "true" =checked ] when
input>
label>> escape-string write
</input> ;
@ -183,12 +176,18 @@ M: checkbox render*
GENERIC: link-title ( obj -- string )
GENERIC: link-href ( obj -- url )
M: string link-title ;
M: string link-href ;
M: url link-title ;
M: url link-href ;
SINGLETON: link
M: link render*
2drop
<a dup link-href =href a>
link-title object>string escape-string write
link-title present escape-string write
</a> ;
! XMode code component

9
extra/html/elements/elements.factor
View File

@ -4,7 +4,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations
sequences strings words xml.entities compiler.units effects ;
sequences strings words xml.entities compiler.units effects
urls math math.parser combinators present ;
IN: html.elements
@ -130,7 +131,7 @@ SYMBOL: html
" " write-html
write-html
"='" write-html
escape-quoted-string write-html
present escape-quoted-string write-html
"'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ;
@ -162,7 +163,7 @@ SYMBOL: html
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "multiple"
"media" "title" "multiple" "checked"
] [ define-attribute-word ] each
>>
@ -178,7 +179,7 @@ SYMBOL: html
<html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
<head> <title> swap write </title> </head>
<body> call </body>
</html> ;
</html> ; inline
: render-error ( message -- )
<span "error" =class span> escape-string write </span> ;

2
extra/html/parser/analyzer/analyzer.factor
View File

@ -1,6 +1,6 @@
USING: assocs html.parser kernel math sequences strings ascii
arrays shuffle unicode.case namespaces splitting http
sequences.lib accessors io combinators http.client ;
sequences.lib accessors io combinators http.client urls ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;

67
extra/html/templates/chloe/chloe-tests.factor
View File

@ -1,7 +1,7 @@
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
namespaces xml html.components
splitting unicode.categories ;
splitting unicode.categories furnace ;
IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test
@ -27,8 +27,7 @@ IN: html.templates.chloe.tests
: test-template ( name -- template )
"resource:extra/html/templates/chloe/test/"
swap
".xml" 3append <chloe> ;
prepend <chloe> ;
[ "Hello world" ] [
[
@ -70,24 +69,6 @@ IN: html.templates.chloe.tests
] run-template
] unit-test
SYMBOL: test6-aux?
[ "True" ] [
[
test6-aux? on
"test6" test-template call-template
] run-template
] unit-test
SYMBOL: test7-aux?
[ "" ] [
[
test7-aux? off
"test7" test-template call-template
] run-template
] unit-test
[ ] [ blank-values ] unit-test
[ ] [ "A label" "label" set-value ] unit-test
@ -128,7 +109,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
[
"test9" test-template call-template
"test7" test-template call-template
] run-template [ blank? not ] filter
] unit-test
@ -143,7 +124,7 @@ TUPLE: person first-name last-name ;
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
[
"test10" test-template call-template
"test8" test-template call-template
] run-template [ blank? not ] filter
] unit-test
@ -155,7 +136,47 @@ TUPLE: person first-name last-name ;
] unit-test
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
[
"test8" test-template call-template
] run-template [ blank? not ] filter
] unit-test
[ ] [ 1 "id" set-value ] unit-test
[ "<a name=\"1\">Hello</a>" ] [
[
"test9" test-template call-template
] run-template
] unit-test
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
[ "<form method='POST' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
[
"test10" test-template call-template
] run-template
] unit-test
[ ] [ blank-values ] unit-test
[ ] [
H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } } "person" set-value
] unit-test
[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr></table>" ] [
[
"test11" test-template call-template
] run-template [ blank? not ] filter
] unit-test
[ ] [
blank-values
{ "a" "b" } "choices" set-value
"true" "b" set-value
] unit-test
[ "<input type='checkbox' name='a'>a</input><input type='checkbox' name='b' checked='true'>b</input>" ] [
[
"test12" test-template call-template
] run-template
] unit-test

288
extra/html/templates/chloe/chloe.factor
View File

@ -3,19 +3,16 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math
unicode.case tuple-syntax mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
html.templates
http.server
http.server.auth
http.server.flows
http.server.actions
http.server.sessions ;
html.templates.chloe.syntax ;
IN: html.templates.chloe
! Chloe is Ed's favorite web designer
SYMBOL: tag-stack
TUPLE: chloe path ;
@ -23,8 +20,6 @@ C: <chloe> chloe
DEFER: process-template
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
: chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = ] assoc-filter ;
@ -38,35 +33,23 @@ DEFER: process-template
[ t ]
} cond nip ;
SYMBOL: tags
MEMO: chloe-name ( string -- name )
name new
swap >>tag
chloe-ns >>url ;
: required-attr ( tag name -- value )
dup chloe-name rot at*
[ nip ] [ drop " attribute is required" append throw ] if ;
: optional-attr ( tag name -- value )
chloe-name swap at ;
: process-tag-children ( tag -- )
[ process-template ] each ;
CHLOE: chloe process-tag-children ;
: children>string ( tag -- string )
[ process-tag-children ] with-string-writer ;
: title-tag ( tag -- )
children>string set-title ;
CHLOE: title children>string set-title ;
: write-title-tag ( tag -- )
CHLOE: write-title
drop
"head" tags get member? "title" tags get member? not and
"head" tag-stack get member?
"title" tag-stack get member? not and
[ <title> write-title </title> ] [ write-title ] if ;
: style-tag ( tag -- )
CHLOE: style
dup "include" optional-attr dup [
swap children>string empty? [
"style tag cannot have both an include attribute and a body" throw
@ -76,241 +59,80 @@ MEMO: chloe-name ( string -- name )
drop children>string
] if add-style ;
: write-style-tag ( tag -- )
CHLOE: write-style
drop <style> write-style </style> ;
: atom-tag ( tag -- )
[ "title" required-attr ]
[ "href" required-attr ]
bi set-atom-feed ;
CHLOE: even "index" value even? [ process-tag-children ] [ drop ] if ;
: write-atom-tag ( tag -- )
drop
"head" tags get member? [
write-atom-feed
] [
atom-feed get value>> second write
] if ;
CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
: flow-attr ( tag -- )
"flow" optional-attr {
{ "none" [ flow-id off ] }
{ "begin" [ begin-flow ] }
{ "current" [ ] }
{ f [ ] }
} case ;
: session-attr ( tag -- )
"session" optional-attr {
{ "none" [ session off flow-id off ] }
{ "current" [ ] }
{ f [ ] }
} case ;
: a-start-tag ( tag -- )
: (bind-tag) ( tag quot -- )
[
<a
dup flow-attr
dup session-attr
dup "value" optional-attr [ value f ] [
[ "href" required-attr ]
[ "query" optional-attr parse-query-attr ]
bi
] ?if link>string =href
a>
] with-scope ;
[ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
: a-tag ( tag -- )
[ a-start-tag ]
[ process-tag-children ]
[ drop </a> ]
tri ;
CHLOE: each [ with-each-value ] (bind-tag) ;
: form-start-tag ( tag -- )
[
[
<form
"POST" =method
{
[ flow-attr ]
[ session-attr ]
[ "action" required-attr resolve-base-path =action ]
[ tag-attrs non-chloe-attrs-only print-attrs ]
} cleave
form>
] [
hidden-form-field
"for" optional-attr [ hidden render ] when*
] bi
] with-scope ;
CHLOE: bind-each [ with-each-object ] (bind-tag) ;
: form-tag ( tag -- )
[ form-start-tag ]
[ process-tag-children ]
[ drop </form> ]
tri ;
CHLOE: bind [ with-values ] (bind-tag) ;
DEFER: process-chloe-tag
: error-message-tag ( tag -- )
children>string render-error ;
STRING: button-tag-markup
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<button type="submit"></button>
</t:form>
;
CHLOE: comment drop ;
: add-tag-attrs ( attrs tag -- )
tag-attrs swap update ;
: button-tag ( tag -- )
button-tag-markup string>xml delegate
{
[ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
[ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
[ [ children>string 1array ] dip "button" tag-named set-tag-children ]
[ nip ]
} 2cleave process-chloe-tag ;
CHLOE: call-next-template drop call-next-template ;
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
: attr>var ( value -- word/f )
attr>word dup symbol? [
"Must be a symbol: " swap append throw
] unless ;
: if-satisfied? ( tag -- ? )
t swap
{
[ "code" optional-attr [ attr>word execute and ] when* ]
[ "var" optional-attr [ attr>var get and ] when* ]
[ "svar" optional-attr [ attr>var sget and ] when* ]
[ "uvar" optional-attr [ attr>var uget and ] when* ]
[ "value" optional-attr [ value and ] when* ]
} cleave ;
[ "code" optional-attr [ attr>word execute ] [ t ] if* ]
[ "value" optional-attr [ value ] [ t ] if* ]
bi and ;
: if-tag ( tag -- )
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
CHLOE: if dup if-satisfied? [ process-tag-children ] [ drop ] if ;
: even-tag ( tag -- )
"index" value even? [ process-tag-children ] [ drop ] if ;
CHLOE-SINGLETON: label
CHLOE-SINGLETON: link
CHLOE-SINGLETON: farkup
CHLOE-SINGLETON: inspector
CHLOE-SINGLETON: comparison
CHLOE-SINGLETON: html
CHLOE-SINGLETON: hidden
: odd-tag ( tag -- )
"index" value odd? [ process-tag-children ] [ drop ] if ;
: (each-tag) ( tag quot -- )
[
[ "values" required-attr value ] keep
'[ , process-tag-children ]
] dip call ; inline
: each-tag ( tag -- )
[ with-each-value ] (each-tag) ;
: each-tuple-tag ( tag -- )
[ with-each-tuple ] (each-tag) ;
: 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 ;
: validation-messages-tag ( tag -- )
drop render-validation-messages ;
: singleton-component-tag ( tag class -- )
[ "name" required-attr ] dip render ;
: attrs>slots ( tag tuple -- )
[ attrs>> ] [ <mirror> ] bi*
'[
swap tag>> dup "name" =
[ 2drop ] [ , set-at ] if
] assoc-each ;
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr ]
[ new [ attrs>slots ] keep ]
2bi render ;
CHLOE-TUPLE: field
CHLOE-TUPLE: textarea
CHLOE-TUPLE: password
CHLOE-TUPLE: choice
CHLOE-TUPLE: checkbox
CHLOE-TUPLE: code
: process-chloe-tag ( tag -- )
dup name-tag {
{ "chloe" [ process-tag-children ] }
! HTML head
{ "title" [ title-tag ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "atom" [ atom-tag ] }
{ "write-atom" [ write-atom-tag ] }
! HTML elements
{ "a" [ a-tag ] }
{ "button" [ button-tag ] }
! Components
{ "label" [ label singleton-component-tag ] }
{ "link" [ link singleton-component-tag ] }
{ "code" [ code tuple-component-tag ] }
{ "farkup" [ farkup singleton-component-tag ] }
{ "inspector" [ inspector singleton-component-tag ] }
{ "comparison" [ comparison singleton-component-tag ] }
{ "html" [ html singleton-component-tag ] }
! Forms
{ "form" [ form-tag ] }
{ "error-message" [ error-message-tag ] }
{ "validation-messages" [ validation-messages-tag ] }
{ "hidden" [ hidden singleton-component-tag ] }
{ "field" [ field tuple-component-tag ] }
{ "password" [ password tuple-component-tag ] }
{ "textarea" [ textarea tuple-component-tag ] }
{ "choice" [ choice tuple-component-tag ] }
{ "checkbox" [ checkbox tuple-component-tag ] }
! Control flow
{ "if" [ if-tag ] }
{ "even" [ even-tag ] }
{ "odd" [ odd-tag ] }
{ "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 ] }
[ "Unknown chloe tag: " prepend throw ]
} case ;
dup name-tag dup tags get at
[ call ] [ "Unknown chloe tag: " prepend throw ] ?if ;
: process-tag ( tag -- )
{
[ name-tag >lower tags get push ]
[ name-tag >lower tag-stack get push ]
[ write-start-tag ]
[ process-tag-children ]
[ write-end-tag ]
[ drop tags get pop* ]
[ drop tag-stack get pop* ]
} cleave ;
: expand-attrs ( tag -- tag )
dup [ tag? ] is? [
clone [
[ "@" ?head [ value present ] when ] assoc-map
] change-attrs
] when ;
: process-template ( xml -- )
expand-attrs
{
{ [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
{ [ dup [ tag? ] is? ] [ process-tag ] }
@ -319,7 +141,7 @@ STRING: button-tag-markup
: process-chloe ( xml -- )
[
V{ } clone tags set
V{ } clone tag-stack set
nested-template? get [
process-template
@ -334,6 +156,6 @@ STRING: button-tag-markup
] with-scope ;
M: chloe call-template*
path>> utf8 <file-reader> read-xml process-chloe ;
path>> ".xml" append utf8 <file-reader> read-xml process-chloe ;
INSTANCE: chloe template

61
extra/html/templates/chloe/syntax/syntax.factor Normal file
View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: html.templates.chloe.syntax
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize parser
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
html.templates ;
SYMBOL: tags
tags global [ H{ } clone or ] change-at
: define-chloe-tag ( name quot -- ) swap tags get set-at ;
: CHLOE:
scan parse-definition define-chloe-tag ; parsing
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
MEMO: chloe-name ( string -- name )
name new
swap >>tag
chloe-ns >>url ;
: required-attr ( tag name -- value )
dup chloe-name rot at*
[ nip ] [ drop " attribute is required" append throw ] if ;
: optional-attr ( tag name -- value )
chloe-name swap at ;
: singleton-component-tag ( tag class -- )
[ "name" required-attr ] dip render ;
: CHLOE-SINGLETON:
scan-word
[ word-name ] [ '[ , singleton-component-tag ] ] bi
define-chloe-tag ;
parsing
: attrs>slots ( tag tuple -- )
[ attrs>> ] [ <mirror> ] bi*
'[
swap tag>> dup "name" =
[ 2drop ] [ , set-at ] if
] assoc-each ;
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr ]
[ new [ attrs>slots ] keep ]
2bi render ;
: CHLOE-TUPLE:
scan-word
[ word-name ] [ '[ , tuple-component-tag ] ] bi
define-chloe-tag ;
parsing

13
extra/html/templates/chloe/test/test10.xml
View File

@ -1,14 +1,3 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<table>
<t:each-tuple t:values="people">
<tr>
<td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td>
</tr>
</t:each-tuple>
</table>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:bind t:name="a"><t:form t:action="foo"/></t:bind></t:chloe>

4
extra/html/templates/chloe/test/test11.xml
View File

@ -3,12 +3,12 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<table>
<t:each-assoc t:values="people">
<t:bind t:name="person">
<tr>
<td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td>
</tr>
</t:each-assoc>
</t:bind>
</table>
</t:chloe>

3
extra/html/templates/chloe/test/test12.xml Normal file
View File

@ -0,0 +1,3 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><t:each t:name="choices"><t:checkbox t:name="@value" t:label="@value" /></t:each></t:chloe>

24
extra/html/templates/chloe/test/test6.xml
View File

@ -2,8 +2,26 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if t:var="html.templates.chloe.tests:test6-aux?">
True
</t:if>
<t:label t:name="label" />
<t:link t:name="link" />
<t:code t:name="code" mode="mode" />
<t:farkup t:name="farkup" />
<t:inspector t:name="inspector" />
<t:html t:name="html" />
<t:field t:name="field" t:size="13" />
<t:password t:name="password" t:size="10" />
<t:textarea t:name="textarea" t:rows="5" t:cols="10" />
<t:choice t:name="choice" t:choices="choices" />
<t:checkbox t:name="checkbox">Checkbox</t:checkbox>
</t:chloe>

8
extra/html/templates/chloe/test/test7.xml
View File

@ -2,8 +2,10 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:if t:var="html.templates.chloe.tests:test7-aux?">
True
</t:if>
<ul>
<t:each t:name="numbers">
<li><t:label t:name="value"/></li>
</t:each>
</ul>
</t:chloe>

29
extra/html/templates/chloe/test/test8.xml
View File

@ -2,26 +2,13 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:label t:name="label" />
<t:link t:name="link" />
<t:code t:name="code" mode="mode" />
<t:farkup t:name="farkup" />
<t:inspector t:name="inspector" />
<t:html t:name="html" />
<t:field t:name="field" t:size="13" />
<t:password t:name="password" t:size="10" />
<t:textarea t:name="textarea" t:rows="5" t:cols="10" />
<t:choice t:name="choice" t:choices="choices" />
<t:checkbox t:name="checkbox">Checkbox</t:checkbox>
<table>
<t:bind-each t:name="people">
<tr>
<td><t:label t:name="first-name"/></td>
<td><t:label t:name="last-name"/></td>
</tr>
</t:bind-each>
</table>
</t:chloe>

10
extra/html/templates/chloe/test/test9.xml
View File

@ -1,11 +1,3 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<ul>
<t:each t:values="numbers">
<li><t:label t:name="value"/></li>
</t:each>
</ul>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"><a name="@id">Hello</a></t:chloe>

25
extra/html/templates/templates.factor
View File

@ -2,7 +2,8 @@
! 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.elements io.streams.string quotations ;
arrays strings html.elements io.streams.string
quotations xml.data xml.writer ;
IN: html.templates
MIXIN: template
@ -13,6 +14,8 @@ M: string call-template* write ;
M: callable call-template* call ;
M: xml call-template* write-xml ;
M: object call-template* output-stream get stream-copy ;
ERROR: template-error template error ;
@ -43,17 +46,17 @@ SYMBOL: style
: write-style ( -- )
style get >string write ;
SYMBOL: atom-feed
SYMBOL: atom-feeds
: set-atom-feed ( title url -- )
2array atom-feed get >box ;
: add-atom-feed ( title url -- )
2array atom-feeds get push ;
: write-atom-feed ( -- )
atom-feed get value>> [
: write-atom-feeds ( -- )
atom-feeds get [
<link "alternate" =rel "application/atom+xml" =type
[ first =title ] [ second =href ] bi
first2 [ =title ] [ =href ] bi*
link/>
] when* ;
] each ;
SYMBOL: nested-template?
@ -66,9 +69,9 @@ M: f call-template* drop call-next-template ;
: with-boilerplate ( body template -- )
[
title get [ <box> title set ] unless
atom-feed get [ <box> atom-feed set ] unless
style get [ SBUF" " clone style set ] unless
title [ <box> or ] change
style [ SBUF" " clone or ] change
atom-feeds [ V{ } like ] change
[
[

24
extra/http/client/client-tests.factor
View File

@ -1,5 +1,5 @@
USING: http.client http.client.private http tools.test
tuple-syntax namespaces ;
tuple-syntax namespaces urls ;
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
@ -10,36 +10,26 @@ tuple-syntax namespaces ;
[
TUPLE{ request
protocol: http
url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" }
method: "GET"
host: "www.apple.com"
port: 80
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
}
] [
[
"http://www.apple.com/index.html"
<get-request>
] with-scope
"http://www.apple.com/index.html"
<get-request>
] unit-test
[
TUPLE{ request
protocol: https
url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" }
method: "GET"
host: "www.amazon.com"
port: 443
path: "/index.html"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client vocabulary" } }
}
] [
[
"https://www.amazon.com/index.html"
<get-request>
] with-scope
"https://www.amazon.com/index.html"
<get-request>
] unit-test

23
extra/http/client/client.factor
View File

@ -4,7 +4,7 @@ USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors math.order
io.encodings.8-bit io.encodings.binary io.streams.duplex
fry debugger inspector ascii ;
fry debugger inspector ascii urls ;
IN: http.client
: max-redirects 10 ;
@ -21,14 +21,16 @@ DEFER: http-request
SYMBOL: redirects
: redirect-url ( request url -- request )
'[ , >url ensure-port derive-url ensure-port ] change-url ;
: do-redirect ( response data -- response data )
over code>> 300 399 between? [
drop
redirects inc
redirects get max-redirects < [
request get
swap "location" header dup absolute-url?
[ request-with-url ] [ request-with-path ] if
swap "location" header redirect-url
"GET" >>method http-request
] [
too-many-redirects
@ -51,7 +53,7 @@ PRIVATE>
: http-request ( request -- response data )
dup request [
dup request-addr latin1 [
dup url>> url-addr latin1 [
1 minutes timeouts
write-request
read-response
@ -62,8 +64,8 @@ PRIVATE>
: <get-request> ( url -- request )
<request>
swap request-with-url
"GET" >>method ;
"GET" >>method
swap >url ensure-port >>url ;
: http-get* ( url -- response data )
<get-request> http-request ;
@ -98,12 +100,11 @@ M: download-failed error.
: download ( url -- )
dup download-name download-to ;
: <post-request> ( content-type content url -- request )
: <post-request> ( post-data url -- request )
<request>
"POST" >>method
swap request-with-url
swap >>post-data
swap >>post-data-type ;
swap >url ensure-port >>url
swap >>post-data ;
: http-post ( content-type content url -- response data )
: http-post ( post-data url -- response data )
<post-request> http-request ;

144
extra/http/http-tests.factor
View File

@ -1,58 +1,27 @@
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences
assocs io.sockets db db.sqlite continuations ;
assocs io.sockets db db.sqlite continuations urls hashtables ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ f ] [ "%XX%XX%XX" url-decode ] unit-test
[ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test
[ "hello world" ] [ "hello world%" url-decode ] unit-test
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
[ "/" ] [ "http://foo.com" url>path ] unit-test
[ "/" ] [ "http://foo.com/" url>path ] unit-test
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
: lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1
GET http://foo/bar HTTP/1.1
POST http://foo/bar HTTP/1.1
Some-Header: 1
Some-Header: 2
Content-Length: 4
Content-type: application/octet-stream
blah
;
[
TUPLE{ request
protocol: http
port: 80
method: "GET"
path: "/bar"
query: H{ }
url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
method: "POST"
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
post-data: "blah"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
cookies: V{ }
}
] [
@ -62,8 +31,9 @@ blah
] unit-test
STRING: read-request-test-1'
GET /bar HTTP/1.1
POST /bar HTTP/1.1
content-length: 4
content-type: application/octet-stream
some-header: 1; 2
blah
@ -85,14 +55,10 @@ Host: www.sex.com
[
TUPLE{ request
protocol: http
port: 80
url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
method: "HEAD"
path: "/bar"
query: H{ }
version: "1.1"
header: H{ { "host" "www.sex.com" } }
host: "www.sex.com"
cookies: V{ }
}
] [
@ -101,6 +67,15 @@ Host: www.sex.com
] with-string-reader
] unit-test
STRING: read-request-test-3
GET nested HTTP/1.0
;
[ read-request-test-3 [ read-request ] with-string-reader ]
[ "Bad request: URL" = ]
must-fail-with
STRING: read-response-test-1
HTTP/1.1 404 not found
Content-Type: text/html; charset=UTF8
@ -114,7 +89,7 @@ blah
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF8" } }
cookies: V{ }
cookies: { }
content-type: "text/html"
content-charset: "UTF8"
}
@ -145,14 +120,16 @@ read-response-test-1' 1array [
] unit-test
! Live-fire exercise
USING: http.server http.server.static http.server.sessions
http.server.actions http.server.auth.login http.server.db http.client
USING: http.server http.server.static furnace.sessions
furnace.actions furnace.auth.login furnace.db http.client
io.server io.files io io.encodings.ascii
accessors namespaces threads ;
accessors namespaces threads
http.server.responses http.server.redirection
http.server.dispatchers ;
: add-quit-action
<action>
[ stop-server [ "Goodbye" write ] <html-content> ] >>display
[ stop-server "Goodbye" "text/html" <content> ] >>display
"quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ;
@ -171,7 +148,7 @@ test-db [
"resource:extra/http/test" <static> >>default
"nested" add-responder
<action>
[ "redirect-loop" f <standard-redirect> ] >>display
[ URL" redirect-loop" <temporary-redirect> ] >>display
"redirect-loop" add-responder
main-responder set
@ -186,16 +163,6 @@ test-db [
"http://localhost:1237/nested/foo.html" http-get =
] unit-test
! Try with a slightly malformed request
[ t ] [
"localhost" 1237 <inet> ascii [
"GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush
read-crlf drop
read-header
] with-client "location" swap at "/" head?
] unit-test
[ "http://localhost:1237/redirect-loop" http-get ]
[ too-many-redirects? ] must-fail-with
@ -207,7 +174,7 @@ test-db [
[ ] [
[
<dispatcher>
<action> f <protected>
<action> <protected>
<login>
<sessions>
"" add-responder
@ -237,7 +204,7 @@ test-db [
[ ] [
[
<dispatcher>
<action> [ [ "Hi" write ] <text-content> ] >>display
<action> [ [ "Hi" write ] "text/plain" <content> ] >>display
<login>
<sessions>
"" add-responder
@ -254,3 +221,56 @@ test-db [
[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
USING: html.components html.elements xml xml.utilities validators
furnace furnace.flash ;
SYMBOL: a
[ ] [
[
<dispatcher>
<action>
[ a get-global "a" set-value ] >>init
[ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
[ { { "a" [ v-integer ] } } validate-params ] >>validate
[ "a" value a set-global URL" " <redirect> ] >>submit
<flash-scopes>
<sessions>
>>default
add-quit-action
test-db <db-persistence>
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
] with-scope
] unit-test
[ ] [ 100 sleep ] unit-test
3 a set-global
: test-a string>xml "input" tag-named "value" swap at ;
[ "3" ] [
"http://localhost:1237/" http-get*
swap dup cookies>> "cookies" set session-id-key get-cookie
value>> "session-id" set test-a
] unit-test
[ "4" ] [
H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
"http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
! Test flash scope
[ "xyz" ] [
H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
"http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
] unit-test
[ 4 ] [ a get-global ] unit-test
[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test

315
extra/http/http.factor
View File

@ -4,92 +4,18 @@ USING: accessors kernel combinators math namespaces
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format
math.parser calendar calendar.format present
io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets io.sockets.secure
io io.server io.sockets.secure
unicode.case unicode.categories qualified
html.templates ;
urls html.templates xml xml.data xml.writer ;
EXCLUDE: fry => , ;
IN: http
SINGLETON: http
SINGLETON: https
GENERIC: http-port ( protocol -- port )
M: http http-port drop 80 ;
M: https http-port drop 443 ;
GENERIC: protocol>string ( protocol -- string )
M: http protocol>string drop "http" ;
M: https protocol>string drop "https" ;
: string>protocol ( string -- protocol )
{
{ "http" [ http ] }
{ "https" [ https ] }
[ "Unknown protocol: " swap append throw ]
} case ;
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
{
{ [ dup letter? ] [ t ] }
{ [ dup LETTER? ] [ t ] }
{ [ dup digit? ] [ t ] }
{ [ dup "/_-.:" member? ] [ t ] }
[ f ]
} cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
2drop
] [
[ 1+ dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex [ 3 + ] dip ;
: url-decode-+-or-other ( index str ch -- index str )
dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
: url-decode-iter ( index str -- )
2dup length >= [
2drop
] [
2dup nth dup CHAR: % = [
drop url-decode-%
] [
url-decode-+-or-other
] if url-decode-iter
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make utf8 decode ;
: crlf "\r\n" write ;
: add-header ( value key assoc -- )
@ -128,10 +54,9 @@ M: https protocol>string drop "https" ;
: header-value>string ( value -- string )
{
{ [ dup number? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>http-string ] }
{ [ dup string? ] [ ] }
{ [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
{ [ dup array? ] [ [ header-value>string ] map "; " join ] }
[ present ]
} cond ;
: check-header-string ( str -- str )
@ -145,42 +70,6 @@ M: https protocol>string drop "https" ;
header-value>string check-header-string write crlf
] assoc-each crlf ;
: add-query-param ( value key assoc -- )
[
at [
{
{ [ dup string? ] [ swap 2array ] }
{ [ dup array? ] [ swap suffix ] }
{ [ dup not ] [ drop ] }
} cond
] when*
] 2keep set-at ;
: query>assoc ( query -- assoc )
dup [
"&" split H{ } clone [
[
[ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
add-query-param
] curry each
] keep
] when ;
: assoc>query ( hash -- str )
[
{
{ [ dup number? ] [ number>string 1array ] }
{ [ dup string? ] [ 1array ] }
{ [ dup sequence? ] [ ] }
} cond
] assoc-map
[
[
[ url-encode ] dip
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
TUPLE: cookie name value path domain expires max-age http-only ;
: <cookie> ( value name -- cookie )
@ -236,16 +125,11 @@ TUPLE: cookie name value path domain expires max-age http-only ;
[ unparse-cookie ] map concat "; " join ;
TUPLE: request
protocol
host
port
method
path
query
url
version
header
post-data
post-data-type
cookies ;
: set-header ( request/response value key -- request/response )
@ -254,51 +138,30 @@ cookies ;
: <request>
request new
"1.1" >>version
http >>protocol
<url>
"http" >>protocol
H{ } clone >>query
>>url
H{ } clone >>header
H{ } clone >>query
V{ } clone >>cookies
"close" "connection" set-header
"Factor http.client vocabulary" "user-agent" set-header ;
: query-param ( request key -- value )
swap query>> at ;
: set-query-param ( request value key -- request )
pick query>> set-at ;
: chop-hostname ( str -- str' )
":" split1 "//" ?head drop nip
CHAR: / over index over length or tail
dup empty? [ drop "/" ] when ;
: url>path ( url -- path )
#! Technically, only proxies are meant to support hostnames
#! in HTTP requests, but IE sends these sometimes so we
#! just chop the hostname part.
url-decode
dup { "http://" "https://" } [ head? ] with contains?
[ chop-hostname ] when ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
>>method ;
: read-query ( request -- request )
" " read-until
[ "Bad request: query params" throw ] unless
query>assoc >>query ;
: check-absolute ( url -- url )
dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline
: read-url ( request -- request )
" ?" read-until {
{ CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
{ CHAR: ? [ url>path >>path read-query ] }
[ "Bad request: URL" throw ]
} case ;
" " read-until [
dup empty? [ drop read-url ] [ >url check-absolute >>url ] if
] [ "Bad request: URL" throw ] if ;
: parse-version ( string -- version )
"HTTP/" ?head [ "Bad version" throw ] unless
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
"HTTP/" ?head [ "Bad request: version" throw ] unless
dup { "1.0" "1.1" } member? [ "Bad request: version" throw ] unless ;
: read-request-version ( request -- request )
read-crlf [ CHAR: \s = ] left-trim
@ -311,34 +174,33 @@ cookies ;
: header ( request/response key -- value )
swap header>> at ;
SYMBOL: max-post-request
TUPLE: post-data raw content content-type ;
1024 256 * max-post-request set-global
: <post-data> ( raw content-type -- post-data )
post-data new
swap >>content-type
swap >>raw ;
: content-length ( header -- n )
"content-length" swap at string>number dup [
dup max-post-request get > [
"content-length > max-post-request" throw
] when
] when ;
: parse-post-data ( post-data -- post-data )
[ ] [ raw>> ] [ content-type>> ] tri {
{ "application/x-www-form-urlencoded" [ query>assoc ] }
{ "text/xml" [ string>xml ] }
[ drop ]
} case >>content ;
: read-post-data ( request -- request )
dup header>> content-length [ read >>post-data ] when* ;
: parse-host ( string -- host port )
"." ?tail drop ":" split1
dup [ string>number ] when ;
dup method>> "POST" = [
[ ]
[ "content-length" header string>number read ]
[ "content-type" header ] tri
<post-data> parse-post-data >>post-data
] when ;
: extract-host ( request -- request )
dup [ "host" header parse-host ] keep protocol>> http-port or
[ >>host ] [ >>port ] bi* ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
: parse-post-data ( request -- request )
dup post-data-type>> "application/x-www-form-urlencoded" =
[ dup post-data>> query>assoc >>post-data ] when ;
[ ] [ url>> ] [ "host" header parse-host ] tri
[ >>host ] [ >>port ] bi*
ensure-port
drop ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
@ -349,6 +211,9 @@ SYMBOL: max-post-request
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
: detect-protocol ( request -- request )
dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
: read-request ( -- request )
<request>
read-method
@ -356,58 +221,53 @@ SYMBOL: max-post-request
read-request-version
read-request-header
read-post-data
detect-protocol
extract-host
extract-post-data-type
parse-post-data
extract-cookies ;
: write-method ( request -- request )
dup method>> write bl ;
: (link>string) ( url query -- url' )
[ url-encode ] [ assoc>query ] bi*
dup empty? [ drop ] [ "?" swap 3append ] if ;
: write-url ( request -- )
[ path>> ] [ query>> ] bi (link>string) write ;
: write-request-url ( request -- request )
dup write-url bl ;
dup url>> relative-url present write bl ;
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
: unparse-post-data ( request -- request )
dup post-data>> dup sequence? [ drop ] [
assoc>query >>post-data
"application/x-www-form-urlencoded" >>post-data-type
] if ;
GENERIC: protocol-addr ( request protocol -- addr )
M: object protocol-addr
drop [ host>> ] [ port>> ] bi <inet> ;
M: https protocol-addr
call-next-method <secure> ;
: request-addr ( request -- addr )
dup protocol>> protocol-addr ;
: request-host ( request -- string )
[ host>> ] [ port>> ] bi dup http http-port =
: url-host ( url -- string )
[ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: write-request-header ( request -- request )
dup header>> >hashtable
over host>> [ over request-host "host" pick set-at ] when
over post-data>> [ length "content-length" pick set-at ] when*
over post-data-type>> [ "content-type" pick set-at ] when*
over url>> host>> [ over url>> url-host "host" pick set-at ] when
over post-data>> [
[ raw>> length "content-length" pick set-at ]
[ content-type>> "content-type" pick set-at ]
bi
] when*
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
write-header ;
GENERIC: >post-data ( object -- post-data )
M: post-data >post-data ;
M: string >post-data "application/octet-stream" <post-data> ;
M: byte-array >post-data "application/octet-stream" <post-data> ;
M: xml >post-data xml>string "text/xml" <post-data> ;
M: assoc >post-data assoc>query "application/x-www-form-urlencoded" <post-data> ;
M: f >post-data ;
: unparse-post-data ( request -- request )
[ >post-data ] change-post-data ;
: write-post-data ( request -- request )
dup post-data>> [ write ] when* ;
dup method>> "POST" = [ dup post-data>> raw>> write ] when ;
: write-request ( request -- )
unparse-post-data
@ -419,39 +279,6 @@ M: https protocol-addr
flush
drop ;
: request-with-path ( request path -- request )
[ "/" prepend ] [ "/" ] if*
"?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
: request-with-url ( request url -- request )
":" split1
[ string>protocol >>protocol ]
[
"//" ?head [ "Invalid URL" throw ] unless
"/" split1
[
parse-host [ >>host ] [ >>port ] bi*
dup protocol>> http-port '[ , or ] change-port
]
[ request-with-path ]
bi*
] bi* ;
: request-url ( request -- url )
[
[
dup host>> [
[ protocol>> protocol>string write "://" write ]
[ host>> url-encode write ":" write ]
[ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
tri
] [ drop ] if
]
[ path>> "/" head? [ "/" write ] unless ]
[ write-url ]
tri
] with-string-writer ;
GENERIC: write-response ( response -- )
GENERIC: write-full-response ( request response -- )
@ -490,7 +317,7 @@ body ;
: read-response-header
read-header >>header
extract-cookies
dup "set-cookie" header parse-cookies >>cookies
dup "content-type" header [
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
] when* ;
@ -556,7 +383,7 @@ body ;
: <raw-response> ( -- response )
raw-response new
"1.1" >>version ;
"1.1" >>version ;
M: raw-response write-response ( respose -- )
write-response-version

35
extra/http/mime/mime.factor
View File

@ -1,35 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io assocs kernel sequences math namespaces splitting ;
IN: http.mime
: file-extension ( filename -- extension )
"." split dup length 1 <= [ drop f ] [ peek ] if ;
: mime-type ( filename -- mime-type )
file-extension "mime-types" get at "application/octet-stream" or ;
H{
{ "html" "text/html" }
{ "txt" "text/plain" }
{ "xml" "text/xml" }
{ "css" "text/css" }
{ "gif" "image/gif" }
{ "png" "image/png" }
{ "jpg" "image/jpeg" }
{ "jpeg" "image/jpeg" }
{ "jar" "application/octet-stream" }
{ "zip" "application/octet-stream" }
{ "tgz" "application/octet-stream" }
{ "tar.gz" "application/octet-stream" }
{ "gz" "application/octet-stream" }
{ "pdf" "application/pdf" }
{ "factor" "text/plain" }
{ "cgi" "application/x-cgi-script" }
{ "fhtml" "application/x-factor-server-page" }
} "mime-types" set-global

94
extra/http/server/actions/actions.factor
View File

@ -1,94 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators http.server
validators http hashtables namespaces fry continuations locals
boxes xml.entities html.elements html.components io arrays math ;
IN: http.server.actions
SYMBOL: params
SYMBOL: rest-param
: render-validation-messages ( -- )
validation-messages get
dup empty? [ drop ] [
<ul "errors" =class ul>
[ <li> message>> escape-string write </li> ] each
</ul>
] if ;
TUPLE: action rest-param init display validate submit ;
: new-action ( class -- action )
new
[ ] >>init
[ <400> ] >>display
[ ] >>validate
[ <400> ] >>submit ;
: <action> ( -- action )
action new-action ;
: handle-get ( action -- response )
blank-values
[ init>> call ]
[ display>> call ]
bi ;
: validation-failed ( -- * )
request get method>> "POST" =
[ action get display>> call ] [ <400> ] if exit-with ;
: handle-post ( action -- response )
init-validation
blank-values
[ validate>> call ]
[ submit>> call ] bi ;
: handle-rest-param ( arg -- )
dup length 1 > action get rest-param>> not or
[ <404> exit-with ] [
action get rest-param>> associate rest-param set
] if ;
M: action call-responder* ( path action -- response )
dup action set
'[
, dup empty? [ drop ] [ handle-rest-param ] if
init-validation
,
request get
[ request-params rest-param get assoc-union params set ]
[ method>> ] bi
{
{ "GET" [ handle-get ] }
{ "HEAD" [ handle-get ] }
{ "POST" [ handle-post ] }
} case
] with-exit-continuation ;
: param ( name -- value )
params get at ;
: check-validation ( -- )
validation-failed? [ validation-failed ] when ;
: validate-params ( validators -- )
params get swap validate-values from-assoc
check-validation ;
: validate-integer-id ( -- )
{ { "id" [ v-number ] } } validate-params ;
TUPLE: page-action < action template ;
: <page-action> ( -- page )
page-action new-action
dup '[ , template>> <html-content> ] >>display ;
TUPLE: feed-action < action feed ;
: <feed-action> ( -- feed )
feed-action new
dup '[ , feed>> call <feed-content> ] >>display ;

21
extra/http/server/cgi/cgi.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files io.streams.duplex
combinators arrays io.launcher io http.server.static http.server
http accessors sequences strings math.parser fry ;
http accessors sequences strings math.parser fry urls ;
IN: http.server.cgi
: post? request get method>> "POST" = ;
@ -14,13 +14,12 @@ IN: http.server.cgi
"HTTP/" request get version>> append "SERVER_PROTOCOL" set
"Factor" "SERVER_SOFTWARE" set
dup "PATH_TRANSLATED" set
"SCRIPT_FILENAME" set
[ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi
request get path>> "SCRIPT_NAME" set
request get url>> path>> "SCRIPT_NAME" set
request get host>> "SERVER_NAME" set
request get port>> number>string "SERVER_PORT" set
request get url>> host>> "SERVER_NAME" set
request get url>> port>> number>string "SERVER_PORT" set
"" "PATH_INFO" set
"" "REMOTE_HOST" set
"" "REMOTE_ADDR" set
@ -29,15 +28,17 @@ IN: http.server.cgi
"" "REMOTE_IDENT" set
request get method>> "REQUEST_METHOD" set
request get query>> assoc>query "QUERY_STRING" set
request get url>> query>> assoc>query "QUERY_STRING" set
request get "cookie" header "HTTP_COOKIE" set
request get "user-agent" header "HTTP_USER_AGENT" set
request get "accept" header "HTTP_ACCEPT" set
post? [
request get post-data-type>> "CONTENT_TYPE" set
request get post-data>> length number>string "CONTENT_LENGTH" set
request get post-data>> raw>>
[ "CONTENT_TYPE" set ]
[ length number>string "CONTENT_LENGTH" set ]
bi
] when
] H{ } make-assoc ;
@ -52,7 +53,7 @@ IN: http.server.cgi
"CGI output follows" >>message
swap '[
, output-stream get swap <cgi-process> <process-stream> [
post? [ request get post-data>> write flush ] when
post? [ request get post-data>> raw>> write flush ] when
input-stream get swap (stream-copy)
] with-stream
] >>body ;

4
extra/http/server/db/db-tests.factor
View File

@ -1,4 +0,0 @@
IN: http.server.db.tests
USING: tools.test http.server.db ;
\ <db-persistence> must-infer

97
extra/http/server/dispatchers/dispatchers-tests.factor Normal file
View File

@ -0,0 +1,97 @@
USING: http.server http.server.dispatchers http.server.responses
tools.test kernel namespaces accessors io http math sequences
assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
\ find-responder must-infer
\ http-error. must-infer
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder
M: mock-responder call-responder*
nip
path>> on
[ ] "text/plain" <content> ;
: check-dispatch ( tag path -- ? )
V{ } clone responder-nesting set
over off
split-path
main-responder get call-responder
write-response get ;
[
<dispatcher>
"foo" <mock-responder> "foo" add-responder
"bar" <mock-responder> "bar" add-responder
<dispatcher>
"123" <mock-responder> "123" add-responder
"default" <mock-responder> >>default
"baz" add-responder
main-responder set
[ "foo" ] [
{ "foo" } main-responder get find-responder path>> nip
] unit-test
[ "bar" ] [
{ "bar" } main-responder get find-responder path>> nip
] unit-test
[ t ] [ "foo" "foo" check-dispatch ] unit-test
[ f ] [ "foo" "bar" check-dispatch ] unit-test
[ t ] [ "bar" "bar" check-dispatch ] unit-test
[ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
[ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
[ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
[ t ] [ "123" "baz/123" check-dispatch ] unit-test
[ t ] [ "123" "baz///123" check-dispatch ] unit-test
] with-scope
[
<dispatcher>
"default" <mock-responder> >>default
main-responder set
[ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
] with-scope
! Make sure path for default responder isn't chopped
TUPLE: path-check-responder ;
C: <path-check-responder> path-check-responder
M: path-check-responder call-responder*
drop
>array "text/plain" <content> ;
[ { "c" } ] [
V{ } clone responder-nesting set
{ "b" "c" }
<dispatcher>
<dispatcher>
<path-check-responder> >>default
"b" add-responder
call-responder
body>>
] unit-test
! Test that "" dispatcher works with default>>
[ ] [
<dispatcher>
"" <mock-responder> "" add-responder
"bar" <mock-responder> "bar" add-responder
"baz" <mock-responder> >>default
main-responder set
[ t ] [ "" "" check-dispatch ] unit-test
[ f ] [ "" "quux" check-dispatch ] unit-test
[ t ] [ "baz" "quux" check-dispatch ] unit-test
[ f ] [ "foo" "bar" check-dispatch ] unit-test
[ t ] [ "bar" "bar" check-dispatch ] unit-test
[ t ] [ "baz" "xxx" check-dispatch ] unit-test
] unit-test

50
extra/http/server/dispatchers/dispatchers.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences assocs accessors splitting
unicode.case http http.server http.server.responses ;
IN: http.server.dispatchers
TUPLE: dispatcher default responders ;
: new-dispatcher ( class -- dispatcher )
new
<404> <trivial-responder> >>default
H{ } clone >>responders ; inline
: <dispatcher> ( -- dispatcher )
dispatcher new-dispatcher ;
: find-responder ( path dispatcher -- path responder )
over empty? [
"" over responders>> at*
[ nip ] [ drop default>> ] if
] [
over first over responders>> at*
[ [ drop rest-slice ] dip ] [ drop default>> ] if
] if ;
M: dispatcher call-responder* ( path dispatcher -- response )
find-responder call-responder ;
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
vhost-dispatcher new-dispatcher ;
: canonical-host ( host -- host' )
>lower "www." ?head drop "." ?tail drop ;
: find-vhost ( dispatcher -- responder )
request get url>> host>> canonical-host over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
find-vhost call-responder ;
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder drop ]
[ drop "" add-responder drop ]
[ 2drop ] 3tri ;

9
extra/http/server/filters/filters.factor Normal file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.server accessors ;
IN: http.server.filters
TUPLE: filter-responder responder ;
M: filter-responder call-responder*
responder>> call-responder ;

64
extra/http/server/flows/flows.factor
View File

@ -1,64 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces sequences arrays kernel
assocs assocs.lib hashtables math.parser
html.elements http http.server http.server.sessions ;
IN: http.server.flows
TUPLE: flows < filter-responder ;
C: <flows> flows
: begin-flow* ( -- id )
request get
[ path>> ] [ request-params ] [ method>> ] tri 3array
flows sget set-at-unique
session-changed ;
: end-flow-post ( path params -- response )
request [
clone
"POST" >>method
swap >>post-data
swap >>path
] change
request get path>> split-path
flows get responder>> call-responder ;
: end-flow* ( default id -- response )
flows sget at
[ first3 "POST" = [ end-flow-post ] [ <standard-redirect> ] if ]
[ f <standard-redirect> ] ?if ;
SYMBOL: flow-id
: flow-id-key "factorflowid" ;
: begin-flow ( -- )
begin-flow* flow-id set ;
: end-flow ( default -- response )
flow-id get end-flow* ;
: add-flow-id ( query -- query' )
flow-id get [ flow-id-key associate assoc-union ] when* ;
: flow-form-field ( -- )
flow-id get [
<input
"hidden" =type
flow-id-key =name
=value
input/>
] when* ;
M: flows call-responder*
dup flows set
[ add-flow-id ] add-link-hook
[ flow-form-field ] add-form-hook
flow-id-key request get request-params at flow-id set
call-next-method ;
M: flows init-session*
H{ } clone flows sset
call-next-method ;

48
extra/http/server/redirection/redirection-tests.factor Normal file
View File

@ -0,0 +1,48 @@
IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test present ;
\ relative-to-request must-infer
[
<request>
<url>
"http" >>protocol
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query
>>url
request set
[ "http://www.apple.com:80/xxx/bar" ] [
<url> relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/baz" ] [
<url> "baz" >>path relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [
<url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.apple.com:80/xxx/bar?c=d" ] [
<url> { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.apple.com:80/flip" ] [
<url> "/flip" >>path relative-to-request present
] unit-test
[ "http://www.apple.com:80/flip?c=d" ] [
<url> "/flip" >>path { { "c" "d" } } >>query relative-to-request present
] unit-test
[ "http://www.jedit.org:80/" ] [
"http://www.jedit.org" >url relative-to-request present
] unit-test
[ "http://www.jedit.org:80/?a=b" ] [
"http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present
] unit-test
] with-scope

24
extra/http/server/redirection/redirection.factor Normal file
View File

@ -0,0 +1,24 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces
logging urls http http.server http.server.responses ;
IN: http.server.redirection
: relative-to-request ( url -- url' )
request get url>>
clone
f >>query
swap derive-url ensure-port ;
: <custom-redirect> ( url code message -- response )
<trivial-response>
swap dup url? [ relative-to-request ] when
"location" set-header ;
\ <custom-redirect> DEBUG add-input-logging
: <permanent-redirect> ( url -- response )
301 "Moved Permanently" <custom-redirect> ;
: <temporary-redirect> ( url -- response )
307 "Temporary Redirect" <custom-redirect> ;

37
extra/http/server/responses/responses.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html.elements math.parser http accessors kernel
io io.streams.string ;
IN: http.server.responses
: <content> ( body content-type -- response )
<response>
200 >>code
"Document follows" >>message
swap >>content-type
swap >>body ;
: trivial-response-body ( code message -- )
<html>
<body>
<h1> [ number>string write bl ] [ write ] bi* </h1>
</body>
</html> ;
: <trivial-response> ( code message -- response )
2dup [ trivial-response-body ] with-string-writer
"text/html" <content>
swap >>message
swap >>code ;
: <304> ( -- response )
304 "Not modified" <trivial-response> ;
: <403> ( -- response )
403 "Forbidden" <trivial-response> ;
: <400> ( -- response )
400 "Bad request" <trivial-response> ;
: <404> ( -- response )
404 "Not found" <trivial-response> ;

142
extra/http/server/server-tests.factor Executable file → Normal file
View File

@ -1,142 +1,4 @@
USING: http.server tools.test kernel namespaces accessors
io http math sequences assocs arrays classes words ;
USING: http http.server math sequences continuations tools.test ;
IN: http.server.tests
\ find-responder must-infer
[
<request>
http >>protocol
"www.apple.com" >>host
"/xxx/bar" >>path
{ { "a" "b" } } >>query
request set
[ ] link-hook set
[ "http://www.apple.com:80/xxx/bar?a=b" ] [ f f derive-url ] unit-test
[ "http://www.apple.com:80/xxx/baz?a=b" ] [ "baz" f derive-url ] unit-test
[ "http://www.apple.com:80/xxx/baz?c=d" ] [ "baz" { { "c" "d" } } derive-url ] unit-test
[ "http://www.apple.com:80/xxx/bar?c=d" ] [ f { { "c" "d" } } derive-url ] unit-test
[ "http://www.apple.com:80/flip?a=b" ] [ "/flip" f derive-url ] unit-test
[ "http://www.apple.com:80/flip?c=d" ] [ "/flip" { { "c" "d" } } derive-url ] unit-test
[ "http://www.jedit.org" ] [ "http://www.jedit.org" f derive-url ] unit-test
[ "http://www.jedit.org?a=b" ] [ "http://www.jedit.org" { { "a" "b" } } derive-url ] unit-test
] with-scope
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder
M: mock-responder call-responder*
nip
path>> on
[ ] <text-content> ;
: check-dispatch ( tag path -- ? )
H{ } clone base-paths set
over off
split-path
main-responder get call-responder
write-response get ;
[
<dispatcher>
"foo" <mock-responder> "foo" add-responder
"bar" <mock-responder> "bar" add-responder
<dispatcher>
"123" <mock-responder> "123" add-responder
"default" <mock-responder> >>default
"baz" add-responder
main-responder set
[ "foo" ] [
{ "foo" } main-responder get find-responder path>> nip
] unit-test
[ "bar" ] [
{ "bar" } main-responder get find-responder path>> nip
] unit-test
[ t ] [ "foo" "foo" check-dispatch ] unit-test
[ f ] [ "foo" "bar" check-dispatch ] unit-test
[ t ] [ "bar" "bar" check-dispatch ] unit-test
[ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
[ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
[ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
[ t ] [ "123" "baz/123" check-dispatch ] unit-test
[ t ] [ "123" "baz///123" check-dispatch ] unit-test
] with-scope
[
<dispatcher>
"default" <mock-responder> >>default
main-responder set
[ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
] with-scope
! Make sure path for default responder isn't chopped
TUPLE: path-check-responder ;
C: <path-check-responder> path-check-responder
M: path-check-responder call-responder*
drop
>array <text-content> ;
[ { "c" } ] [
H{ } clone base-paths set
{ "b" "c" }
<dispatcher>
<dispatcher>
<path-check-responder> >>default
"b" add-responder
call-responder
body>>
] unit-test
! Test that "" dispatcher works with default>>
[ ] [
<dispatcher>
"" <mock-responder> "" add-responder
"bar" <mock-responder> "bar" add-responder
"baz" <mock-responder> >>default
main-responder set
[ t ] [ "" "" check-dispatch ] unit-test
[ f ] [ "" "quux" check-dispatch ] unit-test
[ t ] [ "baz" "quux" check-dispatch ] unit-test
[ f ] [ "foo" "bar" check-dispatch ] unit-test
[ t ] [ "bar" "bar" check-dispatch ] unit-test
[ t ] [ "baz" "xxx" check-dispatch ] unit-test
] unit-test
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
TUPLE: base-path-check-responder ;
C: <base-path-check-responder> base-path-check-responder
M: base-path-check-responder call-responder*
2drop
"$funny-dispatcher" resolve-base-path
<text-content> ;
[ ] [
<dispatcher>
<dispatcher>
<funny-dispatcher>
<base-path-check-responder> "c" add-responder
"b" add-responder
"a" add-responder
main-responder set
] unit-test
[ "/a/b/" ] [
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test

269
extra/http/server/server.factor
View File

@ -1,276 +1,74 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
threads sequences prettyprint io.server logging calendar http
html.streams html.elements accessors math.parser
combinators.lib tools.vocabs debugger continuations random
combinators destructors io.encodings.8-bit fry classes words
math rss json.writer ;
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader http http.server.responses logging calendar
destructors html.elements html.streams io.server
io.encodings.8-bit io.timeouts io assocs debugger continuations
fry tools.vocabs math ;
IN: http.server
SYMBOL: responder-nesting
SYMBOL: main-responder
SYMBOL: development-mode
! path is a sequence of path component strings
GENERIC: call-responder* ( path responder -- response )
: request-params ( request -- assoc )
dup method>> {
{ "GET" [ query>> ] }
{ "HEAD" [ query>> ] }
{ "POST" [ post-data>> ] }
} case ;
: <content> ( body content-type -- response )
<response>
200 >>code
"Document follows" >>message
swap >>content-type
swap >>body ;
: <text-content> ( body -- response )
"text/plain" <content> ;
: <html-content> ( body -- response )
"text/html" <content> ;
: <xml-content> ( body -- response )
"text/xml" <content> ;
: <feed-content> ( feed -- response )
'[ , feed>xml ] "text/xml" <content> ;
: <json-content> ( obj -- response )
'[ , >json ] "application/json" <content> ;
TUPLE: trivial-responder response ;
C: <trivial-responder> trivial-responder
M: trivial-responder call-responder* nip response>> call ;
M: trivial-responder call-responder* nip response>> clone ;
: trivial-response-body ( code message -- )
<html>
<body>
<h1> [ number>string write bl ] [ write ] bi* </h1>
</body>
</html> ;
: <trivial-response> ( code message -- response )
2dup '[ , , trivial-response-body ] <html-content>
swap >>message
swap >>code ;
: <400> ( -- response )
400 "Bad request" <trivial-response> ;
: <404> ( -- response )
404 "Not Found" <trivial-response> ;
SYMBOL: 404-responder
[ <404> ] <trivial-responder> 404-responder set-global
SYMBOL: base-paths
main-responder global [ <404> <trivial-responder> or ] change-at
: invert-slice ( slice -- slice' )
dup slice? [
[ seq>> ] [ from>> ] bi head-slice
] [
drop { }
] if ;
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
: add-base-path ( path dispatcher -- )
[ invert-slice ] [ class word-name ] bi*
base-paths get set-at ;
: add-responder-nesting ( path responder -- )
[ invert-slice ] dip 2array responder-nesting get push ;
: call-responder ( path responder -- response )
[ add-base-path ] [ call-responder* ] 2bi ;
SYMBOL: link-hook
: add-link-hook ( quot -- )
link-hook [ compose ] change ; inline
: modify-query ( query -- query )
link-hook get call ;
: base-path ( string -- path )
dup base-paths get at
[ ] [ "No such responder: " swap append throw ] ?if ;
: resolve-base-path ( string -- string' )
"$" ?head [
[
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
: link>string ( url query -- url' )
[ resolve-base-path ] [ modify-query ] bi* (link>string) ;
: write-link ( url query -- )
link>string write ;
SYMBOL: form-hook
: add-form-hook ( quot -- )
form-hook [ compose ] change ;
: hidden-form-field ( -- )
form-hook get call ;
: absolute-redirect ( to query -- url )
#! Same host.
request get clone
swap [ >>query ] when*
swap url-encode >>path
[ modify-query ] change-query
request-url ;
: replace-last-component ( path with -- path' )
[ "/" last-split1 drop "/" ] dip 3append ;
: relative-redirect ( to query -- url )
request get clone
swap [ >>query ] when*
swap [ '[ , replace-last-component ] change-path ] when*
[ modify-query ] change-query
request-url ;
: derive-url ( to query -- url )
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
{ [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
[ relative-redirect ]
} cond ;
: <redirect> ( to query code message -- response )
<trivial-response> -rot derive-url "location" set-header ;
\ <redirect> DEBUG add-input-logging
: <permanent-redirect> ( to query -- response )
301 "Moved Permanently" <redirect> ;
: <temporary-redirect> ( to query -- response )
307 "Temporary Redirect" <redirect> ;
: <standard-redirect> ( to query -- response )
request get method>> "POST" =
[ <permanent-redirect> ] [ <temporary-redirect> ] if ;
TUPLE: dispatcher default responders ;
: new-dispatcher ( class -- dispatcher )
new
404-responder get >>default
H{ } clone >>responders ; inline
: <dispatcher> ( -- dispatcher )
dispatcher new-dispatcher ;
: find-responder ( path dispatcher -- path responder )
over empty? [
"" over responders>> at*
[ nip ] [ drop default>> ] if
] [
over first over responders>> at*
[ [ drop rest-slice ] dip ] [ drop default>> ] if
] if ;
M: dispatcher call-responder* ( path dispatcher -- response )
find-responder call-responder ;
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
404-responder get H{ } clone vhost-dispatcher boa ;
: find-vhost ( dispatcher -- responder )
request get host>> over responders>> at*
[ nip ] [ drop default>> ] if ;
M: vhost-dispatcher call-responder* ( path dispatcher -- response )
find-vhost call-responder ;
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder drop ]
[ drop "" add-responder drop ]
[ 2drop ] 3tri ;
TUPLE: filter-responder responder ;
M: filter-responder call-responder*
responder>> call-responder ;
SYMBOL: main-responder
main-responder global
[ drop 404-responder get-global ] cache
drop
SYMBOL: development-mode
[ add-responder-nesting ] [ call-responder* ] 2bi ;
: http-error. ( error -- )
"Internal server error" [
development-mode get [
[ print-error nl :c ] with-html-stream
] [
500 "Internal server error"
trivial-response-body
] if
[ print-error nl :c ] with-html-stream
] simple-page ;
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
swap '[ , http-error. ] >>body ;
swap development-mode get [ '[ , http-error. ] >>body ] [ drop ] if ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" =
[ drop ] [
'[
, write-response-body
] [
http-error.
] recover
] if ;
[ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ;
LOG: httpd-hit NOTICE
: log-request ( request -- )
{ method>> host>> path>> } map-exec-with httpd-hit ;
SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: with-exit-continuation ( quot -- )
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
[ method>> ] [ url>> [ host>> ] [ path>> ] bi ] bi 3array httpd-hit ;
: split-path ( string -- path )
"/" split harvest ;
: init-request ( -- )
H{ } clone base-paths set
[ ] link-hook set
[ ] form-hook set ;
: init-request ( request -- )
request set
V{ } clone responder-nesting set ;
: dispatch-request ( request -- response )
url>> path>> split-path main-responder get call-responder ;
: do-request ( request -- response )
[
init-request
[ request set ]
'[
,
[ init-request ]
[ log-request ]
[ path>> split-path main-responder get call-responder ] tri
[ <404> ] unless*
] [
[ \ do-request log-error ]
[ <500> ]
bi
] recover ;
[ dispatch-request ] tri
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
: ?refresh-all ( -- )
development-mode get-global
@ -287,8 +85,7 @@ SYMBOL: exit-continuation
: httpd ( port -- )
dup integer? [ internet-server ] when
"http.server" latin1
[ handle-client ] with-server ;
"http.server" latin1 [ handle-client ] with-server ;
: httpd-main ( -- )
8888 httpd ;

25
extra/http/server/static/static.factor
View File

@ -1,10 +1,15 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar io io.files kernel math math.order
math.parser http http.server namespaces parser sequences strings
assocs hashtables debugger http.mime sorting html.elements
html.templates.fhtml logging calendar.format accessors
io.encodings.binary fry xml.entities destructors ;
math.parser namespaces parser sequences strings
assocs hashtables debugger mime-types sorting logging
calendar.format accessors
io.encodings.binary fry xml.entities destructors urls
html.elements html.templates.fhtml
http
http.server
http.server.responses
http.server.redirection ;
IN: http.server.static
! special maps mime types to quots with effect ( path -- )
@ -17,12 +22,6 @@ TUPLE: file-responder root hook special allow-listings ;
2drop t
] if ;
: <304> ( -- response )
304 "Not modified" <trivial-response> ;
: <403> ( -- response )
403 "Forbidden" <trivial-response> ;
: <file-responder> ( root hook -- responder )
file-responder new
swap >>hook
@ -71,7 +70,7 @@ TUPLE: file-responder root hook special allow-listings ;
: list-directory ( directory -- response )
file-responder get allow-listings>> [
'[ , directory. ] <html-content>
'[ , directory. ] "text/html" <content>
] [
drop <403>
] if ;
@ -85,7 +84,7 @@ TUPLE: file-responder root hook special allow-listings ;
find-index [ serve-file ] [ list-directory ] ?if
] [
drop
request get path>> "/" append f <standard-redirect>
request get url>> clone [ "/" append ] change-path <permanent-redirect>
] if ;
: serve-object ( filename -- response )
@ -101,6 +100,6 @@ M: file-responder call-responder* ( path responder -- response )
! file responder integration
: enable-fhtml ( responder -- responder )
[ <fhtml> <html-content> ]
[ <fhtml> "text/html" <content> ]
"application/x-factor-server-page"
pick special>> set-at ;

20
extra/io/pools/pools.factor
View File

@ -1,13 +1,22 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays namespaces sequences continuations
destructors io.sockets ;
destructors io.sockets alien alien.syntax ;
IN: io.pools
TUPLE: pool connections disposed ;
TUPLE: pool connections disposed expired ;
: check-pool ( pool -- )
dup check-disposed
dup expired>> expired? [
ALIEN: 31337 >>expired
connections>> [ delete-all ] [ dispose-each ] bi
] [ drop ] if ;
: <pool> ( class -- pool )
new V{ } clone >>connections ; inline
new V{ } clone
>>connections
dup check-pool ; inline
M: pool dispose* connections>> dispose-each ;
@ -17,15 +26,14 @@ M: pool dispose* connections>> dispose-each ;
TUPLE: return-connection conn pool ;
: return-connection ( conn pool -- )
dup check-disposed connections>> push ;
dup check-pool connections>> push ;
GENERIC: make-connection ( pool -- conn )
: new-connection ( pool -- )
[ make-connection ] keep return-connection ;
dup check-pool [ make-connection ] keep return-connection ;
: acquire-connection ( pool -- conn )
dup check-disposed
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
connections>> pop ;

15
extra/io/unix/launcher/parser/parser.factor
View File

@ -1,7 +1,6 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: peg peg.parsers kernel sequences strings words
memoize ;
USING: peg peg.parsers kernel sequences strings words ;
IN: io.unix.launcher.parser
! Our command line parser. Supported syntax:
@ -9,20 +8,20 @@ IN: io.unix.launcher.parser
! foo\ bar -- escaping the space
! 'foo bar' -- quotation
! "foo bar" -- quotation
MEMO: 'escaped-char' ( -- parser )
"\\" token [ drop t ] satisfy 2seq [ second ] action ;
: 'escaped-char' ( -- parser )
"\\" token any-char 2seq [ second ] action ;
MEMO: 'quoted-char' ( delimiter -- parser' )
: 'quoted-char' ( delimiter -- parser' )
'escaped-char'
swap [ member? not ] curry satisfy
2choice ; inline
MEMO: 'quoted' ( delimiter -- parser )
: 'quoted' ( delimiter -- parser )
dup 'quoted-char' repeat0 swap dup surrounded-by ;
MEMO: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
MEMO: 'argument' ( -- parser )
: 'argument' ( -- parser )
"\"" 'quoted'
"'" 'quoted'
'unquoted' 3choice

33
extra/jamshred/gl/gl.factor
View File

@ -1,8 +1,6 @@
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types colors jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.vectors opengl
opengl.gl opengl.glu sequences ;
USING: accessors alien.c-types colors jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences ;
IN: jamshred.gl
: min-vertices 6 ; inline
@ -14,6 +12,35 @@ IN: jamshred.gl
: n-segments-ahead ( -- n ) 60 ; inline
: n-segments-behind ( -- n ) 40 ; inline
: wall-drawing-offset ( -- n )
#! so that we can't see through the wall, we draw it a bit further away
0.15 ;
: wall-drawing-radius ( segment -- r )
radius>> wall-drawing-offset + ;
: wall-up ( segment -- v )
[ wall-drawing-radius ] [ up>> ] bi n*v ;
: wall-left ( segment -- v )
[ wall-drawing-radius ] [ left>> ] bi n*v ;
: segment-vertex ( theta segment -- vertex )
[
[ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
] [
location>> v+
] bi ;
: segment-vertex-normal ( vertex segment -- normal )
location>> swap v- normalize ;
: segment-vertex-and-normal ( segment theta -- vertex normal )
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
: equally-spaced-radians ( n -- seq )
#! return a sequence of n numbers between 0 and 2pi
dup [ / pi 2 * * ] curry map ;
: draw-segment-vertex ( segment theta -- )
over segment-color gl-color segment-vertex-and-normal
gl-normal gl-vertex ;

4
extra/jamshred/jamshred.factor
View File

@ -88,7 +88,7 @@ jamshred-gadget H{
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
} set-gestures
: jamshred-window ( -- )
[ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
: jamshred-window ( -- jamshred )
[ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
MAIN: jamshred-window

11
extra/jamshred/oint/oint.factor
View File

@ -39,8 +39,11 @@ C: <oint> oint
: random-turn ( oint theta -- )
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
: location+ ( v oint -- )
[ location>> v+ ] [ (>>location) ] bi ;
: go-forward ( distance oint -- )
[ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
[ forward>> n*v ] [ location+ ] bi ;
: distance-vector ( oint oint -- vector )
[ location>> ] bi@ swap v- ;
@ -62,3 +65,9 @@ C: <oint> oint
:: reflect ( v n -- v' )
#! bounce v on a surface with normal n
v v n v. n n v. / 2 * n n*v v- ;
: half-way ( p1 p2 -- p3 )
over v- 2 v/n v+ ;
: half-way-between-oints ( o1 o2 -- p )
[ location>> ] bi@ half-way ;

104
extra/jamshred/player/player.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007 Alex Chapman
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
USING: accessors colors combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices shuffle sequences system ;
USE: tools.walker
IN: jamshred.player
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
@ -30,6 +31,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
[ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
[ (>>nearest-segment) ] tri ;
: update-time ( player -- seconds-passed )
millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
: moved ( player -- ) millis swap (>>last-move) ;
: speed-range ( -- range )
@ -41,38 +45,82 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
: multiply-player-speed ( n player -- )
[ * speed-range clamp-to-range ] change-speed drop ;
: distance-to-move ( player -- distance )
[ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
[ (>>last-move) ] tri ;
: distance-to-move ( seconds-passed player -- distance )
speed>> * ;
DEFER: (move-player)
: bounce ( d-left player -- d-left' player )
{
[ dup nearest-segment>> bounce-off-wall ]
[ sounds>> bang ]
[ 3/4 swap multiply-player-speed ]
[ ]
} cleave ;
: ?bounce ( distance-remaining player -- )
:: (distance) ( heading player -- current next location heading )
player nearest-segment>>
player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
player location>> heading ;
: distance-to-heading-segment ( heading player -- distance )
(distance) distance-to-next-segment ;
: distance-to-heading-segment-area ( heading player -- distance )
(distance) distance-to-next-segment-area ;
: distance-to-collision ( player -- distance )
dup nearest-segment>> (distance-to-collision) ;
: from ( player -- radius distance-from-centre )
[ nearest-segment>> dup radius>> swap ] [ location>> ] bi
distance-from-centre ;
: distance-from-wall ( player -- distance ) from - ;
: fraction-from-centre ( player -- fraction ) from swap / ;
: fraction-from-wall ( player -- fraction )
fraction-from-centre 1 swap - ;
: update-nearest-segment2 ( heading player -- )
2dup distance-to-heading-segment-area 0 <= [
[ tunnel>> ] [ nearest-segment>> rot heading-segment ]
[ (>>nearest-segment) ] tri
] [
2drop
] if ;
:: move-player-on-heading ( d-left player distance heading -- d-left' player )
[let* | d-to-move [ d-left distance min ]
move-v [ d-to-move heading n*v ] |
move-v player location+
heading player update-nearest-segment2
d-left d-to-move - player ] ;
: move-toward-wall ( d-left player d-to-wall -- d-left' player )
over [ forward>> ] keep distance-to-heading-segment-area min
over forward>> move-player-on-heading ;
: ?move-player-freely ( d-left player -- d-left' player )
over 0 > [
{
[ dup nearest-segment>> bounce ]
[ sounds>> bang ]
[ 3/4 swap multiply-player-speed ]
[ (move-player) ]
} cleave
] [
2drop
] if ;
dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
move-toward-wall ?move-player-freely
] [ drop ] if
] when ;
: move-player-distance ( distance-remaining player distance -- distance-remaining player )
pick min tuck over go-forward [ - ] dip ;
: drag-heading ( player -- heading )
[ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
: (move-player) ( distance-remaining player -- )
over 0 <= [
2drop
] [
dup dup nearest-segment>> distance-to-collision
move-player-distance ?bounce
] if ;
: drag-player ( d-left player -- d-left' player )
dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
[ drag-heading move-player-on-heading ] bi ;
: (move-player) ( d-left player -- d-left' player )
?move-player-freely over 0 > [
! bounce
drag-player
(move-player)
] when ;
: move-player ( player -- )
[ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
[ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
: update-player ( player -- )
dup move-player nearest-segment>>
white swap set-segment-color ;
[ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;

2
extra/jamshred/tunnel/tunnel-tests.factor
View File

@ -42,4 +42,4 @@ IN: jamshred.tunnel.tests
[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
[ { 0 1 0 } ]
[ simple-collision-up collision-vector 0 bounce-offset 0 3array v+ ] unit-test
[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test

94
extra/jamshred/tunnel/tunnel.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2007 Alex Chapman
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
USE: tools.walker
IN: jamshred.tunnel
: n-segments ( -- n ) 5000 ; inline
@ -8,21 +9,6 @@ IN: jamshred.tunnel
TUPLE: segment < oint number color radius ;
C: <segment> segment
: segment-vertex ( theta segment -- vertex )
tuck 2dup up>> swap sin v*n
>r left>> swap cos v*n r> v+
swap location>> v+ ;
: segment-vertex-normal ( vertex segment -- normal )
location>> swap v- normalize ;
: segment-vertex-and-normal ( segment theta -- vertex normal )
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
: equally-spaced-radians ( n -- seq )
#! return a sequence of n numbers between 0 and 2pi
dup [ / pi 2 * * ] curry map ;
: segment-number++ ( segment -- )
[ number>> 1+ ] keep (>>number) ;
@ -40,9 +26,7 @@ C: <segment> segment
: (random-segments) ( segments n -- segments )
dup 0 > [
>r dup peek random-segment over push r> 1- (random-segments)
] [
drop
] if ;
] [ drop ] if ;
: default-segment-radius ( -- r ) 1 ;
@ -66,7 +50,7 @@ C: <segment> segment
: <straight-tunnel> ( -- segments )
n-segments simple-segments ;
: sub-tunnel ( from to sements -- segments )
: sub-tunnel ( from to segments -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
[ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
@ -97,6 +81,32 @@ C: <segment> segment
[ nearest-segment-forward ] 3keep
nearest-segment-backward r> nearer-segment ;
: get-segment ( segments n -- segment )
over sequence-index-range clamp-to-range swap nth ;
: next-segment ( segments current-segment -- segment )
number>> 1+ get-segment ;
: previous-segment ( segments current-segment -- segment )
number>> 1- get-segment ;
: heading-segment ( segments current-segment heading -- segment )
#! the next segment on the given heading
over forward>> v. 0 <=> {
{ +gt+ [ next-segment ] }
{ +lt+ [ previous-segment ] }
{ +eq+ [ nip ] } ! current segment
} case ;
:: distance-to-next-segment ( current next location heading -- distance )
[let | cf [ current forward>> ] |
cf next location>> v. cf location v. - cf heading v. / ] ;
:: distance-to-next-segment-area ( current next location heading -- distance )
[let | cf [ current forward>> ]
h [ next current half-way-between-oints ] |
cf h v. cf location v. - cf heading v. / ] ;
: vector-to-centre ( seg loc -- v )
over location>> swap v- swap forward>> proj-perp ;
@ -106,19 +116,25 @@ C: <segment> segment
: wall-normal ( seg oint -- n )
location>> vector-to-centre normalize ;
: from ( seg loc -- radius d-f-c )
dupd location>> distance-from-centre [ radius>> ] dip ;
: distant ( -- n ) 1000 ;
: distance-from-wall ( seg loc -- distance ) from - ;
: fraction-from-centre ( seg loc -- fraction ) from / ;
: fraction-from-wall ( seg loc -- fraction )
fraction-from-centre 1 swap - ;
: max-real ( a b -- c )
#! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
dup real? [
over real? [ max ] [ nip ] if
] [
drop dup real? [ drop distant ] unless
] if ;
:: collision-coefficient ( v w r -- c )
[let* | a [ v dup v. ]
b [ v w v. 2 * ]
c [ w dup v. r sq - ] |
c b a quadratic max ] ;
v norm 0 = [
distant
] [
[let* | a [ v dup v. ]
b [ v w v. 2 * ]
c [ w dup v. r sq - ] |
c b a quadratic max-real ]
] if ;
: sideways-heading ( oint segment -- v )
[ forward>> ] bi@ proj-perp ;
@ -126,18 +142,12 @@ C: <segment> segment
: sideways-relative-location ( oint segment -- loc )
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
: bounce-offset 0.1 ; inline
: bounce-radius ( segment -- r )
radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?)
: (distance-to-collision) ( oint segment -- distance )
[ sideways-heading ] [ sideways-relative-location ]
[ nip radius>> ] 2tri collision-coefficient ;
: collision-vector ( oint segment -- v )
[ sideways-heading ] [ sideways-relative-location ]
[ bounce-radius ] 2tri
swap [ collision-coefficient ] dip forward>> n*v ;
: distance-to-collision ( oint segment -- distance )
collision-vector norm ;
dupd (distance-to-collision) swap forward>> n*v ;
: bounce-forward ( segment oint -- )
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
@ -151,6 +161,6 @@ C: <segment> segment
#! must be done after forward and left!
nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
: bounce ( oint segment -- )
: bounce-off-wall ( oint segment -- )
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;

2
extra/json/reader/reader.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel parser-combinators namespaces sequences promises strings
assocs math math.parser math.vectors math.functions math.order
lazy-lists hashtables ascii ;
lists hashtables ascii ;
IN: json.reader
! Grammar for JSON from RFC 4627

445
extra/lazy-lists/lazy-lists.factor
View File

@ -1,445 +0,0 @@
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
! Updated by Matthew Willis, July 2006
! Updated by Chris Double, September 2006
!
USING: kernel sequences math vectors arrays namespaces
quotations promises combinators io ;
IN: lazy-lists
! Lazy List Protocol
MIXIN: list
GENERIC: car ( cons -- car )
GENERIC: cdr ( cons -- cdr )
GENERIC: nil? ( cons -- ? )
M: promise car ( promise -- car )
force car ;
M: promise cdr ( promise -- cdr )
force cdr ;
M: promise nil? ( cons -- bool )
force nil? ;
TUPLE: cons car cdr ;
C: cons cons
M: cons car ( cons -- car )
cons-car ;
M: cons cdr ( cons -- cdr )
cons-cdr ;
: nil ( -- cons )
T{ cons f f f } ;
M: cons nil? ( cons -- bool )
nil eq? ;
: 1list ( obj -- cons )
nil cons ;
: 2list ( a b -- cons )
nil cons cons ;
: 3list ( a b c -- cons )
nil cons cons cons ;
! Both 'car' and 'cdr' are promises
TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
[ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
M: lazy-cons car ( lazy-cons -- car )
lazy-cons-car force ;
M: lazy-cons cdr ( lazy-cons -- cdr )
lazy-cons-cdr force ;
M: lazy-cons nil? ( lazy-cons -- bool )
nil eq? ;
: 1lazy-list ( a -- lazy-cons )
[ nil ] lazy-cons ;
: 2lazy-list ( a b -- lazy-cons )
1lazy-list 1quotation lazy-cons ;
: 3lazy-list ( a b c -- lazy-cons )
2lazy-list 1quotation lazy-cons ;
: lnth ( n list -- elt )
swap [ cdr ] times car ;
: (llength) ( list acc -- n )
over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
: llength ( list -- n )
0 (llength) ;
: uncons ( cons -- car cdr )
#! Return the car and cdr of the lazy list
dup car swap cdr ;
: leach ( list quot -- )
swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
: lreduce ( list identity quot -- result )
swapd leach ; inline
TUPLE: memoized-cons original car cdr nil? ;
: not-memoized ( -- obj )
{ } ;
: not-memoized? ( obj -- bool )
not-memoized eq? ;
: <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized
memoized-cons boa ;
M: memoized-cons car ( memoized-cons -- car )
dup memoized-cons-car not-memoized? [
dup memoized-cons-original car [ swap set-memoized-cons-car ] keep
] [
memoized-cons-car
] if ;
M: memoized-cons cdr ( memoized-cons -- cdr )
dup memoized-cons-cdr not-memoized? [
dup memoized-cons-original cdr [ swap set-memoized-cons-cdr ] keep
] [
memoized-cons-cdr
] if ;
M: memoized-cons nil? ( memoized-cons -- bool )
dup memoized-cons-nil? not-memoized? [
dup memoized-cons-original nil? [ swap set-memoized-cons-nil? ] keep
] [
memoized-cons-nil?
] if ;
TUPLE: lazy-map cons quot ;
C: <lazy-map> lazy-map
: lmap ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
M: lazy-map car ( lazy-map -- car )
[ lazy-map-cons car ] keep
lazy-map-quot call ;
M: lazy-map cdr ( lazy-map -- cdr )
[ lazy-map-cons cdr ] keep
lazy-map-quot lmap ;
M: lazy-map nil? ( lazy-map -- bool )
lazy-map-cons nil? ;
: lmap-with ( value list quot -- result )
with lmap ;
TUPLE: lazy-take n cons ;
C: <lazy-take> lazy-take
: ltake ( n list -- result )
over zero? [ 2drop nil ] [ <lazy-take> ] if ;
M: lazy-take car ( lazy-take -- car )
lazy-take-cons car ;
M: lazy-take cdr ( lazy-take -- cdr )
[ lazy-take-n 1- ] keep
lazy-take-cons cdr ltake ;
M: lazy-take nil? ( lazy-take -- bool )
dup lazy-take-n zero? [
drop t
] [
lazy-take-cons nil?
] if ;
TUPLE: lazy-until cons quot ;
C: <lazy-until> lazy-until
: luntil ( list quot -- result )
over nil? [ drop ] [ <lazy-until> ] if ;
M: lazy-until car ( lazy-until -- car )
lazy-until-cons car ;
M: lazy-until cdr ( lazy-until -- cdr )
[ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
[ 2drop nil ] [ luntil ] if ;
M: lazy-until nil? ( lazy-until -- bool )
drop f ;
TUPLE: lazy-while cons quot ;
C: <lazy-while> lazy-while
: lwhile ( list quot -- result )
over nil? [ drop ] [ <lazy-while> ] if ;
M: lazy-while car ( lazy-while -- car )
lazy-while-cons car ;
M: lazy-while cdr ( lazy-while -- cdr )
[ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
M: lazy-while nil? ( lazy-while -- bool )
[ car ] keep lazy-while-quot call not ;
TUPLE: lazy-filter cons quot ;
C: <lazy-filter> lazy-filter
: lfilter ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
: car-filter? ( lazy-filter -- ? )
[ lazy-filter-cons car ] keep
lazy-filter-quot call ;
: skip ( lazy-filter -- )
[ lazy-filter-cons cdr ] keep
set-lazy-filter-cons ;
M: lazy-filter car ( lazy-filter -- car )
dup car-filter? [ lazy-filter-cons ] [ dup skip ] if car ;
M: lazy-filter cdr ( lazy-filter -- cdr )
dup car-filter? [
[ lazy-filter-cons cdr ] keep
lazy-filter-quot lfilter
] [
dup skip cdr
] if ;
M: lazy-filter nil? ( lazy-filter -- bool )
dup lazy-filter-cons nil? [
drop t
] [
dup car-filter? [
drop f
] [
dup skip nil?
] if
] if ;
: list>vector ( list -- vector )
[ [ , ] leach ] V{ } make ;
: list>array ( list -- array )
[ [ , ] leach ] { } make ;
TUPLE: lazy-append list1 list2 ;
C: <lazy-append> lazy-append
: lappend ( list1 list2 -- result )
over nil? [ nip ] [ <lazy-append> ] if ;
M: lazy-append car ( lazy-append -- car )
lazy-append-list1 car ;
M: lazy-append cdr ( lazy-append -- cdr )
[ lazy-append-list1 cdr ] keep
lazy-append-list2 lappend ;
M: lazy-append nil? ( lazy-append -- bool )
drop f ;
TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list )
: lfrom ( n -- list )
[ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
lazy-from-by-n ;
M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ lazy-from-by-n ] keep
lazy-from-by-quot dup slip lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool )
drop f ;
TUPLE: lazy-zip list1 list2 ;
C: <lazy-zip> lazy-zip
: lzip ( list1 list2 -- lazy-zip )
over nil? over nil? or
[ 2drop nil ] [ <lazy-zip> ] if ;
M: lazy-zip car ( lazy-zip -- car )
[ lazy-zip-list1 car ] keep lazy-zip-list2 car 2array ;
M: lazy-zip cdr ( lazy-zip -- cdr )
[ lazy-zip-list1 cdr ] keep lazy-zip-list2 cdr lzip ;
M: lazy-zip nil? ( lazy-zip -- bool )
drop f ;
TUPLE: sequence-cons index seq ;
C: <sequence-cons> sequence-cons
: seq>list ( index seq -- list )
2dup length >= [
2drop nil
] [
<sequence-cons>
] if ;
M: sequence-cons car ( sequence-cons -- car )
[ sequence-cons-index ] keep
sequence-cons-seq nth ;
M: sequence-cons cdr ( sequence-cons -- cdr )
[ sequence-cons-index 1+ ] keep
sequence-cons-seq seq>list ;
M: sequence-cons nil? ( sequence-cons -- bool )
drop f ;
: >list ( object -- list )
{
{ [ dup sequence? ] [ 0 swap seq>list ] }
{ [ dup list? ] [ ] }
[ "Could not convert object to a list" throw ]
} cond ;
TUPLE: lazy-concat car cdr ;
C: <lazy-concat> lazy-concat
DEFER: lconcat
: (lconcat) ( car cdr -- list )
over nil? [
nip lconcat
] [
<lazy-concat>
] if ;
: lconcat ( list -- result )
dup nil? [
drop nil
] [
uncons (lconcat)
] if ;
M: lazy-concat car ( lazy-concat -- car )
lazy-concat-car car ;
M: lazy-concat cdr ( lazy-concat -- cdr )
[ lazy-concat-car cdr ] keep lazy-concat-cdr (lconcat) ;
M: lazy-concat nil? ( lazy-concat -- bool )
dup lazy-concat-car nil? [
lazy-concat-cdr nil?
] [
drop f
] if ;
: lcartesian-product ( list1 list2 -- result )
swap [ swap [ 2array ] lmap-with ] lmap-with lconcat ;
: lcartesian-product* ( lists -- result )
dup nil? [
drop nil
] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
] reduce
] if ;
: lcomp ( list quot -- result )
[ lcartesian-product* ] dip lmap ;
: lcomp* ( list guards quot -- result )
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lmap ;
DEFER: lmerge
: (lmerge) ( list1 list2 -- result )
over [ car ] curry -rot
[
dup [ car ] curry -rot
[
[ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
: lmerge ( list1 list2 -- result )
{
{ [ over nil? ] [ nip ] }
{ [ dup nil? ] [ drop ] }
{ [ t ] [ (lmerge) ] }
} cond ;
TUPLE: lazy-io stream car cdr quot ;
C: <lazy-io> lazy-io
: lcontents ( stream -- result )
f f [ stream-read1 ] <lazy-io> ;
: llines ( stream -- result )
f f [ stream-readln ] <lazy-io> ;
M: lazy-io car ( lazy-io -- car )
dup lazy-io-car dup [
nip
] [
drop dup lazy-io-stream over lazy-io-quot call
swap dupd set-lazy-io-car
] if ;
M: lazy-io cdr ( lazy-io -- cdr )
dup lazy-io-cdr dup [
nip
] [
drop dup
[ lazy-io-stream ] keep
[ lazy-io-quot ] keep
car [
[ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
] [
3drop nil
] if
] if ;
M: lazy-io nil? ( lazy-io -- bool )
car not ;
INSTANCE: cons list
INSTANCE: sequence-cons list
INSTANCE: memoized-cons list
INSTANCE: promise list
INSTANCE: lazy-io list
INSTANCE: lazy-concat list
INSTANCE: lazy-cons list
INSTANCE: lazy-map list
INSTANCE: lazy-take list
INSTANCE: lazy-append list
INSTANCE: lazy-from-by list
INSTANCE: lazy-zip list
INSTANCE: lazy-while list
INSTANCE: lazy-until list
INSTANCE: lazy-filter list

2
extra/lcs/diff2html/diff2html.factor
View File

@ -38,7 +38,7 @@ M: delete diff-line
</tr> ;
: htmlize-diff ( diff -- )
<table "comparison" =class table>
<table "100%" =width "comparison" =class table>
<tr> <th> "Old" write </th> <th> "New" write </th> </tr>
[ diff-line ] each
</table> ;

39
extra/lisp/lisp-tests.factor
View File

@ -1,17 +1,19 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: lisp lisp.parser tools.test sequences math kernel parser ;
USING: lisp lisp.parser tools.test sequences math kernel parser arrays ;
IN: lisp.test
[
init-env
"#f" [ f ] lisp-define
"#t" [ t ] lisp-define
[ f ] "#f" lisp-define
[ t ] "#t" lisp-define
"+" "math" "+" define-primitve
"-" "math" "-" define-primitve
"+" "math" "+" define-primitive
"-" "math" "-" define-primitive
! "list" [ >array ] lisp-define
{ 5 } [
[ 2 3 ] "+" <lisp-symbol> funcall
@ -22,26 +24,39 @@ IN: lisp.test
] unit-test
{ 3 } [
"((lambda (x y) (+ x y)) 1 2)" lisp-string>factor call
"((lambda (x y) (+ x y)) 1 2)" lisp-eval
] unit-test
{ 42 } [
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-string>factor call
"((lambda (x y z) (+ x (- y z))) 40 3 1)" lisp-eval
] unit-test
{ T{ lisp-symbol f "if" } } [
"(defmacro if (pred tr fl) (quasiquote (cond ((unquote pred) (unquote tr)) (#t (unquote fl)))))" lisp-eval
] unit-test
{ t } [
T{ lisp-symbol f "if" } lisp-macro?
] unit-test
{ 1 } [
"(if #t 1 2)" lisp-string>factor call
"(if #t 1 2)" lisp-eval
] unit-test
{ "b" } [
"(cond (#f \"a\") (#t \"b\"))" lisp-string>factor call
"(cond (#f \"a\") (#t \"b\"))" lisp-eval
] unit-test
{ 5 } [
"(begin (+ 1 4))" lisp-string>factor call
"(begin (+ 1 4))" lisp-eval
] unit-test
{ 3 } [
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-string>factor call
"((lambda (x) (if x (begin (+ 1 2)) (- 3 5))) #t)" lisp-eval
] unit-test
] with-interactive-vocabs
! { { 1 2 3 4 5 } } [
! "(list 1 2 3 4 5)" lisp-eval
! ] unit-test
] with-interactive-vocabs

142
extra/lisp/lisp.factor
View File

@ -1,48 +1,47 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math bake locals locals.private accessors
vectors syntax lisp.parser assocs parser sequences.lib words quotations
fry ;
namespaces combinators math locals locals.private accessors
vectors syntax lisp.parser assocs parser sequences.lib words
quotations fry lists inspector ;
IN: lisp
DEFER: convert-form
DEFER: funcall
DEFER: lookup-var
DEFER: lookup-macro
DEFER: lisp-macro?
DEFER: macro-expand
DEFER: define-lisp-macro
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( s-exp -- quot )
[ ] [ convert-form compose ] reduce ; inline
: convert-if ( s-exp -- quot )
rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
: convert-body ( cons -- quot )
[ ] [ convert-form compose ] foldl ; inline
: convert-begin ( s-exp -- quot )
rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ;
: convert-begin ( cons -- quot )
cdr [ convert-form ] [ ] lmap-as '[ , [ funcall ] each ] ;
: convert-cond ( s-exp -- quot )
rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
{ } map-as '[ , cond ] ;
: convert-cond ( cons -- quot )
cdr [ 2car [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
{ } lmap-as '[ , cond ] ;
: convert-general-form ( s-exp -- quot )
unclip convert-form swap convert-body swap '[ , @ funcall ] ;
: convert-general-form ( cons -- quot )
uncons [ convert-body ] [ convert-form ] bi* '[ , @ funcall ] ;
! words for convert-lambda
<PRIVATE
: localize-body ( assoc body -- assoc newbody )
[ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
[ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
] map ;
[ lisp-symbol? ] pick '[ [ name>> , at ] [ ] bi or ] traverse ;
: localize-lambda ( body vars -- newbody newvars )
make-locals dup push-locals swap
[ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
[ swap localize-body convert-form swap pop-locals ] dip swap ;
: split-lambda ( s-exp -- body vars )
first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
: split-lambda ( cons -- body-cons vars-seq )
3car -rot nip [ name>> ] lmap>array ; inline
: rest-lambda ( body vars -- quot )
: rest-lambda ( body vars -- quot )
"&rest" swap [ index ] [ remove ] 2bi
localize-lambda <lambda>
'[ , cut '[ @ , ] , compose ] ;
@ -51,46 +50,80 @@ DEFER: lookup-var
localize-lambda <lambda> '[ , compose ] ;
PRIVATE>
: convert-lambda ( s-exp -- quot )
: convert-lambda ( cons -- quot )
split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
: convert-quoted ( s-exp -- quot )
second 1quotation ;
: convert-quoted ( cons -- quot )
cdr 1quotation ;
: convert-list-form ( s-exp -- quot )
dup first dup lisp-symbol?
[ name>>
{ { "lambda" [ convert-lambda ] }
{ "quote" [ convert-quoted ] }
{ "if" [ convert-if ] }
{ "begin" [ convert-begin ] }
{ "cond" [ convert-cond ] }
[ drop convert-general-form ]
} case ]
[ drop convert-general-form ] if ;
: convert-unquoted ( cons -- quot )
"unquote not valid outside of quasiquote!" throw ;
: convert-form ( lisp-form -- quot )
{ { [ dup s-exp? ] [ body>> convert-list-form ] }
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
[ 1quotation ]
: convert-quasiquoted ( cons -- newcons )
[ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
[ cadr ] traverse ;
: convert-defmacro ( cons -- quot )
cdr [ car ] keep [ convert-lambda ] [ car name>> ] bi define-lisp-macro 1quotation ;
: form-dispatch ( cons lisp-symbol -- quot )
name>>
{ { "lambda" [ convert-lambda ] }
{ "defmacro" [ convert-defmacro ] }
{ "quote" [ convert-quoted ] }
{ "unquote" [ convert-unquoted ] }
{ "quasiquote" [ convert-quasiquoted ] }
{ "begin" [ convert-begin ] }
{ "cond" [ convert-cond ] }
[ drop convert-general-form ]
} case ;
: convert-list-form ( cons -- quot )
dup car
{ { [ dup lisp-macro? ] [ drop macro-expand ] }
{ [ dup lisp-symbol? ] [ form-dispatch ] }
[ drop convert-general-form ]
} cond ;
: convert-form ( lisp-form -- quot )
{
{ [ dup cons? ] [ convert-list-form ] }
{ [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
[ 1quotation ]
} cond ;
: compile-form ( lisp-ast -- quot )
convert-form lambda-rewrite call ; inline
: macro-call ( lambda -- cons )
call ; inline
: macro-expand ( cons -- quot )
uncons [ list>seq [ ] like ] [ lookup-macro macro-call compile-form ] bi* call ;
: lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast convert-form lambda-rewrite call ;
lisp-expr parse-result-ast compile-form ;
: lisp-eval ( str -- * )
lisp-string>factor call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env
ERROR: no-such-var var ;
SYMBOL: macro-env
ERROR: no-such-var variable-name ;
M: no-such-var summary drop "No such variable" ;
: init-env ( -- )
H{ } clone lisp-env set ;
H{ } clone lisp-env set
H{ } clone macro-env set ;
: lisp-define ( name quot -- )
swap lisp-env get set-at ;
: lisp-define ( quot name -- )
lisp-env get set-at ;
: lisp-get ( name -- word )
dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
dup lisp-env get at [ ] [ no-such-var ] ?if ;
: lookup-var ( lisp-symbol -- quot )
name>> lisp-get ;
@ -98,5 +131,14 @@ ERROR: no-such-var var ;
: funcall ( quot sym -- * )
dup lisp-symbol? [ lookup-var ] when call ; inline
: define-primitve ( name vocab word -- )
swap lookup 1quotation '[ , compose call ] lisp-define ;
: define-primitive ( name vocab word -- )
swap lookup 1quotation '[ , compose call ] swap lisp-define ;
: lookup-macro ( lisp-symbol -- lambda )
name>> macro-env get at ;
: define-lisp-macro ( quot name -- )
macro-env get set-at ;
: lisp-macro? ( car -- ? )
dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;

46
extra/lisp/parser/parser-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: lisp.parser tools.test peg peg.ebnf ;
USING: lisp.parser tools.test peg peg.ebnf lists ;
IN: lisp.parser.tests
@ -9,38 +9,60 @@ IN: lisp.parser.tests
] unit-test
{ -42 } [
"-42" "atom" \ lisp-expr rule parse parse-result-ast
"-42" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ 37/52 } [
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ 123.98 } [
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "" } [
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
"\"\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "aoeu" } [
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
"\"aoeu\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ "aoeu\"de" } [
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
"\"aoeu\\\"de\"" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ T{ lisp-symbol f "foobar" } } [
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
"foobar" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ T{ lisp-symbol f "+" } } [
"+" "atom" \ lisp-expr rule parse parse-result-ast
"+" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test
{ T{ s-exp f
V{ T{ lisp-symbol f "foo" } 1 2 "aoeu" } } } [
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
{ +nil+ } [
"()" lisp-expr parse-result-ast
] unit-test
{ T{
cons
f
T{ lisp-symbol f "foo" }
T{
cons
f
1
T{ cons f 2 T{ cons f "aoeu" +nil+ } }
} } } [
"(foo 1 2 \"aoeu\")" lisp-expr parse-result-ast
] unit-test
{ T{ cons f
1
T{ cons f
T{ cons f 3 T{ cons f 4 +nil+ } }
T{ cons f 2 +nil+ } }
}
} [
"(1 (3 4) 2)" lisp-expr parse-result-ast
] unit-test

16
extra/lisp/parser/parser.factor
View File

@ -1,16 +1,13 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
combinators.lib math ;
USING: kernel peg peg.ebnf peg.expr math.parser sequences arrays strings
combinators.lib math fry accessors lists ;
IN: lisp.parser
TUPLE: lisp-symbol name ;
C: <lisp-symbol> lisp-symbol
TUPLE: s-exp body ;
C: <s-exp> s-exp
EBNF: lisp-expr
_ = (" " | "\t" | "\n")*
LPAREN = "("
@ -24,8 +21,9 @@ rational = integer "/" (digit)+ => [[ first3 nip string
number = float
| rational
| integer
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
| "<" | "#" | " =" | ">" | "?" | "^" | "_"
| "~" | "+" | "-" | "." | "@"
letters = [a-zA-Z] => [[ 1array >string ]]
initials = letters | id-specials
numbers = [0-9] => [[ 1array >string ]]
@ -36,6 +34,6 @@ string = dquote ( escaped | !(dquote) . )* dquote => [[ second >string ]]
atom = number
| identifier
| string
list-item = _ (atom|s-expression) _ => [[ second ]]
s-expression = LPAREN (list-item)* RPAREN => [[ second <s-exp> ]]
list-item = _ ( atom | s-expression ) _ => [[ second ]]
s-expression = LPAREN (list-item)* RPAREN => [[ second seq>cons ]]
;EBNF

1
extra/lists/authors.txt Normal file
View File

@ -0,0 +1 @@
James Cash

0
extra/lazy-lists/authors.txt → extra/lists/lazy/authors.txt
View File

0
extra/lazy-lists/examples/authors.txt → extra/lists/lazy/examples/authors.txt
View File

0
extra/lazy-lists/examples/examples-tests.factor → extra/lists/lazy/examples/examples-tests.factor
View File

6
extra/lazy-lists/examples/examples.factor → extra/lists/lazy/examples/examples.factor
View File

@ -2,8 +2,8 @@
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: lazy-lists math kernel sequences quotations ;
IN: lazy-lists.examples
USING: lists.lazy math kernel sequences quotations ;
IN: lists.lazy.examples
: naturals 0 lfrom ;
: positives 1 lfrom ;
@ -11,5 +11,5 @@ IN: lazy-lists.examples
: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
: powers-of-2 1 [ 2 * ] lfrom-by ;
: ones 1 [ ] lfrom-by ;
: squares naturals [ dup * ] lmap ;
: squares naturals [ dup * ] lazy-map ;
: first-five-squares 5 squares ltake list>array ;

79
extra/lazy-lists/lazy-lists-docs.factor → extra/lists/lazy/lazy-docs.factor
View File

@ -1,48 +1,8 @@
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax sequences strings ;
IN: lazy-lists
{ car cons cdr nil nil? list? uncons } related-words
HELP: cons
{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
{ $description "Constructs a cons cell." } ;
HELP: car
{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
{ $description "Returns the first item in the list." } ;
HELP: cdr
{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
{ $description "Returns the tail of the list." } ;
HELP: nil
{ $values { "cons" "An empty cons" } }
{ $description "Returns a representation of an empty list" } ;
HELP: nil?
{ $values { "cons" "a cons object" } { "?" "a boolean" } }
{ $description "Return true if the cons object is the nil cons." } ;
HELP: list? ( object -- ? )
{ $values { "object" "an object" } { "?" "a boolean" } }
{ $description "Returns true if the object conforms to the list protocol." } ;
{ 1list 2list 3list } related-words
HELP: 1list
{ $values { "obj" "an object" } { "cons" "a cons object" } }
{ $description "Create a list with 1 element." } ;
HELP: 2list
{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
{ $description "Create a list with 2 elements." } ;
HELP: 3list
{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
{ $description "Create a list with 3 elements." } ;
USING: help.markup help.syntax sequences strings lists ;
IN: lists.lazy
HELP: lazy-cons
{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
@ -68,37 +28,15 @@ HELP: <memoized-cons>
{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
{ $see-also cons car cdr nil nil? } ;
HELP: lnth
{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
{ $description "Outputs the nth element of the list." }
{ $see-also llength cons car cdr } ;
{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
HELP: llength
{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
{ $description "Outputs the length of the list. This should not be called on an infinite list." }
{ $see-also lnth cons car cdr } ;
HELP: uncons
{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
{ leach lreduce lmap lmap-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
HELP: leach
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
{ $description "Call the quotation for each item in the list." } ;
HELP: lreduce
{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
HELP: lmap
HELP: lazy-map
{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lmap-with
HELP: lazy-map-with
{ $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;
{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
HELP: ltake
{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
@ -147,6 +85,8 @@ HELP: >list
{ $values { "object" "an object" } { "list" "a list" } }
{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
{ $see-also seq>list } ;
{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
HELP: lconcat
{ $values { "list" "a list of lists" } { "result" "a list" } }
@ -175,7 +115,7 @@ HELP: lmerge
{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
{ $description "Return the result of merging the two lists in a lazy manner." }
{ $examples
{ $example "USING: lazy-lists prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
{ $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
} ;
HELP: lcontents
@ -187,4 +127,3 @@ HELP: llines
{ $values { "stream" "a stream" } { "result" "a list" } }
{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
{ $see-also lcontents } ;

6
extra/lazy-lists/lazy-lists-tests.factor → extra/lists/lazy/lazy-tests.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2006 Matthew Willis and Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: lazy-lists tools.test kernel math io sequences ;
IN: lazy-lists.tests
USING: lists lists.lazy tools.test kernel math io sequences ;
IN: lists.lazy.tests
[ { 1 2 3 4 } ] [
{ 1 2 3 4 } >list list>array
@ -25,5 +25,5 @@ IN: lazy-lists.tests
] unit-test
[ { 4 5 6 } ] [
3 { 1 2 3 } >list [ + ] lmap-with list>array
3 { 1 2 3 } >list [ + ] lazy-map-with list>array
] unit-test

392
extra/lists/lazy/lazy.factor Normal file
View File

@ -0,0 +1,392 @@
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
! Updated by Matthew Willis, July 2006
! Updated by Chris Double, September 2006
! Updated by James Cash, June 2008
!
USING: kernel sequences math vectors arrays namespaces
quotations promises combinators io lists accessors ;
IN: lists.lazy
M: promise car ( promise -- car )
force car ;
M: promise cdr ( promise -- cdr )
force cdr ;
M: promise nil? ( cons -- bool )
force nil? ;
! Both 'car' and 'cdr' are promises
TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
[ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
M: lazy-cons car ( lazy-cons -- car )
car>> force ;
M: lazy-cons cdr ( lazy-cons -- cdr )
cdr>> force ;
M: lazy-cons nil? ( lazy-cons -- bool )
nil eq? ;
: 1lazy-list ( a -- lazy-cons )
[ nil ] lazy-cons ;
: 2lazy-list ( a b -- lazy-cons )
1lazy-list 1quotation lazy-cons ;
: 3lazy-list ( a b c -- lazy-cons )
2lazy-list 1quotation lazy-cons ;
TUPLE: memoized-cons original car cdr nil? ;
: not-memoized ( -- obj )
{ } ;
: not-memoized? ( obj -- bool )
not-memoized eq? ;
: <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized
memoized-cons boa ;
M: memoized-cons car ( memoized-cons -- car )
dup car>> not-memoized? [
dup original>> car [ >>car drop ] keep
] [
car>>
] if ;
M: memoized-cons cdr ( memoized-cons -- cdr )
dup cdr>> not-memoized? [
dup original>> cdr [ >>cdr drop ] keep
] [
cdr>>
] if ;
M: memoized-cons nil? ( memoized-cons -- bool )
dup nil?>> not-memoized? [
dup original>> nil? [ >>nil? drop ] keep
] [
nil?>>
] if ;
TUPLE: lazy-map cons quot ;
C: <lazy-map> lazy-map
: lazy-map ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
M: lazy-map car ( lazy-map -- car )
[ cons>> car ] keep
quot>> call ;
M: lazy-map cdr ( lazy-map -- cdr )
[ cons>> cdr ] keep
quot>> lazy-map ;
M: lazy-map nil? ( lazy-map -- bool )
cons>> nil? ;
: lazy-map-with ( value list quot -- result )
with lazy-map ;
TUPLE: lazy-take n cons ;
C: <lazy-take> lazy-take
: ltake ( n list -- result )
over zero? [ 2drop nil ] [ <lazy-take> ] if ;
M: lazy-take car ( lazy-take -- car )
cons>> car ;
M: lazy-take cdr ( lazy-take -- cdr )
[ n>> 1- ] keep
cons>> cdr ltake ;
M: lazy-take nil? ( lazy-take -- bool )
dup n>> zero? [
drop t
] [
cons>> nil?
] if ;
TUPLE: lazy-until cons quot ;
C: <lazy-until> lazy-until
: luntil ( list quot -- result )
over nil? [ drop ] [ <lazy-until> ] if ;
M: lazy-until car ( lazy-until -- car )
cons>> car ;
M: lazy-until cdr ( lazy-until -- cdr )
[ cons>> uncons ] keep quot>> tuck call
[ 2drop nil ] [ luntil ] if ;
M: lazy-until nil? ( lazy-until -- bool )
drop f ;
TUPLE: lazy-while cons quot ;
C: <lazy-while> lazy-while
: lwhile ( list quot -- result )
over nil? [ drop ] [ <lazy-while> ] if ;
M: lazy-while car ( lazy-while -- car )
cons>> car ;
M: lazy-while cdr ( lazy-while -- cdr )
[ cons>> cdr ] keep quot>> lwhile ;
M: lazy-while nil? ( lazy-while -- bool )
[ car ] keep quot>> call not ;
TUPLE: lazy-filter cons quot ;
C: <lazy-filter> lazy-filter
: lfilter ( list quot -- result )
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
: car-filter? ( lazy-filter -- ? )
[ cons>> car ] [ quot>> ] bi call ;
: skip ( lazy-filter -- )
dup cons>> cdr >>cons drop ;
M: lazy-filter car ( lazy-filter -- car )
dup car-filter? [ cons>> ] [ dup skip ] if car ;
M: lazy-filter cdr ( lazy-filter -- cdr )
dup car-filter? [
[ cons>> cdr ] [ quot>> ] bi lfilter
] [
dup skip cdr
] if ;
M: lazy-filter nil? ( lazy-filter -- bool )
dup cons>> nil? [
drop t
] [
dup car-filter? [
drop f
] [
dup skip nil?
] if
] if ;
: list>vector ( list -- vector )
[ [ , ] leach ] V{ } make ;
: list>array ( list -- array )
[ [ , ] leach ] { } make ;
TUPLE: lazy-append list1 list2 ;
C: <lazy-append> lazy-append
: lappend ( list1 list2 -- result )
over nil? [ nip ] [ <lazy-append> ] if ;
M: lazy-append car ( lazy-append -- car )
list1>> car ;
M: lazy-append cdr ( lazy-append -- cdr )
[ list1>> cdr ] keep
list2>> lappend ;
M: lazy-append nil? ( lazy-append -- bool )
drop f ;
TUPLE: lazy-from-by n quot ;
C: lfrom-by lazy-from-by ( n quot -- list )
: lfrom ( n -- list )
[ 1+ ] lfrom-by ;
M: lazy-from-by car ( lazy-from-by -- car )
n>> ;
M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ n>> ] keep
quot>> dup slip lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool )
drop f ;
TUPLE: lazy-zip list1 list2 ;
C: <lazy-zip> lazy-zip
: lzip ( list1 list2 -- lazy-zip )
over nil? over nil? or
[ 2drop nil ] [ <lazy-zip> ] if ;
M: lazy-zip car ( lazy-zip -- car )
[ list1>> car ] keep list2>> car 2array ;
M: lazy-zip cdr ( lazy-zip -- cdr )
[ list1>> cdr ] keep list2>> cdr lzip ;
M: lazy-zip nil? ( lazy-zip -- bool )
drop f ;
TUPLE: sequence-cons index seq ;
C: <sequence-cons> sequence-cons
: seq>list ( index seq -- list )
2dup length >= [
2drop nil
] [
<sequence-cons>
] if ;
M: sequence-cons car ( sequence-cons -- car )
[ index>> ] keep
seq>> nth ;
M: sequence-cons cdr ( sequence-cons -- cdr )
[ index>> 1+ ] keep
seq>> seq>list ;
M: sequence-cons nil? ( sequence-cons -- bool )
drop f ;
: >list ( object -- list )
{
{ [ dup sequence? ] [ 0 swap seq>list ] }
{ [ dup list? ] [ ] }
[ "Could not convert object to a list" throw ]
} cond ;
TUPLE: lazy-concat car cdr ;
C: <lazy-concat> lazy-concat
DEFER: lconcat
: (lconcat) ( car cdr -- list )
over nil? [
nip lconcat
] [
<lazy-concat>
] if ;
: lconcat ( list -- result )
dup nil? [
drop nil
] [
uncons swap (lconcat)
] if ;
M: lazy-concat car ( lazy-concat -- car )
car>> car ;
M: lazy-concat cdr ( lazy-concat -- cdr )
[ car>> cdr ] keep cdr>> (lconcat) ;
M: lazy-concat nil? ( lazy-concat -- bool )
dup car>> nil? [
cdr>> nil?
] [
drop f
] if ;
: lcartesian-product ( list1 list2 -- result )
swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ;
: lcartesian-product* ( lists -- result )
dup nil? [
drop nil
] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat
] reduce
] if ;
: lcomp ( list quot -- result )
[ lcartesian-product* ] dip lazy-map ;
: lcomp* ( list guards quot -- result )
[ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
DEFER: lmerge
: (lmerge) ( list1 list2 -- result )
over [ car ] curry -rot
[
dup [ car ] curry -rot
[
[ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
: lmerge ( list1 list2 -- result )
{
{ [ over nil? ] [ nip ] }
{ [ dup nil? ] [ drop ] }
{ [ t ] [ (lmerge) ] }
} cond ;
TUPLE: lazy-io stream car cdr quot ;
C: <lazy-io> lazy-io
: lcontents ( stream -- result )
f f [ stream-read1 ] <lazy-io> ;
: llines ( stream -- result )
f f [ stream-readln ] <lazy-io> ;
M: lazy-io car ( lazy-io -- car )
dup car>> dup [
nip
] [
drop dup stream>> over quot>> call
swap dupd set-lazy-io-car
] if ;
M: lazy-io cdr ( lazy-io -- cdr )
dup cdr>> dup [
nip
] [
drop dup
[ stream>> ] keep
[ quot>> ] keep
car [
[ f f ] dip <lazy-io> [ >>cdr drop ] keep
] [
3drop nil
] if
] if ;
M: lazy-io nil? ( lazy-io -- bool )
car not ;
INSTANCE: sequence-cons list
INSTANCE: memoized-cons list
INSTANCE: promise list
INSTANCE: lazy-io list
INSTANCE: lazy-concat list
INSTANCE: lazy-cons list
INSTANCE: lazy-map list
INSTANCE: lazy-take list
INSTANCE: lazy-append list
INSTANCE: lazy-from-by list
INSTANCE: lazy-zip list
INSTANCE: lazy-while list
INSTANCE: lazy-until list
INSTANCE: lazy-filter list

0
extra/lazy-lists/old-doc.html → extra/lists/lazy/old-doc.html
View File

0
extra/lazy-lists/summary.txt → extra/lists/lazy/summary.txt
View File

0
extra/lazy-lists/tags.txt → extra/lists/lazy/tags.txt
View File

Some files were not shown because too many files have changed in this diff Show More