Merge branch 'master' of factorcode.org:/git/factor
commit
e6295a2d54
|
@ -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
|
||||
|
|
|
@ -147,6 +147,9 @@ PRIVATE>
|
|||
] if
|
||||
] unless ;
|
||||
|
||||
: file-extension ( filename -- extension )
|
||||
"." last-split1 nip ;
|
||||
|
||||
! File info
|
||||
TUPLE: file-info type size permissions modified ;
|
||||
|
||||
|
|
|
@ -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 -- )" } } }
|
||||
|
|
|
@ -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:
|
||||
|
|
|
@ -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>> ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ) ;
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
|
@ -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? ;
|
|
@ -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>
|
|
@ -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>
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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"
|
||||
{
|
|
@ -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,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
|
|
@ -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 ;
|
|
@ -0,0 +1,4 @@
|
|||
IN: furnace.db.tests
|
||||
USING: tools.test furnace.db ;
|
||||
|
||||
\ <db-persistence> must-infer
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
|
@ -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='&&&'/>" ]
|
||||
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
|
||||
unit-test
|
|
@ -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 ;
|
|
@ -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> ;
|
|
@ -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
|
||||
|
||||
[
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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
|
||||
|
||||
|
|
|
@ -0,0 +1,5 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: help.html
|
||||
|
||||
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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> ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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>
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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>
|
|
@ -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>
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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>
|
||||
|
|
|
@ -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
|
||||
|
||||
[
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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 ;
|
||||
|
|
|
@ -1,4 +0,0 @@
|
|||
IN: http.server.db.tests
|
||||
USING: tools.test http.server.db ;
|
||||
|
||||
\ <db-persistence> must-infer
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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
|
|
@ -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> ;
|
|
@ -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> ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,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
|
||||
|
|
|
@ -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
|
|
@ -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> ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
James Cash
|
|
@ -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 ;
|
|
@ -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 } ;
|
||||
|
|
@ -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
|
|
@ -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
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue