alien.structs alien.syntax cpu.architecture alien inspector
quotations assocs kernel.private threads continuations.private
libc combinators compiler.errors continuations layouts accessors
-;
+init ;
IN: alien.compiler
TUPLE: #alien-node < node return parameters abi ;
! this hashtable, they will all be blown away by code GC, beware
SYMBOL: callbacks
-callbacks global [ H{ } assoc-like ] change-at
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
: register-callback ( word -- ) dup callbacks get set-at ;
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
- xt>> [ word-xt drop <alien> ] curry
+ xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
recursive-state get infer-quot ;
\ alien-callback [
pop-literal nip >>abi
pop-parameters >>parameters
pop-literal nip >>return
- gensym dup register-callback >>xt
+ gensym >>xt
callback-bottom
] "infer" set-word-prop
ARTICLE: "c-unions" "C unions"
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
{ $subsection POSTPONE: C-UNION: }
-"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
+"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
"Arrays of C unions can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
{ $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators"
-"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary."
+"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
$nl
+"A looping combinator:"
+{ $subsection while }
"Generalization of " { $link bi } " and " { $link tri } ":"
{ $subsection cleave }
"Generalization of " { $link bi* } " and " { $link tri* } ":"
-USING: help.syntax help.markup generator.fixup math kernel
+USING: help.syntax help.markup math kernel
words strings alien ;
+IN: generator.fixup
HELP: frame-required
{ $values { "n" "a non-negative integer" } }
{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
-HELP: (rel-fixup)
-{ $values { "arg" integer } { "class" "a relocation class" } { "type" "a relocation type" } { "offset" integer } { "pair" "a pair of integers" } }
-{ $description "Creates a relocation instruction for the VM's runtime compiled code linker." } ;
-
HELP: add-literal
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs hashtables
+USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words
-quotations strings alien.strings layouts system combinators
-math.bitfields words.private cpu.architecture math.order ;
+quotations strings alien.accessors alien.strings layouts system
+combinators math.bitfields words.private cpu.architecture
+math.order accessors growable ;
IN: generator.fixup
: no-stack-frame -1 ; inline
: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
- dup label-fixup-class rc-absolute?
+ dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
- dup label-fixup-label swap label-fixup-class
- compiled-offset 4 - rot 3array label-table get push ;
+ dup label>> swap class>> compiled-offset 4 - rot
+ 3array label-table get push ;
TUPLE: rel-fixup arg class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
-: (rel-fixup) ( arg class type offset -- pair )
- pick rc-absolute-cell = cell 4 ? -
- >r { 0 8 16 } bitfield r>
- 2array ;
+: push-4 ( value vector -- )
+ [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying ] tri
+ swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
- dup rel-fixup-arg
- over rel-fixup-class
- rot rel-fixup-type
- compiled-offset (rel-fixup)
- relocation-table get push-all ;
+ [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
+ [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
+ [ relocation-table get push-4 ] bi@ ;
M: frame-required fixup* drop ;
0 swap rt-here rel-fixup ;
: init-fixup ( -- )
- V{ } clone relocation-table set
+ BV{ } clone relocation-table set
V{ } clone label-table set ;
: resolve-labels ( labels -- labels' )
dup stack-frame-size swap [ fixup* ] each drop
literal-table get >array
- relocation-table get >array
+ relocation-table get >byte-array
label-table get resolve-labels
] { } make ;
-USING: help.markup help.syntax io math ;
+USING: help.markup help.syntax io math byte-arrays ;
IN: io.binary
ARTICLE: "stream-binary" "Working with binary data"
-"The core stream words read and write strings. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
+"Stream words on binary streams only read and write byte arrays. Packed binary integers can be read and written by converting to and from sequences of bytes. Floating point numbers can be read and written by converting them into a their bitwise integer representation (" { $link "floats" } ")."
$nl
"There are two ways to order the bytes making up an integer; " { $emphasis "little endian" } " byte order outputs the least significant byte first, and the most significant byte last, whereas " { $emphasis "big endian" } " is the other way around."
$nl
{ $description "Outputs the " { $snippet "n" } "th least significant byte of the sign-extended 2's complement representation of " { $snippet "x" } "." } ;
HELP: >le
-{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
+{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in little endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: >be
-{ $values { "x" integer } { "n" "a non-negative integer" } { "str" "a string" } }
+{ $values { "x" integer } { "n" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Converts an integer " { $snippet "x" } " into a string of " { $snippet "n" } " bytes in big endian order. Truncation will occur if the integer is not in the range " { $snippet "[-2^(8n),2^(8n))" } "." } ;
HELP: mask-byte
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
-: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
-: >be ( x n -- str ) >le dup reverse-here ;
+: >le ( x n -- byte-array ) [ nth-byte ] with B{ } map-as ;
+: >be ( x n -- byte-array ) >le dup reverse-here ;
: d>w/w ( d -- w1 w2 )
dup HEX: ffffffff bitand
] if
] unless ;
+: file-extension ( filename -- extension )
+ "." last-split1 nip ;
+
! File info
TUPLE: file-info type size permissions modified ;
": keep ( x quot -- x )"
" over >r call r> ; inline"
}
-"Word inlining is documented in " { $link "declarations" } "."
-$nl
-"A looping combinator:"
-{ $subsection while } ;
+"Word inlining is documented in " { $link "declarations" } "." ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
{ $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 }
{ $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? } ;
{ $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 -- )" } } }
{ $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" }
[ normalize ] map ;
: read-model ( stream -- model )
- "Reading model" print flush [
- ascii [ parse-model ] with-file-reader
- [ normals ] 2keep 3array
- ] time ;
+ ascii [ parse-model ] with-file-reader
+ [ normals ] 2keep 3array ;
: model-path "bun_zipper.ply" temp-file ;
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: cairo cairo.ffi ui.render kernel opengl.gl opengl
-math byte-arrays ui.gadgets accessors arrays
-namespaces io.backend ;
+USING: sequences math opengl.gadgets kernel
+byte-arrays cairo.ffi cairo io.backend
+ui.gadgets accessors opengl.gl
+arrays ;
IN: cairo.gadgets
-! We need two kinds of gadgets:
-! one performs the cairo ops once and caches the bytes, the other
-! performs cairo ops every refresh
-
-TUPLE: cairo-gadget width height quot cache? bytes ;
-PREDICATE: cached-cairo < cairo-gadget cache?>> ;
-: <cairo-gadget> ( width height quot -- cairo-gadget )
- cairo-gadget construct-gadget
- swap >>quot
- swap >>height
- swap >>width ;
-
-: <cached-cairo> ( width height quot -- cairo-gadget )
- <cairo-gadget> t >>cache? ;
-
: width>stride ( width -- stride ) 4 * ;
-: copy-cairo ( width height quot -- byte-array )
- >r over width>stride
+: copy-cairo ( dim quot -- byte-array )
+ >r first2 over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
r> with-cairo-from-surface ;
-: (cairo>bytes) ( gadget -- byte-array )
- [ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
+TUPLE: cairo-gadget < texture-gadget quot ;
-GENERIC: cairo>bytes
-M: cairo-gadget cairo>bytes ( gadget -- byte-array )
- (cairo>bytes) ;
+: <cairo-gadget> ( dim quot -- gadget )
+ cairo-gadget construct-gadget
+ swap >>quot
+ swap >>dim ;
-M: cached-cairo cairo>bytes ( gadget -- byte-array )
- dup bytes>> [ ] [
- dup (cairo>bytes) [ >>bytes drop ] keep
- ] ?if ;
+M: cairo-gadget format>> drop GL_BGRA ;
-: cairo>png ( gadget path -- )
- >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
- [ height>> ] tri over width>stride
- cairo_image_surface_create_for_data
- r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
+M: cairo-gadget render* ( gadget -- )
+ dup
+ [ dim>> 2^-bounds ] [ quot>> copy-cairo ] bi
+ >>bytes call-next-method ;
-M: cairo-gadget draw-gadget* ( gadget -- )
- origin get [
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- [ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
- [ cairo>bytes ] tri glDrawPixels
- ] with-translation ;
-
-M: cairo-gadget pref-dim* ( gadget -- rect )
- [ width>> ] [ height>> ] bi 2array ;
+! maybe also texture>png
+! : cairo>png ( gadget path -- )
+! >r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
+! [ height>> ] tri over width>stride
+! cairo_image_surface_create_for_data
+! r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
: copy-surface ( surface -- )
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
-: <bytes-gadget> ( width height bytes -- cairo-gadget )
- >r [ ] <cached-cairo> r> >>bytes ;
-
: <png-gadget> ( path -- gadget )
normalize-path cairo_image_surface_create_from_png
[ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height 2dup ]
+ [ cairo_image_surface_get_height 2array dup 2^-bounds ]
[ [ copy-surface ] curry copy-cairo ] tri
- <bytes-gadget> ;
\ No newline at end of file
+ GL_BGRA rot <texture-gadget> ;
+
+
+++ /dev/null
-USING: cairo.pango cairo cairo.ffi cairo.gadgets
-alien.c-types kernel math ;
-IN: cairo.pango.gadgets
-
-: (pango-gadget) ( setup show -- gadget )
- [ drop layout-size ]
- [ compose [ with-pango ] curry <cached-cairo> ] 2bi ;
-
-: <pango-gadget> ( quot -- gadget )
- [ cr layout pango_cairo_show_layout ] (pango-gadget) ;
-
-USING: prettyprint sequences ui.gadgets.panes ;
-: hello-pango ( -- )
- 50 [ 6 + ] map [
- "Sans Bold " swap unparse append
- [ layout-font "Hello, Pango!" layout-text ] curry
- <pango-gadget> gadget.
- ] each ;
-
-MAIN: hello-pango
+++ /dev/null
-! Copyright (C) 2008 Matthew Willis.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! pangocairo bindings, from pango/pangocairo.h
-
-USING: cairo.ffi alien.c-types math
-alien.syntax system combinators alien ;
-IN: cairo.pango
-
-<< "pangocairo" {
-! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
-! { [ os macosx? ] [ "libpangocairo.dylib" ] }
- { [ os unix? ] [ "libpangocairo-1.0.so" ] }
-} cond "cdecl" add-library >>
-
-LIBRARY: pangocairo
-
-TYPEDEF: void* PangoCairoFont
-TYPEDEF: void* PangoCairoFontMap
-TYPEDEF: void* PangoFontMap
-
-FUNCTION: PangoFontMap*
-pango_cairo_font_map_new ( ) ;
-
-FUNCTION: PangoFontMap*
-pango_cairo_font_map_new_for_font_type ( cairo_font_type_t fonttype ) ;
-
-FUNCTION: PangoFontMap*
-pango_cairo_font_map_get_default ( ) ;
-
-FUNCTION: cairo_font_type_t
-pango_cairo_font_map_get_font_type ( PangoCairoFontMap* fontmap ) ;
-
-FUNCTION: void
-pango_cairo_font_map_set_resolution ( PangoCairoFontMap* fontmap, double dpi ) ;
-
-FUNCTION: double
-pango_cairo_font_map_get_resolution ( PangoCairoFontMap* fontmap ) ;
-
-FUNCTION: PangoContext*
-pango_cairo_font_map_create_context ( PangoCairoFontMap* fontmap ) ;
-
-FUNCTION: cairo_scaled_font_t*
-pango_cairo_font_get_scaled_font ( PangoCairoFont* font ) ;
-
-! Update a Pango context for the current state of a cairo context
-FUNCTION: void
-pango_cairo_update_context ( cairo_t* cr, PangoContext* context ) ;
-
-FUNCTION: void
-pango_cairo_context_set_font_options ( PangoContext* context, cairo_font_options_t* options ) ;
-
-FUNCTION: cairo_font_options_t*
-pango_cairo_context_get_font_options ( PangoContext* context ) ;
-
-FUNCTION: void
-pango_cairo_context_set_resolution ( PangoContext* context, double dpi ) ;
-
-FUNCTION: double
-pango_cairo_context_get_resolution ( PangoContext* context ) ;
-
-! Convenience
-FUNCTION: PangoLayout*
-pango_cairo_create_layout ( cairo_t* cr ) ;
-
-FUNCTION: void
-pango_cairo_update_layout ( cairo_t* cr, PangoLayout* layout ) ;
-
-! Rendering
-FUNCTION: void
-pango_cairo_show_glyph_string ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
-
-FUNCTION: void
-pango_cairo_show_layout_line ( cairo_t* cr, PangoLayoutLine* line ) ;
-
-FUNCTION: void
-pango_cairo_show_layout ( cairo_t* cr, PangoLayout* layout ) ;
-
-FUNCTION: void
-pango_cairo_show_error_underline ( cairo_t* cr, double x, double y, double width, double height ) ;
-
-! Rendering to a path
-FUNCTION: void
-pango_cairo_glyph_string_path ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
-
-FUNCTION: void
-pango_cairo_layout_line_path ( cairo_t* cr, PangoLayoutLine* line ) ;
-
-FUNCTION: void
-pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
-
-FUNCTION: void
-pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Helpful functions from other parts of pango
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: PANGO_SCALE 1024 ;
-
-FUNCTION: void
-pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
-
-FUNCTION: char*
-pango_layout_get_text ( PangoLayout* layout ) ;
-
-FUNCTION: void
-pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ;
-
-TYPEDEF: void* PangoFontDescription
-
-FUNCTION: PangoFontDescription*
-pango_font_description_from_string ( char* str ) ;
-
-FUNCTION: char*
-pango_font_description_to_string ( PangoFontDescription* desc ) ;
-
-FUNCTION: char*
-pango_font_description_to_filename ( PangoFontDescription* desc ) ;
-
-FUNCTION: void
-pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ;
-
-FUNCTION: PangoFontDescription*
-pango_layout_get_font_description ( PangoLayout* layout ) ;
-
-FUNCTION: void
-pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ;
-
-FUNCTION: void
-pango_font_description_free ( PangoFontDescription* desc ) ;
-
-TYPEDEF: void* gpointer
-
-FUNCTION: void
-g_object_unref ( gpointer object ) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Higher level words and combinators
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: destructors accessors namespaces kernel cairo ;
-
-TUPLE: pango-layout alien ;
-C: <pango-layout> pango-layout
-M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
-
-: layout ( -- pango-layout ) pango-layout get ;
-
-: (with-pango) ( layout quot -- )
- >r alien>> pango-layout r> with-variable ; inline
-
-: with-pango ( quot -- )
- cr pango_cairo_create_layout <pango-layout> swap
- [ (with-pango) ] curry with-disposal ; inline
-
-: pango-layout-get-pixel-size ( layout -- width height )
- 0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
- [ *int ] bi@ ;
-
-: dummy-pango ( quot -- )
- >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
- r> [ with-pango ] curry with-cairo-from-surface ; inline
-
-: layout-size ( quot -- width height )
- [ layout pango-layout-get-pixel-size ] compose dummy-pango ; inline
-
-: layout-font ( str -- )
- pango_font_description_from_string
- dup zero? [ "pango: not a valid font." throw ] when
- layout over pango_layout_set_font_description
- pango_font_description_free ;
-
-: layout-text ( str -- )
- layout swap -1 pango_layout_set_text ;
USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
: samples ( -- )
{ arc clip clip-image dash gradient text utf8 }
- [ 256 256 rot 1quotation <cached-cairo> gadget. ] each ;
+ [ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
- MAIN: samples
\ No newline at end of file
+ MAIN: samples
[ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
MACRO: 3|| ( quots -- ? )
- [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+ [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;
-SINGLETON: throwable
-SINGLETON: nonthrowable
-
-: make-throwable ( obj -- obj' )
- dup sequence? [
- [ make-throwable ] map
- ] [
- throwable >>type
- ] if ;
-
-: make-nonthrowable ( obj -- obj' )
- dup sequence? [
- [ make-nonthrowable ] map
- ] [
- nonthrowable >>type
- ] if ;
-
TUPLE: result-set sql in-params out-params handle n max ;
: construct-statement ( sql in out class -- statement )
new
swap >>out-params
swap >>in-params
- swap >>sql
- throwable >>type ;
+ swap >>sql ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: execute-statement* ( statement type -- )
-M: throwable execute-statement* ( statement type -- )
+M: object execute-statement* ( statement type -- )
drop query-results dispose ;
-M: nonthrowable execute-statement* ( statement type -- )
- drop [ query-results dispose ] [ 2drop ] recover ;
-
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: db.errors
+
+ERROR: db-error ;
+ERROR: sql-error ;
+
+
+ERROR: table-exists ;
+ERROR: bad-schema ;
: drop-table-sql ( table -- statement )
[
- "drop table " 0% 0% ";" 0% drop
+ "drop table " 0% 0% drop
] query-make ;
M: postgresql-db drop-sql-statement ( class -- seq )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
-strings
-math.bitfields.lib namespaces.lib db db.tuples db.types
-math.intervals ;
+strings math.parser math.intervals combinators
+math.bitfields.lib namespaces.lib db db.tuples db.types ;
IN: db.queries
GENERIC: where ( specs obj -- )
: maybe-make-retryable ( statement -- statement )
- dup in-params>> [ generator-bind? ] contains? [
- make-retryable
- ] when ;
+ dup in-params>> [ generator-bind? ] contains?
+ [ make-retryable ] when ;
: query-make ( class quot -- )
>r sql-props r>
- [ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
+ [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
" from " 0% 0%
where-clause
] query-make ;
+
+: do-group ( tuple groups -- )
+ [
+ ", " join " group by " prepend append
+ ] curry change-sql drop ;
+
+: do-order ( tuple order -- )
+ [
+ ", " join " order by " prepend append
+ ] curry change-sql drop ;
+
+: do-offset ( tuple n -- )
+ [
+ number>string " offset " prepend append
+ ] curry change-sql drop ;
+
+: do-limit ( tuple n -- )
+ [
+ number>string " limit " prepend append
+ ] curry change-sql drop ;
+
+: make-advanced-statement ( tuple advanced -- tuple' )
+ dupd
+ {
+ [ group>> [ do-group ] [ drop ] if* ]
+ [ order>> [ do-order ] [ drop ] if* ]
+ [ limit>> [ do-limit ] [ drop ] if* ]
+ [ offset>> [ do-offset ] [ drop ] if* ]
+ } 2cleave ;
+
+M: db <advanced-select-statement> ( tuple class group order limit offset -- tuple )
+ advanced-statement boa
+ [ <select-by-slots-statement> ] dip make-advanced-statement ;
! TUPLE: person name age ;
: insert-1
{ insert
- { table "person" }
- { columns "name" "age" }
- { values "erg" 26 }
+ {
+ { table "person" }
+ { columns "name" "age" }
+ { values "erg" 26 }
+ }
} ;
: update-1
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
-io.backend ;
+io.backend db.errors ;
IN: db.sqlite.lib
-: sqlite-error ( n -- * )
- sqlite-error-messages nth throw ;
+ERROR: sqlite-error < db-error n string ;
+ERROR: sqlite-sql-error < sql-error n string ;
-: sqlite-statement-error-string ( -- str )
- db get db-handle sqlite3_errmsg ;
+: throw-sqlite-error ( n -- * )
+ dup sqlite-error-messages nth sqlite-error ;
: sqlite-statement-error ( -- * )
- sqlite-statement-error-string throw ;
+ SQLITE_ERROR
+ db get db-handle sqlite3_errmsg sqlite-sql-error ;
: sqlite-check-result ( n -- )
{
- { [ dup SQLITE_OK = ] [ drop ] }
- { [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
- [ sqlite-error ]
- } cond ;
+ { SQLITE_OK [ ] }
+ { SQLITE_ERROR [ sqlite-statement-error ] }
+ [ throw-sqlite-error ]
+ } case ;
: sqlite-open ( path -- db )
normalize-path
dup sqlite-#columns [ sqlite-column ] with map ;
: sqlite-step-has-more-rows? ( prepared -- bool )
- dup SQLITE_ROW = [
- drop t
- ] [
- dup SQLITE_DONE =
- [ drop ] [ sqlite-check-result ] if f
- ] if ;
+ {
+ { SQLITE_ROW [ t ] }
+ { SQLITE_DONE [ f ] }
+ [ sqlite-check-result f ]
+ } case ;
: sqlite-next ( prepared -- ? )
sqlite3_step sqlite-step-has-more-rows? ;
swap >>path ;
M: sqlite-db db-open ( db -- db )
- [ path>> sqlite-open ] [ swap >>handle ] bi ;
+ dup path>> sqlite-open >>handle ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
{ "default" [ first number>string join-space ] }
[ 2drop ]
} case ;
-
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
-db.postgresql accessors random math.bitfields.lib ;
+db.postgresql accessors random math.bitfields.lib
+math.ranges strings sequences.lib ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
: test-sqlite ( quot -- )
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
-: test-postgresql ( -- )
->r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
+: test-postgresql ( quot -- )
+ >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
TUPLE: exam id name score ;
+: random-exam ( -- exam )
+ f
+ 6 [ CHAR: a CHAR: b [a,b] random ] replicate >string
+ 100 random
+ exam boa ;
+
: test-intervals ( -- )
exam "EXAM"
{
] test-postgresql
-TUPLE: suparclass a ;
+TUPLE: suparclass id a ;
suparclass f {
{ "id" "ID" +db-assigned-id+ }
{ "b" "B" TEXT }
} define-persistent
+TUPLE: fubbclass < subbclass ;
+
+fubbclass "FUBCLASS" { } define-persistent
+
: test-db-inheritance ( -- )
- [ ] [ subbclass ensure-table ] unit-test ;
+ [ ] [ subbclass ensure-table ] unit-test
+ [ ] [ fubbclass ensure-table ] unit-test
+
+ [ ] [
+ subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
+ ] unit-test
+
+ [ t "hi" 5 ] [
+ subbclass new "id" get >>id select-tuple
+ [ subbclass? ] [ b>> ] [ a>> ] tri
+ ] unit-test
+
+ [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
+
+ [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;
[ test-db-inheritance ] test-sqlite
"db-columns" set-word-prop
"db-relations" set-word-prop ;
-ERROR: not-persistent ;
+ERROR: not-persistent class ;
: db-table ( class -- obj )
- "db-table" word-prop [ not-persistent ] unless* ;
+ dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- obj )
superclasses [ "db-columns" word-prop ] map concat ;
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( tuple class -- obj )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
+TUPLE: advanced-statement group order offset limit ;
+HOOK: <advanced-select-statement> db ( tuple class group order offset limit -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
[ regenerate-params bind-statement* f ] cleanup
] curry 10 retry drop ;
-: resulting-tuple ( row out-params -- tuple )
- dup first class>> new [
+: resulting-tuple ( class row out-params -- tuple )
+ rot class new [
[
>r slot-name>> r> set-slot-named
] curry 2each
] keep ;
-: query-tuples ( statement -- seq )
+: query-tuples ( exemplar-tuple statement -- seq )
[ out-params>> ] keep query-results [
- [ sql-row-typed swap resulting-tuple ] with query-map
+ [ sql-row-typed swap resulting-tuple ] with with query-map
] with-disposal ;
: query-modify-tuple ( tuple statement -- )
: recreate-table ( class -- )
[
- drop-sql-statement make-nonthrowable
- [ execute-statement ] with-disposals
+ [ drop-sql-statement [ execute-statement ] with-disposals
+ ] curry ignore-errors
] [ create-table ] bi ;
: ensure-table ( class -- )
[ bind-tuple ] keep execute-statement
] with-disposal ;
+: do-select ( exemplar-tuple statement -- tuples )
+ [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
+
: select-tuples ( tuple -- tuples )
- dup dup class <select-by-slots-statement> [
- [ bind-tuple ] keep query-tuples
- ] with-disposal ;
+ dup dup class <select-by-slots-statement> do-select ;
-: select-tuple ( tuple -- tuple/f ) select-tuples ?first ;
+: select-tuple ( tuple -- tuple/f )
+ dup dup class f f f 1 <advanced-select-statement>
+ do-select ?first ;
HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n )
- class "slots" word-prop slot-named slot-spec-offset ;
+ class superclasses [ "slots" word-prop ] map concat
+ slot-named slot-spec-offset ;
: get-slot-named ( name obj -- value )
tuck offset-of-slot slot ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-ERROR: name-error name ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: cache-get ( query -- rrs/f )
dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
: message-query ( message -- query ) question-section>> 1st ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name )
+ {
+ { [ dup empty? ] [ "." append ] }
+ { [ dup peek CHAR: . = ] [ ] }
+ { [ t ] [ "." append ] }
+ }
+ cond ;
--- /dev/null
+
+USING: kernel
+ combinators
+ vectors
+ sequences
+ io.sockets
+ accessors
+ combinators.lib
+ newfx
+ dns dns.cache dns.misc ;
+
+IN: dns.forwarding
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! DNS server - caching, forwarding
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (socket) ( -- vec ) V{ f } ;
+
+: socket ( -- socket ) (socket) 1st ;
+
+: init-socket-on-port ( port -- )
+ f swap <inet4> <datagram> 0 (socket) as-mutate ;
+
+: init-socket ( -- ) 53 init-socket-on-port ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (upstream-server) ( -- vec ) V{ f } ;
+
+: upstream-server ( -- ip ) (upstream-server) 1st ;
+
+: set-upstream-server ( ip -- ) 0 (upstream-server) as-mutate ;
+
+: init-upstream-server ( -- )
+ upstream-server not
+ [ resolv-conf-server set-upstream-server ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 1&& <-&& ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rrs? ( obj -- ? ) { [ NX = not ] [ f = not ] } 1&& ;
+
+: query->answer/cache ( query -- rrs/NX/f )
+ dup cache-get* dup { [ rrs? ] [ NX = ] } 1||
+ [ nip ]
+ [
+ drop
+ dup clone CNAME >>type cache-get* dup { [ NX = ] [ f = ] } 1||
+ [ nip ]
+ [ ! query rrs
+ tuck ! rrs query rrs
+ 1st ! rrs query rr/cname
+ rdata>> ! rrs query name
+ >r clone r> >>name ! rrs query
+ query->answer/cache ! rrs rrs/NX/f
+ dup rrs? [ append ] [ nip ] if
+ ]
+ if
+ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: answer-from-cache ( message -- message/f )
+ dup message-query ! message query
+ dup query->answer/cache ! message query rrs/NX/f
+ {
+ { [ dup f = ] [ 3drop f ] }
+ { [ dup NX = ] [ 2drop NAME-ERROR >>rcode ] }
+ { [ t ] [ nip >>answer-section ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: answer-from-server ( message -- message )
+ upstream-server ask-server
+ cache-message ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: find-answer ( message -- message )
+ dup answer-from-cache dup
+ [ nip ]
+ [ drop answer-from-server ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: loop ( -- )
+ socket receive ! byte-array addr-spec
+ swap ! addr-spec byte-array
+ parse-message ! addr-spec message
+ find-answer ! addr-spec message
+ message->ba ! addr-spec byte-array
+ swap ! byte-array addr-spec
+ socket send
+ loop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start ( -- ) init-socket init-upstream-server loop ;
+
+MAIN: start
\ No newline at end of file
--- /dev/null
+
+USING: kernel sequences splitting io.files io.encodings.utf8 random newfx ;
+
+IN: dns.misc
+
+: resolv-conf-servers ( -- seq )
+ "/etc/resolv.conf" utf8 file-lines
+ [ " " split ] map
+ [ 1st "nameserver" = ] filter
+ [ 2nd ] map ;
+
+: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
\ No newline at end of file
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Need to cache records even in the case of name error
-
-: cache-message ( message -- message )
- dup dup rcode>> NAME-ERROR =
- [
- [ question-section>> 1st ]
- [ authority-section>> [ type>> SOA = ] filter random ttl>> ]
- bi
- cache-nx
- ]
- [
- {
- [ answer-section>> cache-add-rrs ]
- [ authority-section>> cache-add-rrs ]
- [ additional-section>> cache-add-rrs ]
- }
- cleave
- ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Ask and cache the records
-
-: ask* ( message -- message ) ask cache-message ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup vector? ! name result ?
[ nip 1st rdata>> ]
: name->ip/cache ( name -- ip )
canonical/cache
dup A IN query boa cache-get ! name result
- {
- {
- [ dup NX = ]
- [ 2drop f ]
- }
- {
- [ dup f = ]
- [ 2drop f ]
- }
{
- [ t ]
- [ nip random rdata>> ]
+ { [ dup NX = ] [ 2drop f ] }
+ { [ dup f = ] [ 2drop f ] }
+ { [ t ] [ nip random rdata>> ] }
}
- }
- cond ;
+ cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/server ( name -- name )
- dup CNAME IN query boa query->message ask* answer-section>>
+ dup CNAME IN query boa query->message ask cache-message answer-section>>
[ type>> CNAME = ] filter dup empty? not
[ nip 1st rdata>> ]
[ drop ]
: name->ip/server ( name -- ip )
canonical/server
- dup A IN query boa query->message ask* answer-section>>
+ dup A IN query boa query->message ask cache-message answer-section>>
[ type>> A = ] filter dup empty? not
[ nip random rdata>> ]
[ 2drop f ]
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: fully-qualified ( name -- name )
- {
- { [ dup empty? ] [ "." append ] }
- { [ dup peek CHAR: . = ] [ ] }
- { [ t ] [ "." append ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: name->ip ( name -- ip )
fully-qualified
dup name->ip/cache dup
--- /dev/null
+
+USING: kernel sequences random accessors dns ;
+
+IN: dns.stub
+
+! Stub resolver
+!
+! Generally useful, but particularly when running a forwarding,
+! caching, nameserver on localhost with multiple Factor instances
+! querying it.
+
+: name->ip ( name -- ip )
+ A IN query boa
+ query->message
+ ask
+ dup rcode>> NAME-ERROR =
+ [ message-query name>> name-error ]
+ [ answer-section>> [ type>> A = ] filter random rdata>> ]
+ if ;
+
--- /dev/null
+USING: kernel furnace.actions validators
+tools.test math math.parser multiline namespaces http
+io.streams.string http.server sequences splitting accessors ;
+IN: furnace.actions.tests
+
+<action>
+ [ "a" param "b" param [ string>number ] bi@ + ] >>display
+"action-1" set
+
+: lf>crlf "\n" split "\r\n" join ;
+
+STRING: action-request-test-1
+GET http://foo/bar?a=12&b=13 HTTP/1.1
+
+blah
+;
+
+[ 25 ] [
+ action-request-test-1 lf>crlf
+ [ read-request ] with-string-reader
+ 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
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors sequences kernel assocs combinators\r
+validators http hashtables namespaces fry continuations locals\r
+io arrays math boxes splitting urls\r
+xml.entities\r
+http.server\r
+http.server.responses\r
+furnace\r
+furnace.flash\r
+html.elements\r
+html.components\r
+html.components\r
+html.templates.chloe\r
+html.templates.chloe.syntax ;\r
+IN: furnace.actions\r
+\r
+SYMBOL: params\r
+\r
+SYMBOL: rest\r
+\r
+: render-validation-messages ( -- )\r
+ validation-messages get\r
+ dup empty? [ drop ] [\r
+ <ul "errors" =class ul>\r
+ [ <li> message>> escape-string write </li> ] each\r
+ </ul>\r
+ ] if ;\r
+\r
+CHLOE: validation-messages drop render-validation-messages ;\r
+\r
+TUPLE: action rest init display validate submit ;\r
+\r
+: new-action ( class -- action )\r
+ new\r
+ [ ] >>init\r
+ [ <400> ] >>display\r
+ [ ] >>validate\r
+ [ <400> ] >>submit ;\r
+\r
+: <action> ( -- action )\r
+ action new-action ;\r
+\r
+: flashed-variables ( -- seq )\r
+ { validation-messages named-validation-messages } ;\r
+\r
+: handle-get ( action -- response )\r
+ '[\r
+ ,\r
+ [ init>> call ]\r
+ [ drop flashed-variables restore-flash ]\r
+ [ display>> call ]\r
+ tri\r
+ ] with-exit-continuation ;\r
+\r
+: validation-failed ( -- * )\r
+ request get method>> "POST" = [ f ] [ <400> ] if exit-with ;\r
+\r
+: (handle-post) ( action -- response )\r
+ [ validate>> call ] [ submit>> call ] bi ;\r
+\r
+: param ( name -- value )\r
+ params get at ;\r
+\r
+: revalidate-url-key "__u" ;\r
+\r
+: check-url ( url -- ? )\r
+ request get url>>\r
+ [ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;\r
+\r
+: revalidate-url ( -- url/f )\r
+ revalidate-url-key param dup [ >url dup check-url swap and ] when ;\r
+\r
+: handle-post ( action -- response )\r
+ '[\r
+ form-nesting-key params get at " " split\r
+ [ , (handle-post) ]\r
+ [ swap '[ , , nest-values ] ] reduce\r
+ call\r
+ ] with-exit-continuation\r
+ [\r
+ revalidate-url\r
+ [ flashed-variables <flash-redirect> ] [ <403> ] if*\r
+ ] unless* ;\r
+\r
+: handle-rest ( path action -- assoc )\r
+ rest>> dup [ [ "/" join ] dip associate ] [ 2drop f ] if ;\r
+\r
+: init-action ( path action -- )\r
+ blank-values\r
+ init-validation\r
+ handle-rest\r
+ request get request-params assoc-union params set ;\r
+\r
+M: action call-responder* ( path action -- response )\r
+ [ init-action ] keep\r
+ request get method>> {\r
+ { "GET" [ handle-get ] }\r
+ { "HEAD" [ handle-get ] }\r
+ { "POST" [ handle-post ] }\r
+ } case ;\r
+\r
+M: action modify-form\r
+ drop request get url>> revalidate-url-key hidden-form-field ;\r
+\r
+: check-validation ( -- )\r
+ validation-failed? [ validation-failed ] when ;\r
+\r
+: validate-params ( validators -- )\r
+ params get swap validate-values from-object\r
+ check-validation ;\r
+\r
+: validate-integer-id ( -- )\r
+ { { "id" [ v-number ] } } validate-params ;\r
+\r
+TUPLE: page-action < action template ;\r
+\r
+: <chloe-content> ( path -- response )\r
+ resolve-template-path <chloe> "text/html" <content> ;\r
+\r
+: <page-action> ( -- page )\r
+ page-action new-action\r
+ dup '[ , template>> <chloe-content> ] >>display ;\r
--- /dev/null
+! 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 ;
--- /dev/null
+! Copyright (c) 2008 Slava Pestov\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors assocs namespaces kernel sequences sets\r
+http.server\r
+http.server.filters\r
+http.server.dispatchers\r
+furnace.sessions\r
+furnace.auth.providers ;\r
+IN: furnace.auth\r
+\r
+SYMBOL: logged-in-user\r
+\r
+GENERIC: init-user-profile ( responder -- )\r
+\r
+M: object init-user-profile drop ;\r
+\r
+M: dispatcher init-user-profile\r
+ default>> init-user-profile ;\r
+\r
+M: filter-responder init-user-profile\r
+ responder>> init-user-profile ;\r
+\r
+: profile ( -- assoc ) logged-in-user get profile>> ;\r
+\r
+: user-changed ( -- )\r
+ logged-in-user get t >>changed? drop ;\r
+\r
+: uget ( key -- value )\r
+ profile at ;\r
+\r
+: uset ( value key -- )\r
+ profile set-at\r
+ user-changed ;\r
+\r
+: uchange ( quot key -- )\r
+ profile swap change-at\r
+ user-changed ; inline\r
+\r
+SYMBOL: capabilities\r
+\r
+V{ } clone capabilities set-global\r
+\r
+: define-capability ( word -- ) capabilities get adjoin ;\r
--- /dev/null
+! Copyright (c) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors quotations assocs kernel splitting\r
+base64 html.elements io combinators sequences\r
+http http.server.filters http.server.responses http.server\r
+furnace.auth.providers furnace.auth.login ;\r
+IN: furnace.auth.basic\r
+\r
+TUPLE: basic-auth < filter-responder realm provider ;\r
+\r
+C: <basic-auth> basic-auth\r
+\r
+: authorization-ok? ( provider header -- ? )\r
+ #! Given the realm and the 'Authorization' header,\r
+ #! authenticate the user.\r
+ dup [\r
+ " " split1 swap "Basic" = [\r
+ base64> ":" split1 spin check-login\r
+ ] [\r
+ 2drop f\r
+ ] if\r
+ ] [\r
+ 2drop f\r
+ ] if ;\r
+\r
+: <401> ( realm -- response )\r
+ 401 "Unauthorized" <trivial-response>\r
+ "Basic realm=\"" rot "\"" 3append\r
+ "WWW-Authenticate" set-header\r
+ [\r
+ <html> <body>\r
+ "Username or Password is invalid" write\r
+ </body> </html>\r
+ ] >>body ;\r
+\r
+: logged-in? ( request responder -- ? )\r
+ provider>> swap "authorization" header authorization-ok? ;\r
+\r
+M: basic-auth call-responder* ( request path responder -- response )\r
+ pick over logged-in?\r
+ [ call-next-method ] [ 2nip realm>> <401> ] if ;\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Profile</t:title>
+
+ <t:form t:action="$login/edit-profile">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:label t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Current password:</th>
+ <td><t:password t:name="password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you don't want to change your current password, leave this field blank.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you are changing your password, enter it twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Update" />
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+IN: furnace.auth.login.tests\r
+USING: tools.test furnace.auth.login ;\r
+\r
+\ <login> must-infer\r
+\ allow-registration must-infer\r
+\ allow-password-recovery must-infer\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors quotations assocs kernel splitting\r
+combinators sequences namespaces hashtables sets\r
+fry arrays threads qualified random validators words\r
+io\r
+io.sockets\r
+io.encodings.utf8\r
+io.encodings.string\r
+io.binary\r
+continuations\r
+destructors\r
+checksums\r
+checksums.sha2\r
+validators\r
+html.components\r
+html.elements\r
+urls\r
+http\r
+http.server\r
+http.server.dispatchers\r
+http.server.filters\r
+http.server.responses\r
+furnace\r
+furnace.auth\r
+furnace.auth.providers\r
+furnace.auth.providers.db\r
+furnace.actions\r
+furnace.asides\r
+furnace.flash\r
+furnace.sessions\r
+furnace.boilerplate ;\r
+QUALIFIED: smtp\r
+IN: furnace.auth.login\r
+\r
+: word>string ( word -- string )\r
+ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ;\r
+\r
+: words>strings ( seq -- seq' )\r
+ [ word>string ] map ;\r
+\r
+: string>word ( string -- word )\r
+ ":" split1 swap lookup ;\r
+\r
+: strings>words ( seq -- seq' )\r
+ [ string>word ] map ;\r
+\r
+TUPLE: login < dispatcher users checksum ;\r
+\r
+TUPLE: protected < filter-responder description capabilities ;\r
+\r
+: users ( -- provider )\r
+ login get users>> ;\r
+\r
+: encode-password ( string salt -- bytes )\r
+ [ utf8 encode ] [ 4 >be ] bi* append\r
+ login get checksum>> checksum-bytes ;\r
+\r
+: >>encoded-password ( user string -- user )\r
+ 32 random-bits [ encode-password ] keep\r
+ [ >>password ] [ >>salt ] bi* ; inline\r
+\r
+: valid-login? ( password user -- ? )\r
+ [ salt>> encode-password ] [ password>> ] bi = ;\r
+\r
+: check-login ( password username -- user/f )\r
+ users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
+\r
+! Destructor\r
+TUPLE: user-saver user ;\r
+\r
+C: <user-saver> user-saver\r
+\r
+M: user-saver dispose\r
+ user>> dup changed?>> [ users update-user ] [ drop ] if ;\r
+\r
+: save-user-after ( user -- )\r
+ <user-saver> &dispose drop ;\r
+\r
+! ! ! Login\r
+: successful-login ( user -- response )\r
+ username>> set-uid URL" $login" end-aside ;\r
+\r
+: login-failed ( -- * )\r
+ "invalid username or password" validation-error\r
+ validation-failed ;\r
+\r
+: <login-action> ( -- action )\r
+ <page-action>\r
+ [\r
+ protected fget [\r
+ [ description>> "description" set-value ]\r
+ [ capabilities>> words>strings "capabilities" set-value ] bi\r
+ ] when*\r
+ ] >>init\r
+\r
+ { login "login" } >>template\r
+\r
+ [\r
+ {\r
+ { "username" [ v-required ] }\r
+ { "password" [ v-required ] }\r
+ } validate-params\r
+\r
+ "password" value\r
+ "username" value check-login\r
+ [ successful-login ] [ login-failed ] if*\r
+ ] >>submit ;\r
+\r
+! ! ! New user registration\r
+\r
+: user-exists ( -- * )\r
+ "username taken" validation-error\r
+ validation-failed ;\r
+\r
+: password-mismatch ( -- * )\r
+ "passwords do not match" validation-error\r
+ validation-failed ;\r
+\r
+: same-password-twice ( -- )\r
+ "new-password" value "verify-password" value =\r
+ [ password-mismatch ] unless ;\r
+\r
+: <register-action> ( -- action )\r
+ <page-action>\r
+ { login "register" } >>template\r
+\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "realname" [ [ v-one-line ] v-optional ] }\r
+ { "new-password" [ v-password ] }\r
+ { "verify-password" [ v-password ] }\r
+ { "email" [ [ v-email ] v-optional ] }\r
+ { "captcha" [ v-captcha ] }\r
+ } validate-params\r
+\r
+ same-password-twice\r
+ ] >>validate\r
+\r
+ [\r
+ "username" value <user>\r
+ "realname" value >>realname\r
+ "new-password" value >>encoded-password\r
+ "email" value >>email\r
+ H{ } clone >>profile\r
+\r
+ users new-user [ user-exists ] unless*\r
+\r
+ login get init-user-profile\r
+\r
+ successful-login\r
+ ] >>submit ;\r
+\r
+! ! ! Editing user profile\r
+\r
+: <edit-profile-action> ( -- action )\r
+ <page-action>\r
+ [\r
+ logged-in-user get\r
+ [ username>> "username" set-value ]\r
+ [ realname>> "realname" set-value ]\r
+ [ email>> "email" set-value ]\r
+ tri\r
+ ] >>init\r
+\r
+ { login "edit-profile" } >>template\r
+\r
+ [\r
+ uid "username" set-value\r
+\r
+ {\r
+ { "realname" [ [ v-one-line ] v-optional ] }\r
+ { "password" [ ] }\r
+ { "new-password" [ [ v-password ] v-optional ] }\r
+ { "verify-password" [ [ v-password ] v-optional ] } \r
+ { "email" [ [ v-email ] v-optional ] }\r
+ } validate-params\r
+\r
+ { "password" "new-password" "verify-password" }\r
+ [ value empty? not ] contains? [\r
+ "password" value uid check-login\r
+ [ "incorrect password" validation-error ] unless\r
+\r
+ same-password-twice\r
+ ] when\r
+ ] >>validate\r
+\r
+ [\r
+ logged-in-user get\r
+\r
+ "new-password" value dup empty?\r
+ [ drop ] [ >>encoded-password ] if\r
+\r
+ "realname" value >>realname\r
+ "email" value >>email\r
+\r
+ t >>changed?\r
+\r
+ drop\r
+\r
+ URL" $login" end-aside\r
+ ] >>submit ;\r
+\r
+! ! ! Password recovery\r
+\r
+SYMBOL: lost-password-from\r
+\r
+: current-host ( -- string )\r
+ request get url>> host>> host-name or ;\r
+\r
+: new-password-url ( user -- url )\r
+ "recover-3"\r
+ swap [\r
+ [ username>> "username" set ]\r
+ [ ticket>> "ticket" set ]\r
+ bi\r
+ ] H{ } make-assoc\r
+ derive-url ;\r
+\r
+: password-email ( user -- email )\r
+ smtp:<email>\r
+ [ "[ " % current-host % " ] password recovery" % ] "" make >>subject\r
+ lost-password-from get >>from\r
+ over email>> 1array >>to\r
+ [\r
+ "This e-mail was sent by the application server on " % current-host % "\n" %\r
+ "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %\r
+ "login form, and requested a new password for the user named ``" %\r
+ over username>> % "''.\n" %\r
+ "\n" %\r
+ "If you believe that this request was legitimate, you may click the below link in\n" %\r
+ "your browser to set a new password for your account:\n" %\r
+ "\n" %\r
+ swap new-password-url %\r
+ "\n\n" %\r
+ "Love,\n" %\r
+ "\n" %\r
+ " FactorBot\n" %\r
+ ] "" make >>body ;\r
+\r
+: send-password-email ( user -- )\r
+ '[ , password-email smtp:send-email ]\r
+ "E-mail send thread" spawn drop ;\r
+\r
+: <recover-action-1> ( -- action )\r
+ <page-action>\r
+ { login "recover-1" } >>template\r
+\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "email" [ v-email ] }\r
+ { "captcha" [ v-captcha ] }\r
+ } validate-params\r
+ ] >>validate\r
+\r
+ [\r
+ "email" value "username" value\r
+ users issue-ticket [\r
+ send-password-email\r
+ ] when*\r
+\r
+ URL" $login/recover-2" <redirect>\r
+ ] >>submit ;\r
+\r
+: <recover-action-2> ( -- action )\r
+ <page-action>\r
+ { login "recover-2" } >>template ;\r
+\r
+: <recover-action-3> ( -- action )\r
+ <page-action>\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "ticket" [ v-required ] }\r
+ } validate-params\r
+ ] >>init\r
+\r
+ { login "recover-3" } >>template\r
+\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "ticket" [ v-required ] }\r
+ { "new-password" [ v-password ] }\r
+ { "verify-password" [ v-password ] }\r
+ } validate-params\r
+\r
+ same-password-twice\r
+ ] >>validate\r
+\r
+ [\r
+ "ticket" value\r
+ "username" value\r
+ users claim-ticket [\r
+ "new-password" value >>encoded-password\r
+ users update-user\r
+\r
+ URL" $login/recover-4" <redirect>\r
+ ] [\r
+ <403>\r
+ ] if*\r
+ ] >>submit ;\r
+\r
+: <recover-action-4> ( -- action )\r
+ <page-action>\r
+ { login "recover-4" } >>template ;\r
+\r
+! ! ! Logout\r
+: <logout-action> ( -- action )\r
+ <action>\r
+ [\r
+ f set-uid\r
+ URL" $login" end-aside\r
+ ] >>submit ;\r
+\r
+! ! ! Authentication logic\r
+: <protected> ( responder -- protected )\r
+ protected new\r
+ swap >>responder ;\r
+\r
+: show-login-page ( -- response )\r
+ begin-aside\r
+ URL" $login/login" { protected } <flash-redirect> ;\r
+\r
+: check-capabilities ( responder user -- ? )\r
+ [ capabilities>> ] bi@ subset? ;\r
+\r
+M: protected call-responder* ( path responder -- response )\r
+ dup protected set\r
+ uid dup [\r
+ users get-user 2dup check-capabilities [\r
+ [ logged-in-user set ] [ save-user-after ] bi\r
+ call-next-method\r
+ ] [\r
+ 3drop show-login-page\r
+ ] if\r
+ ] [\r
+ 3drop show-login-page\r
+ ] if ;\r
+\r
+M: login call-responder* ( path responder -- response )\r
+ dup login set\r
+ call-next-method ;\r
+\r
+: <login-boilerplate> ( responder -- responder' )\r
+ <boilerplate>\r
+ { login "boilerplate" } >>template ;\r
+\r
+: <login> ( responder -- auth )\r
+ login new-dispatcher\r
+ swap >>default\r
+ <login-action> <login-boilerplate> "login" add-responder\r
+ <logout-action> <login-boilerplate> "logout" add-responder\r
+ users-in-db >>users\r
+ sha-256 >>checksum ;\r
+\r
+! ! ! Configuration\r
+\r
+: allow-edit-profile ( login -- login )\r
+ <edit-profile-action> <protected>\r
+ "edit your profile" >>description\r
+ <login-boilerplate>\r
+ "edit-profile" add-responder ;\r
+\r
+: allow-registration ( login -- login )\r
+ <register-action> <login-boilerplate>\r
+ "register" add-responder ;\r
+\r
+: allow-password-recovery ( login -- login )\r
+ <recover-action-1> <login-boilerplate>\r
+ "recover-password" add-responder\r
+ <recover-action-2> <login-boilerplate>\r
+ "recover-2" add-responder\r
+ <recover-action-3> <login-boilerplate>\r
+ "recover-3" add-responder\r
+ <recover-action-4> <login-boilerplate>\r
+ "recover-4" add-responder ;\r
+\r
+: allow-edit-profile? ( -- ? )\r
+ login get responders>> "edit-profile" swap key? ;\r
+\r
+: allow-registration? ( -- ? )\r
+ login get responders>> "register" swap key? ;\r
+\r
+: allow-password-recovery? ( -- ? )\r
+ login get responders>> "recover-password" swap key? ;\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <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>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="password" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Log in" />
+ <t:validation-messages />
+
+ </p>
+
+ </t:form>
+
+ <p>
+ <t:if t:code="furnace.auth.login:allow-registration?">
+ <t:a t:href="register">Register</t:a>
+ </t:if>
+ |
+ <t:if t:code="furnace.auth.login:allow-password-recovery?">
+ <t:a t:href="recover-password">Recover Password</t:a>
+ </t:if>
+ </p>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 1 of 4</t:title>
+
+ <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
+
+ <t:form t:action="recover-password">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <input type="submit" value="Recover password" />
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 2 of 4</t:title>
+
+ <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 3 of 4</t:title>
+
+ <p>Choose a new password for your account.</p>
+
+ <t:form t:action="new-password">
+
+ <table>
+
+ <t:hidden t:name="username" />
+ <t:hidden t:name="ticket" />
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify password:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Set password" />
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>\r
+\r
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
+\r
+ <t:title>Recover lost password: step 4 of 4</t:title>\r
+\r
+ <p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>\r
+\r
+</t:chloe>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User Registration</t:title>
+
+ <t:form t:action="register">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Register" />
+ <t:validation-messages />
+
+ </p>
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+IN: furnace.auth.providers.assoc.tests\r
+USING: furnace.actions furnace.auth.providers \r
+furnace.auth.providers.assoc furnace.auth.login\r
+tools.test namespaces accessors kernel ;\r
+\r
+<action> <login>\r
+ <users-in-memory> >>users\r
+login set\r
+\r
+[ t ] [\r
+ "slava" <user>\r
+ "foobar" >>encoded-password\r
+ "slava@factorcode.org" >>email\r
+ H{ } clone >>profile\r
+ users new-user\r
+ username>> "slava" =\r
+] unit-test\r
+\r
+[ f ] [\r
+ "slava" <user>\r
+ H{ } clone >>profile\r
+ users new-user\r
+] unit-test\r
+\r
+[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
+\r
+[ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
+\r
+[ t ] [ "user" get >boolean ] unit-test\r
+\r
+[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
+\r
+[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
+\r
+[ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+IN: furnace.auth.providers.assoc\r
+USING: accessors assocs kernel furnace.auth.providers ;\r
+\r
+TUPLE: users-in-memory assoc ;\r
+\r
+: <users-in-memory> ( -- provider )\r
+ H{ } clone users-in-memory boa ;\r
+\r
+M: users-in-memory get-user ( username provider -- user/f )\r
+ assoc>> at ;\r
+\r
+M: users-in-memory update-user ( user provider -- ) 2drop ;\r
+\r
+M: users-in-memory new-user ( user provider -- user/f )\r
+ [ dup username>> ] dip assoc>>\r
+ 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;\r
--- /dev/null
+IN: furnace.auth.providers.db.tests\r
+USING: furnace.actions\r
+furnace.auth.login\r
+furnace.auth.providers\r
+furnace.auth.providers.db tools.test\r
+namespaces db db.sqlite db.tuples continuations\r
+io.files accessors kernel ;\r
+\r
+<action> <login>\r
+ users-in-db >>users\r
+login set\r
+\r
+[ "auth-test.db" temp-file delete-file ] ignore-errors\r
+\r
+"auth-test.db" temp-file sqlite-db [\r
+\r
+ init-users-table\r
+\r
+ [ t ] [\r
+ "slava" <user>\r
+ "foobar" >>encoded-password\r
+ "slava@factorcode.org" >>email\r
+ H{ } clone >>profile\r
+ users new-user\r
+ username>> "slava" =\r
+ ] unit-test\r
+\r
+ [ f ] [\r
+ "slava" <user>\r
+ H{ } clone >>profile\r
+ users new-user\r
+ ] unit-test\r
+\r
+ [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
+\r
+ [ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
+\r
+ [ t ] [ "user" get >boolean ] unit-test\r
+\r
+ [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
+\r
+ [ ] [ "user" get users update-user ] unit-test\r
+\r
+ [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
+\r
+ [ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
+] with-db\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.tuples db.types accessors
+furnace.auth.providers kernel continuations
+classes.singleton ;
+IN: furnace.auth.providers.db
+
+user "USERS"
+{
+ { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
+ { "realname" "REALNAME" { VARCHAR 256 } }
+ { "password" "PASSWORD" BLOB +not-null+ }
+ { "salt" "SALT" INTEGER +not-null+ }
+ { "email" "EMAIL" { VARCHAR 256 } }
+ { "ticket" "TICKET" { VARCHAR 256 } }
+ { "capabilities" "CAPABILITIES" FACTOR-BLOB }
+ { "profile" "PROFILE" FACTOR-BLOB }
+ { "deleted" "DELETED" INTEGER +not-null+ }
+} define-persistent
+
+: init-users-table user ensure-table ;
+
+SINGLETON: users-in-db
+
+M: users-in-db get-user
+ drop <user> select-tuple ;
+
+M: users-in-db new-user
+ drop
+ [
+ user new
+ over username>> >>username
+ select-tuple [
+ drop f
+ ] [
+ dup insert-tuple
+ ] if
+ ] with-transaction ;
+
+M: users-in-db update-user
+ drop update-tuple ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: furnace.auth.providers kernel ;\r
+IN: furnace.auth.providers.null\r
+\r
+TUPLE: no-users ;\r
+\r
+: no-users T{ no-users } ;\r
+\r
+M: no-users get-user 2drop f ;\r
+\r
+M: no-users new-user 2drop f ;\r
+\r
+M: no-users update-user 2drop ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel accessors random math.parser locals\r
+sequences math ;\r
+IN: furnace.auth.providers\r
+\r
+TUPLE: user\r
+username realname\r
+password salt\r
+email ticket capabilities profile deleted changed? ;\r
+\r
+: <user> ( username -- user )\r
+ user new\r
+ swap >>username\r
+ 0 >>deleted ;\r
+\r
+GENERIC: get-user ( username provider -- user/f )\r
+\r
+GENERIC: update-user ( user provider -- )\r
+\r
+GENERIC: new-user ( user provider -- user/f )\r
+\r
+! Password recovery support\r
+\r
+:: issue-ticket ( email username provider -- user/f )\r
+ [let | user [ username provider get-user ] |\r
+ user [\r
+ user email>> length 0 > [\r
+ user email>> email = [\r
+ user\r
+ 256 random-bits >hex >>ticket\r
+ dup provider update-user\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] ;\r
+\r
+:: claim-ticket ( ticket username provider -- user/f )\r
+ [let | user [ username provider get-user ] |\r
+ user [\r
+ user ticket>> ticket = [\r
+ user f >>ticket dup provider update-user\r
+ ] [ f ] if\r
+ ] [ f ] if\r
+ ] ;\r
+\r
+! For configuration\r
+\r
+: add-user ( provider user -- provider )\r
+ over new-user [ "User exists" throw ] when ;\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces
+html.templates html.templates.chloe
+locals
+http.server
+http.server.filters
+furnace ;
+IN: furnace.boilerplate
+
+TUPLE: boilerplate < filter-responder template ;
+
+: <boilerplate> f boilerplate boa ;
+
+M:: boilerplate call-responder* ( path responder -- )
+ path responder call-next-method
+ dup content-type>> "text/html" = [
+ clone [| body |
+ [
+ body
+ responder template>> resolve-template-path <chloe>
+ with-boilerplate
+ ]
+ ] change-body
+ ] when ;
--- /dev/null
+IN: furnace.db.tests
+USING: tools.test furnace.db ;
+
+\ <db-persistence> must-infer
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel accessors continuations namespaces destructors\r
+db db.pools io.pools http.server http.server.filters\r
+furnace.sessions ;\r
+IN: furnace.db\r
+\r
+TUPLE: db-persistence < filter-responder pool ;\r
+\r
+: <db-persistence> ( responder params db -- responder' )\r
+ <db-pool> db-persistence boa ;\r
+\r
+M: db-persistence call-responder*\r
+ [\r
+ pool>> [ acquire-connection ] keep\r
+ [ return-connection-later ] [ drop db set ] 2bi\r
+ ]\r
+ [ call-next-method ] bi ;\r
--- /dev/null
+! 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 ;
--- /dev/null
+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
--- /dev/null
+! 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 [ hidden render ] 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 ;
--- /dev/null
+! 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> ;
--- /dev/null
+Doug Coleman
--- /dev/null
+IN: furnace.sessions.tests\r
+USING: tools.test http furnace.sessions\r
+furnace.actions http.server http.server.responses\r
+math namespaces kernel accessors\r
+prettyprint io.streams.string io.files splitting destructors\r
+sequences db db.sqlite continuations urls math.parser\r
+furnace ;\r
+\r
+: with-session\r
+ [\r
+ [ [ save-session-after ] [ session set ] bi ] dip call\r
+ ] with-destructors ; inline\r
+\r
+TUPLE: foo ;\r
+\r
+C: <foo> foo\r
+\r
+M: foo init-session* drop 0 "x" sset ;\r
+\r
+M: foo call-responder*\r
+ 2drop\r
+ "x" [ 1+ ] schange\r
+ "x" sget number>string "text/html" <content> ;\r
+\r
+: url-responder-mock-test\r
+ [\r
+ <request>\r
+ "GET" >>method\r
+ dup url>>\r
+ "id" get session-id-key set-query-param\r
+ "/" >>path drop\r
+ init-request\r
+ { } sessions get call-responder\r
+ [ write-response-body drop ] with-string-writer\r
+ ] with-destructors ;\r
+\r
+: sessions-mock-test\r
+ [\r
+ <request>\r
+ "GET" >>method\r
+ "cookies" get >>cookies\r
+ dup url>> "/" >>path drop\r
+ init-request\r
+ { } sessions get call-responder\r
+ [ write-response-body drop ] with-string-writer\r
+ ] with-destructors ;\r
+\r
+: <exiting-action>\r
+ <action>\r
+ [ [ ] "text/plain" <content> exit-with ] >>display ;\r
+\r
+[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors\r
+\r
+"auth-test.db" temp-file sqlite-db [\r
+\r
+ <request> init-request\r
+ init-sessions-table\r
+\r
+ [ ] [\r
+ <foo> <sessions>\r
+ sessions set\r
+ ] unit-test\r
+\r
+ [\r
+ [ ] [\r
+ empty-session\r
+ 123 >>id session set\r
+ ] unit-test\r
+\r
+ [ ] [ 3 "x" sset ] unit-test\r
+\r
+ [ 9 ] [ "x" sget sq ] unit-test\r
+\r
+ [ ] [ "x" [ 1- ] schange ] unit-test\r
+\r
+ [ 4 ] [ "x" sget sq ] unit-test\r
+\r
+ [ t ] [ session get changed?>> ] unit-test\r
+ ] with-scope\r
+\r
+ [ t ] [\r
+ begin-session id>>\r
+ get-session session?\r
+ ] unit-test\r
+\r
+ [ { 5 0 } ] [\r
+ [\r
+ begin-session\r
+ dup [ 5 "a" sset ] with-session\r
+ dup [ "a" sget , ] with-session\r
+ dup [ "x" sget , ] with-session\r
+ drop\r
+ ] { } make\r
+ ] unit-test\r
+\r
+ [ 0 ] [\r
+ begin-session id>>\r
+ get-session [ "x" sget ] with-session\r
+ ] unit-test\r
+\r
+ [ { 5 0 } ] [\r
+ [\r
+ begin-session id>>\r
+ dup get-session [ 5 "a" sset ] with-session\r
+ dup get-session [ "a" sget , ] with-session\r
+ dup get-session [ "x" sget , ] with-session\r
+ drop\r
+ ] { } make\r
+ ] unit-test\r
+\r
+ [ ] [\r
+ <foo> <sessions>\r
+ sessions set\r
+ ] unit-test\r
+\r
+ [\r
+ <request>\r
+ "GET" >>method\r
+ dup url>> "/" >>path drop\r
+ request set\r
+ { "etc" } sessions get call-responder response set\r
+ [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
+ response get\r
+ ] with-destructors\r
+ response set\r
+\r
+ [ ] [ response get cookies>> "cookies" set ] unit-test\r
+\r
+ [ "2" ] [ sessions-mock-test ] unit-test\r
+ [ "3" ] [ sessions-mock-test ] unit-test\r
+ [ "4" ] [ sessions-mock-test ] unit-test\r
+\r
+ [\r
+ [ ] [\r
+ <request>\r
+ "GET" >>method\r
+ dup url>>\r
+ "id" get session-id-key set-query-param\r
+ "/" >>path drop\r
+ request set\r
+\r
+ [\r
+ { } <exiting-action> <sessions>\r
+ call-responder\r
+ ] with-destructors response set\r
+ ] unit-test\r
+\r
+ [ "text/plain" ] [ response get content-type>> ] unit-test\r
+\r
+ [ f ] [ response get cookies>> empty? ] unit-test\r
+ ] with-scope\r
+] with-db\r
--- /dev/null
+! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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 http.server.dispatchers http.server.filters
+html.elements furnace ;
+IN: furnace.sessions
+
+TUPLE: session id expires uid namespace changed? ;
+
+: <session> ( id -- session )
+ session new
+ swap >>id ;
+
+session "SESSIONS"
+{
+ { "id" "ID" +random-id+ system-random-generator }
+ { "expires" "EXPIRES" TIMESTAMP +not-null+ }
+ { "uid" "UID" { VARCHAR 255 } }
+ { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: get-session ( id -- session )
+ dup [ <session> select-tuple ] when ;
+
+: init-sessions-table session ensure-table ;
+
+: start-expiring-sessions ( db seq -- )
+ '[
+ , , [
+ session new
+ -1.0/0.0 now [a,b] >>expires
+ delete-tuples
+ ] with-db
+ ] 5 minutes every drop ;
+
+GENERIC: init-session* ( responder -- )
+
+M: object init-session* drop ;
+
+M: dispatcher init-session* default>> init-session* ;
+
+M: filter-responder init-session* responder>> init-session* ;
+
+TUPLE: sessions < filter-responder timeout domain ;
+
+: <sessions> ( responder -- responder' )
+ sessions new
+ swap >>responder
+ 20 minutes >>timeout ;
+
+: (session-changed) ( session -- )
+ t >>changed? drop ;
+
+: session-changed ( -- )
+ session get (session-changed) ;
+
+: sget ( key -- value )
+ session get namespace>> at ;
+
+: sset ( value key -- )
+ session get
+ [ namespace>> set-at ] [ (session-changed) ] bi ;
+
+: schange ( key quot -- )
+ session get
+ [ namespace>> swap change-at ] keep
+ (session-changed) ; inline
+
+: uid ( -- uid )
+ session get uid>> ;
+
+: set-uid ( uid -- )
+ session get [ (>>uid) ] [ (session-changed) ] bi ;
+
+: init-session ( session -- )
+ session [ sessions get init-session* ] with-variable ;
+
+: cutoff-time ( -- time )
+ sessions get timeout>> from-now ;
+
+: touch-session ( session -- )
+ cutoff-time >>expires drop ;
+
+: empty-session ( -- session )
+ f <session>
+ H{ } clone >>namespace
+ dup touch-session ;
+
+: begin-session ( -- session )
+ empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
+
+! Destructor
+TUPLE: session-saver session ;
+
+C: <session-saver> session-saver
+
+M: session-saver dispose
+ session>> dup changed?>> [
+ [ touch-session ] [ update-tuple ] bi
+ ] [ drop ] if ;
+
+: save-session-after ( session -- )
+ <session-saver> &dispose drop ;
+
+: existing-session ( path session -- response )
+ [ session set ] [ save-session-after ] bi
+ sessions get responder>> call-responder ;
+
+: 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 request-params at string>number ;
+
+: request-session-id ( -- id/f )
+ request get dup method>> {
+ { "GET" [ cookie-session-id ] }
+ { "HEAD" [ cookie-session-id ] }
+ { "POST" [ post-session-id ] }
+ } case ;
+
+: request-session ( -- session/f )
+ request-session-id get-session ;
+
+: <session-cookie> ( id -- cookie )
+ session-id-key <cookie>
+ "$sessions" resolve-base-path >>path
+ sessions get timeout>> from-now >>expires
+ sessions get domain>> >>domain ;
+
+: put-session-cookie ( response -- response' )
+ session get id>> number>string <session-cookie> put-cookie ;
+
+M: sessions modify-form ( responder -- )
+ drop session get id>> session-id-key hidden-form-field ;
+
+M: sessions call-responder* ( path responder -- response )
+ sessions set
+ request-session [ begin-session ] unless*
+ existing-session put-session-cookie ;
+
+: logout-all-sessions ( uid -- )
+ session new swap >>uid delete-tuples ;
--- /dev/null
+! 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 ;
! 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
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
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
[ ] [ 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>
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
: 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 ;
: 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-assoc ( seq quot -- )
- '[ from-assoc @ ] with-each-index ; inline
-
-: with-each-tuple ( seq quot -- )
- '[ from-tuple @ ] 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-assoc-values ( assoc quot -- )
- '[ blank-values , from-assoc @ ] with-scope ; inline
+SYMBOL: nested-values
-: 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 [
] 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 -- )
<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
: 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 ;
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
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
- object>string escape-string write
+ present escape-string write
</option> ;
: render-options ( options selected -- )
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
<input
"checkbox" =type
swap =name
- swap [ "true" =selected ] when
+ swap [ "true" =checked ] when
input>
label>> escape-string write
</input> ;
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
! 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
" " 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 } ;
"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
>>
<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> ;
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 ;
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
: test-template ( name -- template )
"resource:extra/html/templates/chloe/test/"
- swap
- ".xml" 3append <chloe> ;
+ prepend <chloe> ;
[ "Hello world" ] [
[
] 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
[ "<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
[ "<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
] 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
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 ;
DEFER: process-template
-: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-
: chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = ] assoc-filter ;
[ 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
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 ;
-
-: write-atom-tag ( tag -- )
- drop
- "head" tags get member? [
- write-atom-feed
- ] [
- atom-feed get value>> second write
- ] 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 -- )
- [
- <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 ;
-
-: a-tag ( tag -- )
- [ a-start-tag ]
- [ process-tag-children ]
- [ drop </a> ]
- tri ;
-
-: 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 ;
-
-: form-tag ( tag -- )
- [ form-start-tag ]
- [ process-tag-children ]
- [ drop </form> ]
- tri ;
-
-DEFER: process-chloe-tag
-
-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 ;
-
-: 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 ;
-
-: 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 ;
-
-: if-tag ( tag -- )
- dup if-satisfied? [ process-tag-children ] [ drop ] if ;
-
-: even-tag ( tag -- )
- "index" value even? [ process-tag-children ] [ drop ] if ;
-
-: odd-tag ( tag -- )
- "index" value odd? [ process-tag-children ] [ drop ] if ;
+CHLOE: even "index" value even? [ 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) ;
+CHLOE: odd "index" value odd? [ process-tag-children ] [ drop ] if ;
: (bind-tag) ( tag quot -- )
[
- [ "name" required-attr value ] keep
+ [ "name" required-attr ] keep
'[ , process-tag-children ]
] dip call ; inline
-: bind-tuple-tag ( tag -- )
- [ with-tuple-values ] (bind-tag) ;
+CHLOE: each [ with-each-value ] (bind-tag) ;
-: bind-assoc-tag ( tag -- )
- [ with-assoc-values ] (bind-tag) ;
+CHLOE: bind-each [ with-each-object ] (bind-tag) ;
+
+CHLOE: bind [ with-values ] (bind-tag) ;
: error-message-tag ( tag -- )
children>string render-error ;
-: validation-messages-tag ( tag -- )
- drop render-validation-messages ;
+CHLOE: comment drop ;
-: singleton-component-tag ( tag class -- )
- [ "name" required-attr ] dip render ;
+CHLOE: call-next-template drop call-next-template ;
-: attrs>slots ( tag tuple -- )
- [ attrs>> ] [ <mirror> ] bi*
- '[
- swap tag>> dup "name" =
- [ 2drop ] [ , set-at ] if
- ] assoc-each ;
+: attr>word ( value -- word/f )
+ dup ":" split1 swap lookup
+ [ ] [ "No such word: " swap append throw ] ?if ;
-: tuple-component-tag ( tag class -- )
- [ drop "name" required-attr ]
- [ new [ attrs>slots ] keep ]
- 2bi render ;
+: if-satisfied? ( tag -- ? )
+ [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+ [ "value" optional-attr [ value ] [ t ] if* ]
+ bi and ;
+
+CHLOE: if dup if-satisfied? [ 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
+
+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 ] }
: process-chloe ( xml -- )
[
- V{ } clone tags set
+ V{ } clone tag-stack set
nested-template? get [
process-template
] 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
--- /dev/null
+! 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
<?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>
<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>
--- /dev/null
+<?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>
<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>
<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>
<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>
<?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>
! 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
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 ;
: 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?
: 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
[
[
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
[
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
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 ;
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
: http-request ( request -- response data )
dup request [
- dup request-addr latin1 [
+ dup url>> url-addr latin1 [
1 minutes timeouts
write-request
read-response
: <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 ;
: 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 ;
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{ }
}
] [
] 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
[
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{ }
}
] [
] 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
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF8" } }
- cookies: V{ }
+ cookies: { }
content-type: "text/html"
content-charset: "UTF8"
}
] 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 ;
"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
"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
[ ] [
[
<dispatcher>
+ <action> <protected>
<login>
<sessions>
"" add-responder
[ ] [
[
<dispatcher>
- <action> [ [ "Hi" write ] <text-content> ] >>display
+ <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
<login>
<sessions>
"" add-responder
[ "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
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 -- )
: 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 )
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 )
[ 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 )
: <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
: 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* ;
: 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
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
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 -- )
: 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* ;
: <raw-response> ( -- response )
raw-response new
- "1.1" >>version ;
+ "1.1" >>version ;
M: raw-response write-response ( respose -- )
write-response-version
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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
+++ /dev/null
-USING: kernel http.server.actions validators
-tools.test math math.parser multiline namespaces http
-io.streams.string http.server sequences splitting accessors ;
-IN: http.server.actions.tests
-
-<action>
- [ "a" param "b" param [ string>number ] bi@ + ] >>display
-"action-1" set
-
-: lf>crlf "\n" split "\r\n" join ;
-
-STRING: action-request-test-1
-GET http://foo/bar?a=12&b=13 HTTP/1.1
-
-blah
-;
-
-[ 25 ] [
- init-request
- action-request-test-1 lf>crlf
- [ read-request ] with-string-reader
- request set
- { } "action-1" get call-responder
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors sequences kernel assocs combinators http.server\r
-validators http hashtables namespaces fry continuations locals\r
-boxes xml.entities html.elements html.components io arrays math ;\r
-IN: http.server.actions\r
-\r
-SYMBOL: params\r
-\r
-SYMBOL: rest-param\r
-\r
-: render-validation-messages ( -- )\r
- validation-messages get\r
- dup empty? [ drop ] [\r
- <ul "errors" =class ul>\r
- [ <li> message>> escape-string write </li> ] each\r
- </ul>\r
- ] if ;\r
-\r
-TUPLE: action rest-param init display validate submit ;\r
-\r
-: new-action ( class -- action )\r
- new\r
- [ ] >>init\r
- [ <400> ] >>display\r
- [ ] >>validate\r
- [ <400> ] >>submit ;\r
-\r
-: <action> ( -- action )\r
- action new-action ;\r
-\r
-: handle-get ( action -- response )\r
- blank-values\r
- [ init>> call ]\r
- [ display>> call ]\r
- bi ;\r
-\r
-: validation-failed ( -- * )\r
- request get method>> "POST" =\r
- [ action get display>> call ] [ <400> ] if exit-with ;\r
-\r
-: handle-post ( action -- response )\r
- init-validation\r
- blank-values\r
- [ validate>> call ]\r
- [ submit>> call ] bi ;\r
-\r
-: handle-rest-param ( arg -- )\r
- dup length 1 > action get rest-param>> not or\r
- [ <404> exit-with ] [\r
- action get rest-param>> associate rest-param set\r
- ] if ;\r
-\r
-M: action call-responder* ( path action -- response )\r
- dup action set\r
- '[\r
- , dup empty? [ drop ] [ handle-rest-param ] if\r
-\r
- init-validation\r
- ,\r
- request get\r
- [ request-params rest-param get assoc-union params set ]\r
- [ method>> ] bi\r
- {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
- ] with-exit-continuation ;\r
-\r
-: param ( name -- value )\r
- params get at ;\r
-\r
-: check-validation ( -- )\r
- validation-failed? [ validation-failed ] when ;\r
-\r
-: validate-params ( validators -- )\r
- params get swap validate-values from-assoc\r
- check-validation ;\r
-\r
-: validate-integer-id ( -- )\r
- { { "id" [ v-number ] } } validate-params ;\r
-\r
-TUPLE: page-action < action template ;\r
-\r
-: <page-action> ( -- page )\r
- page-action new-action\r
- dup '[ , template>> <html-content> ] >>display ;\r
-\r
-TUPLE: feed-action < action feed ;\r
-\r
-: <feed-action> ( -- feed )\r
- feed-action new\r
- dup '[ , feed>> call <feed-content> ] >>display ;\r
+++ /dev/null
-! Copyright (c) 2008 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs namespaces kernel sequences sets\r
-http.server\r
-http.server.sessions\r
-http.server.auth.providers ;\r
-IN: http.server.auth\r
-\r
-SYMBOL: logged-in-user\r
-\r
-GENERIC: init-user-profile ( responder -- )\r
-\r
-M: object init-user-profile drop ;\r
-\r
-M: dispatcher init-user-profile\r
- default>> init-user-profile ;\r
-\r
-M: filter-responder init-user-profile\r
- responder>> init-user-profile ;\r
-\r
-: profile ( -- assoc ) logged-in-user get profile>> ;\r
-\r
-: user-changed ( -- )\r
- logged-in-user get t >>changed? drop ;\r
-\r
-: uget ( key -- value )\r
- profile at ;\r
-\r
-: uset ( value key -- )\r
- profile set-at\r
- user-changed ;\r
-\r
-: uchange ( quot key -- )\r
- profile swap change-at\r
- user-changed ; inline\r
-\r
-SYMBOL: capabilities\r
-\r
-V{ } clone capabilities set-global\r
-\r
-: define-capability ( word -- ) capabilities get adjoin ;\r
+++ /dev/null
-! Copyright (c) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors quotations assocs kernel splitting\r
-base64 html.elements io combinators http.server\r
-http.server.auth.providers http.server.auth.login\r
-http sequences ;\r
-IN: http.server.auth.basic\r
-\r
-TUPLE: basic-auth < filter-responder realm provider ;\r
-\r
-C: <basic-auth> basic-auth\r
-\r
-: authorization-ok? ( provider header -- ? )\r
- #! Given the realm and the 'Authorization' header,\r
- #! authenticate the user.\r
- dup [\r
- " " split1 swap "Basic" = [\r
- base64> ":" split1 spin check-login\r
- ] [\r
- 2drop f\r
- ] if\r
- ] [\r
- 2drop f\r
- ] if ;\r
-\r
-: <401> ( realm -- response )\r
- 401 "Unauthorized" <trivial-response>\r
- "Basic realm=\"" rot "\"" 3append\r
- "WWW-Authenticate" set-header\r
- [\r
- <html> <body>\r
- "Username or Password is invalid" write\r
- </body> </html>\r
- ] >>body ;\r
-\r
-: logged-in? ( request responder -- ? )\r
- provider>> swap "authorization" header authorization-ok? ;\r
-\r
-M: basic-auth call-responder* ( request path responder -- response )\r
- pick over logged-in?\r
- [ call-next-method ] [ 2nip realm>> <401> ] if ;\r
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Edit Profile</t:title>
-
- <t:form t:action="$login/edit-profile">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:label t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Current password:</th>
- <td><t:password t:name="password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>If you don't want to change your current password, leave this field blank.</td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>If you are changing your password, enter it twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- </table>
-
- <p>
- <input type="submit" value="Update" />
- <t:validation-messages />
- </p>
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-IN: http.server.auth.login.tests\r
-USING: tools.test http.server.auth.login ;\r
-\r
-\ <login> must-infer\r
-\ allow-registration must-infer\r
-\ allow-password-recovery must-infer\r
+++ /dev/null
-! Copyright (c) 2008 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors quotations assocs kernel splitting\r
-combinators sequences namespaces hashtables sets\r
-fry arrays threads qualified random validators\r
-io\r
-io.sockets\r
-io.encodings.utf8\r
-io.encodings.string\r
-io.binary\r
-continuations\r
-destructors\r
-checksums\r
-checksums.sha2\r
-validators\r
-html.components\r
-html.elements\r
-html.templates\r
-html.templates.chloe\r
-http\r
-http.server\r
-http.server.auth\r
-http.server.auth.providers\r
-http.server.auth.providers.db\r
-http.server.actions\r
-http.server.flows\r
-http.server.sessions\r
-http.server.boilerplate ;\r
-QUALIFIED: smtp\r
-IN: http.server.auth.login\r
-\r
-TUPLE: login < dispatcher users checksum ;\r
-\r
-: users ( -- provider )\r
- login get users>> ;\r
-\r
-: encode-password ( string salt -- bytes )\r
- [ utf8 encode ] [ 4 >be ] bi* append\r
- login get checksum>> checksum-bytes ;\r
-\r
-: >>encoded-password ( user string -- user )\r
- 32 random-bits [ encode-password ] keep\r
- [ >>password ] [ >>salt ] bi* ; inline\r
-\r
-: valid-login? ( password user -- ? )\r
- [ salt>> encode-password ] [ password>> ] bi = ;\r
-\r
-: check-login ( password username -- user/f )\r
- users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;\r
-\r
-! Destructor\r
-TUPLE: user-saver user ;\r
-\r
-C: <user-saver> user-saver\r
-\r
-M: user-saver dispose\r
- user>> dup changed?>> [ users update-user ] [ drop ] if ;\r
-\r
-: save-user-after ( user -- )\r
- <user-saver> &dispose drop ;\r
-\r
-: login-template ( name -- template )\r
- "resource:extra/http/server/auth/login/" swap ".xml"\r
- 3append <chloe> ;\r
-\r
-! ! ! Login\r
-: successful-login ( user -- response )\r
- username>> set-uid "$login" end-flow ;\r
-\r
-: login-failed ( -- * )\r
- "invalid username or password" validation-error\r
- validation-failed ;\r
-\r
-: <login-action> ( -- action )\r
- <action>\r
- [ "login" login-template <html-content> ] >>display\r
-\r
- [\r
- {\r
- { "username" [ v-required ] }\r
- { "password" [ v-required ] }\r
- } validate-params\r
-\r
- "password" value\r
- "username" value check-login\r
- [ successful-login ] [ login-failed ] if*\r
- ] >>submit ;\r
-\r
-! ! ! New user registration\r
-\r
-: user-exists ( -- * )\r
- "username taken" validation-error\r
- validation-failed ;\r
-\r
-: password-mismatch ( -- * )\r
- "passwords do not match" validation-error\r
- validation-failed ;\r
-\r
-: same-password-twice ( -- )\r
- "new-password" value "verify-password" value =\r
- [ password-mismatch ] unless ;\r
-\r
-: <register-action> ( -- action )\r
- <page-action>\r
- "register" login-template >>template\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "realname" [ [ v-one-line ] v-optional ] }\r
- { "new-password" [ v-password ] }\r
- { "verify-password" [ v-password ] }\r
- { "email" [ [ v-email ] v-optional ] }\r
- { "captcha" [ v-captcha ] }\r
- } validate-params\r
-\r
- same-password-twice\r
- ] >>validate\r
-\r
- [\r
- "username" value <user>\r
- "realname" value >>realname\r
- "new-password" value >>encoded-password\r
- "email" value >>email\r
- H{ } clone >>profile\r
-\r
- users new-user [ user-exists ] unless*\r
-\r
- login get init-user-profile\r
-\r
- successful-login\r
- ] >>submit ;\r
-\r
-! ! ! Editing user profile\r
-\r
-: <edit-profile-action> ( -- action )\r
- <action>\r
- [\r
- logged-in-user get\r
- [ username>> "username" set-value ]\r
- [ realname>> "realname" set-value ]\r
- [ email>> "email" set-value ]\r
- tri\r
- ] >>init\r
-\r
- [ "edit-profile" login-template <html-content> ] >>display\r
-\r
- [\r
- uid "username" set-value\r
-\r
- {\r
- { "realname" [ [ v-one-line ] v-optional ] }\r
- { "password" [ ] }\r
- { "new-password" [ [ v-password ] v-optional ] }\r
- { "verify-password" [ [ v-password ] v-optional ] } \r
- { "email" [ [ v-email ] v-optional ] }\r
- } validate-params\r
-\r
- { "password" "new-password" "verify-password" }\r
- [ value empty? not ] contains? [\r
- "password" value uid check-login\r
- [ "incorrect password" validation-error ] unless\r
-\r
- same-password-twice\r
- ] when\r
- ] >>validate\r
-\r
- [\r
- logged-in-user get\r
-\r
- "new-password" value dup empty?\r
- [ drop ] [ >>encoded-password ] if\r
-\r
- "realname" value >>realname\r
- "email" value >>email\r
-\r
- t >>changed?\r
-\r
- drop\r
-\r
- "$login" end-flow\r
- ] >>submit ;\r
-\r
-! ! ! Password recovery\r
-\r
-SYMBOL: lost-password-from\r
-\r
-: current-host ( -- string )\r
- request get host>> host-name or ;\r
-\r
-: new-password-url ( user -- url )\r
- "new-password"\r
- swap [\r
- [ username>> "username" set ]\r
- [ ticket>> "ticket" set ]\r
- bi\r
- ] H{ } make-assoc\r
- derive-url ;\r
-\r
-: password-email ( user -- email )\r
- smtp:<email>\r
- [ "[ " % current-host % " ] password recovery" % ] "" make >>subject\r
- lost-password-from get >>from\r
- over email>> 1array >>to\r
- [\r
- "This e-mail was sent by the application server on " % current-host % "\n" %\r
- "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %\r
- "login form, and requested a new password for the user named ``" %\r
- over username>> % "''.\n" %\r
- "\n" %\r
- "If you believe that this request was legitimate, you may click the below link in\n" %\r
- "your browser to set a new password for your account:\n" %\r
- "\n" %\r
- swap new-password-url %\r
- "\n\n" %\r
- "Love,\n" %\r
- "\n" %\r
- " FactorBot\n" %\r
- ] "" make >>body ;\r
-\r
-: send-password-email ( user -- )\r
- '[ , password-email smtp:send-email ]\r
- "E-mail send thread" spawn drop ;\r
-\r
-: <recover-action-1> ( -- action )\r
- <action>\r
- [ "recover-1" login-template <html-content> ] >>display\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "email" [ v-email ] }\r
- { "captcha" [ v-captcha ] }\r
- } validate-params\r
- ] >>validate\r
-\r
- [\r
- "email" value "username" value\r
- users issue-ticket [\r
- send-password-email\r
- ] when*\r
-\r
- "recover-2" login-template <html-content>\r
- ] >>submit ;\r
-\r
-: <recover-action-3> ( -- action )\r
- <action>\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- } validate-params\r
- ] >>init\r
-\r
- [ "recover-3" login-template <html-content> ] >>display\r
-\r
- [\r
- {\r
- { "username" [ v-username ] }\r
- { "ticket" [ v-required ] }\r
- { "new-password" [ v-password ] }\r
- { "verify-password" [ v-password ] }\r
- } validate-params\r
-\r
- same-password-twice\r
- ] >>validate\r
-\r
- [\r
- "ticket" value\r
- "username" value\r
- users claim-ticket [\r
- "new-password" value >>encoded-password\r
- users update-user\r
-\r
- "recover-4" login-template <html-content>\r
- ] [\r
- <400>\r
- ] if*\r
- ] >>submit ;\r
-\r
-! ! ! Logout\r
-: <logout-action> ( -- action )\r
- <action>\r
- [\r
- f set-uid\r
- "$login/login" end-flow\r
- ] >>submit ;\r
-\r
-! ! ! Authentication logic\r
-\r
-TUPLE: protected < filter-responder capabilities ;\r
-\r
-C: <protected> protected\r
-\r
-: show-login-page ( -- response )\r
- begin-flow\r
- "$login/login" f <standard-redirect> ;\r
-\r
-: check-capabilities ( responder user -- ? )\r
- [ capabilities>> ] bi@ subset? ;\r
-\r
-M: protected call-responder* ( path responder -- response )\r
- uid dup [\r
- users get-user 2dup check-capabilities [\r
- [ logged-in-user set ] [ save-user-after ] bi\r
- call-next-method\r
- ] [\r
- 3drop show-login-page\r
- ] if\r
- ] [\r
- 3drop show-login-page\r
- ] if ;\r
-\r
-M: login call-responder* ( path responder -- response )\r
- dup login set\r
- call-next-method ;\r
-\r
-: <login-boilerplate> ( responder -- responder' )\r
- <boilerplate>\r
- "boilerplate" login-template >>template ;\r
-\r
-: <login> ( responder -- auth )\r
- login new-dispatcher\r
- swap >>default\r
- <login-action> <login-boilerplate> "login" add-responder\r
- <logout-action> <login-boilerplate> "logout" add-responder\r
- users-in-db >>users\r
- sha-256 >>checksum ;\r
-\r
-! ! ! Configuration\r
-\r
-: allow-edit-profile ( login -- login )\r
- <edit-profile-action> f <protected> <login-boilerplate>\r
- "edit-profile" add-responder ;\r
-\r
-: allow-registration ( login -- login )\r
- <register-action> <login-boilerplate>\r
- "register" add-responder ;\r
-\r
-: allow-password-recovery ( login -- login )\r
- <recover-action-1> <login-boilerplate>\r
- "recover-password" add-responder\r
- <recover-action-3> <login-boilerplate>\r
- "new-password" add-responder ;\r
-\r
-: allow-edit-profile? ( -- ? )\r
- login get responders>> "edit-profile" swap key? ;\r
-\r
-: allow-registration? ( -- ? )\r
- login get responders>> "register" swap key? ;\r
-\r
-: allow-password-recovery? ( -- ? )\r
- login get responders>> "recover-password" swap key? ;\r
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Login</t:title>
-
- <t:form t:action="login">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="password" /></td>
- </tr>
-
- </table>
-
- <p>
-
- <input type="submit" value="Log in" />
- <t:validation-messages />
-
- </p>
-
- </t:form>
-
- <p>
- <t:if code="http.server.auth.login:login-failed?">
- <t:a t:href="register">Register</t:a>
- </t:if>
- |
- <t:if code="http.server.auth.login:allow-password-recovery?">
- <t:a t:href="recover-password">Recover Password</t:a>
- </t:if>
- </p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 1 of 4</t:title>
-
- <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
-
- <t:form t:action="recover-password">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:field t:name="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
- </tr>
-
- </table>
-
- <input type="submit" value="Recover password" />
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 2 of 4</t:title>
-
- <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Recover lost password: step 3 of 4</t:title>
-
- <p>Choose a new password for your account.</p>
-
- <t:form t:action="new-password">
-
- <table>
-
- <t:hidden t:name="username" />
- <t:hidden t:name="ticket" />
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify password:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- </table>
-
- <p>
- <input type="submit" value="Set password" />
- <t:validation-messages />
- </p>
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>\r
-\r
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
-\r
- <t:title>Recover lost password: step 4 of 4</t:title>\r
-\r
- <p>Your password has been reset. You may now <t:a t:href="login">log in</t:a>.</p>\r
-\r
-</t:chloe>\r
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New User Registration</t:title>
-
- <t:form t:action="register">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:field t:name="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:password t:name="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:password t:name="verify-password" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:field t:name="email" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:field t:name="captcha" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
-
- </table>
-
- <p>
-
- <input type="submit" value="Register" />
- <t:validation-messages />
-
- </p>
-
- </t:form>
-
-</t:chloe>
+++ /dev/null
-IN: http.server.auth.providers.assoc.tests\r
-USING: http.server.actions http.server.auth.providers \r
-http.server.auth.providers.assoc http.server.auth.login\r
-tools.test namespaces accessors kernel ;\r
-\r
-<action> <login>\r
- <users-in-memory> >>users\r
-login set\r
-\r
-[ t ] [\r
- "slava" <user>\r
- "foobar" >>encoded-password\r
- "slava@factorcode.org" >>email\r
- H{ } clone >>profile\r
- users new-user\r
- username>> "slava" =\r
-] unit-test\r
-\r
-[ f ] [\r
- "slava" <user>\r
- H{ } clone >>profile\r
- users new-user\r
-] unit-test\r
-\r
-[ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
-[ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
-\r
-[ t ] [ "user" get >boolean ] unit-test\r
-\r
-[ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
-\r
-[ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
-[ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-IN: http.server.auth.providers.assoc\r
-USING: accessors assocs kernel\r
-http.server.auth.providers ;\r
-\r
-TUPLE: users-in-memory assoc ;\r
-\r
-: <users-in-memory> ( -- provider )\r
- H{ } clone users-in-memory boa ;\r
-\r
-M: users-in-memory get-user ( username provider -- user/f )\r
- assoc>> at ;\r
-\r
-M: users-in-memory update-user ( user provider -- ) 2drop ;\r
-\r
-M: users-in-memory new-user ( user provider -- user/f )\r
- [ dup username>> ] dip assoc>>\r
- 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;\r
+++ /dev/null
-IN: http.server.auth.providers.db.tests\r
-USING: http.server.actions\r
-http.server.auth.login\r
-http.server.auth.providers\r
-http.server.auth.providers.db tools.test\r
-namespaces db db.sqlite db.tuples continuations\r
-io.files accessors kernel ;\r
-\r
-<action> <login>\r
- users-in-db >>users\r
-login set\r
-\r
-[ "auth-test.db" temp-file delete-file ] ignore-errors\r
-\r
-"auth-test.db" temp-file sqlite-db [\r
-\r
- init-users-table\r
-\r
- [ t ] [\r
- "slava" <user>\r
- "foobar" >>encoded-password\r
- "slava@factorcode.org" >>email\r
- H{ } clone >>profile\r
- users new-user\r
- username>> "slava" =\r
- ] unit-test\r
-\r
- [ f ] [\r
- "slava" <user>\r
- H{ } clone >>profile\r
- users new-user\r
- ] unit-test\r
-\r
- [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
- [ ] [ "foobar" "slava" check-login "user" set ] unit-test\r
-\r
- [ t ] [ "user" get >boolean ] unit-test\r
-\r
- [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test\r
-\r
- [ ] [ "user" get users update-user ] unit-test\r
-\r
- [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test\r
-\r
- [ f ] [ "foobar" "slava" check-login >boolean ] unit-test\r
-] with-db\r
+++ /dev/null
-! 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
-classes.singleton ;
-IN: http.server.auth.providers.db
-
-user "USERS"
-{
- { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
- { "realname" "REALNAME" { VARCHAR 256 } }
- { "password" "PASSWORD" BLOB +not-null+ }
- { "salt" "SALT" INTEGER +not-null+ }
- { "email" "EMAIL" { VARCHAR 256 } }
- { "ticket" "TICKET" { VARCHAR 256 } }
- { "capabilities" "CAPABILITIES" FACTOR-BLOB }
- { "profile" "PROFILE" FACTOR-BLOB }
- { "deleted" "DELETED" INTEGER +not-null+ }
-} define-persistent
-
-: init-users-table user ensure-table ;
-
-SINGLETON: users-in-db
-
-M: users-in-db get-user
- drop <user> select-tuple ;
-
-M: users-in-db new-user
- drop
- [
- user new
- over username>> >>username
- select-tuple [
- drop f
- ] [
- dup insert-tuple
- ] if
- ] with-transaction ;
-
-M: users-in-db update-user
- drop update-tuple ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: http.server.auth.providers kernel ;\r
-IN: http.server.auth.providers.null\r
-\r
-TUPLE: no-users ;\r
-\r
-: no-users T{ no-users } ;\r
-\r
-M: no-users get-user 2drop f ;\r
-\r
-M: no-users new-user 2drop f ;\r
-\r
-M: no-users update-user 2drop ;\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel accessors random math.parser locals\r
-sequences math ;\r
-IN: http.server.auth.providers\r
-\r
-TUPLE: user\r
-username realname\r
-password salt\r
-email ticket capabilities profile deleted changed? ;\r
-\r
-: <user> ( username -- user )\r
- user new\r
- swap >>username\r
- 0 >>deleted ;\r
-\r
-GENERIC: get-user ( username provider -- user/f )\r
-\r
-GENERIC: update-user ( user provider -- )\r
-\r
-GENERIC: new-user ( user provider -- user/f )\r
-\r
-! Password recovery support\r
-\r
-:: issue-ticket ( email username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user email>> length 0 > [\r
- user email>> email = [\r
- user\r
- 256 random-bits >hex >>ticket\r
- dup provider update-user\r
- ] [ f ] if\r
- ] [ f ] if\r
- ] [ f ] if\r
- ] ;\r
-\r
-:: claim-ticket ( ticket username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user ticket>> ticket = [\r
- user f >>ticket dup provider update-user\r
- ] [ f ] if\r
- ] [ f ] if\r
- ] ;\r
-\r
-! For configuration\r
-\r
-: add-user ( provider user -- provider )\r
- over new-user [ "User exists" throw ] when ;\r
+++ /dev/null
-! 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
-
-TUPLE: boilerplate < filter-responder template ;
-
-: <boilerplate> f boilerplate boa ;
-
-M:: boilerplate call-responder* ( path responder -- )
- path responder call-next-method
- dup content-type>> "text/html" = [
- clone [| body |
- [ body responder template>> with-boilerplate ]
- ] change-body
- ] when ;
+++ /dev/null
-IN: http.server.callbacks\r
-USING: http.server.actions http.server.callbacks accessors\r
-http.server http tools.test namespaces io fry sequences\r
-splitting kernel hashtables continuations ;\r
-\r
-[ 123 ] [\r
- [\r
- init-request\r
-\r
- <request> "GET" >>method request set\r
- [\r
- exit-continuation set\r
- { }\r
- <action> [ [ "hello" print 123 ] show-final ] >>display\r
- <callback-responder>\r
- call-responder\r
- ] callcc1\r
- ] with-scope\r
-] unit-test\r
-\r
-[\r
- init-request\r
-\r
- <action> [\r
- [\r
- "hello" print\r
- '[ , write ] <html-content>\r
- ] show-page\r
- "byebye" print\r
- [ 123 ] show-final\r
- ] >>display\r
- <callback-responder> "r" set\r
-\r
- [ 123 ] [\r
- [\r
- exit-continuation set\r
- <request> "GET" >>method request set\r
- { } "r" get call-responder\r
- ] callcc1\r
-\r
- body>> first\r
-\r
- <request>\r
- "GET" >>method\r
- swap cont-id associate >>query\r
- "/" >>path\r
- request set\r
-\r
- [\r
- exit-continuation set\r
- { }\r
- "r" get call-responder\r
- ] callcc1\r
-\r
- ! get-post-get\r
- <request>\r
- "GET" >>method\r
- swap "location" header "=" last-split1 nip cont-id associate >>query\r
- "/" >>path\r
- request set\r
-\r
- [\r
- exit-continuation set\r
- { }\r
- "r" get call-responder\r
- ] callcc1\r
- ] unit-test\r
-] with-scope\r
+++ /dev/null
-! Copyright (C) 2004 Chris Double.\r
-! Copyright (C) 2006, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: http http.server io kernel math namespaces\r
-continuations calendar sequences assocs hashtables\r
-accessors arrays alarms quotations combinators fry assocs.lib ;\r
-IN: http.server.callbacks\r
-\r
-SYMBOL: responder\r
-\r
-TUPLE: callback-responder responder callbacks ;\r
-\r
-: <callback-responder> ( responder -- responder' )\r
- #! A continuation responder is a special type of session\r
- #! manager. However it works entirely differently from\r
- #! the URL and cookie session managers.\r
- H{ } clone callback-responder boa ;\r
-\r
-TUPLE: callback cont quot expires alarm responder ;\r
-\r
-: timeout 20 minutes ;\r
-\r
-: timeout-callback ( callback -- )\r
- [ alarm>> cancel-alarm ]\r
- [ dup responder>> callbacks>> delete-at ]\r
- bi ;\r
-\r
-: touch-callback ( callback -- )\r
- dup expires>> [\r
- dup alarm>> [ cancel-alarm ] when*\r
- dup '[ , timeout-callback ] timeout later >>alarm\r
- ] when drop ;\r
-\r
-: <callback> ( cont quot expires? -- callback )\r
- f callback-responder get callback boa\r
- dup touch-callback ;\r
-\r
-: invoke-callback ( callback -- response )\r
- [ touch-callback ]\r
- [ quot>> request get exit-continuation get 3array ]\r
- [ cont>> continue-with ]\r
- tri ;\r
-\r
-: register-callback ( cont quot expires? -- id )\r
- <callback> callback-responder get callbacks>> set-at-unique ;\r
-\r
-: forward-to-url ( url query -- * )\r
- #! When executed inside a 'show' call, this will force a\r
- #! HTTP 302 to occur to instruct the browser to forward to\r
- #! the request URL.\r
- <temporary-redirect> exit-with ;\r
-\r
-: cont-id "factorcontid" ;\r
-\r
-: forward-to-id ( id -- * )\r
- #! When executed inside a 'show' call, this will force a\r
- #! HTTP 302 to occur to instruct the browser to forward to\r
- #! the request URL.\r
- f swap cont-id associate forward-to-url ;\r
-\r
-: restore-request ( pair -- )\r
- first3 exit-continuation set request set call ;\r
-\r
-SYMBOL: post-refresh-get?\r
-\r
-: redirect-to-here ( -- )\r
- #! Force a redirect to the client browser so that the browser\r
- #! goes to the current point in the code. This forces an URL\r
- #! change on the browser so that refreshing that URL will\r
- #! immediately run from this code point. This prevents the\r
- #! "this request will issue a POST" warning from the browser\r
- #! and prevents re-running the previous POST logic. This is\r
- #! known as the 'post-refresh-get' pattern.\r
- post-refresh-get? get [\r
- [\r
- [ ] t register-callback forward-to-id\r
- ] callcc1 restore-request\r
- ] [\r
- post-refresh-get? on\r
- ] if ;\r
-\r
-SYMBOL: current-show\r
-\r
-: store-current-show ( -- )\r
- #! Store the current continuation in the variable 'current-show'\r
- #! so it can be returned to later by 'quot-id'. Note that it\r
- #! recalls itself when the continuation is called to ensure that\r
- #! it resets its value back to the most recent show call.\r
- [ current-show set f ] callcc1\r
- [ restore-request store-current-show ] when* ;\r
-\r
-: show-final ( quot -- * )\r
- [ redirect-to-here store-current-show ] dip\r
- call exit-with ; inline\r
-\r
-: resuming-callback ( responder request -- id )\r
- cont-id query-param swap callbacks>> at ;\r
-\r
-M: callback-responder call-responder* ( path responder -- response )\r
- '[\r
- , ,\r
-\r
- [ callback-responder set ]\r
- [ request get resuming-callback ] bi\r
-\r
- [\r
- invoke-callback\r
- ] [\r
- callback-responder get responder>> call-responder\r
- ] ?if\r
- ] with-exit-continuation ;\r
-\r
-: show-page ( quot -- )\r
- [ redirect-to-here store-current-show ] dip\r
- [\r
- [ ] t register-callback swap call exit-with\r
- ] callcc1 restore-request ; inline\r
-\r
-: quot-id ( quot -- id )\r
- current-show get swap t register-callback ;\r
-\r
-: quot-url ( quot -- url )\r
- quot-id f swap cont-id associate derive-url ;\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: namespaces kernel assocs io.files io.streams.duplex\r
combinators arrays io.launcher io http.server.static http.server\r
-http accessors sequences strings math.parser fry ;\r
+http accessors sequences strings math.parser fry urls ;\r
IN: http.server.cgi\r
\r
: post? request get method>> "POST" = ;\r
"HTTP/" request get version>> append "SERVER_PROTOCOL" set\r
"Factor" "SERVER_SOFTWARE" set\r
\r
- dup "PATH_TRANSLATED" set\r
- "SCRIPT_FILENAME" set\r
+ [ "PATH_TRANSLATED" set ] [ "SCRIPT_FILENAME" set ] bi\r
\r
- request get path>> "SCRIPT_NAME" set\r
+ request get url>> path>> "SCRIPT_NAME" set\r
\r
- request get host>> "SERVER_NAME" set\r
- request get port>> number>string "SERVER_PORT" set\r
+ request get url>> host>> "SERVER_NAME" set\r
+ request get url>> port>> number>string "SERVER_PORT" set\r
"" "PATH_INFO" set\r
"" "REMOTE_HOST" set\r
"" "REMOTE_ADDR" set\r
"" "REMOTE_IDENT" set\r
\r
request get method>> "REQUEST_METHOD" set\r
- request get query>> assoc>query "QUERY_STRING" set\r
+ request get url>> query>> assoc>query "QUERY_STRING" set\r
request get "cookie" header "HTTP_COOKIE" set \r
\r
request get "user-agent" header "HTTP_USER_AGENT" set\r
request get "accept" header "HTTP_ACCEPT" set\r
\r
post? [\r
- request get post-data-type>> "CONTENT_TYPE" set\r
- request get post-data>> length number>string "CONTENT_LENGTH" set\r
+ request get post-data>> raw>>\r
+ [ "CONTENT_TYPE" set ]\r
+ [ length number>string "CONTENT_LENGTH" set ]\r
+ bi\r
] when\r
] H{ } make-assoc ;\r
\r
"CGI output follows" >>message\r
swap '[\r
, output-stream get swap <cgi-process> <process-stream> [\r
- post? [ request get post-data>> write flush ] when\r
+ post? [ request get post-data>> raw>> write flush ] when\r
input-stream get swap (stream-copy)\r
] with-stream\r
] >>body ;\r
+++ /dev/null
-IN: http.server.db.tests
-USING: tools.test http.server.db ;
-
-\ <db-persistence> must-infer
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: db db.pools io.pools http.server http.server.sessions\r
-kernel accessors continuations namespaces destructors ;\r
-IN: http.server.db\r
-\r
-TUPLE: db-persistence < filter-responder pool ;\r
-\r
-: <db-persistence> ( responder params db -- responder' )\r
- <db-pool> db-persistence boa ;\r
-\r
-M: db-persistence call-responder*\r
- [\r
- pool>> [ acquire-connection ] keep\r
- [ return-connection-later ] [ drop db set ] 2bi\r
- ]\r
- [ call-next-method ] bi ;\r
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
+++ /dev/null
-! 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 ;
--- /dev/null
+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
--- /dev/null
+! 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> ;
--- /dev/null
+! 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> ;
-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
! 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
-! 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 ;
+SYMBOL: responder-nesting
-: <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> ;
+SYMBOL: main-responder
-: <feed-content> ( feed -- response )
- '[ , feed>xml ] "text/xml" <content> ;
+SYMBOL: development-mode
-: <json-content> ( obj -- response )
- '[ , >json ] "application/json" <content> ;
+! path is a sequence of path component strings
+GENERIC: call-responder* ( path responder -- response )
TUPLE: trivial-responder response ;
C: <trivial-responder> trivial-responder
-M: trivial-responder call-responder* nip response>> call ;
-
-: 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> ;
+M: trivial-responder call-responder* nip response>> clone ;
-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
: 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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: http.server.sessions.tests\r
-USING: tools.test http http.server.sessions\r
-http.server.actions http.server math namespaces kernel accessors\r
-prettyprint io.streams.string io.files splitting destructors\r
-sequences db db.sqlite continuations ;\r
-\r
-: with-session\r
- [\r
- [ [ save-session-after ] [ session set ] bi ] dip call\r
- ] with-destructors ; inline\r
-\r
-TUPLE: foo ;\r
-\r
-C: <foo> foo\r
-\r
-M: foo init-session* drop 0 "x" sset ;\r
-\r
-M: foo call-responder*\r
- 2drop\r
- "x" [ 1+ ] schange\r
- [ "x" sget pprint ] <html-content> ;\r
-\r
-: url-responder-mock-test\r
- [\r
- <request>\r
- "GET" >>method\r
- "id" get session-id-key set-query-param\r
- "/" >>path\r
- request set\r
- { } sessions get call-responder\r
- [ write-response-body drop ] with-string-writer\r
- ] with-destructors ;\r
-\r
-: sessions-mock-test\r
- [\r
- <request>\r
- "GET" >>method\r
- "cookies" get >>cookies\r
- "/" >>path\r
- request set\r
- { } sessions get call-responder\r
- [ write-response-body drop ] with-string-writer\r
- ] with-destructors ;\r
-\r
-: <exiting-action>\r
- <action>\r
- [ [ ] <text-content> exit-with ] >>display ;\r
-\r
-[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors\r
-\r
-"auth-test.db" temp-file sqlite-db [\r
-\r
- init-request\r
- init-sessions-table\r
-\r
- [ ] [\r
- <foo> <sessions>\r
- sessions set\r
- ] unit-test\r
-\r
- [\r
- [ ] [\r
- empty-session\r
- 123 >>id session set\r
- ] unit-test\r
-\r
- [ ] [ 3 "x" sset ] unit-test\r
-\r
- [ 9 ] [ "x" sget sq ] unit-test\r
-\r
- [ ] [ "x" [ 1- ] schange ] unit-test\r
-\r
- [ 4 ] [ "x" sget sq ] unit-test\r
-\r
- [ t ] [ session get changed?>> ] unit-test\r
- ] with-scope\r
-\r
- [ t ] [\r
- begin-session id>>\r
- get-session session?\r
- ] unit-test\r
-\r
- [ { 5 0 } ] [\r
- [\r
- begin-session\r
- dup [ 5 "a" sset ] with-session\r
- dup [ "a" sget , ] with-session\r
- dup [ "x" sget , ] with-session\r
- drop\r
- ] { } make\r
- ] unit-test\r
-\r
- [ 0 ] [\r
- begin-session id>>\r
- get-session [ "x" sget ] with-session\r
- ] unit-test\r
-\r
- [ { 5 0 } ] [\r
- [\r
- begin-session id>>\r
- dup get-session [ 5 "a" sset ] with-session\r
- dup get-session [ "a" sget , ] with-session\r
- dup get-session [ "x" sget , ] with-session\r
- drop\r
- ] { } make\r
- ] unit-test\r
-\r
- [ ] [\r
- <foo> <sessions>\r
- sessions set\r
- ] unit-test\r
-\r
- [\r
- <request>\r
- "GET" >>method\r
- "/" >>path\r
- request set\r
- { "etc" } sessions get call-responder response set\r
- [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test\r
- response get\r
- ] with-destructors\r
- response set\r
-\r
- [ ] [ response get cookies>> "cookies" set ] unit-test\r
-\r
- [ "2" ] [ sessions-mock-test ] unit-test\r
- [ "3" ] [ sessions-mock-test ] unit-test\r
- [ "4" ] [ sessions-mock-test ] unit-test\r
-\r
- [\r
- [ ] [\r
- <request>\r
- "GET" >>method\r
- "id" get session-id-key set-query-param\r
- "/" >>path\r
- request set\r
-\r
- [\r
- { } <exiting-action> <sessions>\r
- call-responder\r
- ] with-destructors response set\r
- ] unit-test\r
-\r
- [ "text/plain" ] [ response get content-type>> ] unit-test\r
-\r
- [ f ] [ response get cookies>> empty? ] unit-test\r
- ] with-scope\r
-] with-db\r
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-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
-
-TUPLE: session id expires uid namespace changed? ;
-
-: <session> ( id -- session )
- session new
- swap >>id ;
-
-session "SESSIONS"
-{
- { "id" "ID" +random-id+ system-random-generator }
- { "expires" "EXPIRES" TIMESTAMP +not-null+ }
- { "uid" "UID" { VARCHAR 255 } }
- { "namespace" "NAMESPACE" FACTOR-BLOB }
-} define-persistent
-
-: get-session ( id -- session )
- dup [ <session> select-tuple ] when ;
-
-: init-sessions-table session ensure-table ;
-
-: start-expiring-sessions ( db seq -- )
- '[
- , , [
- session new
- -1.0/0.0 now [a,b] >>expires
- delete-tuples
- ] with-db
- ] 5 minutes every drop ;
-
-GENERIC: init-session* ( responder -- )
-
-M: object init-session* drop ;
-
-M: dispatcher init-session* default>> init-session* ;
-
-M: filter-responder init-session* responder>> init-session* ;
-
-TUPLE: sessions < filter-responder timeout domain ;
-
-: <sessions> ( responder -- responder' )
- sessions new
- swap >>responder
- 20 minutes >>timeout ;
-
-: (session-changed) ( session -- )
- t >>changed? drop ;
-
-: session-changed ( -- )
- session get (session-changed) ;
-
-: sget ( key -- value )
- session get namespace>> at ;
-
-: sset ( value key -- )
- session get
- [ namespace>> set-at ] [ (session-changed) ] bi ;
-
-: schange ( key quot -- )
- session get
- [ namespace>> swap change-at ] keep
- (session-changed) ; inline
-
-: uid ( -- uid )
- session get uid>> ;
-
-: set-uid ( uid -- )
- session get [ (>>uid) ] [ (session-changed) ] bi ;
-
-: init-session ( session -- )
- session [ sessions get init-session* ] with-variable ;
-
-: cutoff-time ( -- time )
- sessions get timeout>> from-now ;
-
-: touch-session ( session -- )
- cutoff-time >>expires drop ;
-
-: empty-session ( -- session )
- f <session>
- H{ } clone >>namespace
- dup touch-session ;
-
-: begin-session ( -- session )
- empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
-
-! Destructor
-TUPLE: session-saver session ;
-
-C: <session-saver> session-saver
-
-M: session-saver dispose
- session>> dup changed?>> [
- [ touch-session ] [ update-tuple ] bi
- ] [ drop ] if ;
-
-: save-session-after ( session -- )
- <session-saver> &dispose drop ;
-
-: existing-session ( path session -- response )
- [ session set ] [ save-session-after ] bi
- sessions get responder>> call-responder ;
-
-: session-id-key "factorsessid" ;
-
-: 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 ;
-
-: request-session-id ( -- id/f )
- request get dup method>> {
- { "GET" [ cookie-session-id ] }
- { "HEAD" [ cookie-session-id ] }
- { "POST" [ post-session-id ] }
- } case ;
-
-: request-session ( -- session/f )
- request-session-id get-session ;
-
-: <session-cookie> ( id -- cookie )
- session-id-key <cookie>
- "$sessions" resolve-base-path >>path
- sessions get timeout>> from-now >>expires
- sessions get domain>> >>domain ;
-
-: 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 call-responder* ( path responder -- response )
- [ session-form-field ] add-form-hook
- sessions set
- request-session [ begin-session ] unless*
- existing-session put-session-cookie ;
-
-: logout-all-sessions ( uid -- )
- session new swap >>uid delete-tuples ;
! Copyright (C) 2004, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: calendar io io.files kernel math math.order\r
-math.parser http http.server namespaces parser sequences strings\r
-assocs hashtables debugger http.mime sorting html.elements\r
-html.templates.fhtml logging calendar.format accessors\r
-io.encodings.binary fry xml.entities destructors ;\r
+math.parser namespaces parser sequences strings\r
+assocs hashtables debugger mime-types sorting logging\r
+calendar.format accessors\r
+io.encodings.binary fry xml.entities destructors urls\r
+html.elements html.templates.fhtml\r
+http\r
+http.server\r
+http.server.responses\r
+http.server.redirection ;\r
IN: http.server.static\r
\r
! special maps mime types to quots with effect ( path -- )\r
2drop t\r
] if ;\r
\r
-: <304> ( -- response )\r
- 304 "Not modified" <trivial-response> ;\r
-\r
-: <403> ( -- response )\r
- 403 "Forbidden" <trivial-response> ;\r
-\r
: <file-responder> ( root hook -- responder )\r
file-responder new\r
swap >>hook\r
\r
: list-directory ( directory -- response )\r
file-responder get allow-listings>> [\r
- '[ , directory. ] <html-content>\r
+ '[ , directory. ] "text/html" <content>\r
] [\r
drop <403>\r
] if ;\r
find-index [ serve-file ] [ list-directory ] ?if\r
] [\r
drop\r
- request get path>> "/" append f <standard-redirect>\r
+ request get url>> clone [ "/" append ] change-path <permanent-redirect>\r
] if ;\r
\r
: serve-object ( filename -- response )\r
\r
! file responder integration\r
: enable-fhtml ( responder -- responder )\r
- [ <fhtml> <html-content> ]\r
+ [ <fhtml> "text/html" <content> ]\r
"application/x-factor-server-page"\r
pick special>> set-at ;\r
! 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 ;
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 ;
! 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:
! 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
: handle-overlapped ( timeout -- ? )
wait-for-overlapped [
- >r drop GetLastError
- [ 1array ] [ expected-io-error? ] bi
- [ r> 2drop f ] [ r> resume-callback t ] if
+ dup [
+ >r drop GetLastError 1array r> resume-callback t
+ ] [
+ 2drop f
+ ] if
] [
resume-callback t
] if ;
--- /dev/null
+USING: arrays json.reader kernel multiline strings tools.test ;
+IN: json.reader.tests
+
+{ f } [ "false" json> ] unit-test
+{ t } [ "true" json> ] unit-test
+{ json-null } [ "null" json> ] unit-test
+{ 0 } [ "0" json> ] unit-test
+{ 102 } [ "102" json> ] unit-test
+{ -102 } [ "-102" json> ] unit-test
+{ 102 } [ "+102" json> ] unit-test
+{ 102.0 } [ "102.0" json> ] unit-test
+{ 102.5 } [ "102.5" json> ] unit-test
+{ 102.5 } [ "102.50" json> ] unit-test
+{ -10250 } [ "-102.5e2" json> ] unit-test
+{ -10250 } [ "-102.5E+2" json> ] unit-test
+{ 10.25 } [ "1025e-2" json> ] unit-test
+{ 0.125 } [ "0.125" json> ] unit-test
+{ -0.125 } [ "-0.125" json> ] unit-test
+
+{ " fuzzy pickles " } [ <" " fuzzy pickles " "> json> ] unit-test
+{ "while 1:\n\tpass" } [ <" "while 1:\n\tpass" "> json> ] unit-test
+{ 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
+{ HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
+
+{ { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
+{ H{ { "US$" 1.0 } { "EU€" 1.5 } } } [ <" { "US$":1.00, "EU\u20AC":1.50 } "> json> ] unit-test
+{ H{
+ { "fib" { 1 1 2 3 5 8 H{ { "etc" "etc" } } } }
+ { "prime" { 2 3 5 7 11 13 } }
+} } [ <" {
+ "fib": [1, 1, 2, 3, 5, 8,
+ { "etc":"etc" } ],
+ "prime":
+ [ 2,3, 5,7,
+11,
+13
+] }
+"> json> ] unit-test
+
+{ 0 } [ " 0" json> ] unit-test
+{ 0 } [ "0 " json> ] unit-test
+{ 0 } [ " 0 " json> ] unit-test
+
! 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
+SYMBOL: json-null
+
: [<&>] ( quot -- quot )
{ } make unclip [ <&> ] reduce ;
" " token
"\n" token <|>
"\r" token <|>
- "\t" token <|>
- "" token <|> ;
+ "\t" token <|> <*> ;
LAZY: spaced ( parser -- parser )
'ws' swap &> 'ws' <& ;
"," token spaced ;
LAZY: 'false' ( -- parser )
- "false" token ;
+ "false" token [ drop f ] <@ ;
LAZY: 'null' ( -- parser )
- "null" token ;
+ "null" token [ drop json-null ] <@ ;
LAZY: 'true' ( -- parser )
- "true" token ;
+ "true" token [ drop t ] <@ ;
LAZY: 'quot' ( -- parser )
"\"" token ;
+LAZY: 'hex-digit' ( -- parser )
+ [ digit> ] satisfy [ digit> ] <@ ;
+
+: hex-digits>ch ( digits -- ch )
+ 0 [ swap 16 * + ] reduce ;
+
+LAZY: 'string-char' ( -- parser )
+ [ quotable? ] satisfy
+ "\\b" token [ drop 8 ] <@ <|>
+ "\\t" token [ drop CHAR: \t ] <@ <|>
+ "\\n" token [ drop CHAR: \n ] <@ <|>
+ "\\f" token [ drop 12 ] <@ <|>
+ "\\r" token [ drop CHAR: \r ] <@ <|>
+ "\\\"" token [ drop CHAR: " ] <@ <|>
+ "\\/" token [ drop CHAR: / ] <@ <|>
+ "\\\\" token [ drop CHAR: \\ ] <@ <|>
+ "\\u" token 'hex-digit' 4 exactly-n &>
+ [ hex-digits>ch ] <@ <|> ;
+
LAZY: 'string' ( -- parser )
'quot'
- [
- [ quotable? ] keep
- [ CHAR: \\ = or ] keep
- CHAR: " = not and
- ] satisfy <*> &>
+ 'string-char' <*> &>
'quot' <& [ >string ] <@ ;
DEFER: 'value'
LAZY: 'plus' ( -- parser )
"+" token ;
+LAZY: 'sign' ( -- parser )
+ 'minus' 'plus' <|> ;
+
LAZY: 'zero' ( -- parser )
"0" token [ drop 0 ] <@ ;
: sign-number ( pair -- number )
#! Pair is { minus? num }
#! Convert the json number value to a factor number
- dup second swap first [ -1 * ] when ;
+ dup second swap first [ first "-" = [ -1 * ] when ] when* ;
LAZY: 'exp' ( -- parser )
'e'
- 'minus' 'plus' <|> <?> &>
+ 'sign' <?> &>
'digit0-9' <+> [ decimal>integer ] <@ <&> [ sign-number ] <@ ;
: sequence>frac ( seq -- num )
dup second dup [ 10 swap first ^ swap first * ] [ drop first ] if ;
LAZY: 'number' ( -- parser )
- 'minus' <?>
+ 'sign' <?>
[ 'int' , 'frac' 0 succeed <|> , ] [<&>] [ sum ] <@
'exp' <?> <&> [ raise-to-power ] <@ <&> [ sign-number ] <@ ;
'object' ,
'array' ,
'number' ,
- ] [<|>] ;
+ ] [<|>] spaced ;
: json> ( string -- object )
#! Parse a json formatted string to a factor object
+++ /dev/null
-Chris Double
-Samuel Tardieu
-Matthew Willis
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: lazy-lists.examples lazy-lists tools.test ;
-IN: lazy-lists.examples.tests
-
-[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
-[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
+++ /dev/null
-! Rewritten by Matthew Willis, July 2006
-! 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
-
-: naturals 0 lfrom ;
-: positives 1 lfrom ;
-: evens 0 [ 2 + ] lfrom-by ;
-: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
-: powers-of-2 1 [ 2 * ] lfrom-by ;
-: ones 1 [ ] lfrom-by ;
-: squares naturals [ dup * ] lmap ;
-: first-five-squares 5 squares ltake list>array ;
+++ /dev/null
-! 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." } ;
-
-HELP: lazy-cons
-{ $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
-{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
-{ $see-also cons car cdr nil nil? } ;
-
-{ 1lazy-list 2lazy-list 3lazy-list } related-words
-
-HELP: 1lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
-
-HELP: 2lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: 3lazy-list
-{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: <memoized-cons>
-{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
-{ $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 } ;
-
-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
-{ $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
-{ $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." } ;
-
-HELP: ltake
-{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " 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: lfilter
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " 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: lwhile
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: luntil
-{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: list>vector
-{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
-{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>array } ;
-
-HELP: list>array
-{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
-{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>vector } ;
-
-HELP: lappend
-{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
-{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
-
-HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
-
-HELP: lfrom
-{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
-
-HELP: seq>list
-{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
-{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
-{ $see-also >list } ;
-
-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 } ;
-
-HELP: lconcat
-{ $values { "list" "a list of lists" } { "result" "a list" } }
-{ $description "Concatenates a list of lists together into one list." } ;
-
-HELP: lcartesian-product
-{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
-{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcartesian-product*
-{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
-{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcomp
-{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
-
-HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
-{ $examples
- { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
-} ;
-
-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 }" }
-} ;
-
-HELP: lcontents
-{ $values { "stream" "a stream" } { "result" string } }
-{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
-{ $see-also llines } ;
-
-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 } ;
-
+++ /dev/null
-! 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
-
-[ { 1 2 3 4 } ] [
- { 1 2 3 4 } >list list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
-] unit-test
-
-[ { 5 6 6 7 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
-] unit-test
-
-[ { 5 6 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
-] unit-test
-
-[ { 4 5 6 } ] [
- 3 { 1 2 3 } >list [ + ] lmap-with list>array
-] unit-test
+++ /dev/null
-! 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
+++ /dev/null
-<html>
- <head>
- <title>Lazy Evaluation</title>
- <link rel="stylesheet" type="text/css" href="style.css">
- </head>
- <body>
- <h1>Lazy Evaluation</h1>
-<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
- ability to describe infinite structures, and to delay execution of
- expressions until they are actually used.</p>
-<p>Lazy lists, like normal lists, are composed of a head and tail. In
- a lazy list the head and tail are something called a 'promise'.
- To convert a
- 'promise' into its actual value a word called 'force' is used. To
- convert a value into a 'promise' the word to use is 'delay'.</p>
-<table border="1">
-<tr><td><a href="#delay">delay</a></td></tr>
-<tr><td><a href="#force">force</a></td></tr>
-</table>
-
-<p>Many of the lazy list words are named similar to the standard list
- words but with an 'l' suffixed to it. Here are the commonly used
- words and their equivalent list operation:</p>
-<table border="1">
-<tr><th>Lazy List</th><th>Normal List</th></tr>
-<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
-<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
-<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
-<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
-<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
-<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
-<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
-<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
-<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
-<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
-<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
-<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
-</table>
-<p>A few additional words specific to lazy lists are:</p>
-<table border="1">
-<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
-number of items from the lazy list.</td></tr>
-<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
-concatenate them together in a lazy manner, returning a single lazy
-list.</td></tr>
-<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
-that contains the same elements as the normal list.</td></tr>
-</table>
-<h2>Reference</h2>
-<!-- delay description -->
-<a name="delay">
-<h3>delay ( quot -- <promise> )</h3>
-<p>'delay' is used to convert a value or expression into a promise.
- The word 'force' is used to convert that promise back to its
- value, or to force evaluation of the expression to return a value.
-</p>
-<p>The value on the stack that 'delay' expects must be quoted. This is
- a requirement to prevent it from being evaluated.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- force description -->
-<a name="force">
-<h3>force ( <promise> -- value )</h3>
-<p>'force' will evaluate a promises original expression
- and leave the value of that expression on the stack.
-</p>
-<p>A promise can be forced multiple times but the expression
- is only evaluated once. Future calls of 'force' on the promise
- will returned the cached value of the original force. If the
- expression contains side effects, such as i/o, then that i/o
- will only occur on the first 'force'. See below for an example
- (steps 3-5).
-</p>
-<p>If a promise is itself delayed, a force will evaluate all promises
- until a value is returned. Due to this behaviour it is generally not
- possible to delay a promise. The example below shows what happens
- in this case.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-
- #! Multiple forces on a promise returns cached value
- ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
- ( 4 ) dup <a href="#force">force</a> .
- => hello
- 42
- ( 5 ) <a href="#force">force</a> .
- => 42
-
- #! Forcing a delayed promise cascades up to return
- #! original value, rather than the promise.
- ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
- ( 7 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- lnil description -->
-<a name="lnil">
-<h3>lnil ( -- lcons )</h3>
-<p>Returns a value representing the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> .
- => << promise [ ] [ [ ] ] t [ ] >>
-</pre>
-
-<!-- lnil description -->
-<a name="lnilp">
-<h3>lnil? ( lcons -- bool )</h3>
-<p>Returns true if the given lazy cons is the value representing
- the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
- => [ ]
- ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
-</pre>
-
-<!-- lcons description -->
-<a name="lcons">
-<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
-<p>Provides the same effect as 'cons' does for normal lists.
- Both values provided must be promises (ie. expressions that have
- had <a href="#delay">delay</a> called on them).
-</p>
-<p>As the car and cdr passed on the stack are promises, they are not
- evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
- are called on the lazy cons.</p>
-<pre class="code">
- ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => "car"
- ( 3 ) dup <a href="#lcdr">lcdr</a> .
- => "cdr"
-</pre>
-
-<!-- lunit description -->
-<a name="lunit">
-<h3>lunit ( value-promise -- llist )</h3>
-<p>Provides the same effect as 'unit' does for normal lists. It
-creates a lazy list where the first element is the value given.</p>
-<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
- a promise and is not evaluated until the <a href="#lcar">lcar</a>
- of the list is requested.</a>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => 42
- ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 4 ) [ . ] <a href="#leach">leach</a>
- => 42
-</pre>
-
-<!-- lcar description -->
-<a name="lcar">
-<h3>lcar ( lcons -- value )</h3>
-<p>Provides the same effect as 'car' does for normal lists. It
-returns the first element in a lazy cons cell. This will force
-the evaluation of that element.</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcar">lcar</a> .
- => 42
-</pre>
-
-<!-- lcdr description -->
-<a name="lcdr">
-<h3>lcdr ( lcons -- value )</h3>
-<p>Provides the same effect as 'cdr' does for normal lists. It
-returns the second element in a lazy cons cell and forces it. This
-causes that element to be evaluated immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> .
- => 11
-</pre>
-
-<pre class="code">
- ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 6
- ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 7
- ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 8
-</pre>
-
-<!-- lnth description -->
-<a name="lnth">
-<h3>lnth ( n llist -- value )</h3>
-<p>Provides the same effect as 'nth' does for normal lists. It
-returns the nth value in the lazy list. It causes all the values up to
-'n' to be evaluated.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) 5 swap <a href="#lnth">lnth</a> .
- => 6
-</pre>
-
-<!-- luncons description -->
-<a name="luncons">
-<h3>luncons ( lcons -- car cdr )</h3>
-<p>Provides the same effect as 'uncons' does for normal lists. It
-returns the car and cdr of the lazy list.</p>
-<pre class="code">
- ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#luncons">luncons</a> . .
- => 6
- 5
-</pre>
-
-<!-- lmap description -->
-<a name="lmap">
-<h3>lmap ( llist quot -- llist )</h3>
-<p>Lazily maps over a lazy list applying the quotation to each element.
-A new lazy list is returned which contains the results of the
-quotation.</p>
-<p>When intially called nothing in the original lazy list is
-evaluated. Only when <a href="#lcar">lcar</a> is called will the item
-in the list be evaluated and applied to the quotation. Ditto with <a
-href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
- => < infinite list of numbers incrementing by 2 >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 4 6 8 10 ]
-</pre>
-
-<!-- lsubset description -->
-<a name="lsubset">
-<h3>lsubset ( llist pred -- llist )</h3>
-<p>Provides the same effect as 'subset' does for normal lists. It
-lazily iterates over a lazy list applying the predicate quotation to each
-element. If that quotation returns true, the element will be included
-in the resulting lazy list. If it is false, the element will be skipped.
-A new lazy list is returned which contains all elements where the
-predicate returned true.</p>
-<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
-will occur. A lazy list is returned that when values are retrieved
-from in then items are evaluated and checked against the predicate.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
- => < infinite list of prime numbers >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 3 5 7 11 ]
-</pre>
-
-<!-- leach description -->
-<a name="leach">
-<h3>leach ( llist quot -- )</h3>
-<p>Provides the same effect as 'each' does for normal lists. It
-lazily iterates over a lazy list applying the quotation to each
-element. If this operation is applied to an infinite list it will
-never return unless the quotation escapes out by calling a continuation.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
- => < infinite list of odd numbers >
- ( 3 ) [ . ] <a href="#leach">leach</a>
- => 1
- 3
- 5
- 7
- ... for ever ...
-</pre>
-
-<!-- ltake description -->
-<a name="ltake">
-<h3>ltake ( n llist -- llist )</h3>
-<p>Iterates over the lazy list 'n' times, appending each element to a
-lazy list. This provides a convenient way of getting elements out of
-an infinite lazy list.</p>
-<pre class="code">
- ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
- ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 1 1 1 1 1 ]
-</pre>
-
-<!-- lappend description -->
-<a name="lappend">
-<h3>lappend ( llist1 llist2 -- llist )</h3>
-<p>Lazily appends two lists together. The actual appending is done
-lazily on iteration rather than immediately so it works very fast no
-matter how large the list.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
-</pre>
-
-<!-- lappend* description -->
-<a name="lappendstar">
-<h3>lappend* ( llists -- llist )</h3>
-<p>Given a lazy list of lazy lists, concatenate them together in a
-lazy fashion. The actual appending is done lazily on iteration rather
-than immediately so it works very fast no matter how large the lists.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
- ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
- ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
- ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
- ( 5 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
-</pre>
-
-<!-- list>llist description -->
-<a name="list2llist">
-<h3>list>llist ( list -- llist )</h3>
-<p>Converts a normal list into a lazy list. This is done lazily so the
-initial list is not iterated through immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
-</pre>
-
-<p class="footer">
-News and updates to this software can be obtained from the authors
-weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
-<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
-</body> </html>
+++ /dev/null
-Lazy lists
+++ /dev/null
-extensions
-collections
</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> ;
! 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
"#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
] 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
{ 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
\ No newline at end of file
+
+! { { 1 2 3 4 5 } } [
+! "(list 1 2 3 4 5)" lisp-eval
+! ] unit-test
+
+] with-interactive-vocabs
! 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
+namespaces combinators math locals locals.private accessors
vectors syntax lisp.parser assocs parser sequences.lib words quotations
-fry ;
+fry lists inspector ;
IN: lisp
DEFER: convert-form
DEFER: funcall
DEFER: lookup-var
+DEFER: lisp-macro?
+DEFER: lookup-macro
+DEFER: macro-call
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: convert-body ( s-exp -- quot )
- [ ] [ convert-form compose ] reduce ; inline
+: convert-body ( cons -- quot )
+ [ ] [ convert-form compose ] foldl ; inline
-: convert-if ( s-exp -- quot )
- rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
+: convert-if ( cons -- quot )
+ cdr 3car [ convert-form ] tri@ '[ @ , , if ] ;
-: 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 ;
+ dupd [ dup lisp-symbol? [ tuck name>> swap at swap or ]
+ [ dup cons? [ localize-body ] when nip ] if
+ ] with lmap>array ;
: 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 seq>cons 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 ] ;
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-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-quoted ( cons -- quot )
+ cdr 1quotation ;
+
+: convert-unquoted ( cons -- quot )
+ "unquote not valid outside of quasiquote!" throw ;
+
+: convert-quasiquoted ( cons -- newcons )
+ [ { [ dup list? ] [ car dup lisp-symbol? ] [ name>> "unquote" equal? dup ] } && nip ]
+ [ cadr ] traverse ;
+
+: form-dispatch ( lisp-symbol -- quot )
+ name>>
+ { { "lambda" [ convert-lambda ] }
+ { "quote" [ convert-quoted ] }
+ { "unquote" [ convert-unquoted ] }
+ { "quasiquote" [ convert-quasiquoted ] }
+ { "if" [ convert-if ] }
+ { "begin" [ convert-begin ] }
+ { "cond" [ convert-cond ] }
+ [ drop convert-general-form ]
+ } case ;
+
+: macro-expand ( cons -- quot )
+ uncons lookup-macro macro-call convert-form ;
+
+: convert-list-form ( cons -- quot )
+ dup car
+ { { [ dup lisp-macro? ] [ macro-expand ] }
+ { [ dup lisp-symbol? ] [ form-dispatch ] }
+ [ drop convert-general-form ]
+ } cond ;
: convert-form ( lisp-form -- quot )
- { { [ dup s-exp? ] [ body>> convert-list-form ] }
- { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
- [ 1quotation ]
+ {
+ { [ dup cons? ] [ convert-list-form ] }
+ { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
+ [ 1quotation ]
} cond ;
: lisp-string>factor ( str -- quot )
lisp-expr parse-result-ast convert-form lambda-rewrite call ;
+: lisp-eval ( str -- * )
+ lisp-string>factor call ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env
ERROR: no-such-var var ;
+
+SYMBOL: macro-env
+
+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-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 ;
: funcall ( quot sym -- * )
dup lisp-symbol? [ lookup-var ] when call ; inline
-: define-primitve ( name vocab word -- )
- swap lookup 1quotation '[ , compose call ] lisp-define ;
\ No newline at end of file
+: define-primitive ( name vocab word -- )
+ swap lookup 1quotation '[ , compose call ] lisp-define ;
+
+: lookup-macro ( lisp-symbol -- macro )
+ name>> macro-env get at ;
+
+: lisp-macro? ( car -- ? )
+ dup lisp-symbol? [ name>> macro-env get key? ] [ drop f ] if ;
! 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
] 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
\ No newline at end of file
! 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 = "("
number = float
| rational
| integer
-id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | "#"
- | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
+id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":"
+ | "<" | "#" | " =" | ">" | "?" | "^" | "_"
+ | "~" | "+" | "-" | "." | "@"
letters = [a-zA-Z] => [[ 1array >string ]]
initials = letters | id-specials
numbers = [0-9] => [[ 1array >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
\ No newline at end of file
--- /dev/null
+James Cash
--- /dev/null
+Chris Double
+Samuel Tardieu
+Matthew Willis
--- /dev/null
+Chris Double
--- /dev/null
+USING: lazy-lists.examples lazy-lists tools.test ;
+IN: lazy-lists.examples.tests
+
+[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
+[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
--- /dev/null
+! Rewritten by Matthew Willis, July 2006
+! 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
+
+: naturals 0 lfrom ;
+: positives 1 lfrom ;
+: evens 0 [ 2 + ] lfrom-by ;
+: odds 1 lfrom [ 2 mod 1 = ] lfilter ;
+: powers-of-2 1 [ 2 * ] lfrom-by ;
+: ones 1 [ ] lfrom-by ;
+: squares naturals [ dup * ] lazy-map ;
+: first-five-squares 5 squares ltake list>array ;
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+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" } }
+{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
+{ $see-also cons car cdr nil nil? } ;
+
+{ 1lazy-list 2lazy-list 3lazy-list } related-words
+
+HELP: 1lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
+
+HELP: 2lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: 3lazy-list
+{ $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: <memoized-cons>
+{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
+{ $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? } ;
+
+{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
+
+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: 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 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" } }
+{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " 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: lfilter
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
+{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " 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: lwhile
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: luntil
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: list>vector
+{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
+{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>array } ;
+
+HELP: list>array
+{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
+{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>vector } ;
+
+HELP: lappend
+{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
+{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
+
+HELP: lfrom-by
+{ $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
+
+HELP: lfrom
+{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
+
+HELP: seq>list
+{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
+{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
+{ $see-also >list } ;
+
+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" } }
+{ $description "Concatenates a list of lists together into one list." } ;
+
+HELP: lcartesian-product
+{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
+{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcartesian-product*
+{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
+{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcomp
+{ $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
+
+HELP: lcomp*
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
+{ $examples
+ { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
+} ;
+
+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 }" }
+} ;
+
+HELP: lcontents
+{ $values { "stream" "a stream" } { "result" string } }
+{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
+{ $see-also llines } ;
+
+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 } ;
+
--- /dev/null
+! Copyright (C) 2006 Matthew Willis and Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+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
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
+] unit-test
+
+[ { 5 6 6 7 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
+] unit-test
+
+[ { 5 6 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
+] unit-test
+
+[ { 4 5 6 } ] [
+ 3 { 1 2 3 } >list [ + ] lazy-map-with list>array
+] unit-test
--- /dev/null
+! 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 ] keep
+ quot>> call ;
+
+: skip ( lazy-filter -- )
+ dup cons>> cdr >>cons ;
+
+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 ] keep
+ quot>> 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
--- /dev/null
+<html>
+ <head>
+ <title>Lazy Evaluation</title>
+ <link rel="stylesheet" type="text/css" href="style.css">
+ </head>
+ <body>
+ <h1>Lazy Evaluation</h1>
+<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
+ ability to describe infinite structures, and to delay execution of
+ expressions until they are actually used.</p>
+<p>Lazy lists, like normal lists, are composed of a head and tail. In
+ a lazy list the head and tail are something called a 'promise'.
+ To convert a
+ 'promise' into its actual value a word called 'force' is used. To
+ convert a value into a 'promise' the word to use is 'delay'.</p>
+<table border="1">
+<tr><td><a href="#delay">delay</a></td></tr>
+<tr><td><a href="#force">force</a></td></tr>
+</table>
+
+<p>Many of the lazy list words are named similar to the standard list
+ words but with an 'l' suffixed to it. Here are the commonly used
+ words and their equivalent list operation:</p>
+<table border="1">
+<tr><th>Lazy List</th><th>Normal List</th></tr>
+<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
+<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
+<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
+<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
+<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
+<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
+<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
+<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
+<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
+<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
+<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
+<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
+</table>
+<p>A few additional words specific to lazy lists are:</p>
+<table border="1">
+<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
+number of items from the lazy list.</td></tr>
+<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
+concatenate them together in a lazy manner, returning a single lazy
+list.</td></tr>
+<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
+that contains the same elements as the normal list.</td></tr>
+</table>
+<h2>Reference</h2>
+<!-- delay description -->
+<a name="delay">
+<h3>delay ( quot -- <promise> )</h3>
+<p>'delay' is used to convert a value or expression into a promise.
+ The word 'force' is used to convert that promise back to its
+ value, or to force evaluation of the expression to return a value.
+</p>
+<p>The value on the stack that 'delay' expects must be quoted. This is
+ a requirement to prevent it from being evaluated.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- force description -->
+<a name="force">
+<h3>force ( <promise> -- value )</h3>
+<p>'force' will evaluate a promises original expression
+ and leave the value of that expression on the stack.
+</p>
+<p>A promise can be forced multiple times but the expression
+ is only evaluated once. Future calls of 'force' on the promise
+ will returned the cached value of the original force. If the
+ expression contains side effects, such as i/o, then that i/o
+ will only occur on the first 'force'. See below for an example
+ (steps 3-5).
+</p>
+<p>If a promise is itself delayed, a force will evaluate all promises
+ until a value is returned. Due to this behaviour it is generally not
+ possible to delay a promise. The example below shows what happens
+ in this case.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+
+ #! Multiple forces on a promise returns cached value
+ ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
+ ( 4 ) dup <a href="#force">force</a> .
+ => hello
+ 42
+ ( 5 ) <a href="#force">force</a> .
+ => 42
+
+ #! Forcing a delayed promise cascades up to return
+ #! original value, rather than the promise.
+ ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
+ ( 7 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- lnil description -->
+<a name="lnil">
+<h3>lnil ( -- lcons )</h3>
+<p>Returns a value representing the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> .
+ => << promise [ ] [ [ ] ] t [ ] >>
+</pre>
+
+<!-- lnil description -->
+<a name="lnilp">
+<h3>lnil? ( lcons -- bool )</h3>
+<p>Returns true if the given lazy cons is the value representing
+ the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
+ => [ ]
+ ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+</pre>
+
+<!-- lcons description -->
+<a name="lcons">
+<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
+<p>Provides the same effect as 'cons' does for normal lists.
+ Both values provided must be promises (ie. expressions that have
+ had <a href="#delay">delay</a> called on them).
+</p>
+<p>As the car and cdr passed on the stack are promises, they are not
+ evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
+ are called on the lazy cons.</p>
+<pre class="code">
+ ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => "car"
+ ( 3 ) dup <a href="#lcdr">lcdr</a> .
+ => "cdr"
+</pre>
+
+<!-- lunit description -->
+<a name="lunit">
+<h3>lunit ( value-promise -- llist )</h3>
+<p>Provides the same effect as 'unit' does for normal lists. It
+creates a lazy list where the first element is the value given.</p>
+<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
+ a promise and is not evaluated until the <a href="#lcar">lcar</a>
+ of the list is requested.</a>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => 42
+ ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 4 ) [ . ] <a href="#leach">leach</a>
+ => 42
+</pre>
+
+<!-- lcar description -->
+<a name="lcar">
+<h3>lcar ( lcons -- value )</h3>
+<p>Provides the same effect as 'car' does for normal lists. It
+returns the first element in a lazy cons cell. This will force
+the evaluation of that element.</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcar">lcar</a> .
+ => 42
+</pre>
+
+<!-- lcdr description -->
+<a name="lcdr">
+<h3>lcdr ( lcons -- value )</h3>
+<p>Provides the same effect as 'cdr' does for normal lists. It
+returns the second element in a lazy cons cell and forces it. This
+causes that element to be evaluated immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> .
+ => 11
+</pre>
+
+<pre class="code">
+ ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 6
+ ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 7
+ ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 8
+</pre>
+
+<!-- lnth description -->
+<a name="lnth">
+<h3>lnth ( n llist -- value )</h3>
+<p>Provides the same effect as 'nth' does for normal lists. It
+returns the nth value in the lazy list. It causes all the values up to
+'n' to be evaluated.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) 5 swap <a href="#lnth">lnth</a> .
+ => 6
+</pre>
+
+<!-- luncons description -->
+<a name="luncons">
+<h3>luncons ( lcons -- car cdr )</h3>
+<p>Provides the same effect as 'uncons' does for normal lists. It
+returns the car and cdr of the lazy list.</p>
+<pre class="code">
+ ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#luncons">luncons</a> . .
+ => 6
+ 5
+</pre>
+
+<!-- lmap description -->
+<a name="lmap">
+<h3>lmap ( llist quot -- llist )</h3>
+<p>Lazily maps over a lazy list applying the quotation to each element.
+A new lazy list is returned which contains the results of the
+quotation.</p>
+<p>When intially called nothing in the original lazy list is
+evaluated. Only when <a href="#lcar">lcar</a> is called will the item
+in the list be evaluated and applied to the quotation. Ditto with <a
+href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
+ => < infinite list of numbers incrementing by 2 >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 4 6 8 10 ]
+</pre>
+
+<!-- lsubset description -->
+<a name="lsubset">
+<h3>lsubset ( llist pred -- llist )</h3>
+<p>Provides the same effect as 'subset' does for normal lists. It
+lazily iterates over a lazy list applying the predicate quotation to each
+element. If that quotation returns true, the element will be included
+in the resulting lazy list. If it is false, the element will be skipped.
+A new lazy list is returned which contains all elements where the
+predicate returned true.</p>
+<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
+will occur. A lazy list is returned that when values are retrieved
+from in then items are evaluated and checked against the predicate.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
+ => < infinite list of prime numbers >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 3 5 7 11 ]
+</pre>
+
+<!-- leach description -->
+<a name="leach">
+<h3>leach ( llist quot -- )</h3>
+<p>Provides the same effect as 'each' does for normal lists. It
+lazily iterates over a lazy list applying the quotation to each
+element. If this operation is applied to an infinite list it will
+never return unless the quotation escapes out by calling a continuation.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
+ => < infinite list of odd numbers >
+ ( 3 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 3
+ 5
+ 7
+ ... for ever ...
+</pre>
+
+<!-- ltake description -->
+<a name="ltake">
+<h3>ltake ( n llist -- llist )</h3>
+<p>Iterates over the lazy list 'n' times, appending each element to a
+lazy list. This provides a convenient way of getting elements out of
+an infinite lazy list.</p>
+<pre class="code">
+ ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
+ ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 1 1 1 1 1 ]
+</pre>
+
+<!-- lappend description -->
+<a name="lappend">
+<h3>lappend ( llist1 llist2 -- llist )</h3>
+<p>Lazily appends two lists together. The actual appending is done
+lazily on iteration rather than immediately so it works very fast no
+matter how large the list.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+</pre>
+
+<!-- lappend* description -->
+<a name="lappendstar">
+<h3>lappend* ( llists -- llist )</h3>
+<p>Given a lazy list of lazy lists, concatenate them together in a
+lazy fashion. The actual appending is done lazily on iteration rather
+than immediately so it works very fast no matter how large the lists.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
+ ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
+ ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
+ ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
+ ( 5 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+</pre>
+
+<!-- list>llist description -->
+<a name="list2llist">
+<h3>list>llist ( list -- llist )</h3>
+<p>Converts a normal list into a lazy list. This is done lazily so the
+initial list is not iterated through immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+</pre>
+
+<p class="footer">
+News and updates to this software can be obtained from the authors
+weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
+<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
+</body> </html>
--- /dev/null
+Lazy lists
--- /dev/null
+extensions
+collections
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+
+IN: 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." } ;
+
+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 } ;
+
+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" } { "cdr" "the tail of the list" } { "car" "the head of the list" } }
+{ $description "Put the head and tail of the list on the stack." } ;
+
+{ leach foldl lmap>array } 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: foldl
+{ $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 (in a left-assocative order) using a binary operation and outputs the final result." } ;
+
+HELP: foldr
+{ $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 (in a right-assocative order) using a binary operation, and outputs the final result." } ;
+
+HELP: lmap
+{ $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( old -- new )" } { "result" "the final result" } }
+{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
+
+HELP: lreverse
+{ $values { "list" "a cons object" } { "newlist" "a new cons object" } }
+{ $description "Reverses the input list, outputing a new, reversed list" } ;
+
+HELP: list>seq
+{ $values { "list" "a cons object" } { "array" "an array object" } }
+{ $description "Turns the given cons object into an array, maintaing order." } ;
+
+HELP: seq>list
+{ $values { "array" "an array object" } { "list" "a cons object" } }
+{ $description "Turns the given array into a cons object, maintaing order." } ;
+
+HELP: cons>seq
+{ $values { "cons" "a cons object" } { "array" "an array object" } }
+{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ;
+
+HELP: seq>cons
+{ $values { "seq" "a sequence object" } { "cons" "a cons object" } }
+{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
+
+HELP: traverse
+{ $values { " list" "a cons object" } { "pred" } { "a quotation with stack effect ( list/elt -- ? )" }
+ { "quot" "a quotation with stack effect ( list/elt -- result)" } { "result" "a new cons object" } }
+{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that " { $snippet pred }
+ " returns true for with the result of applying " { $snippet quot } " to." } ;
+
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test lists math ;
+
+IN: lists.tests
+
+{ { 3 4 5 6 7 } } [
+ { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq
+] unit-test
+
+{ { 3 4 5 6 } } [
+ T{ cons f 1
+ T{ cons f 2
+ T{ cons f 3
+ T{ cons f 4
+ +nil+ } } } } [ 2 + ] lmap>array
+] unit-test
+
+{ 10 } [
+ T{ cons f 1
+ T{ cons f 2
+ T{ cons f 3
+ T{ cons f 4
+ +nil+ } } } } 0 [ + ] foldl
+] unit-test
+
+{ T{ cons f
+ 1
+ T{ cons f
+ 2
+ T{ cons f
+ T{ cons f
+ 3
+ T{ cons f
+ 4
+ T{ cons f
+ T{ cons f 5 +nil+ }
+ +nil+ } } }
+ +nil+ } } }
+} [
+ { 1 2 { 3 4 { 5 } } } seq>cons
+] unit-test
+
+{ { 1 2 { 3 4 { 5 } } } } [
+ { 1 2 { 3 4 { 5 } } } seq>cons cons>seq
+] unit-test
+
+{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
+ { 1 2 3 4 } seq>cons [ 1+ ] lmap
+] unit-test
+
+{ 15 } [
+ { 1 2 3 4 5 } seq>list 0 [ + ] foldr
+] unit-test
+
+{ { 5 4 3 2 1 } } [
+ { 1 2 3 4 5 } seq>list lreverse list>seq
+] unit-test
+
+{ { 3 4 { 5 6 { 7 } } } } [
+ { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Chris Double & James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors math arrays vectors classes words locals ;
+
+IN: lists
+
+! List Protocol
+MIXIN: list
+GENERIC: car ( cons -- car )
+GENERIC: cdr ( cons -- cdr )
+GENERIC: nil? ( cons -- ? )
+
+TUPLE: cons car cdr ;
+
+C: cons cons
+
+M: cons car ( cons -- car )
+ car>> ;
+
+M: cons cdr ( cons -- cdr )
+ cdr>> ;
+
+SYMBOL: +nil+
+M: word nil? +nil+ eq? ;
+M: object nil? drop f ;
+
+: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
+
+: nil ( -- +nil+ ) +nil+ ;
+
+: uncons ( cons -- cdr car )
+ [ cdr ] [ car ] bi ;
+
+: 1list ( obj -- cons )
+ nil cons ;
+
+: 2list ( a b -- cons )
+ nil cons cons ;
+
+: 3list ( a b c -- cons )
+ nil cons cons cons ;
+
+: cadr ( cons -- elt )
+ cdr car ;
+
+: 2car ( cons -- car caar )
+ [ car ] [ cdr car ] bi ;
+
+: 3car ( cons -- car caar caaar )
+ [ car ] [ cdr car ] [ cdr cdr car ] tri ;
+
+: 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) ;
+
+: (leach) ( list quot -- cdr quot )
+ [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
+
+: leach ( list quot -- )
+ over nil? [ 2drop ] [ (leach) leach ] if ; inline
+
+: lmap ( list quot -- result )
+ over nil? [ drop ] [ (leach) lmap cons ] if ; inline
+
+: foldl ( list ident quot -- result ) swapd leach ; inline
+
+: foldr ( list ident quot -- result )
+ pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
+ [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
+ call
+ ] if ; inline
+
+: lreverse ( list -- newlist )
+ nil [ swap cons ] foldl ;
+
+: lappend ( list1 list2 -- newlist )
+ ;
+
+: seq>list ( seq -- list )
+ <reversed> nil [ swap cons ] reduce ;
+
+: same? ( obj1 obj2 -- ? )
+ [ class ] bi@ = ;
+
+: seq>cons ( seq -- cons )
+ [ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
+
+: (lmap>array) ( acc cons quot -- newcons )
+ over nil? [ 2drop ]
+ [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline
+
+: lmap>array ( cons quot -- newcons )
+ { } -rot (lmap>array) ; inline
+
+: lmap-as ( cons quot exemplar -- seq )
+ [ lmap>array ] dip like ;
+
+: cons>seq ( cons -- array )
+ [ dup cons? [ cons>seq ] when ] lmap>array ;
+
+: list>seq ( list -- array )
+ [ ] lmap>array ;
+
+: traverse ( list pred quot -- result )
+ [ 2over call [ tuck [ call ] 2dip ] when
+ pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ;
+
+INSTANCE: cons list
\ No newline at end of file
--- /dev/null
+Implementation of lisp-style linked lists
--- /dev/null
+cons
+lists
+sequences
--- /dev/null
+IN: logging.tests
+USING: tools.test logging math ;
+
+: input-logging-test ( a b -- c ) + ;
+
+\ input-logging-test NOTICE add-input-logging
+
+: output-logging-test ( a b -- c ) + ;
+
+\ output-logging-test DEBUG add-output-logging
+
+: error-logging-test ( a b -- c ) / ;
+
+\ error-logging-test ERROR add-error-logging
+
+"logging-test" [
+ [ 4 ] [ 1 3 input-logging-test ] unit-test
+
+ [ 4 ] [ 1 3 output-logging-test ] unit-test
+
+ [ 4/3 ] [ 4 3 error-logging-test ] unit-test
+
+ [ f ] [ 1 0 error-logging-test ] unit-test
+] with-logging
words kernel arrays shuffle tools.annotations\r
prettyprint.config prettyprint debugger io.streams.string\r
splitting continuations effects arrays.lib parser strings\r
-combinators.lib quotations ;\r
+combinators.lib quotations fry symbols accessors ;\r
IN: logging\r
\r
-SYMBOL: DEBUG\r
-SYMBOL: NOTICE\r
-SYMBOL: WARNING\r
-SYMBOL: ERROR\r
-SYMBOL: CRITICAL\r
+SYMBOLS: DEBUG NOTICE WARNING ERROR CRITICAL ;\r
\r
-: log-levels\r
- { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;\r
+: log-levels { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;\r
\r
: send-to-log-server ( array string -- )\r
prefix "log-server" get send ;\r
\r
SYMBOL: log-service\r
\r
-: check-log-message\r
- pick string?\r
- pick word?\r
- pick word? and and\r
- [ "Bad parameters to log-message" throw ] unless ;\r
+: check-log-message ( msg word level -- msg word level )\r
+ 3dup [ string? ] [ word? ] [ word? ] tri* and and\r
+ [ "Bad parameters to log-message" throw ] unless ; inline\r
\r
: log-message ( msg word level -- )\r
check-log-message\r
log-service get dup [\r
- >r >r >r string-lines r> word-name r> word-name r>\r
+ [ [ string-lines ] [ word-name ] [ word-name ] tri* ] dip\r
4array "log-message" send-to-log-server\r
] [\r
4drop\r
PRIVATE>\r
\r
: (define-logging) ( word level quot -- )\r
- >r >r dup r> r> 2curry annotate ;\r
+ [ dup ] 2dip 2curry annotate ;\r
\r
: call-logging-quot ( quot word level -- quot' )\r
"called" -rot [ log-message ] 3curry prepose ;\r
\r
: log-stack ( n word level -- )\r
log-service get [\r
- >r >r [ ndup ] keep narray stack>message\r
- r> r> log-message\r
+ [ [ ndup ] keep narray stack>message ] 2dip log-message\r
] [\r
3drop\r
] if ; inline\r
\r
-: input# stack-effect effect-in length ;\r
+: input# stack-effect in>> length ;\r
\r
: input-logging-quot ( quot word level -- quot' )\r
- over input# -rot [ log-stack ] 3curry prepose ;\r
+ rot [ [ input# ] keep ] 2dip '[ , , , log-stack @ ] ;\r
\r
: add-input-logging ( word level -- )\r
[ input-logging-quot ] (define-logging) ;\r
\r
-: output# stack-effect effect-out length ;\r
+: output# stack-effect out>> length ;\r
\r
: output-logging-quot ( quot word level -- quot' )\r
- over output# -rot [ log-stack ] 3curry compose ;\r
+ [ [ output# ] keep ] dip '[ @ , , , log-stack ] ;\r
\r
: add-output-logging ( word level -- )\r
[ output-logging-quot ] (define-logging) ;\r
\r
: (log-error) ( object word level -- )\r
log-service get [\r
- >r >r [ print-error ] with-string-writer r> r> log-message\r
+ [ [ print-error ] with-string-writer ] 2dip log-message\r
] [\r
2drop rethrow\r
] if ;\r
\r
: log-critical ( error word -- ) CRITICAL (log-error) ;\r
\r
-: stack-balancer ( effect word -- quot )\r
- >r dup effect-in length r> [ over >r ERROR log-stack r> ndrop ] 2curry\r
- swap effect-out length f <repetition> append >quotation ;\r
+: stack-balancer ( effect -- quot )\r
+ [ in>> length [ ndrop ] curry ]\r
+ [ out>> length f <repetition> >quotation ]\r
+ bi append ;\r
\r
: error-logging-quot ( quot word -- quot' )\r
- [ [ log-error ] curry ] keep\r
- [ stack-effect ] keep stack-balancer compose\r
- [ recover ] 2curry ;\r
+ dup stack-effect stack-balancer\r
+ '[ , [ , log-error @ ] recover ] ;\r
\r
: add-error-logging ( word level -- )\r
- [ over >r input-logging-quot r> error-logging-quot ]\r
+ [ [ input-logging-quot ] 2keep drop error-logging-quot ]\r
(define-logging) ;\r
\r
: LOG:\r
#! Syntax: name level\r
- CREATE-WORD\r
- dup scan-word\r
- [ >r >r 1array stack>message r> r> log-message ] 2curry\r
+ CREATE-WORD dup scan-word\r
+ '[ 1array stack>message , , log-message ]\r
define ; parsing\r
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists math.erato tools.test ;
+USING: lists.lazy math.erato tools.test ;
IN: math.erato.tests
[ { 2 3 5 7 11 13 17 19 } ] [ 20 lerato list>array ] unit-test
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lazy-lists math math.functions math.primes.list
+USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
math.ranges sequences ;
IN: math.erato
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math math.primes namespaces sequences ;
+USING: arrays kernel lists math math.primes namespaces sequences ;
IN: math.primes.factors
<PRIVATE
dup empty? [ drop ] [ first , ] if ;
: (factors) ( quot list n -- )
- dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
+ dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
: (decompose) ( n quot -- seq )
[ lprimes rot (factors) ] { } make ;
-USING: arrays math.primes tools.test lazy-lists ;
+USING: arrays math.primes tools.test lists.lazy ;
{ 1237 } [ 1234 next-prime ] unit-test
{ f t } [ 1234 prime? 1237 prime? ] unit-test
! Copyright (C) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel lazy-lists math math.functions math.miller-rabin
+USING: combinators kernel lists.lazy math math.functions math.miller-rabin
math.order math.primes.list math.ranges sequences sorting ;
IN: math.primes
: reset-memoized ( word -- )
"memoize" word-prop clear-assoc ;
+
+: invalidate-memoized ! ( inputs... word )
+ [ #in packer call ] [ "memoize" word-prop delete-at ] bi ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: mime-types.tests
+USING: mime-types tools.test ;
+
+[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
+[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test
+[ "text/plain" ] [ "foo.factor" mime-type ] unit-test
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files io.encodings.ascii assocs sequences splitting
+kernel namespaces fry memoize ;
+IN: mime-types
+
+MEMO: mime-db ( -- seq )
+ "resource:extra/mime-types/mime.types" ascii file-lines
+ [ "#" head? not ] filter [ " \t" split harvest ] map harvest ;
+
+: nonstandard-mime-types ( -- assoc )
+ H{
+ { "factor" "text/plain" }
+ { "cgi" "application/x-cgi-script" }
+ { "fhtml" "application/x-factor-server-page" }
+ } ;
+
+MEMO: mime-types ( -- assoc )
+ [ mime-db [ unclip '[ , _ set ] each ] each ] H{ } make-assoc
+ nonstandard-mime-types assoc-union ;
+
+: mime-type ( filename -- mime-type )
+ file-extension mime-types at "application/octet-stream" or ;
--- /dev/null
+# This is a comment. I love comments.
+
+# This file controls what Internet media types are sent to the client for
+# given file extension(s). Sending the correct media type to the client
+# is important so they know how to handle the content of the file.
+# Extra types can either be added here or by using an AddType directive
+# in your config files. For more information about Internet media types,
+# please read RFC 2045, 2046, 2047, 2048, and 2077. The Internet media type
+# registry is at <http://www.iana.org/assignments/media-types/>.
+
+# MIME type Extensions
+application/activemessage
+application/andrew-inset ez
+application/applefile
+application/atom+xml atom
+application/atomcat+xml atomcat
+application/atomicmail
+application/atomsvc+xml atomsvc
+application/auth-policy+xml
+application/batch-smtp
+application/beep+xml
+application/cals-1840
+application/ccxml+xml ccxml
+application/cellml+xml
+application/cnrp+xml
+application/commonground
+application/conference-info+xml
+application/cpl+xml
+application/csta+xml
+application/cstadata+xml
+application/cybercash
+application/davmount+xml davmount
+application/dca-rft
+application/dec-dx
+application/dialog-info+xml
+application/dicom
+application/dns
+application/dvcs
+application/ecmascript ecma
+application/edi-consent
+application/edi-x12
+application/edifact
+application/epp+xml
+application/eshop
+application/fastinfoset
+application/fastsoap
+application/fits
+application/font-tdpfr pfr
+application/h224
+application/http
+application/hyperstudio stk
+application/iges
+application/im-iscomposing+xml
+application/index
+application/index.cmd
+application/index.obj
+application/index.response
+application/index.vnd
+application/iotp
+application/ipp
+application/isup
+application/javascript js
+application/json json
+application/kpml-request+xml
+application/kpml-response+xml
+application/mac-binhex40 hqx
+application/mac-compactpro cpt
+application/macwriteii
+application/marc mrc
+application/mathematica ma nb mb
+application/mathml+xml mathml
+application/mbms-associated-procedure-description+xml
+application/mbms-deregister+xml
+application/mbms-envelope+xml
+application/mbms-msk+xml
+application/mbms-msk-response+xml
+application/mbms-protection-description+xml
+application/mbms-reception-report+xml
+application/mbms-register+xml
+application/mbms-register-response+xml
+application/mbms-user-service-description+xml
+application/mbox mbox
+application/mediaservercontrol+xml mscml
+application/mikey
+application/mp4 mp4s
+application/mpeg4-generic
+application/mpeg4-iod
+application/mpeg4-iod-xmt
+application/msword doc dot
+application/mxf mxf
+application/nasdata
+application/news-message-id
+application/news-transmission
+application/nss
+application/ocsp-request
+application/ocsp-response
+application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc scpt
+application/oda oda
+application/oebps-package+xml
+application/ogg ogg
+application/parityfec
+application/pdf pdf
+application/pgp-encrypted pgp
+application/pgp-keys
+application/pgp-signature asc sig
+application/pics-rules prf
+application/pidf+xml
+application/pkcs10 p10
+application/pkcs7-mime p7m p7c
+application/pkcs7-signature p7s
+application/pkix-cert cer
+application/pkix-crl crl
+application/pkix-pkipath pkipath
+application/pkixcmp pki
+application/pls+xml pls
+application/poc-settings+xml
+application/postscript ai eps ps
+application/prs.alvestrand.titrax-sheet
+application/prs.cww cww
+application/prs.nprend
+application/prs.plucker
+application/qsig
+application/rdf+xml rdf
+application/reginfo+xml rif
+application/relax-ng-compact-syntax rnc
+application/remote-printing
+application/resource-lists+xml rl
+application/riscos
+application/rlmi+xml
+application/rls-services+xml rs
+application/rsd+xml rsd
+application/rss+xml rss
+application/rtf rtf
+application/rtx
+application/samlassertion+xml
+application/samlmetadata+xml
+application/sbml+xml sbml
+application/sdp sdp
+application/set-payment
+application/set-payment-initiation setpay
+application/set-registration
+application/set-registration-initiation setreg
+application/sgml
+application/sgml-open-catalog
+application/shf+xml shf
+application/sieve
+application/simple-filter+xml
+application/simple-message-summary
+application/simplesymbolcontainer
+application/slate
+application/smil
+application/smil+xml smi smil
+application/soap+fastinfoset
+application/soap+xml
+application/spirits-event+xml
+application/srgs gram
+application/srgs+xml grxml
+application/ssml+xml ssml
+application/timestamp-query
+application/timestamp-reply
+application/tve-trigger
+application/vemmi
+application/vividence.scriptfile
+application/vnd.3gpp.bsf+xml
+application/vnd.3gpp.pic-bw-large plb
+application/vnd.3gpp.pic-bw-small psb
+application/vnd.3gpp.pic-bw-var pvb
+application/vnd.3gpp.sms
+application/vnd.3gpp2.bcmcsinfo+xml
+application/vnd.3gpp2.sms
+application/vnd.3m.post-it-notes pwn
+application/vnd.accpac.simply.aso aso
+application/vnd.accpac.simply.imp imp
+application/vnd.acucobol acu
+application/vnd.acucorp atc acutc
+application/vnd.adobe.xdp+xml xdp
+application/vnd.adobe.xfdf xfdf
+application/vnd.aether.imp
+application/vnd.amiga.ami ami
+application/vnd.anser-web-certificate-issue-initiation cii
+application/vnd.anser-web-funds-transfer-initiation fti
+application/vnd.antix.game-component atx
+application/vnd.apple.installer+xml mpkg
+application/vnd.audiograph aep
+application/vnd.autopackage
+application/vnd.avistar+xml
+application/vnd.blueice.multipass mpm
+application/vnd.bmi bmi
+application/vnd.businessobjects rep
+application/vnd.cab-jscript
+application/vnd.canon-cpdl
+application/vnd.canon-lips
+application/vnd.cendio.thinlinc.clientconf
+application/vnd.chemdraw+xml cdxml
+application/vnd.chipnuts.karaoke-mmd mmd
+application/vnd.cinderella cdy
+application/vnd.cirpack.isdn-ext
+application/vnd.claymore cla
+application/vnd.clonk.c4group c4g c4d c4f c4p c4u
+application/vnd.commerce-battelle
+application/vnd.commonspace csp cst
+application/vnd.contact.cmsg cdbcmsg
+application/vnd.cosmocaller cmc
+application/vnd.crick.clicker clkx
+application/vnd.crick.clicker.keyboard clkk
+application/vnd.crick.clicker.palette clkp
+application/vnd.crick.clicker.template clkt
+application/vnd.crick.clicker.wordbank clkw
+application/vnd.criticaltools.wbs+xml wbs
+application/vnd.ctc-posml pml
+application/vnd.cups-pdf
+application/vnd.cups-postscript
+application/vnd.cups-ppd ppd
+application/vnd.cups-raster
+application/vnd.cups-raw
+application/vnd.curl curl
+application/vnd.cybank
+application/vnd.data-vision.rdz rdz
+application/vnd.denovo.fcselayout-link fe_launch
+application/vnd.dna dna
+application/vnd.dolby.mlp mlp
+application/vnd.dpgraph dpg
+application/vnd.dreamfactory dfac
+application/vnd.dvb.esgcontainer
+application/vnd.dvb.ipdcesgaccess
+application/vnd.dxr
+application/vnd.ecdis-update
+application/vnd.ecowin.chart mag
+application/vnd.ecowin.filerequest
+application/vnd.ecowin.fileupdate
+application/vnd.ecowin.series
+application/vnd.ecowin.seriesrequest
+application/vnd.ecowin.seriesupdate
+application/vnd.enliven nml
+application/vnd.epson.esf esf
+application/vnd.epson.msf msf
+application/vnd.epson.quickanime qam
+application/vnd.epson.salt slt
+application/vnd.epson.ssf ssf
+application/vnd.ericsson.quickcall
+application/vnd.eszigno3+xml es3 et3
+application/vnd.eudora.data
+application/vnd.ezpix-album ez2
+application/vnd.ezpix-package ez3
+application/vnd.fdf fdf
+application/vnd.ffsns
+application/vnd.fints
+application/vnd.flographit gph
+application/vnd.fluxtime.clip ftc
+application/vnd.framemaker fm frame maker
+application/vnd.frogans.fnc fnc
+application/vnd.frogans.ltf ltf
+application/vnd.fsc.weblaunch fsc
+application/vnd.fujitsu.oasys oas
+application/vnd.fujitsu.oasys2 oa2
+application/vnd.fujitsu.oasys3 oa3
+application/vnd.fujitsu.oasysgp fg5
+application/vnd.fujitsu.oasysprs bh2
+application/vnd.fujixerox.art-ex
+application/vnd.fujixerox.art4
+application/vnd.fujixerox.hbpl
+application/vnd.fujixerox.ddd ddd
+application/vnd.fujixerox.docuworks xdw
+application/vnd.fujixerox.docuworks.binder xbd
+application/vnd.fut-misnet
+application/vnd.fuzzysheet fzs
+application/vnd.genomatix.tuxedo txd
+application/vnd.google-earth.kml+xml kml
+application/vnd.google-earth.kmz kmz
+application/vnd.grafeq gqf gqs
+application/vnd.gridmp
+application/vnd.groove-account gac
+application/vnd.groove-help ghf
+application/vnd.groove-identity-message gim
+application/vnd.groove-injector grv
+application/vnd.groove-tool-message gtm
+application/vnd.groove-tool-template tpl
+application/vnd.groove-vcard vcg
+application/vnd.handheld-entertainment+xml zmm
+application/vnd.hbci hbci
+application/vnd.hcl-bireports
+application/vnd.hhe.lesson-player les
+application/vnd.hp-hpgl hpgl
+application/vnd.hp-hpid hpid
+application/vnd.hp-hps hps
+application/vnd.hp-jlyt jlt
+application/vnd.hp-pcl pcl
+application/vnd.hp-pclxl pclxl
+application/vnd.httphone
+application/vnd.hzn-3d-crossword x3d
+application/vnd.ibm.afplinedata
+application/vnd.ibm.electronic-media
+application/vnd.ibm.minipay mpy
+application/vnd.ibm.modcap afp listafp list3820
+application/vnd.ibm.rights-management irm
+application/vnd.ibm.secure-container sc
+application/vnd.igloader igl
+application/vnd.immervision-ivp ivp
+application/vnd.immervision-ivu ivu
+application/vnd.informedcontrol.rms+xml
+application/vnd.intercon.formnet xpw xpx
+application/vnd.intertrust.digibox
+application/vnd.intertrust.nncp
+application/vnd.intu.qbo qbo
+application/vnd.intu.qfx qfx
+application/vnd.ipunplugged.rcprofile rcprofile
+application/vnd.irepository.package+xml irp
+application/vnd.is-xpr xpr
+application/vnd.jam jam
+application/vnd.japannet-directory-service
+application/vnd.japannet-jpnstore-wakeup
+application/vnd.japannet-payment-wakeup
+application/vnd.japannet-registration
+application/vnd.japannet-registration-wakeup
+application/vnd.japannet-setstore-wakeup
+application/vnd.japannet-verification
+application/vnd.japannet-verification-wakeup
+application/vnd.jcp.javame.midlet-rms rms
+application/vnd.jisp jisp
+application/vnd.kahootz ktz ktr
+application/vnd.kde.karbon karbon
+application/vnd.kde.kchart chrt
+application/vnd.kde.kformula kfo
+application/vnd.kde.kivio flw
+application/vnd.kde.kontour kon
+application/vnd.kde.kpresenter kpr kpt
+application/vnd.kde.kspread ksp
+application/vnd.kde.kword kwd kwt
+application/vnd.kenameaapp htke
+application/vnd.kidspiration kia
+application/vnd.kinar kne knp
+application/vnd.koan skp skd skt skm
+application/vnd.liberty-request+xml
+application/vnd.llamagraphics.life-balance.desktop lbd
+application/vnd.llamagraphics.life-balance.exchange+xml lbe
+application/vnd.lotus-1-2-3 123
+application/vnd.lotus-approach apr
+application/vnd.lotus-freelance pre
+application/vnd.lotus-notes nsf
+application/vnd.lotus-organizer org
+application/vnd.lotus-screencam scm
+application/vnd.lotus-wordpro lwp
+application/vnd.macports.portpkg portpkg
+application/vnd.marlin.drm.actiontoken+xml
+application/vnd.marlin.drm.conftoken+xml
+application/vnd.marlin.drm.mdcf
+application/vnd.mcd mcd
+application/vnd.medcalcdata mc1
+application/vnd.mediastation.cdkey cdkey
+application/vnd.meridian-slingshot
+application/vnd.mfer mwf
+application/vnd.mfmp mfm
+application/vnd.micrografx.flo flo
+application/vnd.micrografx.igx igx
+application/vnd.mif mif
+application/vnd.minisoft-hp3000-save
+application/vnd.mitsubishi.misty-guard.trustweb
+application/vnd.mobius.daf daf
+application/vnd.mobius.dis dis
+application/vnd.mobius.mbk mbk
+application/vnd.mobius.mqy mqy
+application/vnd.mobius.msl msl
+application/vnd.mobius.plc plc
+application/vnd.mobius.txf txf
+application/vnd.mophun.application mpn
+application/vnd.mophun.certificate mpc
+application/vnd.motorola.flexsuite
+application/vnd.motorola.flexsuite.adsi
+application/vnd.motorola.flexsuite.fis
+application/vnd.motorola.flexsuite.gotap
+application/vnd.motorola.flexsuite.kmr
+application/vnd.motorola.flexsuite.ttc
+application/vnd.motorola.flexsuite.wem
+application/vnd.mozilla.xul+xml xul
+application/vnd.ms-artgalry cil
+application/vnd.ms-asf asf
+application/vnd.ms-cab-compressed cab
+application/vnd.ms-excel xls xlm xla xlc xlt xlw
+application/vnd.ms-fontobject eot
+application/vnd.ms-htmlhelp chm
+application/vnd.ms-ims ims
+application/vnd.ms-lrm lrm
+application/vnd.ms-playready.initiator+xml
+application/vnd.ms-powerpoint ppt pps pot
+application/vnd.ms-project mpp mpt
+application/vnd.ms-tnef
+application/vnd.ms-wmdrm.lic-chlg-req
+application/vnd.ms-wmdrm.lic-resp
+application/vnd.ms-wmdrm.meter-chlg-req
+application/vnd.ms-wmdrm.meter-resp
+application/vnd.ms-works wps wks wcm wdb
+application/vnd.ms-wpl wpl
+application/vnd.ms-xpsdocument xps
+application/vnd.mseq mseq
+application/vnd.msign
+application/vnd.music-niff
+application/vnd.musician mus
+application/vnd.ncd.control
+application/vnd.nervana
+application/vnd.netfpx
+application/vnd.neurolanguage.nlu nlu
+application/vnd.noblenet-directory nnd
+application/vnd.noblenet-sealer nns
+application/vnd.noblenet-web nnw
+application/vnd.nokia.catalogs
+application/vnd.nokia.conml+wbxml
+application/vnd.nokia.conml+xml
+application/vnd.nokia.isds-radio-presets
+application/vnd.nokia.iptv.config+xml
+application/vnd.nokia.landmark+wbxml
+application/vnd.nokia.landmark+xml
+application/vnd.nokia.landmarkcollection+xml
+application/vnd.nokia.n-gage.ac+xml
+application/vnd.nokia.n-gage.data ngdat
+application/vnd.nokia.n-gage.symbian.install n-gage
+application/vnd.nokia.ncd
+application/vnd.nokia.pcd+wbxml
+application/vnd.nokia.pcd+xml
+application/vnd.nokia.radio-preset rpst
+application/vnd.nokia.radio-presets rpss
+application/vnd.novadigm.edm edm
+application/vnd.novadigm.edx edx
+application/vnd.novadigm.ext ext
+application/vnd.oasis.opendocument.chart odc
+application/vnd.oasis.opendocument.chart-template otc
+application/vnd.oasis.opendocument.formula odf
+application/vnd.oasis.opendocument.formula-template otf
+application/vnd.oasis.opendocument.graphics odg
+application/vnd.oasis.opendocument.graphics-template otg
+application/vnd.oasis.opendocument.image odi
+application/vnd.oasis.opendocument.image-template oti
+application/vnd.oasis.opendocument.presentation odp
+application/vnd.oasis.opendocument.presentation-template otp
+application/vnd.oasis.opendocument.spreadsheet ods
+application/vnd.oasis.opendocument.spreadsheet-template ots
+application/vnd.oasis.opendocument.text odt
+application/vnd.oasis.opendocument.text-master otm
+application/vnd.oasis.opendocument.text-template ott
+application/vnd.oasis.opendocument.text-web oth
+application/vnd.obn
+application/vnd.olpc-sugar xo
+application/vnd.oma-scws-config
+application/vnd.oma-scws-http-request
+application/vnd.oma-scws-http-response
+application/vnd.oma.bcast.associated-procedure-parameter+xml
+application/vnd.oma.bcast.drm-trigger+xml
+application/vnd.oma.bcast.imd+xml
+application/vnd.oma.bcast.notification+xml
+application/vnd.oma.bcast.sgboot
+application/vnd.oma.bcast.sgdd+xml
+application/vnd.oma.bcast.sgdu
+application/vnd.oma.bcast.simple-symbol-container
+application/vnd.oma.bcast.smartcard-trigger+xml
+application/vnd.oma.bcast.sprov+xml
+application/vnd.oma.dd2+xml dd2
+application/vnd.oma.drm.risd+xml
+application/vnd.oma.group-usage-list+xml
+application/vnd.oma.poc.groups+xml
+application/vnd.oma.xcap-directory+xml
+application/vnd.omads-email+xml
+application/vnd.omads-file+xml
+application/vnd.omads-folder+xml
+application/vnd.omaloc-supl-init
+application/vnd.openofficeorg.extension oxt
+application/vnd.osa.netdeploy
+application/vnd.osgi.dp dp
+application/vnd.otps.ct-kip+xml
+application/vnd.palm prc pdb pqa oprc
+application/vnd.paos.xml
+application/vnd.pg.format str
+application/vnd.pg.osasli ei6
+application/vnd.piaccess.application-licence
+application/vnd.picsel efif
+application/vnd.poc.group-advertisement+xml
+application/vnd.pocketlearn plf
+application/vnd.powerbuilder6 pbd
+application/vnd.powerbuilder6-s
+application/vnd.powerbuilder7
+application/vnd.powerbuilder7-s
+application/vnd.powerbuilder75
+application/vnd.powerbuilder75-s
+application/vnd.preminet
+application/vnd.previewsystems.box box
+application/vnd.proteus.magazine mgz
+application/vnd.publishare-delta-tree qps
+application/vnd.pvi.ptid1 ptid
+application/vnd.pwg-multiplexed
+application/vnd.pwg-xhtml-print+xml
+application/vnd.qualcomm.brew-app-res
+application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb
+application/vnd.rapid
+application/vnd.recordare.musicxml mxl
+application/vnd.recordare.musicxml+xml
+application/vnd.renlearn.rlprint
+application/vnd.rn-realmedia rm
+application/vnd.ruckus.download
+application/vnd.s3sms
+application/vnd.scribus
+application/vnd.sealed.3df
+application/vnd.sealed.csf
+application/vnd.sealed.doc
+application/vnd.sealed.eml
+application/vnd.sealed.mht
+application/vnd.sealed.net
+application/vnd.sealed.ppt
+application/vnd.sealed.tiff
+application/vnd.sealed.xls
+application/vnd.sealedmedia.softseal.html
+application/vnd.sealedmedia.softseal.pdf
+application/vnd.seemail see
+application/vnd.sema sema
+application/vnd.semd semd
+application/vnd.semf semf
+application/vnd.shana.informed.formdata ifm
+application/vnd.shana.informed.formtemplate itp
+application/vnd.shana.informed.interchange iif
+application/vnd.shana.informed.package ipk
+application/vnd.simtech-mindmapper twd twds
+application/vnd.smaf mmf
+application/vnd.solent.sdkm+xml sdkm sdkd
+application/vnd.spotfire.dxp dxp
+application/vnd.spotfire.sfs sfs
+application/vnd.sss-cod
+application/vnd.sss-dtf
+application/vnd.sss-ntf
+application/vnd.street-stream
+application/vnd.sun.wadl+xml
+application/vnd.sus-calendar sus susp
+application/vnd.svd svd
+application/vnd.swiftview-ics
+application/vnd.syncml+xml xsm
+application/vnd.syncml.dm+wbxml bdm
+application/vnd.syncml.dm+xml xdm
+application/vnd.syncml.ds.notification
+application/vnd.tao.intent-module-archive tao
+application/vnd.tmobile-livetv tmo
+application/vnd.trid.tpt tpt
+application/vnd.triscape.mxs mxs
+application/vnd.trueapp tra
+application/vnd.truedoc
+application/vnd.ufdl ufd ufdl
+application/vnd.uiq.theme utz
+application/vnd.umajin umj
+application/vnd.unity unityweb
+application/vnd.uoml+xml uoml
+application/vnd.uplanet.alert
+application/vnd.uplanet.alert-wbxml
+application/vnd.uplanet.bearer-choice
+application/vnd.uplanet.bearer-choice-wbxml
+application/vnd.uplanet.cacheop
+application/vnd.uplanet.cacheop-wbxml
+application/vnd.uplanet.channel
+application/vnd.uplanet.channel-wbxml
+application/vnd.uplanet.list
+application/vnd.uplanet.list-wbxml
+application/vnd.uplanet.listcmd
+application/vnd.uplanet.listcmd-wbxml
+application/vnd.uplanet.signal
+application/vnd.vcx vcx
+application/vnd.vd-study
+application/vnd.vectorworks
+application/vnd.vidsoft.vidconference
+application/vnd.visio vsd vst vss vsw
+application/vnd.visionary vis
+application/vnd.vividence.scriptfile
+application/vnd.vsf vsf
+application/vnd.wap.sic
+application/vnd.wap.slc
+application/vnd.wap.wbxml wbxml
+application/vnd.wap.wmlc wmlc
+application/vnd.wap.wmlscriptc wmlsc
+application/vnd.webturbo wtb
+application/vnd.wfa.wsc
+application/vnd.wordperfect wpd
+application/vnd.wqd wqd
+application/vnd.wrq-hp3000-labelled
+application/vnd.wt.stf stf
+application/vnd.wv.csp+wbxml
+application/vnd.wv.csp+xml
+application/vnd.wv.ssp+xml
+application/vnd.xara xar
+application/vnd.xfdl xfdl
+application/vnd.xmpie.cpkg
+application/vnd.xmpie.dpkg
+application/vnd.xmpie.plan
+application/vnd.xmpie.ppkg
+application/vnd.xmpie.xlim
+application/vnd.yamaha.hv-dic hvd
+application/vnd.yamaha.hv-script hvs
+application/vnd.yamaha.hv-voice hvp
+application/vnd.yamaha.smaf-audio saf
+application/vnd.yamaha.smaf-phrase spf
+application/vnd.yellowriver-custom-menu cmp
+application/vnd.zzazz.deck+xml zaz
+application/voicexml+xml vxml
+application/watcherinfo+xml
+application/whoispp-query
+application/whoispp-response
+application/winhlp hlp
+application/wita
+application/wordperfect5.1
+application/wsdl+xml wsdl
+application/wspolicy+xml wspolicy
+application/x-ace-compressed ace
+application/x-bcpio bcpio
+application/x-bittorrent torrent
+application/x-bzip bz
+application/x-bzip2 bz2 boz
+application/x-cdlink vcd
+application/x-chat chat
+application/x-chess-pgn pgn
+application/x-compress
+application/x-cpio cpio
+application/x-csh csh
+application/x-director dcr dir dxr fgd
+application/x-dvi dvi
+application/x-futuresplash spl
+application/x-gtar gtar
+application/x-gzip
+application/x-hdf hdf
+application/x-java-jnlp-file jnlp
+application/x-latex latex
+application/x-ms-wmd wmd
+application/x-ms-wmz wmz
+application/x-msaccess mdb
+application/x-msbinder obd
+application/x-mscardfile crd
+application/x-msclip clp
+application/x-msdownload exe dll com bat msi
+application/x-msmediaview mvb m13 m14
+application/x-msmetafile wmf
+application/x-msmoney mny
+application/x-mspublisher pub
+application/x-msschedule scd
+application/x-msterminal trm
+application/x-mswrite wri
+application/x-netcdf nc cdf
+application/x-pkcs12 p12 pfx
+application/x-pkcs7-certificates p7b spc
+application/x-pkcs7-certreqresp p7r
+application/x-rar-compressed rar
+application/x-sh sh
+application/x-shar shar
+application/x-shockwave-flash swf
+application/x-stuffit sit
+application/x-stuffitx sitx
+application/x-sv4cpio sv4cpio
+application/x-sv4crc sv4crc
+application/x-tar tar
+application/x-tcl tcl
+application/x-tex tex
+application/x-texinfo texinfo texi
+application/x-ustar ustar
+application/x-wais-source src
+application/x-x509-ca-cert der crt
+application/x400-bp
+application/xcap-att+xml
+application/xcap-caps+xml
+application/xcap-el+xml
+application/xcap-error+xml
+application/xcap-ns+xml
+application/xenc+xml xenc
+application/xhtml+xml xhtml xht
+application/xml xml xsl
+application/xml-dtd dtd
+application/xml-external-parsed-entity
+application/xmpp+xml
+application/xop+xml xop
+application/xslt+xml xslt
+application/xspf+xml xspf
+application/xv+xml mxml xhvml xvml xvm
+application/zip zip
+audio/32kadpcm
+audio/3gpp
+audio/3gpp2
+audio/ac3
+audio/amr
+audio/amr-wb
+audio/amr-wb+
+audio/asc
+audio/basic au snd
+audio/bv16
+audio/bv32
+audio/clearmode
+audio/cn
+audio/dat12
+audio/dls
+audio/dsr-es201108
+audio/dsr-es202050
+audio/dsr-es202211
+audio/dsr-es202212
+audio/dvi4
+audio/eac3
+audio/evrc
+audio/evrc-qcp
+audio/evrc0
+audio/evrc1
+audio/evrcb
+audio/evrcb0
+audio/evrcb1
+audio/g722
+audio/g7221
+audio/g723
+audio/g726-16
+audio/g726-24
+audio/g726-32
+audio/g726-40
+audio/g728
+audio/g729
+audio/g7291
+audio/g729d
+audio/g729e
+audio/gsm
+audio/gsm-efr
+audio/ilbc
+audio/l16
+audio/l20
+audio/l24
+audio/l8
+audio/lpc
+audio/midi mid midi kar rmi
+audio/mobile-xmf
+audio/mp4 mp4a
+audio/mp4a-latm m4a m4p
+audio/mpa
+audio/mpa-robust
+audio/mpeg mpga mp2 mp2a mp3 m2a m3a
+audio/mpeg4-generic
+audio/parityfec
+audio/pcma
+audio/pcmu
+audio/prs.sid
+audio/qcelp
+audio/red
+audio/rtp-enc-aescm128
+audio/rtp-midi
+audio/rtx
+audio/smv
+audio/smv0
+audio/smv-qcp
+audio/sp-midi
+audio/t140c
+audio/t38
+audio/telephone-event
+audio/tone
+audio/vdvi
+audio/vmr-wb
+audio/vnd.3gpp.iufp
+audio/vnd.4sb
+audio/vnd.audiokoz
+audio/vnd.celp
+audio/vnd.cisco.nse
+audio/vnd.cmles.radio-events
+audio/vnd.cns.anp1
+audio/vnd.cns.inf1
+audio/vnd.digital-winds eol
+audio/vnd.dlna.adts
+audio/vnd.dolby.mlp
+audio/vnd.everad.plj
+audio/vnd.hns.audio
+audio/vnd.lucent.voice lvp
+audio/vnd.nokia.mobile-xmf
+audio/vnd.nortel.vbk
+audio/vnd.nuera.ecelp4800 ecelp4800
+audio/vnd.nuera.ecelp7470 ecelp7470
+audio/vnd.nuera.ecelp9600 ecelp9600
+audio/vnd.octel.sbc
+audio/vnd.qcelp
+audio/vnd.rhetorex.32kadpcm
+audio/vnd.sealedmedia.softseal.mpeg
+audio/vnd.vmx.cvsd
+audio/wav wav
+audio/x-aiff aif aiff aifc
+audio/x-mpegurl m3u
+audio/x-ms-wax wax
+audio/x-ms-wma wma
+audio/x-pn-realaudio ram ra
+audio/x-pn-realaudio-plugin rmp
+audio/x-wav wav
+chemical/x-cdx cdx
+chemical/x-cif cif
+chemical/x-cmdf cmdf
+chemical/x-cml cml
+chemical/x-csml csml
+chemical/x-pdb pdb
+chemical/x-xyz xyz
+image/bmp bmp
+image/cgm cgm
+image/fits
+image/g3fax g3
+image/gif gif
+image/ief ief
+image/jp2 jp2
+image/jpeg jpeg jpg jpe
+image/jpm
+image/jpx
+image/naplps
+image/pict pict pic pct
+image/png png
+image/prs.btif btif
+image/prs.pti
+image/svg+xml svg svgz
+image/t38
+image/tiff tiff tif
+image/tiff-fx
+image/vnd.adobe.photoshop psd
+image/vnd.cns.inf2
+image/vnd.djvu djvu djv
+image/vnd.dwg dwg
+image/vnd.dxf dxf
+image/vnd.fastbidsheet fbs
+image/vnd.fpx fpx
+image/vnd.fst fst
+image/vnd.fujixerox.edmics-mmr mmr
+image/vnd.fujixerox.edmics-rlc rlc
+image/vnd.globalgraphics.pgb
+image/vnd.microsoft.icon ico
+image/vnd.mix
+image/vnd.ms-modi mdi
+image/vnd.net-fpx npx
+image/vnd.sealed.png
+image/vnd.sealedmedia.softseal.gif
+image/vnd.sealedmedia.softseal.jpg
+image/vnd.svf
+image/vnd.wap.wbmp wbmp
+image/vnd.xiff xif
+image/x-cmu-raster ras
+image/x-cmx cmx
+image/x-icon
+image/x-macpaint pntg pnt mac
+image/x-pcx pcx
+image/x-pict pic pct
+image/x-portable-anymap pnm
+image/x-portable-bitmap pbm
+image/x-portable-graymap pgm
+image/x-portable-pixmap ppm
+image/x-quicktime qtif qti
+image/x-rgb rgb
+image/x-xbitmap xbm
+image/x-xpixmap xpm
+image/x-xwindowdump xwd
+message/cpim
+message/delivery-status
+message/disposition-notification
+message/external-body
+message/http
+message/news
+message/partial
+message/rfc822 eml mime
+message/s-http
+message/sip
+message/sipfrag
+message/tracking-status
+model/iges igs iges
+model/mesh msh mesh silo
+model/vnd.dwf dwf
+model/vnd.flatland.3dml
+model/vnd.gdl gdl
+model/vnd.gs.gdl
+model/vnd.gtw gtw
+model/vnd.moml+xml
+model/vnd.mts mts
+model/vnd.parasolid.transmit.binary
+model/vnd.parasolid.transmit.text
+model/vnd.vtu vtu
+model/vrml wrl vrml
+multipart/alternative
+multipart/appledouble
+multipart/byteranges
+multipart/digest
+multipart/encrypted
+multipart/form-data
+multipart/header-set
+multipart/mixed
+multipart/parallel
+multipart/related
+multipart/report
+multipart/signed
+multipart/voice-message
+text/calendar ics ifb
+text/css css
+text/csv csv
+text/directory
+text/dns
+text/enriched
+text/html html htm
+text/parityfec
+text/plain txt text conf def list log in
+text/prs.fallenstein.rst
+text/prs.lines.tag dsc
+text/red
+text/rfc822-headers
+text/richtext rtx
+text/rtf
+text/rtp-enc-aescm128
+text/rtx
+text/sgml sgml sgm
+text/t140
+text/tab-separated-values tsv
+text/troff t tr roff man me ms
+text/uri-list uri uris urls
+text/vnd.abc
+text/vnd.curl
+text/vnd.dmclientscript
+text/vnd.esmertec.theme-descriptor
+text/vnd.fly fly
+text/vnd.fmi.flexstor flx
+text/vnd.in3d.3dml 3dml
+text/vnd.in3d.spot spot
+text/vnd.iptc.newsml
+text/vnd.iptc.nitf
+text/vnd.latex-z
+text/vnd.motorola.reflex
+text/vnd.ms-mediapackage
+text/vnd.net2phone.commcenter.command
+text/vnd.sun.j2me.app-descriptor jad
+text/vnd.trolltech.linguist
+text/vnd.wap.si
+text/vnd.wap.sl
+text/vnd.wap.wml wml
+text/vnd.wap.wmlscript wmls
+text/x-asm s asm
+text/x-c c cc cxx cpp h hh dic
+text/x-fortran f for f77 f90
+text/x-pascal p pas
+text/x-java-source java
+text/x-setext etx
+text/x-uuencode uu
+text/x-vcalendar vcs
+text/x-vcard vcf
+text/xml
+text/xml-external-parsed-entity
+video/3gpp 3gp
+video/3gpp-tt
+video/3gpp2 3g2
+video/bmpeg
+video/bt656
+video/celb
+video/dv
+video/h261 h261
+video/h263 h263
+video/h263-1998
+video/h263-2000
+video/h264 h264
+video/jpeg jpgv
+video/jpm jpm jpgm
+video/mj2 mj2 mjp2
+video/mp1s
+video/mp2p
+video/mp2t
+video/mp4 mp4 mp4v mpg4 m4v
+video/mp4v-es
+video/mpeg mpeg mpg mpe m1v m2v
+video/mpeg4-generic
+video/mpv
+video/nv
+video/parityfec
+video/pointer
+video/quicktime qt mov
+video/raw
+video/rtp-enc-aescm128
+video/rtx
+video/smpte292m
+video/vc1
+video/vnd.dlna.mpeg-tts
+video/vnd.fvt fvt
+video/vnd.hns.video
+video/vnd.motorola.video
+video/vnd.motorola.videop
+video/vnd.mpegurl mxu m4u
+video/vnd.nokia.interleaved-multimedia
+video/vnd.nokia.videovoip
+video/vnd.objectvideo
+video/vnd.sealed.mpeg1
+video/vnd.sealed.mpeg4
+video/vnd.sealed.swf
+video/vnd.sealedmedia.softseal.mov
+video/vnd.vivo viv
+video/x-dv dv dif
+video/x-fli fli
+video/x-ms-asf asf asx
+video/x-ms-wm wm
+video/x-ms-wmv wmv
+video/x-ms-wmx wmx
+video/x-ms-wvx wvx
+video/x-msvideo avi
+video/x-sgi-movie movie
+x-conference/x-cooltalk ice
-USING: tools.test monads math kernel sequences lazy-lists promises ;
+USING: tools.test monads math kernel sequences lists promises ;
IN: monads.tests
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences sequences.deep splitting
-accessors fry locals combinators namespaces lazy-lists
+accessors fry locals combinators namespaces lists lists.lazy
shuffle ;
IN: monads
M: list monad-of drop list-monad ;
-M: list >>= '[ , _ lmap lconcat ] ;
+M: list >>= '[ , _ lazy-map lconcat ] ;
! State
SINGLETON: state-monad
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
+USING: accessors assocs combinators hashtables kernel lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
IN: morse
<PRIVATE
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math sequences.lib locals ;
+ assocs.lib math.parser math sequences.lib locals mirrors ;
IN: namespaces.lib
] with-scope
]
] ;
+
+: make-object ( quot class -- object )
+ new [ <mirror> swap bind ] keep ; inline
+
+: with-object ( object quot -- )
+ [ <mirror> ] dip bind ; inline
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: locals math.functions math namespaces
+opengl.gl accessors kernel opengl ui.gadgets
+destructors sequences ui.render colors ;
+IN: opengl.gadgets
+
+TUPLE: texture-gadget bytes format dim tex ;
+
+: 2^-ceil ( x -- y )
+ dup 2 < [ 2 * ] [ 1- log2 1+ 2^ ] if ; foldable flushable
+
+: 2^-bounds ( dim -- dim' )
+ [ 2^-ceil ] map ; foldable flushable
+
+: <texture-gadget> ( bytes format dim -- gadget )
+ texture-gadget construct-gadget
+ swap >>dim
+ swap >>format
+ swap >>bytes ;
+
+GENERIC: render* ( texture-gadget -- )
+
+M:: texture-gadget render* ( gadget -- )
+ GL_ENABLE_BIT [
+ GL_TEXTURE_2D glEnable
+ GL_TEXTURE_2D gadget tex>> glBindTexture
+ GL_TEXTURE_2D
+ 0
+ GL_RGBA
+ gadget dim>> 2^-bounds first2
+ 0
+ gadget format>>
+ GL_UNSIGNED_BYTE
+ gadget bytes>>
+ glTexImage2D
+ init-texture
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-attribs ;
+
+:: four-corners ( dim -- )
+ [let* | w [ dim first ]
+ h [ dim second ]
+ dim' [ dim dup 2^-bounds [ /f ] 2map ]
+ w' [ dim' first ]
+ h' [ dim' second ] |
+ 0 0 glTexCoord2d 0 0 glVertex2d
+ 0 h' glTexCoord2d 0 h glVertex2d
+ w' h' glTexCoord2d w h glVertex2d
+ w' 0 glTexCoord2d w 0 glVertex2d
+ ] ;
+
+M: texture-gadget draw-gadget* ( gadget -- )
+ origin get [
+ GL_ENABLE_BIT [
+ white gl-color
+ 1.0 -1.0 glPixelZoom
+ GL_TEXTURE_2D glEnable
+ GL_TEXTURE_2D over tex>> glBindTexture
+ GL_QUADS [
+ dim>> four-corners
+ ] do-state
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-attribs
+ ] with-translation ;
+
+M: texture-gadget graft* ( gadget -- )
+ gen-texture >>tex [ render* ]
+ [ f >>bytes drop ] bi ;
+
+M: texture-gadget ungraft* ( gadget -- )
+ tex>> delete-texture ;
+
+M: texture-gadget pref-dim* ( gadget -- dim ) dim>> ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc
-continuations destructors debugger inspector
+continuations destructors debugger inspector splitting
locals unicode.case
openssl.libcrypto openssl.libssl
io.backend io.ports io.files io.encodings.8-bit io.sockets.secure
OpenSSL_add_all_digests
OpenSSL_add_all_ciphers ;
-SYMBOL: ssl-initiazed?
+SYMBOL: ssl-initialized?
: maybe-init-ssl ( -- )
- ssl-initiazed? get-global [
+ ssl-initialized? get-global [
init-ssl
- t ssl-initiazed? set-global
+ t ssl-initialized? set-global
] unless ;
-[ f ssl-initiazed? set-global ] "openssl" add-init-hook
+[ f ssl-initialized? set-global ] "openssl" add-init-hook
TUPLE: openssl-context < secure-context aliens ;
[ 256 X509_NAME_get_text_by_NID ] keep
swap -1 = [ drop f ] [ latin1 alien>string ] if ;
+: common-names-match? ( expected actual -- ? )
+ [ >lower ] bi@ "*." ?head [ tail? ] [ = ] if ;
+
: check-common-name ( host ssl-handle -- )
- SSL_get_peer_certificate common-name 2dup [ >lower ] bi@ =
+ SSL_get_peer_certificate common-name
+ 2dup common-names-match?
[ 2drop ] [ common-name-verify-error ] if ;
M: openssl check-certificate ( host ssl -- )
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! pangocairo bindings, from pango/pangocairo.h
+USING: cairo.ffi alien.c-types math
+alien.syntax system combinators alien
+memoize
+arrays pango pango.fonts ;
+IN: pango.cairo
+
+<< "pangocairo" {
+! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
+! { [ os macosx? ] [ "libpangocairo.dylib" ] }
+ { [ os unix? ] [ "libpangocairo-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pangocairo
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_new ( ) ;
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_new_for_font_type ( cairo_font_type_t fonttype ) ;
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_get_default ( ) ;
+
+FUNCTION: cairo_font_type_t
+pango_cairo_font_map_get_font_type ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: void
+pango_cairo_font_map_set_resolution ( PangoCairoFontMap* fontmap, double dpi ) ;
+
+FUNCTION: double
+pango_cairo_font_map_get_resolution ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: PangoContext*
+pango_cairo_font_map_create_context ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: cairo_scaled_font_t*
+pango_cairo_font_get_scaled_font ( PangoCairoFont* font ) ;
+
+! Update a Pango context for the current state of a cairo context
+FUNCTION: void
+pango_cairo_update_context ( cairo_t* cr, PangoContext* context ) ;
+
+FUNCTION: void
+pango_cairo_context_set_font_options ( PangoContext* context, cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_font_options_t*
+pango_cairo_context_get_font_options ( PangoContext* context ) ;
+
+FUNCTION: void
+pango_cairo_context_set_resolution ( PangoContext* context, double dpi ) ;
+
+FUNCTION: double
+pango_cairo_context_get_resolution ( PangoContext* context ) ;
+
+! Convenience
+FUNCTION: PangoLayout*
+pango_cairo_create_layout ( cairo_t* cr ) ;
+
+FUNCTION: void
+pango_cairo_update_layout ( cairo_t* cr, PangoLayout* layout ) ;
+
+! Rendering
+FUNCTION: void
+pango_cairo_show_glyph_string ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
+
+FUNCTION: void
+pango_cairo_show_layout_line ( cairo_t* cr, PangoLayoutLine* line ) ;
+
+FUNCTION: void
+pango_cairo_show_layout ( cairo_t* cr, PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_cairo_show_error_underline ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+! Rendering to a path
+FUNCTION: void
+pango_cairo_glyph_string_path ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
+
+FUNCTION: void
+pango_cairo_layout_line_path ( cairo_t* cr, PangoLayoutLine* line ) ;
+
+FUNCTION: void
+pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Higher level words and combinators
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: destructors accessors namespaces kernel cairo ;
+
+TUPLE: pango-layout alien ;
+C: <pango-layout> pango-layout
+M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
+
+: layout ( -- pango-layout ) pango-layout get ;
+
+: (with-pango) ( layout quot -- )
+ >r alien>> pango-layout r> with-variable ; inline
+
+: with-pango ( quot -- )
+ cr pango_cairo_create_layout <pango-layout> swap
+ [ (with-pango) ] curry with-disposal ; inline
+
+: pango-layout-get-pixel-size ( layout -- width height )
+ 0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
+ [ *int ] bi@ ;
+
+MEMO: dummy-cairo ( -- cr )
+ CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create cairo_create ;
+
+: dummy-pango ( quot -- )
+ >r dummy-cairo cairo r> [ with-pango ] curry with-variable ; inline
+
+: layout-size ( quot -- dim )
+ [ layout pango-layout-get-pixel-size 2array ] compose dummy-pango ; inline
+
+: layout-font ( str -- )
+ pango_font_description_from_string
+ dup zero? [ "pango: not a valid font." throw ] when
+ layout over pango_layout_set_font_description
+ pango_font_description_free ;
+
+: layout-text ( str -- )
+ layout swap -1 pango_layout_set_text ;
+
+: show-layout ( -- )
+ cr layout pango_cairo_show_layout ;
+
+: families ( -- families )
+ pango_cairo_font_map_get_default list-families ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: pango.cairo cairo cairo.ffi
+cairo.gadgets namespaces arrays
+fry accessors ui.gadgets assocs
+sequences shuffle opengl opengl.gadgets
+alien.c-types kernel math ;
+IN: pango.cairo.gadgets
+
+SYMBOL: textures
+SYMBOL: dims
+SYMBOL: refcounts
+
+: init-cache ( symbol -- )
+ dup get [ drop ] [ H{ } clone swap set-global ] if ;
+
+textures init-cache
+dims init-cache
+refcounts init-cache
+
+TUPLE: pango-gadget < cairo-gadget text font ;
+
+: cache-key ( gadget -- key )
+ [ font>> ] [ text>> ] bi 2array ;
+
+: refcount-change ( gadget quot -- )
+ >r cache-key refcounts get
+ [ [ 0 ] unless* ] r> compose change-at ;
+
+: <pango-gadget> ( font text -- gadget )
+ pango-gadget construct-gadget
+ swap >>text
+ swap >>font ;
+
+: setup-layout ( {font,text} -- quot )
+ first2 '[ , layout-font , layout-text ] ; inline
+
+M: pango-gadget quot>> ( gadget -- quot )
+ cache-key setup-layout [ show-layout ] compose
+ [ with-pango ] curry ;
+
+M: pango-gadget dim>> ( gadget -- dim )
+ cache-key dims get [ setup-layout layout-size ] cache ;
+
+M: pango-gadget graft* ( gadget -- ) [ 1+ ] refcount-change ;
+
+: release-texture ( gadget -- )
+ cache-key textures get delete-at* [ delete-texture ] [ drop ] if ;
+
+M: pango-gadget ungraft* ( gadget -- )
+ dup [ 1- ] refcount-change
+ dup cache-key refcounts get at
+ zero? [ release-texture ] [ drop ] if ;
+
+M: pango-gadget render* ( gadget -- )
+ [ gen-texture ] [ cache-key textures get set-at ] bi
+ call-next-method ;
+
+M: pango-gadget tex>> ( gadget -- texture )
+ dup cache-key textures get at
+ [ nip ] [ dup render* tex>> ] if* ;
+
+USE: ui.gadgets.panes
+: hello "Sans 50" "hello" <pango-gadget> gadget. ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: prettyprint sequences ui.gadgets.panes
+pango.cairo.gadgets math kernel cairo cairo.ffi
+pango.cairo tools.time namespaces assocs
+threads io.backend io.encodings.utf8 io.files ;
+
+IN: pango.cairo.samples
+
+: hello-pango ( -- )
+ "monospace 10" "resource:extra/pango/cairo/gadgets/gadgets.factor"
+ normalize-path utf8 file-contents
+ <pango-gadget> gadget. ;
+
+: time-pango ( -- )
+ [ hello-pango ] time ;
+
+! clear the caches, for testing.
+: clear-pango ( -- )
+ dims get clear-assoc
+ textures get clear-assoc ;
+
+MAIN: time-pango
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license
+USING: pango alien.syntax alien.c-types
+kernel ;
+IN: pango.fonts
+
+LIBRARY: pango
+
+FUNCTION: void
+pango_font_map_list_families ( PangoFontMap* fontmap, PangoFontFamily*** families, int* n_families ) ;
+
+FUNCTION: char*
+pango_font_family_get_name ( PangoFontFamily* family ) ;
+
+FUNCTION: int
+pango_font_family_is_monospace ( PangoFontFamily* family ) ;
+
+FUNCTION: void
+pango_font_family_list_faces ( PangoFontFamily* family, PangoFontFace*** faces, int* n_faces ) ;
+
+FUNCTION: char*
+pango_font_face_get_face_name ( PangoFontFace* face ) ;
+
+FUNCTION: void
+pango_font_face_list_sizes ( PangoFontFace* face, int** sizes, int* n_sizes ) ;
+
+: list-families ( PangoFontMap* -- PangoFontFamily*-seq )
+ 0 <int> 0 <int> [ pango_font_map_list_families ] 2keep
+ *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
+
+: list-faces ( PangoFontFamily* -- PangoFontFace*-seq )
+ 0 <int> 0 <int> [ pango_font_family_list_faces ] 2keep
+ *int swap *void* [ swap c-void*-array> ] [ g_free ] bi ;
+
+: list-sizes ( PangoFontFace* -- ints )
+ 0 <int> 0 <int> [ pango_font_face_list_sizes ] 2keep
+ *int swap *void* [ swap c-int-array> ] [ g_free ] bi ;
+
+: monospace? ( PangoFontFamily* -- ? )
+ pango_font_family_is_monospace 1 = ;
--- /dev/null
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license
+USING: system
+alien.c-types alien.syntax alien combinators ;
+IN: pango
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Helpful functions from other parts of pango
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<< "pango" {
+! { [ os winnt? ] [ "libpango-1.dll" ] }
+! { [ os macosx? ] [ "libpango.dylib" ] }
+ { [ os unix? ] [ "libpango-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pango
+
+: PANGO_SCALE 1024 ;
+
+FUNCTION: void
+pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
+
+FUNCTION: char*
+pango_layout_get_text ( PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ;
+
+FUNCTION: PangoFontDescription*
+pango_font_description_from_string ( char* str ) ;
+
+FUNCTION: char*
+pango_font_description_to_string ( PangoFontDescription* desc ) ;
+
+FUNCTION: char*
+pango_font_description_to_filename ( PangoFontDescription* desc ) ;
+
+FUNCTION: void
+pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ;
+
+FUNCTION: PangoFontDescription*
+pango_layout_get_font_description ( PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ;
+
+FUNCTION: void
+pango_font_description_free ( PangoFontDescription* desc ) ;
+
+! glib functions
+
+TYPEDEF: void* gpointer
+
+FUNCTION: void
+g_object_unref ( gpointer object ) ;
+
+FUNCTION: void
+g_free ( gpointer mem ) ;
"from the input string. The value consumed is the "
"result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
+{ $example "USING: lists.lazy parser-combinators prettyprint ;" "\"foo\" any-char-parser parse-1 ." "102" } } ;
! Copyright (C) 2005 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel lazy-lists tools.test strings math
+USING: kernel lists.lazy tools.test strings math
sequences parser-combinators arrays math.parser unicode.categories ;
IN: parser-combinators.tests
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists promises kernel sequences strings math
+USING: lists lists.lazy promises kernel sequences strings math
arrays splitting quotations combinators namespaces
unicode.case unicode.categories sequences.deep ;
IN: parser-combinators
>r parse-result-parsed r>
[ parse-result-parsed 2array ] keep
parse-result-unparsed <parse-result>
- ] lmap-with
- ] lmap-with lconcat ;
+ ] lazy-map-with
+ ] lazy-map-with lconcat ;
M: and-parser parse ( input parser -- list )
#! Parse 'input' by sequentially combining the
#! of parser1 and parser2 being applied to the same
#! input. This implements the choice parsing operator.
or-parser-parsers 0 swap seq>list
- [ parse ] lmap-with lconcat ;
+ [ parse ] lazy-map-with lconcat ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
-rot parse [
[ parse-result-parsed swap call ] keep
parse-result-unparsed <parse-result>
- ] lmap-with ;
+ ] lazy-map-with ;
TUPLE: some-parser p1 ;
"the input string. The numeric value of the digit "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'digit' parse-1 ." "1" } } ;
HELP: 'integer'
{ $values
"the input string. The numeric value of the integer "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"123\" 'integer' parse-1 ." "123" } } ;
HELP: 'string'
{ $values
{ "parser" "a parser object" } }
"quotations from the input string. The string value "
" consumed is the result of the parse." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"\\\"foo\\\"\" 'string' parse-1 ." "\"foo\"" } } ;
HELP: 'bold'
{ $values
"'element' should be a parser that can parse the elements. The "
"result of the parser is a sequence of the parsed elements." }
{ $examples
-{ $example "USING: lazy-lists parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
+{ $example "USING: lists.lazy parser-combinators parser-combinators.simple prettyprint ;" "\"1,2,3,4\" 'integer' comma-list parse-1 ." "{ 1 2 3 4 }" } } ;
{ $see-also 'digit' 'integer' 'string' 'bold' 'italic' comma-list } related-words
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel strings math sequences lazy-lists words
+USING: kernel strings math sequences lists.lazy words
math.parser promises parser-combinators unicode.categories ;
IN: parser-combinators.simple
--- /dev/null
+USING: math math.parser calendar calendar.format strings words
+kernel ;
+IN: present
+
+GENERIC: present ( object -- string )
+
+M: real present number>string ;
+
+M: timestamp present timestamp>string ;
+
+M: string present ;
+
+M: word present word-name ;
+
+M: f present drop "" ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists math math.primes ;
+USING: lists math math.primes ;
IN: project-euler.007
! http://projecteuler.net/index.php?section=problems&id=7
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math.algebra math math.functions
+USING: arrays kernel lists lists.lazy math.algebra math math.functions
math.order math.primes math.ranges project-euler.common sequences ;
IN: project-euler.134
PRIVATE>
: euler134 ( -- answer )
- 0 5 lprimes-from uncons [ 1000000 > ] luntil
+ 0 5 lprimes-from uncons swap [ 1000000 > ] luntil
[ [ s + ] keep ] leach drop ;
! [ euler134 ] 10 ave-time
-USING: arrays combinators kernel lazy-lists math math.parser
+USING: arrays combinators kernel lists math math.parser
namespaces parser parser-combinators parser-combinators.simple
promises quotations sequences combinators.lib strings math.order
assocs prettyprint.backend memoize unicode.case unicode.categories ;
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
- <feed xmlns="http://www.w3.org/2005/Atom">
- <title type="text">dive into mark</title>
- <subtitle type="html">
- A <em>lot</em> of effort
- went into making this effortless
- </subtitle>
- <updated>2005-07-31T12:29:29Z</updated>
- <id>tag:example.org,2003:3</id>
- <link rel="alternate" type="text/html"
- hreflang="en" href="http://example.org/"/>
- <link rel="self" type="application/atom+xml"
- href="http://example.org/feed.atom"/>
- <rights>Copyright (c) 2003, Mark Pilgrim</rights>
- <generator uri="http://www.example.com/" version="1.0">
- Example Toolkit
- </generator>
- <entry>
- <title>Atom draft-07 snapshot</title>
- <link rel="alternate" type="text/html"
- href="http://example.org/2005/04/02/atom"/>
- <link rel="enclosure" type="audio/mpeg" length="1337"
- href="http://example.org/audio/ph34r_my_podcast.mp3"/>
- <id>tag:example.org,2003:3.2397</id>
- <updated>2005-07-31T12:29:29Z</updated>
- <published>2003-12-13T08:29:29-04:00</published>
- <author>
- <name>Mark Pilgrim</name>
- <uri>http://example.org/</uri>
- <email>f8dy@example.com</email>
- </author>
- <contributor>
- <name>Sam Ruby</name>
- </contributor>
- <contributor>
- <name>Joe Gregorio</name>
- </contributor>
- <content type="xhtml" xml:lang="en"
- xml:base="http://diveintomark.org/">
- <div xmlns="http://www.w3.org/1999/xhtml">
- <p><i>[Update: The Atom draft is finished.]</i></p>
- </div>
- </content>
- </entry>
- </feed>
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-This library is a simple RSS2 parser and RSS reader web
-application. To run the web application you'll need to make sure you
-have the sqlite library working. This can be tested with
-
- "contrib/sqlite" require
- "contrib/sqlite" test-module
-
-Remember that to use "sqlite" you need to have done the following
-somewhere:
-
- USE: alien
- "sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
-
-Replacing "libsqlite3.so" with the path to the sqlite shared library
-or DLL. I put this in my ~/.factor-rc.
-
-The RSS reader web application creates a database file called
-'rss-reader.db' in the same directory as the Factor executable when
-first started. This database contains all the feed information.
-
-To load the web application use:
-
- "contrib/rss" require
-
-Fire up the web server and navigate to the URL:
-
- http://localhost:8888/responder/maintain-feeds
-
-Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
-update the sqlite database with the feed contains. Use 'Database' to
-view the entries from the database for that feed.
-
+++ /dev/null
-USING: rss io kernel io.files tools.test io.encodings.utf8
-calendar ;
-IN: rss.tests
-
-: load-news-file ( filename -- feed )
- #! Load an news syndication file and process it, returning
- #! it as an feed tuple.
- utf8 file-contents read-feed ;
-
-[ T{
- feed
- f
- "Meerkat"
- "http://meerkat.oreillynet.com"
- {
- T{
- entry
- f
- "XML: A Disruptive Technology"
- "http://c.moreover.com/click/here.pl?r123"
- "\n XML is placing increasingly heavy loads on the existing technical\n infrastructure of the Internet.\n "
- f
- }
- }
-} ] [ "resource:extra/rss/rss1.xml" load-news-file ] unit-test
-[ T{
- feed
- f
- "dive into mark"
- "http://example.org/"
- {
- T{
- entry
- f
- "Atom draft-07 snapshot"
- "http://example.org/2005/04/02/atom"
- "\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
-
- T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
- }
- }
-} ] [ "resource:extra/rss/atom.xml" load-news-file ] unit-test
+++ /dev/null
-! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: xml.utilities kernel assocs xml.generator math.order
- strings sequences xml.data xml.writer
- io.streams.string combinators xml xml.entities io.files io
- http.client namespaces xml.generator hashtables
- calendar.format accessors continuations ;
-IN: rss
-
-: any-tag-named ( tag names -- tag-inside )
- f -rot [ tag-named nip dup ] with find 2drop ;
-
-TUPLE: feed title link entries ;
-
-C: <feed> feed
-
-TUPLE: entry title link description pub-date ;
-
-C: <entry> entry
-
-: try-parsing-timestamp ( string -- timestamp )
- [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
-
-: rss1.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ]
- [ "description" tag-named children>string ]
- [
- f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named dup [ children>string try-parsing-timestamp ] when
- ]
- } cleave <entry> ;
-
-: rss1.0 ( xml -- feed )
- [
- "channel" tag-named
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ] bi
- ] [ "item" tags-named [ rss1.0-entry ] map ] bi
- <feed> ;
-
-: rss2.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ { "link" "guid" } any-tag-named children>string ]
- [ "description" tag-named children>string ]
- [
- { "date" "pubDate" } any-tag-named
- children>string try-parsing-timestamp
- ]
- } cleave <entry> ;
-
-: rss2.0 ( xml -- feed )
- "channel" tag-named
- [ "title" tag-named children>string ]
- [ "link" tag-named children>string ]
- [ "item" tags-named [ rss2.0-entry ] map ]
- tri <feed> ;
-
-: atom1.0-entry ( tag -- entry )
- {
- [ "title" tag-named children>string ]
- [ "link" tag-named "href" swap at ]
- [
- { "content" "summary" } any-tag-named
- dup tag-children [ string? not ] contains?
- [ tag-children [ write-chunk ] with-string-writer ]
- [ children>string ] if
- ]
- [
- { "published" "updated" "issued" "modified" }
- any-tag-named children>string try-parsing-timestamp
- ]
- } cleave <entry> ;
-
-: atom1.0 ( xml -- feed )
- [ "title" tag-named children>string ]
- [ "link" tag-named "href" swap at ]
- [ "entry" tags-named [ atom1.0-entry ] map ]
- tri <feed> ;
-
-: xml>feed ( xml -- feed )
- dup name-tag {
- { "RDF" [ rss1.0 ] }
- { "rss" [ rss2.0 ] }
- { "feed" [ atom1.0 ] }
- } case ;
-
-: read-feed ( string -- feed )
- [ string>xml xml>feed ] with-html-entities ;
-
-: download-feed ( url -- feed )
- #! Retrieve an news syndication file, return as a feed tuple.
- http-get read-feed ;
-
-! Atom generation
-: simple-tag, ( content name -- )
- [ , ] tag, ;
-
-: simple-tag*, ( content name attrs -- )
- [ , ] tag*, ;
-
-: entry, ( entry -- )
- "entry" [
- dup entry-title "title" { { "type" "html" } } simple-tag*,
- "link" over entry-link "href" associate contained*,
- dup entry-pub-date timestamp>rfc3339 "published" simple-tag,
- entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
- ] tag, ;
-
-: feed>xml ( feed -- xml )
- "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
- dup feed-title "title" simple-tag,
- "link" over feed-link "href" associate contained*,
- feed-entries [ entry, ] each
- ] make-xml* ;
-
-: write-feed ( feed -- )
- feed>xml write-xml ;
+++ /dev/null
-<?xml version="1.0" encoding="utf-8"?>
-
-<rdf:RDF
- xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
- xmlns:dc="http://purl.org/dc/elements/1.1/"
- xmlns:sy="http://purl.org/rss/1.0/modules/syndication/"
- xmlns:co="http://purl.org/rss/1.0/modules/company/"
- xmlns:ti="http://purl.org/rss/1.0/modules/textinput/"
- xmlns="http://purl.org/rss/1.0/"
->
-
- <channel rdf:about="http://meerkat.oreillynet.com/?_fl=rss1.0">
- <title>Meerkat</title>
- <link>http://meerkat.oreillynet.com</link>
- <description>Meerkat: An Open Wire Service</description>
- <dc:publisher>The O'Reilly Network</dc:publisher>
- <dc:creator>Rael Dornfest (mailto:rael@oreilly.com)</dc:creator>
- <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
- <dc:date>2000-01-01T12:00+00:00</dc:date>
- <sy:updatePeriod>hourly</sy:updatePeriod>
- <sy:updateFrequency>2</sy:updateFrequency>
- <sy:updateBase>2000-01-01T12:00+00:00</sy:updateBase>
-
- <image rdf:resource="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg" />
-
- <items>
- <rdf:Seq>
- <rdf:li resource="http://c.moreover.com/click/here.pl?r123" />
- </rdf:Seq>
- </items>
-
- <textinput rdf:resource="http://meerkat.oreillynet.com" />
-
- </channel>
-
- <image rdf:about="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg">
- <title>Meerkat Powered!</title>
- <url>http://meerkat.oreillynet.com/icons/meerkat-powered.jpg</url>
- <link>http://meerkat.oreillynet.com</link>
- </image>
-
- <item rdf:about="http://c.moreover.com/click/here.pl?r123">
- <title>XML: A Disruptive Technology</title>
- <link>http://c.moreover.com/click/here.pl?r123</link>
- <dc:description>
- XML is placing increasingly heavy loads on the existing technical
- infrastructure of the Internet.
- </dc:description>
- <dc:publisher>The O'Reilly Network</dc:publisher>
- <dc:creator>Simon St.Laurent (mailto:simonstl@simonstl.com)</dc:creator>
- <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
- <dc:subject>XML</dc:subject>
- <co:name>XML.com</co:name>
- <co:market>NASDAQ</co:market>
- <co:symbol>XML</co:symbol>
- </item>
-
- <textinput rdf:about="http://meerkat.oreillynet.com">
- <title>Search Meerkat</title>
- <description>Search Meerkat's RSS Database...</description>
- <name>s</name>
- <link>http://meerkat.oreillynet.com/</link>
- <ti:function>search</ti:function>
- <ti:inputType>regex</ti:inputType>
- </textinput>
-
-</rdf:RDF>
+++ /dev/null
-RSS 1.0, 2.0 and Atom feed parser
--- /dev/null
+Daniel Ehrenberg
+Chris Double
+Slava Pestov
--- /dev/null
+This library is a simple RSS2 parser and RSS reader web
+application. To run the web application you'll need to make sure you
+have the sqlite library working. This can be tested with
+
+ "contrib/sqlite" require
+ "contrib/sqlite" test-module
+
+Remember that to use "sqlite" you need to have done the following
+somewhere:
+
+ USE: alien
+ "sqlite" "/usr/lib/libsqlite3.so" "cdecl" add-library
+
+Replacing "libsqlite3.so" with the path to the sqlite shared library
+or DLL. I put this in my ~/.factor-rc.
+
+The RSS reader web application creates a database file called
+'rss-reader.db' in the same directory as the Factor executable when
+first started. This database contains all the feed information.
+
+To load the web application use:
+
+ "contrib/rss" require
+
+Fire up the web server and navigate to the URL:
+
+ http://localhost:8888/responder/maintain-feeds
+
+Add any RSS2 compatible feed. Use 'Update Feeds' to retrieve them and
+update the sqlite database with the feed contains. Use 'Database' to
+view the entries from the database for that feed.
+
--- /dev/null
+RSS 1.0, 2.0 and Atom feed parser
--- /dev/null
+USING: syndication io kernel io.files tools.test io.encodings.utf8
+calendar urls ;
+IN: syndication.tests
+
+\ download-feed must-infer
+\ feed>xml must-infer
+
+: load-news-file ( filename -- feed )
+ #! Load an news syndication file and process it, returning
+ #! it as an feed tuple.
+ utf8 file-contents read-feed ;
+
+[ T{
+ feed
+ f
+ "Meerkat"
+ URL" http://meerkat.oreillynet.com"
+ {
+ T{
+ entry
+ f
+ "XML: A Disruptive Technology"
+ URL" http://c.moreover.com/click/here.pl?r123"
+ "\n XML is placing increasingly heavy loads on the existing technical\n infrastructure of the Internet.\n "
+ f
+ }
+ }
+} ] [ "resource:extra/syndication/test/rss1.xml" load-news-file ] unit-test
+[ T{
+ feed
+ f
+ "dive into mark"
+ URL" http://example.org/"
+ {
+ T{
+ entry
+ f
+ "Atom draft-07 snapshot"
+ URL" http://example.org/2005/04/02/atom"
+ "\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
+
+ T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
+ }
+ }
+} ] [ "resource:extra/syndication/test/atom.xml" load-news-file ] unit-test
--- /dev/null
+! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
+! Portions copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml.utilities kernel assocs xml.generator math.order
+ strings sequences xml.data xml.writer
+ io.streams.string combinators xml xml.entities io.files io
+ http.client namespaces xml.generator hashtables
+ calendar.format accessors continuations urls present ;
+IN: syndication
+
+: any-tag-named ( tag names -- tag-inside )
+ f -rot [ tag-named nip dup ] with find 2drop ;
+
+TUPLE: feed title url entries ;
+
+: <feed> ( -- feed ) feed new ;
+
+TUPLE: entry title url description date ;
+
+: set-entries ( feed entries -- feed )
+ [ dup url>> ] dip
+ [ [ derive-url ] change-url ] with map
+ >>entries ;
+
+: <entry> ( -- entry ) entry new ;
+
+: try-parsing-timestamp ( string -- timestamp )
+ [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
+
+: rss1.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ]
+ [ "description" tag-named children>string >>description ]
+ [
+ f "date" "http://purl.org/dc/elements/1.1/" <name>
+ tag-named dup [ children>string try-parsing-timestamp ] when
+ >>date
+ ]
+ } cleave ;
+
+: rss1.0 ( xml -- feed )
+ feed new
+ swap [
+ "channel" tag-named
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ] bi
+ ] [ "item" tags-named [ rss1.0-entry ] map set-entries ] bi ;
+
+: rss2.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ { "link" "guid" } any-tag-named children>string >url >>url ]
+ [ "description" tag-named children>string >>description ]
+ [
+ { "date" "pubDate" } any-tag-named
+ children>string try-parsing-timestamp >>date
+ ]
+ } cleave ;
+
+: rss2.0 ( xml -- feed )
+ feed new
+ swap
+ "channel" tag-named
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named children>string >url >>url ]
+ [ "item" tags-named [ rss2.0-entry ] map set-entries ]
+ tri ;
+
+: atom1.0-entry ( tag -- entry )
+ entry new
+ swap {
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named "href" swap at >url >>url ]
+ [
+ { "content" "summary" } any-tag-named
+ dup tag-children [ string? not ] contains?
+ [ tag-children [ write-chunk ] with-string-writer ]
+ [ children>string ] if >>description
+ ]
+ [
+ { "published" "updated" "issued" "modified" }
+ any-tag-named children>string try-parsing-timestamp
+ >>date
+ ]
+ } cleave ;
+
+: atom1.0 ( xml -- feed )
+ feed new
+ swap
+ [ "title" tag-named children>string >>title ]
+ [ "link" tag-named "href" swap at >url >>url ]
+ [ "entry" tags-named [ atom1.0-entry ] map set-entries ]
+ tri ;
+
+: xml>feed ( xml -- feed )
+ dup name-tag {
+ { "RDF" [ rss1.0 ] }
+ { "rss" [ rss2.0 ] }
+ { "feed" [ atom1.0 ] }
+ } case ;
+
+: read-feed ( string -- feed )
+ [ string>xml xml>feed ] with-html-entities ;
+
+: download-feed ( url -- feed )
+ #! Retrieve an news syndication file, return as a feed tuple.
+ http-get read-feed ;
+
+! Atom generation
+: simple-tag, ( content name -- )
+ [ , ] tag, ;
+
+: simple-tag*, ( content name attrs -- )
+ [ , ] tag*, ;
+
+: entry, ( entry -- )
+ "entry" [
+ {
+ [ title>> "title" { { "type" "html" } } simple-tag*, ]
+ [ url>> present "href" associate "link" swap contained*, ]
+ [ date>> timestamp>rfc3339 "published" simple-tag, ]
+ [ description>> [ "content" { { "type" "html" } } simple-tag*, ] when* ]
+ } cleave
+ ] tag, ;
+
+: feed>xml ( feed -- xml )
+ "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
+ [ title>> "title" simple-tag, ]
+ [ url>> present "href" associate "link" swap contained*, ]
+ [ entries>> [ entry, ] each ]
+ tri
+ ] make-xml* ;
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+ <feed xmlns="http://www.w3.org/2005/Atom">
+ <title type="text">dive into mark</title>
+ <subtitle type="html">
+ A <em>lot</em> of effort
+ went into making this effortless
+ </subtitle>
+ <updated>2005-07-31T12:29:29Z</updated>
+ <id>tag:example.org,2003:3</id>
+ <link rel="alternate" type="text/html"
+ hreflang="en" href="http://example.org/"/>
+ <link rel="self" type="application/atom+xml"
+ href="http://example.org/feed.atom"/>
+ <rights>Copyright (c) 2003, Mark Pilgrim</rights>
+ <generator uri="http://www.example.com/" version="1.0">
+ Example Toolkit
+ </generator>
+ <entry>
+ <title>Atom draft-07 snapshot</title>
+ <link rel="alternate" type="text/html"
+ href="http://example.org/2005/04/02/atom"/>
+ <link rel="enclosure" type="audio/mpeg" length="1337"
+ href="http://example.org/audio/ph34r_my_podcast.mp3"/>
+ <id>tag:example.org,2003:3.2397</id>
+ <updated>2005-07-31T12:29:29Z</updated>
+ <published>2003-12-13T08:29:29-04:00</published>
+ <author>
+ <name>Mark Pilgrim</name>
+ <uri>http://example.org/</uri>
+ <email>f8dy@example.com</email>
+ </author>
+ <contributor>
+ <name>Sam Ruby</name>
+ </contributor>
+ <contributor>
+ <name>Joe Gregorio</name>
+ </contributor>
+ <content type="xhtml" xml:lang="en"
+ xml:base="http://diveintomark.org/">
+ <div xmlns="http://www.w3.org/1999/xhtml">
+ <p><i>[Update: The Atom draft is finished.]</i></p>
+ </div>
+ </content>
+ </entry>
+ </feed>
--- /dev/null
+<?xml version="1.0" encoding="utf-8"?>
+
+<rdf:RDF
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:dc="http://purl.org/dc/elements/1.1/"
+ xmlns:sy="http://purl.org/rss/1.0/modules/syndication/"
+ xmlns:co="http://purl.org/rss/1.0/modules/company/"
+ xmlns:ti="http://purl.org/rss/1.0/modules/textinput/"
+ xmlns="http://purl.org/rss/1.0/"
+>
+
+ <channel rdf:about="http://meerkat.oreillynet.com/?_fl=rss1.0">
+ <title>Meerkat</title>
+ <link>http://meerkat.oreillynet.com</link>
+ <description>Meerkat: An Open Wire Service</description>
+ <dc:publisher>The O'Reilly Network</dc:publisher>
+ <dc:creator>Rael Dornfest (mailto:rael@oreilly.com)</dc:creator>
+ <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
+ <dc:date>2000-01-01T12:00+00:00</dc:date>
+ <sy:updatePeriod>hourly</sy:updatePeriod>
+ <sy:updateFrequency>2</sy:updateFrequency>
+ <sy:updateBase>2000-01-01T12:00+00:00</sy:updateBase>
+
+ <image rdf:resource="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg" />
+
+ <items>
+ <rdf:Seq>
+ <rdf:li resource="http://c.moreover.com/click/here.pl?r123" />
+ </rdf:Seq>
+ </items>
+
+ <textinput rdf:resource="http://meerkat.oreillynet.com" />
+
+ </channel>
+
+ <image rdf:about="http://meerkat.oreillynet.com/icons/meerkat-powered.jpg">
+ <title>Meerkat Powered!</title>
+ <url>http://meerkat.oreillynet.com/icons/meerkat-powered.jpg</url>
+ <link>http://meerkat.oreillynet.com</link>
+ </image>
+
+ <item rdf:about="http://c.moreover.com/click/here.pl?r123">
+ <title>XML: A Disruptive Technology</title>
+ <link>http://c.moreover.com/click/here.pl?r123</link>
+ <dc:description>
+ XML is placing increasingly heavy loads on the existing technical
+ infrastructure of the Internet.
+ </dc:description>
+ <dc:publisher>The O'Reilly Network</dc:publisher>
+ <dc:creator>Simon St.Laurent (mailto:simonstl@simonstl.com)</dc:creator>
+ <dc:rights>Copyright © 2000 O'Reilly & Associates, Inc.</dc:rights>
+ <dc:subject>XML</dc:subject>
+ <co:name>XML.com</co:name>
+ <co:market>NASDAQ</co:market>
+ <co:symbol>XML</co:symbol>
+ </item>
+
+ <textinput rdf:about="http://meerkat.oreillynet.com">
+ <title>Search Meerkat</title>
+ <description>Search Meerkat's RSS Database...</description>
+ <name>s</name>
+ <link>http://meerkat.oreillynet.com/</link>
+ <ti:function>search</ti:function>
+ <ti:inputType>regex</ti:inputType>
+ </textinput>
+
+</rdf:RDF>
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs db db.sqlite db.postgresql http http.server http.server.actions http.server.static io io.files json.writer kernel math.parser namespaces semantic-db sequences strings tangle.path ;
+USING: accessors assocs db db.sqlite db.postgresql
+http http.server http.server.dispatchers http.server.responses
+http.server.static furnace.actions furnace.json
+io io.files json.writer kernel math.parser namespaces
+semantic-db sequences strings tangle.path ;
IN: tangle
GENERIC: render* ( content templater -- output )
[ [ db>> ] [ seq>> ] bi ] dip with-db ;
: node-response ( id -- response )
- load-node [ node-content <text-content> ] [ <404> ] if* ;
+ load-node [ node-content "text/plain" <content> ] [ <404> ] if* ;
: display-node ( params -- response )
[
: submit-node ( params -- response )
[
"node_content" swap at* [
- create-node id>> number>string <text-content>
+ create-node id>> number>string "text/plain" <content>
] [
drop <400>
] if
C: <path-responder> path-responder
M: path-responder call-responder* ( path responder -- response )
- drop path>file [ node-content <text-content> ] [ <404> ] if* ;
+ drop path>file [ node-content "text/plain" <content> ] [ <404> ] if* ;
TUPLE: tangle-dispatcher < dispatcher tangle ;
! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math math.functions tetris.board
-tetris.piece tetris.tetromino lazy-lists combinators system ;
+tetris.piece tetris.tetromino lists combinators system ;
IN: tetris.game
TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
! Copyright (C) 2006, 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays tetris.tetromino math math.vectors
-sequences quotations lazy-lists ;
+sequences quotations lists.lazy ;
IN: tetris.piece
#! A piece adds state to the tetromino that is the piece's delegate. The
[ ] [ "sudoku" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- cell 8 = 30 15 ? 100000 * small-enough?\r
+ cell 8 = 20 10 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [ "hello-ui" shake-and-bake ] unit-test\r
cell 8 = 40 20 ? 100000 * small-enough?\r
] unit-test\r
\r
+[ ] [ "maze" shake-and-bake ] unit-test\r
+\r
+[ t ] [\r
+ cell 8 = 30 15 ? 100000 * small-enough?\r
+] unit-test\r
+\r
[ ] [ "bunny" shake-and-bake ] unit-test\r
\r
[ t ] [\r
: stripped-globals ( -- seq )
[
+ "callbacks" "alien.compiler" lookup ,
+
{
bootstrap.stage2:bootstrap-time
continuations:error
{
gensym
+ name>char-hook
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
vocabs:load-vocab-hook
word
} %
+
+ { } { "optimizer.math.partial" } strip-vocab-globals %
] when
strip-prettyprint? [
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models arrays accessors
-generic generic.standard ;
+generic generic.standard definitions ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup uses \ suspend swap member? ] [ execute break ] }
{ [ dup primitive? ] [ execute break ] }
[ word-def (step-into-quot) ]
} cond ;
SYMBOL: step-all
SYMBOL: step-into-all
SYMBOL: step-back
-SYMBOL: detach
SYMBOL: abandon
SYMBOL: call-in
{
>n ndrop >c c>
continue continue-with
- stop yield suspend sleep (spawn)
+ stop suspend (spawn)
} [
dup [ execute break ] curry
"step-into" set-word-prop
+running+ set-status ;
: walker-stopped ( -- )
- +stopped+ set-status
- [ status +stopped+ eq? ]
- [ [ drop f ] handle-synchronous ]
- [ ] while ;
+ +stopped+ set-status ;
: step-into-all-loop ( -- )
+running+ set-status
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup strings byte-arrays ;
IN: unicode.collation
ABOUT: "unicode.collation"
ARTICLE: "unicode.collation" "Unicode collation algorithm"
-"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode." ;
+"The Unicode Collation Algorithm (UTS #10) forms a reasonable way to sort strings when accouting for all of the characters in Unicode. At the moment, only the default Unicode collation element table (DUCET) is used, but a more accurate collation would take locale into account. The following words are defined:"
+{ $subsection sort-strings }
+{ $subsection collation-key }
+{ $subsection string<=> }
+{ $subsection primary= }
+{ $subsection secondary= }
+{ $subsection tertiary= }
+{ $subsection quaternary= } ;
+
+HELP: sort-strings
+{ $values { "strings" "a sequence of strings" } { "sorted" "the strings in DUCET order" } }
+{ $description "This word takes a sequence of strings and sorts them according to the UCA, using code point order as a tie-breaker." } ;
+
+HELP: collation-key
+{ $values { "string" string } { "key" byte-array } }
+{ $description "This takes a string and gives a representation of the collation key, which can be compared with <=>" } ;
+
+HELP: string<=>
+{ $values { "str1" string } { "str2" string } { "<=>" "one of +lt+, +gt+ or +eq+" } }
+{ $description "This word takes two strings and compares them using the UCA with the DUCET, using code point order as a tie-breaker." } ;
+
+HELP: primary=
+{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
+{ $description "This checks whether the first level of collation is identical. This is the least specific kind of equality test. In Latin script, it can be understood as ignoring case, punctuation and accent marks." } ;
+
+HELP: secondary=
+{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
+{ $description "This checks whether the first two levels of collation are equal. For Latin script, this means accent marks are significant again, and it is otherwise similar to primary=." } ;
+
+HELP: tertiary=
+{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
+{ $description "Along the same lines as secondary=, but case is significant." } ;
+
+HELP: quaternary=
+{ $values { "str1" string } { "str2" string } { "?" "t or f" } }
+{ $description "This is similar to tertiary= but it makes punctuation significant again, while still leaving out things like null bytes and Hebrew vowel marks, which mean absolutely nothing in collation." } ;
[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test\r
[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test\r
[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test\r
+[ { "good bye" "goodbye" "hello" "HELLO" } ]\r
+[ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ]\r
+unit-test\r
\r
parse-test 2 <clumps>\r
[ [ test-two ] assoc-each ] with-null-writer\r
quotations ;\r
IN: unicode.collation\r
\r
+<PRIVATE\r
VALUE: ducet\r
\r
TUPLE: weight primary secondary tertiary ignorable? ;\r
[ [ variable-weight ] each ]\r
} cleave\r
] { } make ;\r
+PRIVATE>\r
\r
: completely-ignorable? ( weight -- ? )\r
[ primary>> ] [ secondary>> ] [ tertiary>> ] tri\r
nfd string>graphemes graphemes>weights\r
filter-ignorable weights>bytes ;\r
\r
+<PRIVATE\r
: insensitive= ( str1 str2 levels-removed -- ? )\r
[\r
swap collation-key swap\r
[ [ 0 = not ] right-trim but-last ] times\r
] curry bi@ = ;\r
+PRIVATE>\r
\r
: primary= ( str1 str2 -- ? )\r
3 insensitive= ;\r
: quaternary= ( str1 str2 -- ? )\r
0 insensitive= ;\r
\r
-: compare-collation ( {str1,key} {str2,key} -- <=> )\r
- 2dup [ second ] bi@ <=> dup +eq+ =\r
- [ drop <=> ] [ 2nip ] if ;\r
-\r
+<PRIVATE\r
: w/collation-key ( str -- {str,key} )\r
- dup collation-key 2array ;\r
+ [ collation-key ] keep 2array ;\r
+PRIVATE>\r
\r
: sort-strings ( strings -- sorted )\r
[ w/collation-key ] map\r
- [ compare-collation ] sort\r
- keys ;\r
+ natural-sort values ;\r
\r
: string<=> ( str1 str2 -- <=> )\r
- [ w/collation-key ] bi@ compare-collation ;\r
+ [ w/collation-key ] compare ;\r
--- /dev/null
+Slava Pestov
--- /dev/null
+Tools for working with URLs (uniform resource locators)
--- /dev/null
+web
+network
--- /dev/null
+IN: urls.tests
+USING: urls urls.private tools.test
+tuple-syntax arrays kernel assocs
+present ;
+
+[ "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
+
+[ "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
+
+: urls
+ {
+ {
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+ "http://www.apple.com:1234/a/path?a=b#foo"
+ }
+ {
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ path: "/a/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+ "http://www.apple.com/a/path?a=b#foo"
+ }
+ {
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/another/fine/path"
+ anchor: "foo"
+ }
+ "http://www.apple.com:1234/another/fine/path#foo"
+ }
+ {
+ TUPLE{ url
+ path: "/a/relative/path"
+ anchor: "foo"
+ }
+ "/a/relative/path#foo"
+ }
+ {
+ TUPLE{ url
+ path: "/a/relative/path"
+ }
+ "/a/relative/path"
+ }
+ {
+ TUPLE{ url
+ path: "a/relative/path"
+ }
+ "a/relative/path"
+ }
+ {
+ TUPLE{ url
+ path: "bar"
+ query: H{ { "a" "b" } }
+ }
+ "bar?a=b"
+ }
+ {
+ TUPLE{ url
+ protocol: "ftp"
+ host: "ftp.kernel.org"
+ username: "slava"
+ path: "/"
+ }
+ "ftp://slava@ftp.kernel.org/"
+ }
+ {
+ TUPLE{ url
+ protocol: "ftp"
+ host: "ftp.kernel.org"
+ username: "slava"
+ password: "secret"
+ path: "/"
+ }
+ "ftp://slava:secret@ftp.kernel.org/"
+ }
+ } ;
+
+urls [
+ [ 1array ] [ [ >url ] curry ] bi* unit-test
+] assoc-each
+
+urls [
+ swap [ 1array ] [ [ present ] curry ] bi* unit-test
+] assoc-each
+
+[ "b" ] [ "a" "b" url-append-path ] unit-test
+
+[ "a/b" ] [ "a/c" "b" url-append-path ] unit-test
+
+[ "a/b" ] [ "a/" "b" url-append-path ] unit-test
+
+[ "/b" ] [ "a" "/b" url-append-path ] unit-test
+
+[ "/b" ] [ "a/b/" "/b" url-append-path ] unit-test
+
+[ "/xxx/bar" ] [ "/xxx/baz" "bar" url-append-path ] unit-test
+
+[
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path"
+ }
+] [
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/foo"
+ }
+
+ TUPLE{ url
+ path: "/a/path"
+ }
+
+ derive-url
+] unit-test
+
+[
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path/relative/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+] [
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path/"
+ }
+
+ TUPLE{ url
+ path: "relative/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+
+ derive-url
+] unit-test
+
+[
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path/relative/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+] [
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ port: 1234
+ path: "/a/path/"
+ }
+
+ TUPLE{ url
+ path: "relative/path"
+ query: H{ { "a" "b" } }
+ anchor: "foo"
+ }
+
+ derive-url
+] unit-test
+
+[
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ path: "/xxx/baz"
+ }
+] [
+ TUPLE{ url
+ protocol: "http"
+ host: "www.apple.com"
+ path: "/xxx/bar"
+ }
+
+ TUPLE{ url
+ path: "baz"
+ }
+
+ derive-url
+] unit-test
+
+[ "a" ] [
+ <url> "a" "b" set-query-param "b" query-param
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel unicode.categories combinators sequences splitting
+fry namespaces assocs arrays strings io.sockets
+io.sockets.secure io.encodings.string io.encodings.utf8
+math math.parser accessors mirrors parser
+prettyprint.backend hashtables present ;
+IN: urls
+
+: 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
+
+<PRIVATE
+
+: push-utf8 ( ch -- )
+ 1string utf8 encode
+ [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+
+PRIVATE>
+
+: url-encode ( str -- str )
+ [
+ [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
+ ] "" make ;
+
+<PRIVATE
+
+: 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 ;
+
+PRIVATE>
+
+: url-decode ( str -- str )
+ [ 0 swap url-decode-iter ] "" make utf8 decode ;
+
+<PRIVATE
+
+: add-query-param ( value key assoc -- )
+ [
+ at [
+ {
+ { [ dup string? ] [ swap 2array ] }
+ { [ dup array? ] [ swap suffix ] }
+ { [ dup not ] [ drop ] }
+ } cond
+ ] when*
+ ] 2keep set-at ;
+
+PRIVATE>
+
+: 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 array? [ [ present ] map ] [ present 1array ] if
+ ] assoc-map
+ [
+ [
+ [ url-encode ] dip
+ [ url-encode "=" swap 3append , ] with each
+ ] assoc-each
+ ] { } make "&" join ;
+
+TUPLE: url protocol username password host port path query anchor ;
+
+: <url> ( -- url ) url new ;
+
+: query-param ( url key -- value )
+ swap query>> at ;
+
+: set-query-param ( url value key -- url )
+ '[ , , _ ?set-at ] change-query ;
+
+: parse-host ( string -- host port )
+ ":" split1 [ url-decode ] [
+ dup [
+ string>number
+ dup [ "Invalid port" throw ] unless
+ ] when
+ ] bi* ;
+
+<PRIVATE
+
+: parse-host-part ( url protocol rest -- url string' )
+ [ >>protocol ] [
+ "//" ?head [ "Invalid URL" throw ] unless
+ "@" split1 [
+ [
+ ":" split1 [ >>username ] [ >>password ] bi*
+ ] dip
+ ] when*
+ "/" split1 [
+ parse-host [ >>host ] [ >>port ] bi*
+ ] [ "/" prepend ] bi*
+ ] bi* ;
+
+PRIVATE>
+
+GENERIC: >url ( obj -- url )
+
+M: url >url ;
+
+M: string >url
+ <url> swap
+ ":" split1 [ parse-host-part ] when*
+ "#" split1 [
+ "?" split1
+ [ url-decode >>path ]
+ [ [ query>assoc >>query ] when* ] bi*
+ ]
+ [ url-decode >>anchor ] bi* ;
+
+<PRIVATE
+
+: unparse-username-password ( url -- )
+ dup username>> dup [
+ % password>> [ ":" % % ] when* "@" %
+ ] [ 2drop ] if ;
+
+: unparse-host-part ( url protocol -- )
+ %
+ "://" %
+ {
+ [ unparse-username-password ]
+ [ host>> url-encode % ]
+ [ port>> [ ":" % # ] when* ]
+ [ path>> "/" head? [ "/" % ] unless ]
+ } cleave ;
+
+M: url present
+ [
+ {
+ [ dup protocol>> dup [ unparse-host-part ] [ 2drop ] if ]
+ [ path>> url-encode % ]
+ [ query>> dup assoc-empty? [ drop ] [ "?" % assoc>query % ] if ]
+ [ anchor>> [ "#" % url-encode % ] when* ]
+ } cleave
+ ] "" make ;
+
+: url-append-path ( path1 path2 -- path )
+ {
+ { [ dup "/" head? ] [ nip ] }
+ { [ dup empty? ] [ drop ] }
+ { [ over "/" tail? ] [ append ] }
+ { [ "/" pick start not ] [ nip ] }
+ [ [ "/" last-split1 drop "/" ] dip 3append ]
+ } cond ;
+
+PRIVATE>
+
+: derive-url ( base url -- url' )
+ [ clone dup ] dip
+ 2dup [ path>> ] bi@ url-append-path
+ [ [ <mirror> ] bi@ [ nip ] assoc-filter update ] dip
+ >>path ;
+
+: relative-url ( url -- url' )
+ clone f >>protocol f >>host f >>port ;
+
+! Half-baked stuff follows
+: secure-protocol? ( protocol -- ? )
+ "https" = ;
+
+: url-addr ( url -- addr )
+ [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
+ secure-protocol? [ <secure> ] when ;
+
+: protocol-port ( protocol -- port )
+ {
+ { "http" [ 80 ] }
+ { "https" [ 443 ] }
+ { "ftp" [ 21 ] }
+ } case ;
+
+: ensure-port ( url -- url' )
+ dup protocol>> '[ , protocol-port or ] change-port ;
+
+! Literal syntax
+: URL" lexer get skip-blank parse-string >url parsed ; parsing
+
+M: url pprint* dup present "URL\" " "\"" pprint-string ;
-USING: math kernel accessors html.components
-http.server http.server.actions
-http.server.sessions html.templates.chloe fry ;
+USING: math kernel accessors http.server http.server.dispatchers
+furnace furnace.actions furnace.sessions
+html.components html.templates.chloe
+fry urls ;
IN: webapps.counter
SYMBOL: count
: <counter-action> ( quot -- action )
<action>
- swap '[ count , schange "" f <standard-redirect> ] >>submit ;
-
-: counter-template ( -- template )
- "resource:extra/webapps/counter/counter.xml" <chloe> ;
+ swap '[
+ count , schange
+ URL" $counter-app" <redirect>
+ ] >>submit ;
: <display-action> ( -- action )
<page-action>
[ count sget "counter" set-value ] >>init
- counter-template >>template ;
+ { counter-app "counter" } >>template ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
io.server
namespaces db db.sqlite smtp
http.server
-http.server.db
-http.server.flows
-http.server.sessions
-http.server.auth.login
-http.server.auth.providers.db
-http.server.boilerplate
-html.templates.chloe
+http.server.dispatchers
+furnace.db
+furnace.asides
+furnace.flash
+furnace.sessions
+furnace.auth.login
+furnace.auth.providers.db
+furnace.boilerplate
webapps.pastebin
webapps.planet
webapps.todo
webapps.wiki
+webapps.wee-url
webapps.user-admin ;
IN: webapps.factor-website
: test-db "resource:test.db" sqlite-db ;
-: factor-template ( path -- template )
- "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
-
: init-factor-db ( -- )
test-db [
init-users-table
init-articles-table
init-revisions-table
+
+ init-short-url-table
] with-db ;
+TUPLE: factor-website < dispatcher ;
+
: <factor-website> ( -- responder )
- <dispatcher>
+ factor-website new-dispatcher
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
<wiki> "wiki" add-responder
+ <wee-url> "wee-url" add-responder
<user-admin> "user-admin" add-responder
<login>
users-in-db >>users
allow-password-recovery
allow-edit-profile
<boilerplate>
- "page" factor-template >>template
- <flows>
- <sessions>
+ { factor-website "page" } >>template
+ <asides> <flash-scopes> <sessions>
test-db <db-persistence> ;
: init-factor-website ( -- )
<t:style t:include="resource:extra/webapps/factor-website/page.css" />
<t:write-style />
+
+ <t:write-atom />
</head>
<body>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Paste - Atom" t:href="$pastebin/paste.atom" t:query="id" />
+ <t:atom t:href="$pastebin/paste.atom" t:query="id">
+ Paste: <t:label t:name="summary" />
+ </t:atom>
<t:title>Paste: <t:label t:name="summary" /></t:title>
<tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:code t:name="contents" t:mode="modes" /></pre>
+ <pre class="description"><t:code t:name="contents" t:mode="mode" /></pre>
<t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
- |
- <t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
- <t:each-tuple t:values="annotations">
+ <t:bind-each t:name="annotations">
- <h2>Annotation: <t:label t:name="summary" /></h2>
+ <a name="@id"><h2>Annotation: <t:label t:name="summary" /></h2></a>
<table>
<tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
<pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
- <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
+ <t:button t:action="$pastebin/delete-annotation" t:for="id" class="link-button link">Delete Annotation</t:button>
- </t:each-tuple>
+ </t:bind-each>
- <t:bind-assoc t:name="new-annotation">
+ <t:bind t:name="new-annotation">
<h2>New Annotation</h2>
- <t:form t:action="$pastebin/new-annotation" t:for="id">
+ <t:form t:action="$pastebin/new-annotation" t:for="parent">
<table>
<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
- <tr><th class="field-label big-field-label">Body:</th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
+ <tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
<tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
<tr>
<td></td>
<input type="SUBMIT" value="Done" />
</t:form>
- </t:bind-assoc>
+ </t:bind>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$pastebin/list.atom">Pastebin</t:atom>
+
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
<div class="navbar">
<t:a t:href="$pastebin/list">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
- <t:if t:code="http.server.sessions:uid">
+ <t:if t:code="furnace.sessions:uid">
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
hashtables sequences.lib db.types db.tuples db combinators
-calendar calendar.format math.parser rss xml.writer
-xmode.catalog validators html.components html.templates.chloe
+calendar calendar.format math.parser syndication urls xml.writer
+xmode.catalog validators
+html.components
+html.templates.chloe
http.server
-http.server.actions
-http.server.auth
-http.server.auth.login
-http.server.boilerplate ;
+http.server.dispatchers
+http.server.redirection
+furnace
+furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
+furnace.syndication ;
IN: webapps.pastebin
+TUPLE: pastebin < dispatcher ;
+
! ! !
! DOMAIN MODEL
! ! !
-TUPLE: paste id summary author mode date contents annotations ;
+TUPLE: entity id summary author mode date contents ;
-\ paste "PASTE"
+entity f
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
- { "date" "DATE" DATETIME +not-null+ , }
+ { "date" "DATE" DATETIME +not-null+ }
{ "contents" "CONTENTS" TEXT +not-null+ }
} define-persistent
+GENERIC: entity-url ( entity -- url )
+
+M: entity feed-entry-title summary>> ;
+
+M: entity feed-entry-date date>> ;
+
+M: entity feed-entry-url entity-url ;
+
+TUPLE: paste < entity annotations ;
+
+\ paste "PASTES" { } define-persistent
+
: <paste> ( id -- paste )
\ paste new
swap >>id ;
: pastes ( -- pastes )
f <paste> select-tuples ;
-TUPLE: annotation aid id summary author mode contents date ;
+TUPLE: annotation < entity parent ;
-annotation "ANNOTATION"
+annotation "ANNOTATIONS"
{
- { "aid" "AID" INTEGER +db-assigned-id+ }
- { "id" "ID" INTEGER +not-null+ }
- { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
- { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
- { "mode" "MODE" { VARCHAR 256 } +not-null+ }
- { "date" "DATE" DATETIME +not-null+ }
- { "contents" "CONTENTS" TEXT +not-null+ }
+ { "parent" "PARENT" INTEGER +not-null+ }
} define-persistent
-: <annotation> ( id aid -- annotation )
+: <annotation> ( parent id -- annotation )
annotation new
- swap >>aid
- swap >>id ;
-
-: fetch-annotations ( paste -- paste )
- dup annotations>> [
- dup id>> f <annotation> select-tuples >>annotations
- ] unless ;
+ swap >>id
+ swap >>parent ;
: paste ( id -- paste )
- <paste> select-tuple fetch-annotations ;
-
-: <id-redirect> ( id next -- response )
- swap "id" associate <standard-redirect> ;
+ [ <paste> select-tuple ]
+ [ f <annotation> select-tuples ]
+ bi >>annotations ;
! ! !
! LINKS, ETC
! ! !
-: pastebin-link ( -- url )
- "$pastebin/list" f link>string ;
+: pastebin-url ( -- url )
+ URL" $pastebin/list" ;
-GENERIC: entity-link ( entity -- url )
+: paste-url ( id -- url )
+ "$pastebin/paste" >url swap "id" set-query-param ;
-M: paste entity-link
- id>> "id" associate "$pastebin/paste" swap link>string ;
+M: paste entity-url
+ id>> paste-url ;
-M: annotation entity-link
- [ id>> "id" associate "$pastebin/paste" swap link>string ]
- [ aid>> number>string "#" prepend ] bi
- append ;
+: annotation-url ( parent id -- url )
+ "$pastebin/paste" >url
+ swap number>string >>anchor
+ swap "id" set-query-param ;
-: pastebin-template ( name -- template )
- "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
+M: annotation entity-url
+ [ parent>> ] [ id>> ] bi annotation-url ;
! ! !
! PASTE LIST
: <pastebin-action> ( -- action )
<page-action>
[ pastes "pastes" set-value ] >>init
- "pastebin" pastebin-template >>template ;
-
-: pastebin-feed-entries ( seq -- entries )
- <reversed> 20 short head [
- entry new
- swap
- [ summary>> >>title ]
- [ date>> >>pub-date ]
- [ entity-link >>link ]
- tri
- ] map ;
-
-: pastebin-feed ( -- feed )
- feed new
- "Factor Pastebin" >>title
- pastebin-link >>link
- pastes pastebin-feed-entries >>entries ;
+ { pastebin "pastebin" } >>template ;
: <pastebin-feed-action> ( -- action )
- <feed-action> [ pastebin-feed ] >>feed ;
+ <feed-action>
+ [ pastebin-url ] >>url
+ [ "Factor Pastebin" ] >>title
+ [ pastes <reversed> ] >>entries ;
! ! !
! PASTES
<page-action>
[
validate-integer-id
- "id" value paste from-tuple
+ "id" value paste from-object
"id" value
"new-annotation" [
- "id" set-value
+ "parent" set-value
mode-names "modes" set-value
"factor" "mode" set-value
] nest-values
] >>init
- "paste" pastebin-template >>template ;
-
-: paste-feed-entries ( paste -- entries )
- fetch-annotations annotations>> pastebin-feed-entries ;
-
-: paste-feed ( paste -- feed )
- feed new
- swap
- [ "Paste #" swap id>> number>string append >>title ]
- [ entity-link >>link ]
- [ paste-feed-entries >>entries ]
- tri ;
+ { pastebin "paste" } >>template ;
: <paste-feed-action> ( -- action )
<feed-action>
[ validate-integer-id ] >>init
- [ "id" value paste annotations>> paste-feed ] >>feed ;
+ [ "id" value paste-url ] >>url
+ [ "Paste " "id" value number>string append ] >>title
+ [ "id" value f <annotation> select-tuples ] >>entries ;
-: validate-paste ( -- )
+: validate-entity ( -- )
{
{ "summary" [ v-one-line ] }
{ "author" [ v-one-line ] }
{ "captcha" [ v-captcha ] }
} validate-params ;
-: deposit-paste-slots ( tuple -- )
+: deposit-entity-slots ( tuple -- )
now >>date
{ "summary" "author" "mode" "contents" } deposit-slots ;
mode-names "modes" set-value
] >>init
- "new-paste" pastebin-template >>template
+ { pastebin "new-paste" } >>template
+
+ [ mode-names "modes" set-value ] >>validate
[
- validate-paste
+ validate-entity
f <paste>
- [ deposit-paste-slots ]
+ [ deposit-entity-slots ]
[ insert-tuple ]
- [ id>> "$pastebin/paste" <id-redirect> ]
+ [ id>> paste-url <redirect> ]
tri
] >>submit ;
[
"id" value <paste> delete-tuples
"id" value f <annotation> delete-tuples
- "$pastebin/list" f <permanent-redirect>
+ URL" $pastebin/list" <redirect>
] >>submit ;
! ! !
! ! !
: <new-annotation-action> ( -- action )
- <page-action>
- [ validate-paste ] >>validate
-
- [ "id" param "$pastebin/paste" <id-redirect> ] >>display
+ <action>
+ [
+ { { "parent" [ v-integer ] } } validate-params
+ validate-entity
+ ] >>validate
[
- f f <annotation>
- {
- [ deposit-paste-slots ]
- [ { "id" } deposit-slots ]
- [ insert-tuple ]
- [
- ! Add anchor here
- id>> "$pastebin/paste" <id-redirect>
- ]
- } cleave
+ "parent" value f <annotation>
+ [ deposit-entity-slots ]
+ [ insert-tuple ]
+ [ entity-url <redirect> ]
+ tri
] >>submit ;
: <delete-annotation-action> ( -- action )
<action>
- [ { { "aid" [ v-number ] } } validate-params ] >>validate
+ [ { { "id" [ v-number ] } } validate-params ] >>validate
[
- f "
aid" value <annotation> select-tuple
+ f "id" value <annotation> select-tuple
[ delete-tuples ]
- [ id>> "$pastebin/paste" <id-redirect> ]
+ [ parent>> paste-url <redirect> ]
bi
] >>submit ;
-TUPLE: pastebin < dispatcher ;
-
SYMBOL: can-delete-pastes?
can-delete-pastes? define-capability
<paste-action> "paste" add-responder
<paste-feed-action> "paste.atom" add-responder
<new-paste-action> "new-paste" add-responder
- <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
+ <delete-paste-action> <protected>
+ "delete pastes" >>description
+ { can-delete-pastes? } >>capabilities "delete-paste" add-responder
<new-annotation-action> "new-annotation" add-responder
- <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
+ <delete-annotation-action> <protected>
+ "delete annotations" >>description
+ { can-delete-pastes? } >>capabilities "delete-annotation" add-responder
<boilerplate>
- "pastebin-common" pastebin-template >>template ;
+ { pastebin "pastebin-common" } >>template ;
: init-pastes-table \ paste ensure-table ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Pastebin - Atom" t:href="$pastebin/list.atom" />
-
<t:title>Pastebin</t:title>
<table width="100%">
<th align="left" width="100">Paste by:</th>
<th align="left" width="200">Date:</th>
- <t:each-tuple t:values="pastes">
+ <t:bind-each t:name="pastes">
<tr>
<td><t:a t:href="$pastebin/paste" t:query="id"><t:label t:name="summary" /></t:a></td>
<td><t:label t:name="author" /></td>
<td><t:label t:name="date" /></td>
</tr>
- </t:each-tuple>
+ </t:bind-each>
</table>
</t:chloe>
<t:title>Planet Factor Administration</t:title>
<ul>
- <t:each-tuple t:values="blogroll">
+ <t:bind-each t:name="blogroll">
<li>
<t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
<t:label t:name="name" />
</t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
- <p>
+ <div>
<t:a t:href="$planet-factor/admin/new-blog">Add Blog</t:a>
| <t:button t:action="$planet-factor/admin/update" class="link-button link">Update</t:button>
- </p>
+ </div>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <p class="news">
- <strong><t:view t:component="title" /></strong> <br/>
- <t:a value="link" t:session="none" class="more">Read More...</t:a>
- </p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h2 class="posting-title">
- <t:a t:value="link" t:session="none"><t:view t:component="title" /></t:a>
- </h2>
-
- <p class="posting-body">
- <t:view t:component="description" />
- </p>
-
- <p class="posting-date">
- <t:a t:value="link" t:session="none"><t:view t:component="pub-date" /></t:a>
- </p>
-
-</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:each-tuple t:values="postings">
+ <t:bind-each t:name="postings">
<p class="news">
- <strong><t:view t:component="title" /></strong> <br/>
- <t:a value="link" t:session="none" class="more">Read More...</t:a>
+ <strong><t:label t:name="title" /></strong> <br/>
+ <t:a value="link" class="more">Read More...</t:a>
</p>
- </t:each-tuple>
+ </t:bind-each>
</t:chloe>
| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
| <t:a t:href="$planet-factor/admin">Admin</t:a>
- <t:if t:code="http.server.sessions:uid">
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.sessions:uid">
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
</div>
USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
sequences.lib db.types db.tuples db fry locals hashtables
-html.components html.templates.chloe
-rss xml.writer
+html.components
+syndication urls xml.writer
validators
http.server
-http.server.actions
-http.server.boilerplate
-http.server.auth.login
-http.server.auth ;
+http.server.dispatchers
+furnace
+furnace.actions
+furnace.boilerplate
+furnace.auth.login
+furnace.auth
+furnace.syndication ;
IN: webapps.planet
-: planet-template ( name -- template )
- "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+TUPLE: planet-factor < dispatcher ;
+
+TUPLE: planet-factor-admin < dispatcher ;
TUPLE: blog id name www-url feed-url ;
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
} define-persistent
-! TUPLE: posting < entry id ;
-TUPLE: posting id title link description pub-date ;
+TUPLE: posting < entry id ;
posting "POSTINGS"
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "title" "TITLE" { VARCHAR 256 } +not-null+ }
- { "link" "LINK" { VARCHAR 256 } +not-null+ }
+ { "url" "LINK" { VARCHAR 256 } +not-null+ }
{ "description" "DESCRIPTION" TEXT +not-null+ }
- { "pub-date" "DATE" TIMESTAMP +not-null+ }
+ { "date" "DATE" TIMESTAMP +not-null+ }
} define-persistent
: init-blog-table blog ensure-table ;
: postings ( -- seq )
posting new select-tuples
- [ [ pub-date>> ] compare invert-comparison ] sort ;
+ [ [ date>> ] compare invert-comparison ] sort ;
: <edit-blogroll-action> ( -- action )
<page-action>
[ blogroll "blogroll" set-value ] >>init
- "admin" planet-template >>template ;
+ { planet-factor "admin" } >>template ;
: <planet-action> ( -- action )
<page-action>
postings "postings" set-value
] >>init
- "planet" planet-template >>template ;
-
-: planet-feed ( -- feed )
- feed new
- "Planet Factor" >>title
- "http://planet.factorcode.org" >>link
- postings >>entries ;
+ { planet-factor "planet" } >>template ;
: <planet-feed-action> ( -- action )
- <feed-action> [ planet-feed ] >>feed ;
+ <feed-action>
+ [ "Planet Factor" ] >>title
+ [ URL" $planet-factor" ] >>url
+ [ postings ] >>entries ;
:: <posting> ( entry name -- entry' )
posting new
name ": " entry title>> 3append >>title
- entry link>> >>link
+ entry url>> >>url
entry description>> >>description
- entry pub-date>> >>pub-date ;
+ entry date>> >>date ;
: fetch-feed ( url -- feed )
download-feed entries>> ;
[ '[ , <posting> ] map ] 2map concat ;
: sort-entries ( entries -- entries' )
- [ [ pub-date>> ] compare invert-comparison ] sort ;
+ [ [ date>> ] compare invert-comparison ] sort ;
: update-cached-postings ( -- )
blogroll fetch-blogroll sort-entries 8 short head [
<action>
[
update-cached-postings
- "" f <permanent-redirect>
+ URL" $planet-factor/admin" <redirect>
] >>submit ;
: <delete-blog-action> ( -- action )
[
"id" value <blog> delete-tuples
- "$planet-factor/admin" f <standard-redirect>
+ URL" $planet-factor/admin" <redirect>
] >>submit ;
: validate-blog ( -- )
{ "feed-url" [ v-url ] }
} validate-params ;
-: <id-redirect> ( id next -- response )
- swap "id" associate <standard-redirect> ;
-
: deposit-blog-slots ( blog -- )
{ "name" "www-url" "feed-url" } deposit-slots ;
: <new-blog-action> ( -- action )
<page-action>
- "new-blog" planet-template >>template
+ { planet-factor "new-blog" } >>template
[ validate-blog ] >>validate
f <blog>
[ deposit-blog-slots ]
[ insert-tuple ]
- [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ]
+ [
+ <url>
+ "$planet-factor/admin/edit-blog" >>path
+ swap id>> "id" set-query-param
+ <redirect>
+ ]
tri
] >>submit ;
<page-action>
[
validate-integer-id
- "id" value <blog> select-tuple from-tuple
+ "id" value <blog> select-tuple from-object
] >>init
- "edit-blog" planet-template >>template
+ { planet-factor "edit-blog" } >>template
[
validate-integer-id
f <blog>
[ deposit-blog-slots ]
[ update-tuple ]
- [ id>> "$planet-factor/admin" <id-redirect> ]
+ [
+ <url>
+ "$planet-factor/admin" >>path
+ swap id>> "id" set-query-param
+ <redirect>
+ ]
tri
] >>submit ;
-TUPLE: planet-factor-admin < dispatcher ;
-
: <planet-factor-admin> ( -- responder )
planet-factor-admin new-dispatcher
<edit-blogroll-action> "blogroll" add-main-responder
can-administer-planet-factor? define-capability
-TUPLE: planet-factor < dispatcher ;
-
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
<planet-action> "list" add-main-responder
- <feed-action> "feed.xml" add-responder
- <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
+ <planet-feed-action> "feed.xml" add-responder
+ <planet-factor-admin> <protected>
+ "administer Planet Factor" >>description
+ { can-administer-planet-factor? } >>capabilities
+ "admin" add-responder
<boilerplate>
- "planet-common" planet-template >>template ;
+ { planet-factor "planet-common" } >>template ;
: start-update-task ( db params -- )
'[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
<tr>
<td>
- <t:each-tuple t:values="postings">
+ <t:bind-each t:name="postings">
<h2 class="posting-title">
- <t:a t:value="link" t:session="none"><t:label t:name="title" /></t:a>
+ <t:a t:value="url"><t:label t:name="title" /></t:a>
</h2>
<p class="posting-body">
</p>
<p class="posting-date">
- <t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
+ <t:a t:value="url"><t:label t:name="pub-date" /></t:a>
</p>
- </t:each-tuple>
+ </t:bind-each>
</td>
<h2>Blogroll</h2>
<ul>
- <t:each t:values="blogroll">
+ <t:each t:name="blogroll">
<li>
<t:link t:name="value"/>
</li>
<input type="SUBMIT" value="Done" />
</t:form>
- <t:if t:value="id">
-
- <t:a t:href="$todo-list/view" t:query="id">View</t:a>
- |
- <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
-
- </t:if>
+ <t:a t:href="$todo-list/view" t:query="id">View</t:a>
+ |
+ <t:button t:action="$todo-list/delete" t:for="id" class="link-button link">Delete</t:button>
</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New Item</t:title>
+
+ <t:form t:action="$todo-list/new">
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:field t:name="priority" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="description" t:rows="20" t:cols="60" /></td></tr>
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+
+</t:chloe>
<th>Edit</th>
</tr>
- <t:each-tuple t:values="items">
+ <t:bind-each t:name="items">
<tr>
<td>
</td>
</tr>
- </t:each-tuple>
+ </t:bind-each>
</table>
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces
-db db.types db.tuples validators hashtables
+db db.types db.tuples validators hashtables urls
html.components
html.templates.chloe
-http.server.sessions
-http.server.boilerplate
-http.server.auth
-http.server.actions
-http.server.db
-http.server.auth.login
-http.server ;
+http.server
+http.server.dispatchers
+furnace
+furnace.sessions
+furnace.boilerplate
+furnace.auth
+furnace.actions
+furnace.db
+furnace.auth.login ;
IN: webapps.todo
+TUPLE: todo-list < dispatcher ;
+
TUPLE: todo uid id priority summary description ;
todo "TODO"
swap >>id
uid >>uid ;
-: todo-template ( name -- template )
- "resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
-
: <view-action> ( -- action )
<page-action>
[
validate-integer-id
- "id" value <todo> select-tuple from-tuple
+ "id" value <todo> select-tuple from-object
] >>init
- "view-todo" todo-template >>template ;
-
-: <id-redirect> ( id next -- response )
- swap "id" associate <standard-redirect> ;
+ { todo-list "view-todo" } >>template ;
: validate-todo ( -- )
{
<page-action>
[ 0 "priority" set-value ] >>init
- "edit-todo" todo-template >>template
+ { todo-list "new-todo" } >>template
[ validate-todo ] >>validate
[
f <todo>
- dup { "summary" "description" } deposit-slots
+ dup { "summary" "priority" "description" } deposit-slots
[ insert-tuple ]
- [ id>> "$todo-list/view" <id-redirect> ]
+ [
+ <url>
+ "$todo-list/view" >>path
+ swap id>> "id" set-query-param
+ <redirect>
+ ]
bi
] >>submit ;
<page-action>
[
validate-integer-id
- "id" value <todo> select-tuple from-tuple
+ "id" value <todo> select-tuple from-object
] >>init
- "edit-todo" todo-template >>template
+ { todo-list "edit-todo" } >>template
[
validate-integer-id
f <todo>
dup { "id" "summary" "priority" "description" } deposit-slots
[ update-tuple ]
- [ id>> "$todo-list/view" <id-redirect> ]
+ [
+ <url>
+ "$todo-list/view" >>path
+ swap id>> "id" set-query-param
+ <redirect>
+ ]
bi
] >>submit ;
[
"id" get <todo> delete-tuples
- "$todo-list/list" f <standard-redirect>
+ URL" $todo-list/list" <redirect>
] >>submit ;
: <list-action> ( -- action )
<page-action>
[ f <todo> select-tuples "items" set-value ] >>init
- "todo-list" todo-template >>template ;
-
-TUPLE: todo-list < dispatcher ;
+ { todo-list "todo-list" } >>template ;
: <todo-list> ( -- responder )
todo-list new-dispatcher
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<boilerplate>
- "todo" todo-template >>template
- f <protected> ;
+ { todo-list "todo" } >>template
+ <protected>
+ "view your todo list" >>description ;
<div class="navbar">
<t:a t:href="$todo-list/list">List Items</t:a>
- | <t:a t:href="$todo-list/edit">Add Item</t:a>
+ | <t:a t:href="$todo-list/new">Add Item</t:a>
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
- <td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
+ <td>
+ <t:each t:name="capabilities">
+ <t:checkbox t:name="@value" t:label="@value" /><br/>
+ </t:each>
+ </td>
</tr>
<tr>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
- <td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
+ <td>
+ <t:each t:name="capabilities">
+ <li><t:checkbox t:name="@value" t:label="@value" /><br/>
+ </t:each>
+ </td>
</tr>
</table>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators words
-assocs db.tuples arrays splitting strings validators
+assocs db.tuples arrays splitting strings validators urls
html.elements
html.components
-html.templates.chloe
-http.server.boilerplate
-http.server.auth.providers
-http.server.auth.providers.db
-http.server.auth.login
-http.server.auth
-http.server.sessions
-http.server.actions
-http.server ;
+furnace
+furnace.boilerplate
+furnace.auth.providers
+furnace.auth.providers.db
+furnace.auth.login
+furnace.auth
+furnace.sessions
+furnace.actions
+http.server
+http.server.dispatchers ;
IN: webapps.user-admin
-: admin-template ( name -- template )
- "resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
-
-: words>strings ( seq -- seq' )
- [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
-
-: strings>words ( seq -- seq' )
- [ ":" split1 swap lookup ] map ;
+TUPLE: user-admin < dispatcher ;
: <user-list-action> ( -- action )
<page-action>
[ f <user> select-tuples "users" set-value ] >>init
- "user-list" admin-template >>template ;
+ { user-admin "user-list" } >>template ;
+
+: init-capabilities ( -- )
+ capabilities get words>strings "capabilities" set-value ;
+
+: selected-capabilities ( -- seq )
+ "capabilities" value
+ [ param empty? not ] filter
+ [ string>word ] map ;
: <new-user-action> ( -- action )
<page-action>
[
- "username" param <user> from-tuple
- capabilities get words>strings "all-capabilities" set-value
+ "username" param <user> from-object
+ init-capabilities
] >>init
- "new-user" admin-template >>template
+ { user-admin "new-user" } >>template
[
- capabilities get words>strings "all-capabilities" set-value
+ init-capabilities
{
{ "username" [ v-username ] }
"email" value >>email
"new-password" value >>encoded-password
H{ } clone >>profile
+ selected-capabilities >>capabilities
insert-tuple
- "$user-admin" f <standard-redirect>
+ URL" $user-admin" <redirect>
] >>submit ;
: validate-username ( -- )
validate-username
"username" value <user> select-tuple
- [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi
+ [ from-object ]
+ [ capabilities>> [ "true" swap word>string set-value ] each ] bi
- capabilities get words>strings "all-capabilities" set-value
+ init-capabilities
] >>init
- "edit-user" admin-template >>template
+ { user-admin "edit-user" } >>template
[
- capabilities get words>strings "all-capabilities" set-value
+ init-capabilities
{
{ "username" [ v-username ] }
{ "new-password" [ [ v-password ] v-optional ] }
{ "verify-password" [ [ v-password ] v-optional ] }
{ "email" [ [ v-email ] v-optional ] }
- { "capabilities" [ ] }
} validate-params
"new-password" "verify-password"
"username" value <user> select-tuple
"realname" value >>realname
"email" value >>email
+ selected-capabilities >>capabilities
"new-password" value empty? [
"new-password" value >>encoded-password
] unless
- "capabilities" value {
- { [ dup string? ] [ 1array ] }
- { [ dup array? ] [ ] }
- } cond strings>words >>capabilities
-
update-tuple
- "$user-admin" f <standard-redirect>
+ URL" $user-admin" <redirect>
] >>submit ;
: <delete-user-action> ( -- action )
[ logout-all-sessions ]
bi
- "$user-admin" f <standard-redirect>
+ URL" $user-admin" <redirect>
] >>submit ;
-TUPLE: user-admin < dispatcher ;
-
SYMBOL: can-administer-users?
can-administer-users? define-capability
<edit-user-action> "edit" add-responder
<delete-user-action> "delete" add-responder
<boilerplate>
- "user-admin" admin-template >>template
- { can-administer-users? } <protected> ;
+ { user-admin "user-admin" } >>template
+ <protected>
+ "administer users" >>description
+ { can-administer-users? } >>capabilities ;
: make-admin ( username -- )
<user>
<t:a t:href="$user-admin">List Users</t:a>
| <t:a t:href="$user-admin/new">Add User</t:a>
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<ul>
- <t:each-tuple t:values="users">
+ <t:bind-each t:name="users">
<li>
<t:a t:href="$user-admin/edit" t:query="username">
<t:label t:name="username" />
</t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:form t:action="$wee-url">
+ <p>Shorten URL: <t:field t:name="url" t:size="40" /></p>
+ <input type="submit" value="Shorten" />
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <p>The URL:</p>
+ <blockquote><t:link t:name="url" /></blockquote>
+ <p>has been shortened to:</p>
+ <blockquote><t:link t:name="short" /></blockquote>
+ <p>enjoy!</p>
+
+</t:chloe>
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.ranges sequences random accessors combinators.lib
+kernel namespaces fry db.types db.tuples urls validators
+html.components http http.server.dispatchers furnace
+furnace.actions furnace.boilerplate ;
+IN: webapps.wee-url
+
+TUPLE: wee-url < dispatcher ;
+
+TUPLE: short-url short url ;
+
+short-url "SHORT_URLS" {
+ { "short" "SHORT" TEXT +user-assigned-id+ }
+ { "url" "URL" TEXT +not-null+ }
+} define-persistent
+
+: init-short-url-table ( -- )
+ short-url ensure-table ;
+
+: letter-bank ( -- seq )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ CHAR: 1 CHAR: 0 [a,b]
+ 3append ; foldable
+
+: random-url ( -- string )
+ 1 6 [a,b] random [ drop letter-bank random ] "" map-as ;
+
+: insert-short-url ( short-url -- short-url )
+ '[ , dup random-url >>short insert-tuple ] 10 retry ;
+
+: shorten ( url -- short )
+ short-url new swap >>url dup select-tuple
+ [ ] [ insert-short-url ] ?if short>> ;
+
+: short>url ( short -- url )
+ "$wee-url/go/" prepend >url adjust-url ;
+
+: expand-url ( string -- url )
+ short-url new swap >>short select-tuple url>> ;
+
+: <shorten-action> ( -- action )
+ <page-action>
+ { wee-url "shorten" } >>template
+ [ { { "url" [ v-url ] } } validate-params ] >>validate
+ [
+ "$wee-url/show/" "url" value shorten append >url <redirect>
+ ] >>submit ;
+
+: <show-action> ( -- action )
+ <page-action>
+ "short" >>rest
+ [
+ { { "short" [ v-one-word ] } } validate-params
+ "short" value expand-url "url" set-value
+ "short" value short>url "short" set-value
+ ] >>init
+ { wee-url "show" } >>template ;
+
+: <go-action> ( -- action )
+ <action>
+ "short" >>rest
+ [ { { "short" [ v-one-word ] } } validate-params ] >>init
+ [ "short" value expand-url <redirect> ] >>display ;
+
+: <wee-url> ( -- wee-url )
+ wee-url new-dispatcher
+ <shorten-action> "" add-responder
+ <show-action> "show" add-responder
+ <go-action> "go" add-responder
+ <boilerplate>
+ { wee-url "wee-url" } >>template ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>WeeURL!</t:title>
+
+ <div class="navbar"><t:a t:href="$wee-url">Shorten URL</t:a></div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
<t:title>All Articles</t:title>
<ul>
- <t:each-tuple t:values="articles">
+ <t:bind-each t:name="articles">
<li>
<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
</t:chloe>
<t:title>Recent Changes</t:title>
<ul>
- <t:each-tuple t:values="changes">
+ <t:bind-each t:name="changes">
<li>
- <t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
+ <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
by
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:bind-tuple t:name="old">
- <t:title>Diff: <t:label t:name="title" /></t:title>
- </t:bind-tuple>
+ <t:title>Diff: <t:label t:name="title" /></t:title>
<table>
<tr>
<th class="field-label">Old revision:</th>
- <t:bind-tuple t:name="old">
+ <t:bind t:name="old">
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
- </t:bind-tuple>
+ </t:bind>
</tr>
<tr>
<th class="field-label">New revision:</th>
- <t:bind-tuple t:name="old">
+ <t:bind t:name="old">
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
- </t:bind-tuple>
+ </t:bind>
</tr>
</table>
<t:comparison t:name="diff" />
- <t:bind-tuple t:name="old">
- <div class="navbar">
- <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
- | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
- | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
- | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
- </div>
- </t:bind-tuple>
-
</t:chloe>
</t:form>
- <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:atom t:href="$wiki/revisions.atom" t:query="title">
+ Revisions of <t:label t:name="title" />
+ </t:atom>
+
+ <t:call-next-template />
+
+ <div class="navbar">
+ <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+ </div>
+
+</t:chloe>
<t:title>Revisions of <t:label t:name="title" /></t:title>
- <ul>
- <t:each-tuple t:values="revisions">
- <li>
- <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
- by
- <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
- </li>
- </t:each-tuple>
- </ul>
+ <div class="revisions">
+ <table>
+ <tr>
+ <th>Revision</th>
+ <th>Author</th>
+ <th>Rollback</th>
+ </tr>
+
+ <t:bind-each t:name="revisions">
+ <tr>
+ <td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
+ <td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
+ <td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
+ </tr>
+ </t:bind-each>
+ </table>
+ </div>
<h2>View Differences</h2>
<td>
<select name="old-id">
- <t:each-tuple t:values="revisions">
+ <t:bind-each t:name="revisions">
<option> <t:label t:name="id" /> </option>
- </t:each-tuple>
+ </t:bind-each>
</select>
</td>
</tr>
<td>
<select name="new-id">
- <t:each-tuple t:values="revisions">
+ <t:bind-each t:name="revisions">
<option> <t:label t:name="id" /> </option>
- </t:each-tuple>
+ </t:bind-each>
</select>
</td>
</tr>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/user-edits.atom" t:query="author">
+ Edits by <t:label t:name="author" />
+ </t:atom>
+
<t:title>Edits by <t:label t:name="author" /></t:title>
<ul>
- <t:each-tuple t:values="user-edits">
+ <t:bind-each t:name="user-edits">
<li>
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
on
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
</li>
- </t:each-tuple>
+ </t:bind-each>
</ul>
</t:chloe>
<t:farkup t:name="content" />
</div>
- <div class="navbar">
- <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
- | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
- | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
- | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
- | This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.
- </div>
+ <p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</em></p>
</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:href="$wiki/changes.atom">
+ Recent Changes
+ </t:atom>
+
<t:style t:include="resource:extra/webapps/wiki/wiki.css" />
<div class="navbar">
| <t:a t:href="$wiki/articles">All Articles</t:a>
| <t:a t:href="$wiki/changes">Recent Changes</t:a>
- <t:if t:code="http.server.sessions:uid">
+ <t:if t:code="furnace.sessions:uid">
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ <t:if t:code="furnace.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:aside="begin">Edit Profile</t:a>
</t:if>
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:aside="begin" class="link-button link">Logout</t:button>
</t:if>
-.comparison table, {
- border-color: #666;
- border-style: solid;
-}
-
.comparison th {
border-width: 1px;
border-color: #666;
border-style: solid;
+ width: 50%;
}
.comparison table {
+ border-color: #666;
+ border-style: solid;
border-width: 1px;
border-spacing: 0;
border-collapse: collapse;
}
-
.insert {
background-color: #9f9;
}
.delete {
background-color: #f99;
}
+
+.revisions table, .revisions td, .revisions th {
+ border-color: #666;
+ border-style: solid;
+}
+
+.revisions table {
+ border-width: 0 0 1px 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+.revisions td, .revisions th {
+ margin: 0;
+ padding: 4px;
+ border-width: 1px 1px 0 0;
+}
+
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel hashtables calendar
namespaces splitting sequences sorting math.order
-html.components
-html.templates.chloe
+html.components syndication
http.server
-http.server.actions
-http.server.auth
-http.server.auth.login
-http.server.boilerplate
+http.server.dispatchers
+furnace
+furnace.actions
+furnace.auth
+furnace.auth.login
+furnace.boilerplate
+furnace.syndication
validators
-db.types db.tuples lcs farkup ;
+db.types db.tuples lcs farkup urls ;
IN: webapps.wiki
+: title-url ( title action -- url )
+ "$wiki/" prepend >url swap "title" set-query-param ;
+
+: view-url ( title -- url ) "view" title-url ;
+
+: edit-url ( title -- url ) "edit" title-url ;
+
+: revisions-url ( title -- url ) "revisions" title-url ;
+
+: revision-url ( id -- url )
+ "$wiki/revision" >url swap "id" set-query-param ;
+
+: user-edits-url ( author -- url )
+ "$wiki/user-edits" >url swap "author" set-query-param ;
+
+TUPLE: wiki < dispatcher ;
+
TUPLE: article title revision ;
article "ARTICLES" {
{ "content" "CONTENT" TEXT +not-null+ }
} define-persistent
+M: revision feed-entry-title
+ [ title>> ] [ drop " by " ] [ author>> ] tri 3append ;
+
+M: revision feed-entry-date date>> ;
+
+M: revision feed-entry-url id>> revision-url ;
+
+: reverse-chronological-order ( seq -- sorted )
+ [ [ date>> ] compare invert-comparison ] sort ;
+
: <revision> ( id -- revision )
revision new swap >>id ;
: init-revisions-table revision ensure-table ;
-: wiki-template ( name -- template )
- "resource:extra/webapps/wiki/" swap ".xml" 3append <chloe> ;
-
-: <title-redirect> ( title next -- response )
- swap "title" associate <standard-redirect> ;
-
: validate-title ( -- )
{ { "title" [ v-one-line ] } } validate-params ;
+: validate-author ( -- )
+ { { "author" [ v-username ] } } validate-params ;
+
: <main-article-action> ( -- action )
<action>
- [ "Front Page" "$wiki/view" <title-redirect> ] >>display ;
+ [ "Front Page" view-url <redirect> ] >>display ;
: <view-article-action> ( -- action )
<action>
- "title" >>rest-param
+ "title" >>rest
[
validate-title
[
"title" value dup <article> select-tuple [
- revision>> <revision> select-tuple from-tuple
- "view" wiki-template <html-content>
+ revision>> <revision> select-tuple from-object
+ { wiki "view" } <chloe-content>
] [
- "$wiki/edit" <title-redirect>
+ edit-url <redirect>
] ?if
] >>display ;
: <view-revision-action> ( -- action )
<page-action>
[
- { { "id" [ v-integer ] } } validate-params
+ validate-integer-id
"id" value <revision>
- select-tuple from-tuple
+ select-tuple from-object
+ "view?title=" relative-link-prefix set
] >>init
- "view" wiki-template >>template ;
+ { wiki "view" } >>template ;
: add-revision ( revision -- )
[ insert-tuple ]
[
validate-title
"title" value <article> select-tuple [
- revision>> <revision> select-tuple from-tuple
+ revision>> <revision> select-tuple from-object
] when*
] >>init
- "edit" wiki-template >>template
+ { wiki "edit" } >>template
[
validate-title
now >>date
logged-in-user get username>> >>author
"content" value >>content
- [ add-revision ]
- [ title>> "$wiki/view" <title-redirect> ] bi
+ [ add-revision ] [ title>> view-url <redirect> ] bi
] >>submit ;
+: list-revisions ( -- seq )
+ f <revision> "title" value >>title select-tuples
+ reverse-chronological-order ;
+
: <list-revisions-action> ( -- action )
<page-action>
[
validate-title
- f <revision> "title" value >>title select-tuples
- [ [ date>> ] compare invert-comparison ] sort
- "revisions" set-value
+ list-revisions "revisions" set-value
] >>init
+ { wiki "revisions" } >>template ;
+
+: <list-revisions-feed-action> ( -- action )
+ <feed-action>
+ [ validate-title ] >>init
+ [ "Revisions of " "title" value append ] >>title
+ [ "title" value revisions-url ] >>url
+ [ list-revisions ] >>entries ;
+
+: <rollback-action> ( -- action )
+ <action>
+ [ validate-integer-id ] >>validate
- "revisions" wiki-template >>template ;
+ [
+ "id" value <revision> select-tuple clone f >>id
+ [ add-revision ] [ title>> view-url <redirect> ] bi
+ ] >>submit ;
+
+: list-changes ( -- seq )
+ "id" value <revision> select-tuples
+ reverse-chronological-order ;
: <list-changes-action> ( -- action )
<page-action>
- [
- f <revision> select-tuples
- [ [ date>> ] compare invert-comparison ] sort
- "changes" set-value
- ] >>init
+ [ list-changes "changes" set-value ] >>init
+
+ { wiki "changes" } >>template ;
- "changes" wiki-template >>template ;
+: <list-changes-feed-action> ( -- action )
+ <feed-action>
+ [ URL" $wiki/changes" ] >>url
+ [ "All changes" ] >>title
+ [ list-changes ] >>entries ;
: <delete-action> ( -- action )
<action>
[
"title" value <article> delete-tuples
f <revision> "title" value >>title delete-tuples
- "" f <standard-redirect>
+ URL" $wiki" <redirect>
] >>submit ;
: <diff-action> ( -- action )
"old-id" "new-id"
[ value <revision> select-tuple ] bi@
- [ [ "old" set-value ] [ "new" set-value ] bi* ]
+ [
+ [ [ title>> "title" set-value ] [ "old" set-value ] bi ]
+ [ "new" set-value ] bi*
+ ]
[ [ content>> string-lines ] bi@ diff "diff" set-value ]
2bi
] >>init
- "diff" wiki-template >>template ;
+ { wiki "diff" } >>template ;
: <list-articles-action> ( -- action )
<page-action>
"articles" set-value
] >>init
- "articles" wiki-template >>template ;
+ { wiki "articles" } >>template ;
+
+: list-user-edits ( -- seq )
+ f <revision> "author" value >>author select-tuples
+ reverse-chronological-order ;
: <user-edits-action> ( -- action )
<page-action>
[
- { { "author" [ v-username ] } } validate-params
- f <revision> "author" value >>author
- select-tuples "user-edits" set-value
+ validate-author
+ list-user-edits "user-edits" set-value
] >>init
+ { wiki "user-edits" } >>template ;
- "user-edits" wiki-template >>template ;
+: <user-edits-feed-action> ( -- action )
+ <feed-action>
+ [ validate-author ] >>init
+ [ "Edits by " "author" value append ] >>title
+ [ "author" value user-edits-url ] >>url
+ [ list-user-edits ] >>entries ;
-TUPLE: wiki < dispatcher ;
+SYMBOL: can-delete-wiki-articles?
+
+can-delete-wiki-articles? define-capability
+
+: <article-boilerplate> ( responder -- responder' )
+ <boilerplate>
+ { wiki "page-common" } >>template ;
: <wiki> ( -- dispatcher )
wiki new-dispatcher
- <main-article-action> "" add-responder
- <view-article-action> "view" add-responder
- <view-revision-action> "revision" add-responder
- <list-revisions-action> "revisions" add-responder
+ <main-article-action> <article-boilerplate> "" add-responder
+ <view-article-action> <article-boilerplate> "view" add-responder
+ <view-revision-action> <article-boilerplate> "revision" add-responder
+ <list-revisions-action> <article-boilerplate> "revisions" add-responder
+ <list-revisions-feed-action> "revisions.atom" add-responder
+ <diff-action> <article-boilerplate> "diff" add-responder
+ <edit-article-action> <article-boilerplate> <protected>
+ "edit wiki articles" >>description
+ "edit" add-responder
+ <rollback-action> "rollback" add-responder
<user-edits-action> "user-edits" add-responder
- <diff-action> "diff" add-responder
<list-articles-action> "articles" add-responder
<list-changes-action> "changes" add-responder
- <edit-article-action> { } <protected> "edit" add-responder
- <delete-action> { } <protected> "delete" add-responder
+ <user-edits-feed-action> "user-edits.atom" add-responder
+ <list-changes-feed-action> "changes.atom" add-responder
+ <delete-action> <protected>
+ "delete wiki articles" >>description
+ { can-delete-wiki-articles? } >>capabilities
+ "delete" add-responder
<boilerplate>
- "wiki-common" wiki-template >>template ;
+ { wiki "wiki-common" } >>template ;
put-http-response ;
: test-rpc-arith
- "add" { 1 2 } <rpc-method> send-rpc xml>string
- "text/xml" swap "http://localhost:8080/responder/rpc/"
+ "add" { 1 2 } <rpc-method> send-rpc
+ "http://localhost:8080/responder/rpc/"
http-post ;
: post-rpc ( rpc url -- rpc )
! This needs to do something in the event of an error
- >r "text/xml" swap send-rpc xml>string r> http-post
- 2nip string>xml receive-rpc ;
+ >r send-rpc r> http-post nip string>xml receive-rpc ;
: invoke-method ( params method url -- )
>r swap <rpc-method> r> post-rpc ;
USING: xmode.tokens xmode.marker xmode.catalog kernel
html.elements io io.files sequences words io.encodings.utf8
-namespaces xml.entities ;
+namespaces xml.entities accessors ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- )
[
- dup token-str swap token-id [
+ [ str>> ] [ id>> ] bi [
<span word-name =class span> escape-string write </span>
] [
- write
+ escape-string write
] if*
] each ;
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: io io.files io.encodings.utf8 namespaces http.server\r
-http.server.static http xmode.code2html kernel sequences\r
-accessors fry ;\r
+http.server.responses http.server.static http xmode.code2html\r
+kernel sequences accessors fry ;\r
IN: xmode.code2html.responder\r
\r
: <sources> ( root -- responder )\r
, utf8 [\r
, file-name input-stream get htmlize-stream\r
] with-file-reader\r
- ] <html-content>\r
+ ] "text/html" <content>\r
] <file-responder> ;\r
Daniel Ehrenberg
+Walton Chan
-Yahoo! search example using XML-RPC
+Yahoo! search example using XML
-USING: tools.test yahoo kernel io.files xml sequences ;
+USING: tools.test yahoo kernel io.files xml sequences accessors urls ;
[ T{
result
"Official site with news, tour dates, discography, store, community, and more."
} ] [ "resource:extra/yahoo/test-results.xml" file>xml parse-yahoo first ] unit-test
-[ "http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=1" ] [ "hi" 1 "Factor-search" query ] unit-test
+[ URL" http://search.yahooapis.com/WebSearchService/V1/webSearch?appid=Factor-search&query=hi&results=2&similar_ok=1" ] [ "hi" <search> "Factor-search" >>appid 2 >>results t >>similar-ok query ] unit-test
-! Copyright (C) 2006 Daniel Ehrenberg
+! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan
! See http://factorcode.org/license.txt for BSD license.
USING: http.client xml xml.utilities kernel sequences
-namespaces http math.parser help math.order locals ;
+math.parser urls accessors locals ;
IN: yahoo
TUPLE: result title url summary ;
C: <result> result
+TUPLE: search query results adult-ok start appid region type
+format similar-ok language country site subscription license ;
+
: parse-yahoo ( xml -- seq )
"Result" deep-tags-named [
{ "Title" "Url" "Summary" }
] map ;
: yahoo-url ( -- str )
- "http://search.yahooapis.com/WebSearchService/V1/webSearch" ;
-
-:: query ( search num appid -- url )
- [
- yahoo-url %
- "?appid=" % appid %
- "&query=" % search url-encode %
- "&results=" % num #
- ] "" make ;
+ URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" ;
+
+:: param ( search url name quot -- search url )
+ search url search quot call
+ [ name set-query-param ] when* ; inline
+
+: num-param ( search str quot -- search )
+ [ dup [ number>string ] when ] compose param ; inline
+
+: bool-param ( search str quot -- search )
+ [ "1" and ] compose param ; inline
+
+: query ( search -- url )
+ yahoo-url clone
+ "appid" [ appid>> ] param
+ "query" [ query>> ] param
+ "region" [ region>> ] param
+ "type" [ type>> ] param
+ "format" [ format>> ] param
+ "language" [ language>> ] param
+ "country" [ country>> ] param
+ "site" [ site>> ] param
+ "subscription" [ subscription>> ] param
+ "license" [ license>> ] param
+ "results" [ results>> ] num-param
+ "start" [ start>> ] num-param
+ "adult_ok" [ adult-ok>> ] bool-param
+ "similar_ok" [ similar-ok>> ] bool-param
+ nip ;
: factor-id
"fRrVAKzV34GDyeRw6bUHDhEWHRedwfOC7e61wwXZLgGF80E67spxdQXuugBe2pgIevMmKwA-" ;
-: search-yahoo/id ( search num id -- seq )
- query http-get string>xml parse-yahoo ;
+: <search> ( query -- search )
+ search new
+ factor-id >>appid
+ 10 >>results
+ swap >>query ;
-: search-yahoo ( search num -- seq )
- factor-id search-yahoo/id ;
+: search-yahoo ( search -- seq )
+ query http-get string>xml parse-yahoo ;
"SYMBOLS:"
))
+(defun factor-indent-line ()
+ "Indent current line as Factor code"
+ (indent-line-to (+ (current-indentation) 4)))
+
(defun factor-mode ()
"A mode for editing programs written in the Factor programming language."
(interactive)
(setq font-lock-defaults
'(factor-font-lock-keywords nil nil nil nil))
(set-syntax-table factor-mode-syntax-table)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'factor-indent-line)
(run-hooks 'factor-mode-hook))
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
--- /dev/null
+USING: furnace furnace.actions furnace.callbacks accessors\r
+http http.server http.server.responses tools.test\r
+namespaces io fry sequences\r
+splitting kernel hashtables continuations ;\r
+IN: furnace.callbacks.tests\r
+\r
+[ 123 ] [\r
+ [\r
+ <request> "GET" >>method init-request\r
+ [\r
+ exit-continuation set\r
+ { }\r
+ <action> [ [ "hello" print 123 ] show-final ] >>display\r
+ <callback-responder>\r
+ call-responder\r
+ ] callcc1\r
+ ] with-scope\r
+] unit-test\r
+\r
+[\r
+ <action> [\r
+ [\r
+ "hello" print\r
+ "text/html" <content>\r
+ ] show-page\r
+ "byebye" print\r
+ [ 123 ] show-final\r
+ ] >>display\r
+ <callback-responder> "r" set\r
+\r
+ [ 123 ] [\r
+ <request> init-request\r
+\r
+ [\r
+ exit-continuation set\r
+ <request> "GET" >>method init-request\r
+ { } "r" get call-responder\r
+ ] callcc1\r
+\r
+ body>> first\r
+\r
+ <request>\r
+ "GET" >>method\r
+ dup url>> rot cont-id associate >>query drop\r
+ dup url>> "/" >>path drop\r
+ init-request\r
+\r
+ [\r
+ exit-continuation set\r
+ { }\r
+ "r" get call-responder\r
+ ] callcc1\r
+\r
+ ! get-post-get\r
+ <request>\r
+ "GET" >>method\r
+ dup url>> rot "location" header query>> >>query drop\r
+ dup url>> "/" >>path drop\r
+ init-request\r
+\r
+ [\r
+ exit-continuation set\r
+ { }\r
+ "r" get call-responder\r
+ ] callcc1\r
+ ] unit-test\r
+] with-scope\r
--- /dev/null
+! Copyright (C) 2004 Chris Double.\r
+! Copyright (C) 2006, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: http http.server io kernel math namespaces\r
+continuations calendar sequences assocs hashtables\r
+accessors arrays alarms quotations combinators fry\r
+http.server.redirection furnace assocs.lib urls ;\r
+IN: furnace.callbacks\r
+\r
+SYMBOL: responder\r
+\r
+TUPLE: callback-responder responder callbacks ;\r
+\r
+: <callback-responder> ( responder -- responder' )\r
+ H{ } clone callback-responder boa ;\r
+\r
+TUPLE: callback cont quot expires alarm responder ;\r
+\r
+: timeout 20 minutes ;\r
+\r
+: timeout-callback ( callback -- )\r
+ [ alarm>> cancel-alarm ]\r
+ [ dup responder>> callbacks>> delete-at ]\r
+ bi ;\r
+\r
+: touch-callback ( callback -- )\r
+ dup expires>> [\r
+ dup alarm>> [ cancel-alarm ] when*\r
+ dup '[ , timeout-callback ] timeout later >>alarm\r
+ ] when drop ;\r
+\r
+: <callback> ( cont quot expires? -- callback )\r
+ f callback-responder get callback boa\r
+ dup touch-callback ;\r
+\r
+: invoke-callback ( callback -- response )\r
+ [ touch-callback ]\r
+ [ quot>> request get exit-continuation get 3array ]\r
+ [ cont>> continue-with ]\r
+ tri ;\r
+\r
+: register-callback ( cont quot expires? -- id )\r
+ <callback> callback-responder get callbacks>> set-at-unique ;\r
+\r
+: forward-to-url ( url -- * )\r
+ #! When executed inside a 'show' call, this will force a\r
+ #! HTTP 302 to occur to instruct the browser to forward to\r
+ #! the request URL.\r
+ <temporary-redirect> exit-with ;\r
+\r
+: cont-id "factorcontid" ;\r
+\r
+: forward-to-id ( id -- * )\r
+ #! When executed inside a 'show' call, this will force a\r
+ #! HTTP 302 to occur to instruct the browser to forward to\r
+ #! the request URL.\r
+ <url>\r
+ swap cont-id set-query-param forward-to-url ;\r
+\r
+: restore-request ( pair -- )\r
+ first3 exit-continuation set request set call ;\r
+\r
+SYMBOL: post-refresh-get?\r
+\r
+: redirect-to-here ( -- )\r
+ #! Force a redirect to the client browser so that the browser\r
+ #! goes to the current point in the code. This forces an URL\r
+ #! change on the browser so that refreshing that URL will\r
+ #! immediately run from this code point. This prevents the\r
+ #! "this request will issue a POST" warning from the browser\r
+ #! and prevents re-running the previous POST logic. This is\r
+ #! known as the 'post-refresh-get' pattern.\r
+ post-refresh-get? get [\r
+ [\r
+ [ ] t register-callback forward-to-id\r
+ ] callcc1 restore-request\r
+ ] [\r
+ post-refresh-get? on\r
+ ] if ;\r
+\r
+SYMBOL: current-show\r
+\r
+: store-current-show ( -- )\r
+ #! Store the current continuation in the variable 'current-show'\r
+ #! so it can be returned to later by 'quot-id'. Note that it\r
+ #! recalls itself when the continuation is called to ensure that\r
+ #! it resets its value back to the most recent show call.\r
+ [ current-show set f ] callcc1\r
+ [ restore-request store-current-show ] when* ;\r
+\r
+: show-final ( quot -- * )\r
+ [ redirect-to-here store-current-show ] dip\r
+ call exit-with ; inline\r
+\r
+: resuming-callback ( responder request -- id )\r
+ url>> cont-id query-param swap callbacks>> at ;\r
+\r
+M: callback-responder call-responder* ( path responder -- response )\r
+ '[\r
+ , ,\r
+\r
+ [ callback-responder set ]\r
+ [ request get resuming-callback ] bi\r
+\r
+ [\r
+ invoke-callback\r
+ ] [\r
+ callback-responder get responder>> call-responder\r
+ ] ?if\r
+ ] with-exit-continuation ;\r
+\r
+: show-page ( quot -- )\r
+ [ redirect-to-here store-current-show ] dip\r
+ [\r
+ [ ] t register-callback swap call exit-with\r
+ ] callcc1 restore-request ; inline\r
+\r
+: quot-id ( quot -- id )\r
+ current-show get swap t register-callback ;\r
+\r
+: quot-url ( quot -- url )\r
+ quot-id f swap cont-id associate derive-url ;\r
{
F_COMPILED *compiled = frame_code(frame);
CELL code_start = (CELL)(compiled + 1);
- CELL literal_start = code_start
- + compiled->code_length
- + compiled->reloc_length;
+ CELL literal_start = code_start + compiled->code_length;
return get(literal_start);
}
}
/* Copy all literals referenced from a code block to newspace */
-void collect_literals_step(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start)
+void collect_literals_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
+ copy_handle(&compiled->relocation);
+
for(scan = literals_start; scan < literal_end; scan += CELLS)
copy_handle((CELL*)scan);
}
/* compiled code */
F_HEAP code_heap;
-typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start);
+typedef void (*CODE_HEAP_ITERATOR)(F_COMPILED *compiled, CELL code_start, CELL literals_start);
INLINE void iterate_code_heap_step(F_COMPILED *compiled, CODE_HEAP_ITERATOR iter)
{
CELL code_start = (CELL)(compiled + 1);
- CELL reloc_start = code_start + compiled->code_length;
- CELL literals_start = reloc_start + compiled->reloc_length;
+ CELL literals_start = code_start + compiled->code_length;
- iter(compiled,code_start,reloc_start,literals_start);
+ iter(compiled,code_start,literals_start);
}
INLINE F_BLOCK *compiled_to_block(F_COMPILED *compiled)
}
/* Perform all fixups on a code block */
-void relocate_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start)
+void relocate_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
- if(reloc_start != literals_start)
+ if(compiled->relocation != F)
{
- F_REL *rel = (F_REL *)reloc_start;
- F_REL *rel_end = (F_REL *)literals_start;
+ F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
+
+ F_REL *rel = (F_REL *)(relocation + 1);
+ F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
}
}
- flush_icache(code_start,reloc_start - code_start);
+ flush_icache(code_start,literals_start - code_start);
}
/* Fixup labels. This is done at compile time, not image load time */
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
- F_ARRAY *relocation,
+ CELL relocation,
F_ARRAY *literals)
{
CELL code_format = compiled_code_format();
CELL code_length = align8(array_capacity(code) * code_format);
- CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
CELL literals_length = array_capacity(literals) * CELLS;
+ REGISTER_ROOT(relocation);
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
- REGISTER_UNTAGGED(relocation);
REGISTER_UNTAGGED(literals);
- CELL here = allot_code_block(sizeof(F_COMPILED) + code_length
- + rel_length + literals_length);
+ CELL here = allot_code_block(sizeof(F_COMPILED) + code_length + literals_length);
UNREGISTER_UNTAGGED(literals);
- UNREGISTER_UNTAGGED(relocation);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
+ UNREGISTER_ROOT(relocation);
/* compiled header */
F_COMPILED *header = (void *)here;
header->type = type;
header->code_length = code_length;
- header->reloc_length = rel_length;
header->literals_length = literals_length;
+ header->relocation = relocation;
here += sizeof(F_COMPILED);
deposit_integers(here,code,code_format);
here += code_length;
- /* relation info */
- deposit_integers(here,relocation,sizeof(unsigned int));
- here += rel_length;
-
/* literals */
deposit_objects(here,literals);
here += literals_length;
F_ARRAY *compiled_code = untag_array(data);
F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
- F_ARRAY *relocation = untag_array(array_nth(compiled_code,1));
+ CELL relocation = array_nth(compiled_code,1);
F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
F_ARRAY *code = untag_array(array_nth(compiled_code,3));
unsigned int offset;
} F_REL;
-void relocate_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start);
+void relocate_code_block(F_COMPILED *relocating, CELL code_start, CELL literals_start);
void default_word_code(F_WORD *word, bool relocate);
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
- F_ARRAY *rel,
+ CELL relocation,
F_ARRAY *literals);
CELL compiled_code_format(void);
for(i = 0; i < MAX_GEN_COUNT; i++)
{
F_GC_STATS *s = &gc_stats[i];
- GROWABLE_ADD(stats,allot_cell(s->collections));
- GROWABLE_ADD(stats,allot_cell(s->gc_time));
- GROWABLE_ADD(stats,allot_cell(s->max_gc_time));
- GROWABLE_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
- GROWABLE_ADD(stats,allot_cell(s->object_count));
- GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->gc_time));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->max_gc_time));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
total_gc_time += s->gc_time;
}
- GROWABLE_ADD(stats,allot_cell(total_gc_time));
- GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
- GROWABLE_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
- GROWABLE_ADD(stats,allot_cell(code_heap_scans));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(total_gc_time));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
+ GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
+ GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
- GROWABLE_TRIM(stats);
+ GROWABLE_ARRAY_TRIM(stats);
dpush(stats);
}
while((obj = next_object()) != F)
{
if(type_of(obj) == WORD_TYPE)
- GROWABLE_ADD(words,obj);
+ GROWABLE_ARRAY_ADD(words,obj);
}
/* End heap scan */
gc_off = false;
- GROWABLE_TRIM(words);
+ GROWABLE_ARRAY_TRIM(words);
return words;
}
CELL look_for;
-void find_code_references_step(F_COMPILED *compiled, CELL code_start,
- CELL reloc_start, CELL literals_start)
+void find_code_references_step(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
CELL scan;
CELL literal_end = literals_start + compiled->literals_length;
for(scan = literals_start; scan < literal_end; scan += CELLS)
{
CELL code_start = (CELL)(compiled + 1);
- CELL literal_start = code_start
- + compiled->code_length
- + compiled->reloc_length;
+ CELL literal_start = code_start + compiled->code_length;
CELL obj = get(literal_start);
}
}
-void fixup_code_block(F_COMPILED *relocating, CELL code_start,
- CELL reloc_start, CELL literals_start)
+void fixup_code_block(F_COMPILED *compiled, CELL code_start, CELL literals_start)
{
/* relocate literal table data */
CELL scan;
- CELL literal_end = literals_start + relocating->literals_length;
+ CELL literal_end = literals_start + compiled->literals_length;
+
+ data_fixup(&compiled->relocation);
for(scan = literals_start; scan < literal_end; scan += CELLS)
data_fixup((CELL*)scan);
- if(reloc_start != literals_start)
- relocate_code_block(relocating,code_start,reloc_start,literals_start);
+ relocate_code_block(compiled,code_start,literals_start);
}
void relocate_code()
{
CELL type; /* this is WORD_TYPE or QUOTATION_TYPE */
CELL code_length; /* # bytes */
- CELL reloc_length; /* # bytes */
CELL literals_length; /* # bytes */
+ CELL relocation; /* tagged pointer to byte-array or f */
} F_COMPILED;
/* Assembly code makes assumptions about the layout of this struct */
while((file = readdir(dir)) != NULL)
{
CELL pair = parse_dir_entry(file);
- GROWABLE_ADD(result,pair);
+ GROWABLE_ARRAY_ADD(result,pair);
}
closedir(dir);
}
UNREGISTER_ROOT(result);
- GROWABLE_TRIM(result);
+ GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
while(*env)
{
CELL string = tag_object(from_char_string(*env));
- GROWABLE_ADD(result,string);
+ GROWABLE_ARRAY_ADD(result,string);
env++;
}
UNREGISTER_ROOT(result);
- GROWABLE_TRIM(result);
+ GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
break;
CELL string = tag_object(from_u16_string(finger));
- GROWABLE_ADD(result,string);
+ GROWABLE_ARRAY_ADD(result,string);
finger = scan + 1;
}
FreeEnvironmentStrings(env);
UNREGISTER_ROOT(result);
- GROWABLE_TRIM(result);
+ GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
CELL name = tag_object(from_u16_string(find_data.cFileName));
CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
CELL pair = allot_array_2(name,dirp);
- GROWABLE_ADD(result,pair);
+ GROWABLE_ARRAY_ADD(result,pair);
}
while (FindNextFile(dir, &find_data));
FindClose(dir);
}
UNREGISTER_ROOT(result);
- GROWABLE_TRIM(result);
+ GROWABLE_ARRAY_TRIM(result);
dpush(result);
}
CELL code = array_nth(quadruple,0);
REGISTER_ROOT(code);
- CELL rel_type = allot_cell(to_fixnum(array_nth(quadruple,2))
- | (to_fixnum(array_nth(quadruple,1)) << 8));
- CELL rel_offset = array_nth(quadruple,3) * compiled_code_format();
+ F_REL rel;
+ rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
+ rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format();
- CELL relocation = allot_array_2(rel_type,rel_offset);
+ F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
+ memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL));
UNREGISTER_ROOT(code);
UNREGISTER_ROOT(literals);
WORD_TYPE,
untag_object(code),
NULL, /* no labels */
- untag_object(relocation),
+ tag_object(relocation),
untag_object(literals));
}
#define EMIT(name,rel_argument) { \
bool rel_p; \
- F_REL rel = rel_to_emit(name,code_format,code_count, \
- rel_argument,&rel_p); \
- if(rel_p) \
- { \
- GROWABLE_ADD(relocation,allot_cell(rel.type)); \
- GROWABLE_ADD(relocation,allot_cell(rel.offset)); \
- } \
- GROWABLE_APPEND(code,code_to_emit(name)); \
+ F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \
+ if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
+ GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
}
bool jit_stack_frame_p(F_ARRAY *array)
GROWABLE_ARRAY(code);
REGISTER_ROOT(code);
- GROWABLE_ARRAY(relocation);
+ GROWABLE_BYTE_ARRAY(relocation);
REGISTER_ROOT(relocation);
GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals);
- GROWABLE_ADD(literals,stack_traces_p() ? quot : F);
+ GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
bool stack_frame = jit_stack_frame_p(untag_object(array));
current stack frame. */
word = untag_object(obj);
- GROWABLE_ADD(literals,array_nth(untag_object(array),i));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1)
{
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
- GROWABLE_ADD(literals,wrapper->object);
+ GROWABLE_ARRAY_ADD(literals,wrapper->object);
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
break;
case FIXNUM_TYPE:
if(stack_frame)
EMIT(JIT_EPILOG,0);
- GROWABLE_ADD(literals,array_nth(untag_object(array),i));
- GROWABLE_ADD(literals,array_nth(untag_object(array),i + 1));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
EMIT(JIT_IF_JUMP,literals_count - 2);
i += 2;
if(stack_frame)
EMIT(JIT_EPILOG,0);
- GROWABLE_ADD(literals,array_nth(untag_object(array),i));
+ GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(JIT_DISPATCH,literals_count - 1);
i++;
break;
}
default:
- GROWABLE_ADD(literals,obj);
+ GROWABLE_ARRAY_ADD(literals,obj);
EMIT(JIT_PUSH_LITERAL,literals_count - 1);
break;
}
EMIT(JIT_RETURN,0);
}
- GROWABLE_TRIM(code);
- GROWABLE_TRIM(relocation);
- GROWABLE_TRIM(literals);
+ GROWABLE_ARRAY_TRIM(code);
+ GROWABLE_ARRAY_TRIM(literals);
+ GROWABLE_BYTE_ARRAY_TRIM(relocation);
F_COMPILED *compiled = add_compiled_block(
QUOTATION_TYPE,
untag_object(code),
NULL,
- untag_object(relocation),
+ relocation,
untag_object(literals));
set_quot_xt(untag_object(quot),compiled);
dpush(tag_object(reallot_array(array,capacity,F)));
}
-F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
+F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
{
REGISTER_ROOT(elt);
UNREGISTER_ROOT(elt);
set_array_nth(result,*result_count,elt);
- *result_count = *result_count + 1;
+ (*result_count)++;
return result;
}
-F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
+F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
{
REGISTER_UNTAGGED(elts);
write_barrier((CELL)result);
- memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
+ memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
*result_count += elts_size;
dpush(tag_object(reallot_byte_array(array,capacity)));
}
+F_BYTE_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count)
+{
+ if(*result_count == byte_array_capacity(result))
+ {
+ result = reallot_byte_array(result,*result_count * 2);
+ }
+
+ bput(BREF(result,*result_count),elt);
+ *result_count++;
+
+ return result;
+}
+
+F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
+{
+ CELL new_size = *result_count + len;
+
+ if(new_size >= byte_array_capacity(result))
+ result = reallot_byte_array(result,new_size * 2);
+
+ memcpy((void *)BREF(result,*result_count),elts,len);
+
+ *result_count = new_size;
+
+ return result;
+}
+
/* Bit arrays */
/* size is in bits */
DECLARE_PRIMITIVE(clone);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
+F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
DECLARE_PRIMITIVE(resize_array);
DECLARE_PRIMITIVE(resize_byte_array);
DECLARE_PRIMITIVE(resize_bit_array);
CELL result##_count = 0; \
CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
-F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count);
+F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count);
-#define GROWABLE_ADD(result,elt) \
- result = tag_object(growable_add(untag_object(result),elt,&result##_count))
+#define GROWABLE_ARRAY_ADD(result,elt) \
+ result = tag_object(growable_array_add(untag_object(result),elt,&result##_count))
-F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
+F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
-#define GROWABLE_APPEND(result,elts) \
- result = tag_object(growable_append(untag_object(result),elts,&result##_count))
+#define GROWABLE_ARRAY_APPEND(result,elts) \
+ result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
-#define GROWABLE_TRIM(result) \
+#define GROWABLE_ARRAY_TRIM(result) \
result = tag_object(reallot_array(untag_object(result),result##_count,F))
+
+/* Macros to simulate a byte vector in C */
+#define GROWABLE_BYTE_ARRAY(result) \
+ CELL result##_count = 0; \
+ CELL result = tag_object(allot_byte_array(100))
+
+F_ARRAY *growable_byte_array_add(F_BYTE_ARRAY *result, CELL elt, CELL *result_count);
+
+#define GROWABLE_BYTE_ARRAY_ADD(result,elt) \
+ result = tag_object(growable_byte_array_add(untag_object(result),elt,&result##_count))
+
+F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
+
+#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
+ result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count))
+
+#define GROWABLE_BYTE_ARRAY_TRIM(result) \
+ result = tag_object(reallot_byte_array(untag_object(result),result##_count))
projects / factor.git / commitdiff