2drop
] { } make
] unit-test
+
+[
+ H{
+ { "bangers" "mash" }
+ { "fries" "onion rings" }
+ }
+] [
+ { "bangers" "fries" } H{
+ { "fish" "chips" }
+ { "bangers" "mash" }
+ { "fries" "onion rings" }
+ { "nachos" "cheese" }
+ } extract-keys
+] unit-test
: map>assoc ( seq quot exemplar -- assoc )
>r [ 2array ] compose { } map-as r> assoc-like ; inline
+: extract-keys ( seq assoc -- subassoc )
+ [ [ dupd at ] curry ] keep map>assoc ;
+
M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f )
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
[ t ] [ "hi" \ hi-tag instance? ] unit-test
+
+! Regression
+GENERIC: method-forget-test
+TUPLE: method-forget-class ;
+M: method-forget-class method-forget-test ;
+
+[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
+[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
+[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
-columns math.order ;
+columns math.order classes.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
! Missing error check
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+! Class forget messyness
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
+[ subclass-forget-test-2 class-usages ]
+unit-test
+
+[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
+[ subclass-forget-test-3 class-usages ]
+unit-test
+
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail
} reset-props
] bi ;
-: reset-tuple-class ( class -- )
- [ [ reset-class ] [ update-map- ] bi ] each-subclass ;
-
-M: tuple-class forget*
- [ reset-tuple-class ] [ call-next-method ] bi ;
-
M: tuple-class rank-class drop 0 ;
M: tuple clone
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
- drop [ swap push-new ] curry each
+ drop [ swap adjoin ] curry each
] [
[
- >r 2dup r> hashcode pick length rem rot nth push-new
+ >r 2dup r> hashcode pick length rem rot nth adjoin
] each 2drop
] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables init ;
+vocabs definitions hashtables init sets ;
IN: compiler.units
SYMBOL: old-definitions
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )
- 2dup key? [ over redefine-error ] when dupd set-at ;
+ 2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )
>r over set-where r> add-once ;
call-recompile-hook
call-update-tuples-hook
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
- updated-definitions notify-definition-observers ;
+ ;
+
+: with-nested-compilation-unit ( quot -- )
+ [
+ H{ } clone changed-definitions set
+ H{ } clone outdated-tuples set
+ [ finish-compilation-unit ] [ ] cleanup
+ ] with-scope ; inline
: with-compilation-unit ( quot -- )
[
H{ } clone outdated-tuples set
<definitions> new-definitions set
<definitions> old-definitions set
- [ finish-compilation-unit ]
- [ ] cleanup
+ [
+ finish-compilation-unit
+ updated-definitions
+ notify-definition-observers
+ ] [ ] cleanup
] with-scope ; inline
: compile-call ( quot -- )
M: integer fixup* , ;
-: push-new* ( obj table -- n )
+: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
-: add-literal ( obj -- n ) literal-table get push-new* ;
+: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
- {
- [ forget-methods ]
- [ update-map- ]
- [ reset-class ]
- [ call-next-method ]
- } cleave ;
+ [
+ class-usages [
+ drop
+ [ forget-methods ]
+ [ update-map- ]
+ [ reset-class ]
+ tri
+ ] assoc-each
+ ]
+ [ call-next-method ] bi ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
} cond ;
: sort-methods ( assoc -- assoc' )
- [ keys sort-classes ]
- [ [ dupd at ] curry ] bi { } map>assoc ;
+ >alist [ keys sort-classes ] keep extract-keys ;
M: predicate-dispatch-engine engine>quot
methods>> clone
M: pair constraint-satisfied?
first constraint-satisfied? ;
-: extract-keys ( seq assoc -- newassoc )
- [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
+: valid-keys ( seq assoc -- newassoc )
+ extract-keys [ nip ] assoc-filter f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of
#! value classes.
dup node-values {
- [ value-intervals get extract-keys >>intervals ]
- [ value-classes get extract-keys >>classes ]
- [ value-literals get extract-keys >>literals ]
+ [ value-intervals get valid-keys >>intervals ]
+ [ value-classes get valid-keys >>classes ]
+ [ value-literals get valid-keys >>literals ]
[ 2drop ]
} cleave ;
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
classes= not [
fixed-point? off
- [ in-d>> value-classes get extract-keys ] keep
+ [ in-d>> value-classes get valid-keys ] keep
set-node-classes
] [ drop ] if
] [ call-next-method ] if
"change-combination" "parser.tests" lookup
"methods" word-prop assoc-size
] unit-test
+
+[ ] [
+ 2 [
+ "IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
+ <string-reader> "twice-fails-test" parse-stream drop
+ ] times
+] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
+ <string-reader> "staging-problem-test" parse-stream
+] unit-test
+
+[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
+
+[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
+ <string-reader> "staging-problem-test" parse-stream
+] unit-test
+
+[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
+
+[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
ERROR: no-current-vocab ;
M: no-current-vocab summary ( obj -- )
- drop "Current vocabulary is f, use IN:" ;
+ drop "Not in a vocabulary; IN: form required" ;
: current-vocab ( -- str )
in get [ no-current-vocab ] unless* ;
"A parsing word cannot be used in the same file it is defined in." ;
: execute-parsing ( word -- )
- new-definitions get [
- dupd first key? [ staging-violation ] when
- ] when*
- execute ;
+ [ changed-definitions get key? [ staging-violation ] when ]
+ [ execute ]
+ bi ;
: parse-step ( accum end -- accum ? )
scan-word {
[ ] [ \ compose see ] unit-test
[ ] [ \ curry see ] unit-test
+
+[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
"Other destructive words:"
{ $subsection move }
{ $subsection exchange }
-{ $subsection push-new }
{ $subsection copy }
{ $subsection replace-slice }
{ $see-also set-nth push pop "sequences-stacks" } ;
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
{ $side-effects "seq" } ;
-HELP: push-new
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
-{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
-{ $examples
- { $example
- "USING: namespaces prettyprint sequences ;"
- "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
- "\"nachos\" \"v\" get push-new"
- "\"salsa\" \"v\" get push-new"
- "\"v\" get ."
- "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
- }
-}
-{ $side-effects "seq" } ;
-
-{ push push-new prefix suffix } related-words
+{ push prefix suffix } related-words
HELP: suffix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
] unit-test
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test
-
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
-
! erg's random tester found this one
[ SBUF" 12341234" ] [
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
-: push-new ( elt seq -- ) [ delete ] 2keep push ;
-
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
[ 0 swap set-nth-unsafe ] keep
: unclip ( seq -- rest first )
[ rest ] [ first ] bi ;
-: unclip-last ( seq -- butfirst last )
+: unclip-last ( seq -- butlast last )
[ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first )
{ $subsection set= }
"A word used to implement the above:"
{ $subsection unique }
+"Adding elements to sets:"
+{ $subsection adjoin }
+{ $subsection conjoin }
{ $see-also member? memq? contains? all? "assocs-sets" } ;
ABOUT: "sets"
+HELP: adjoin
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
+{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
+{ $examples
+ { $example
+ "USING: namespaces prettyprint sets ;"
+ "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
+ "\"nachos\" \"v\" get adjoin"
+ "\"salsa\" \"v\" get adjoin"
+ "\"v\" get ."
+ "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
+ }
+}
+{ $side-effects "seq" } ;
+
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }
[ V{ } ] [ { } { } union ] unit-test
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
USING: assocs hashtables kernel sequences vectors ;
IN: sets
+: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ;
+
+: conjoin ( elt assoc -- ) dupd set-at ;
+
: (prune) ( elt hash vec -- )
- 3dup drop key?
- [ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
- 3drop ; inline
+ 3dup drop key? [ 3drop ] [
+ [ drop conjoin ] [ nip push ] 3bi
+ ] if ; inline
: prune ( seq -- newseq )
[ ] [ length <hashtable> ] [ length <vector> ] tri
[ dup ] H{ } map>assoc ;
: (all-unique?) ( elt hash -- ? )
- 2dup key? [ 2drop f ] [ dupd set-at t ] if ;
+ 2dup key? [ 2drop f ] [ conjoin t ] if ;
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;
USING: help.markup help.syntax sequences strings ;
IN: splitting
+ARTICLE: "groups-clumps" "Groups and clumps"
+"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection groups }
+{ $subsection <groups> }
+{ $subsection <sliced-groups> }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clumps }
+{ $subsection <clumps> }
+{ $subsection <sliced-clumps> }
+"The difference can be summarized as the following:"
+{ $list
+ { "With groups, the subsequences form the original sequence when concatenated:"
+ { $unchecked-example "dup n groups concat sequence= ." "t" }
+ }
+ { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+ { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+ }
+} ;
+
ARTICLE: "sequences-split" "Splitting sequences"
"Splitting sequences at occurrences of subsequences:"
{ $subsection ?head }
{ $subsection ?tail-slice }
{ $subsection split1 }
{ $subsection split }
-"Grouping elements:"
-{ $subsection group }
-"A virtual sequence for grouping elements:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
"Splitting a string into lines:"
-{ $subsection string-lines } ;
+{ $subsection string-lines }
+{ $subsection "groups-clumps" } ;
ABOUT: "sequences-split"
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
HELP: groups
-{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
{ $see-also group } ;
HELP: group
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." }
-{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ;
+{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
+{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
+} ;
HELP: <groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
HELP: <sliced-groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
}
} ;
-{ group <groups> <sliced-groups> } related-words
+HELP: clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
+
+HELP: clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
+} ;
+
+HELP: <clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ "Running averages:"
+ { $example
+ "USING: splitting sequences math prettyprint kernel ;"
+ "IN: scratchpad"
+ ": share-price"
+ " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
+ ""
+ "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
+ "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
+ }
+} ;
+
+HELP: <sliced-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+
+{ clumps groups } related-words
+
+{ clump group } related-words
+
+{ <clumps> <groups> } related-words
+
+{ <sliced-clumps> <sliced-groups> } related-words
HELP: ?head
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
TUPLE: clumps < abstract-groups ;
-: <clumps> ( seq n -- groups )
+: <clumps> ( seq n -- clumps )
clumps construct-groups ; inline
M: clumps length
TUPLE: sliced-clumps < groups ;
-: <sliced-clumps> ( seq n -- groups )
+: <sliced-clumps> ( seq n -- clumps )
sliced-clumps construct-groups ; inline
M: sliced-clumps nth group@ <slice> ;
] define-syntax
"DEFER:" [
- scan in get create
- dup old-definitions get first delete-at
+ scan current-vocab create
+ dup old-definitions get [ delete-at ] with each
set-word
] define-syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [
- [ \ >> parse-until >quotation ] with-compilation-unit
- call
+ [
+ \ >> parse-until >quotation
+ ] with-nested-compilation-unit call
] define-syntax
"call-next-method" [
: define-symbol ( word -- )
dup [ ] curry define-inline ;
-: reset-word ( word -- )
+GENERIC: reset-word ( word -- )
+
+M: word reset-word
{
"unannotated-def"
"parsing" "inline" "foldable" "flushable"
USING: arrays assocs kernel vectors sequences namespaces
-random math.parser ;
+random math.parser math fry ;
IN: assocs.lib
: ref-at ( table key -- value ) swap at ;
: set-at-unique ( value assoc -- key )
dup generate-key [ swap set-at ] keep ;
+
+: histogram ( assoc quot -- assoc' )
+ H{ } clone [
+ swap [ change-at ] 2curry assoc-each
+ ] keep ;
--- /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 ;
cr cairo_fill ;
: utf8 ( -- )
- cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
cairo_select_font_face
cr 50 cairo_set_font_size
"cairo_text_extents_t" malloc-object
- cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents
+ cr "日本語" pick cairo_text_extents
cr over
[ cairo_text_extents_t-width 2 / ]
[ cairo_text_extents_t-x_bearing ] bi +
[ cairo_text_extents_t-y_bearing ] bi +
128 swap - cairo_move_to
free
- cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text
+ cr "日本語" cairo_show_text
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 6 cairo_set_line_width
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp\r
timestamp>string\r
] unit-test\r
+\r
+[\r
+ T{ timestamp f\r
+ 2008\r
+ 5\r
+ 26\r
+ 0\r
+ 37\r
+ 42.12345\r
+ T{ duration f 0 0 0 -5 0 0 }\r
+ }\r
+] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test\r
-USING: math math.order math.parser kernel sequences io\r
+USING: math math.order math.parser math.functions kernel sequences io\r
accessors arrays io.streams.string splitting\r
combinators accessors debugger\r
calendar calendar.format.macros ;\r
: read-hms ( -- h m s )\r
read-00 ":" expect read-00 ":" expect read-00 ;\r
\r
+: read-rfc3339-seconds ( s -- s' ch )\r
+ "+-Z" read-until >r\r
+ [ string>number ] [ length 10 swap ^ ] bi / + r> ;\r
+\r
: (rfc3339>timestamp) ( -- timestamp )\r
read-ymd\r
"Tt" expect\r
read-hms\r
- read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case\r
+ read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case\r
read-rfc3339-gmt-offset\r
<timestamp> ;\r
\r
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
[ 2nip ] append ;
+! or
+
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
+MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
+
+MACRO: 1|| ( quots -- ? )
+ [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
+
+MACRO: 2|| ( quots -- ? )
+ [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+
+MACRO: 3|| ( quots -- ? )
+ [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
-: with-db ( db seq quot -- )
+: with-db ( seq class quot -- )
>r make-db db-open db r>
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
inline
TUPLE: db-pool < pool db params ;
-: <db-pool> ( db params -- pool )
+: <db-pool> ( params db -- pool )
db-pool <pool>
- swap >>params
- swap >>db ;
+ swap >>db
+ swap >>params ;
: with-db-pool ( db params quot -- )
>r <db-pool> r> with-pool ; inline
M: db-pool make-connection ( pool -- )
- [ db>> ] [ params>> ] bi make-db db-open ;
+ [ params>> ] [ db>> ] bi make-db db-open ;
: with-pooled-db ( pool quot -- )
[ db swap with-variable ] curry with-pooled-connection ; inline
[ class \ not-persistent = ] must-fail-with
] test-postgresql
+
+TUPLE: suparclass a ;
+
+suparclass f {
+ { "id" "ID" +db-assigned-id+ }
+ { "a" "A" INTEGER }
+} define-persistent
+
+TUPLE: subbclass < suparclass b ;
+
+subbclass "SUBCLASS" {
+ { "b" "B" TEXT }
+} define-persistent
+
+: test-db-inheritance ( -- )
+ [ ] [ subbclass ensure-table ] unit-test ;
+
+[ test-db-inheritance ] test-sqlite
+
! Don't comment these out. These words must infer
\ bind-tuple must-infer
\ insert-tuple must-infer
"db-table" word-prop [ not-persistent ] unless* ;
: db-columns ( class -- obj )
- "db-columns" word-prop ;
+ superclasses [ "db-columns" word-prop ] map concat ;
: db-relations ( class -- obj )
"db-relations" word-prop ;
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
-: cache-get ( query -- result )
+: cache-get* ( query -- rrs/NX/f )
dup table-get ! query result
{
{ [ dup f = ] [ 2drop f ] } ! not in the cache
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache-get ( query -- rrs/f )
+ dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: rr->entry ( rr -- entry )
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! cache-name-error
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-soa ( message -- rr/soa )
+ authority-section>> [ type>> SOA = ] filter 1st ;
+
+: cache-name-error ( message -- message )
+ dup
+ [ message-query ] [ message-soa ttl>> ] bi
+ cache-nx ;
+
+: cache-message-records ( message -- message )
+ dup
+ {
+ [ answer-section>> cache-add-rrs ]
+ [ authority-section>> cache-add-rrs ]
+ [ additional-section>> cache-add-rrs ]
+ }
+ cleave ;
+
+: cache-message ( message -- message )
+ dup rcode>> NAME-ERROR = [ cache-name-error ] when
+ cache-message-records ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
! TYPE
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
+SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
: type-table ( -- table )
{
{ MINFO 14 }
{ MX 15 }
{ TXT 16 }
+ { AAAA 28 }
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
+: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
+
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-ipv6 ( ba i -- ip )
+ dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: get-rdata ( ba i type -- rdata )
{
{ CNAME [ get-name ] }
{ MX [ get-mx ] }
{ SOA [ get-soa ] }
{ A [ get-ip ] }
+ { AAAA [ get-ipv6 ] }
}
case ;
: ask ( message -- message ) dns-server ask-server ;
-: <query-message> ( query -- message ) <message> swap {1} >>question-section ;
\ No newline at end of file
+: query->message ( query -- message ) <message> swap {1} >>question-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-query ( message -- query ) question-section>> 1st ;
+
--- /dev/null
+
+USING: kernel continuations
+ combinators
+ sequences
+ math
+ random
+ unicode.case
+ accessors symbols
+ combinators.lib combinators.cleave
+ newfx
+ dns dns.cache ;
+
+IN: dns.recursive
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: root-dns-servers ( -- servers )
+ {
+ "192.5.5.241"
+ "192.112.36.4"
+ "128.63.2.53"
+ "192.36.148.17"
+ "192.58.128.30"
+ "193.0.14.129"
+ "199.7.83.42"
+ "202.12.27.33"
+ "198.41.0.4"
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {name-type-class} ( obj -- seq )
+ [ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
+
+: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ;
+
+: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: answer-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query ] bi rr-filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ;
+
+: cname-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: authority-hits ( message -- rrs )
+ authority-section>> [ type>> NS = ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ;
+
+: classify-message ( message -- symbol )
+ {
+ { [ dup rcode>> NAME-ERROR = ] [ drop NAME-ERROR ] }
+ { [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE ] }
+ { [ dup answer-hits empty? not ] [ drop ANSWERED ] }
+ { [ dup cname-hits empty? not ] [ drop CNAME ] }
+ { [ dup authority-hits empty? ] [ drop NO-NAME-SERVERS ] }
+ { [ t ] [ drop UNCLASSIFIED ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: name->ip
+
+! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ;
+
+! : extract-ns-ips ( message -- ips )
+! authority-hits [ rdata>> name->ip/f ] map [ ] filter ;
+
+: extract-ns-ips ( message -- ips )
+ authority-hits [ rdata>> name->ip ] map [ ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (recursive-query) ( query servers -- message )
+ dup random ! query servers server
+ pick query->message 0 >>rd ! query servers server message
+ over ask-server ! query servers server message
+ cache-message ! query servers server message
+ dup classify-message ! query servers server message sym
+ {
+ { NAME-ERROR [ -roll 3drop ] }
+ { ANSWERED [ -roll 3drop ] }
+ { CNAME [ -roll 3drop ] }
+ { NO-NAME-SERVERS [ -roll 3drop ] }
+ {
+ SERVER-FAILURE
+ [
+ -roll ! message query servers server
+ remove ! message query servers
+ dup empty?
+ [ 2drop ]
+ [ rot drop (recursive-query) ]
+ if
+ ]
+ }
+ [ ! query servers server message sym
+ drop nip nip ! query message
+ extract-ns-ips ! query ips
+ (recursive-query)
+ ]
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+: cache-get-ns ( name -- seq/f ) NS IN query boa cache-get ;
+
+: name->servers ( name -- servers )
+ {
+ { [ dup "" = ] [ drop root-dns-servers ] }
+ { [ dup cache-get-ns ] [ cache-get-ns [ rdata>> name->ip ] map ] }
+ { [ t ] [ cdr-name name->servers ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: recursive-query ( query -- message )
+ dup name>> name->servers (recursive-query) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: canonical/cache ( name -- name )
+ dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
+
+: name->ip/cache ( name -- ip/f )
+ canonical/cache
+ A IN query boa cache-get dup [ random rdata>> ] [ ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name-hits? ( message -- message ? ) dup name-hits empty? not ;
+: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
+
+! : name->ip/server ( name -- ip-or-f )
+! A IN query boa root-dns-servers recursive-query ! message
+! {
+! { [ name-hits? ] [ name-hits random rdata>> ] }
+! { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
+! { [ t ] [ drop f ] }
+! }
+! cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->ip/server ( name -- ip-or-f )
+ A IN query boa recursive-query ! message
+ {
+ { [ name-hits? ] [ name-hits random rdata>> ] }
+ { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
+ { [ t ] [ drop f ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : name->ip ( name -- ip )
+! { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ;
+
+: name->ip ( name -- ip )
+ dup name->ip/cache dup
+ [ nip ]
+ [
+ drop dup name->ip/server dup
+ [ nip ]
+ [ drop name-error ]
+ if
+ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/server ( name -- name )
- dup CNAME IN query boa <query-message> ask* answer-section>>
+ dup CNAME IN query boa query->message ask* 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* answer-section>>
[ type>> A = ] filter dup empty? not
[ nip random rdata>> ]
[ 2drop f ]
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
-[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
+[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
-[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
+[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
[ ] [ "[{}]" convert-farkup drop ] unit-test
+
+[
+ "<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[
+ "<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
+[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.styles kernel memoize namespaces peg
sequences strings html.elements xml.entities xmode.code2html
-splitting io.streams.string html peg.parsers html.elements
+splitting io.streams.string peg.parsers
sequences.deep unicode.categories ;
IN: farkup
+SYMBOL: relative-link-prefix
+SYMBOL: link-no-follow?
+
<PRIVATE
: delimiters ( -- string )
: render-code ( string mode -- string' )
>r string-lines r>
[
- [
- H{ { wrap-margin f } } [
- htmlize-lines
- ] with-nesting
- ] with-html-stream
+ <pre>
+ htmlize-lines
+ </pre>
] with-string-writer ;
: check-url ( href -- href' )
CHAR: : over member? [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop "/" ] unless
- ] when ;
+ ] [
+ relative-link-prefix get prepend
+ ] if ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
: make-link ( href text -- seq )
escape-link
- [ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
+ [
+ "<a" ,
+ " href=\"" , >r , r>
+ link-no-follow? get [ " nofollow=\"true\"" , ] when
+ "\">" , , "</a>" ,
+ ] { } make ;
: make-image-link ( href alt -- seq )
escape-link
"[[" token hide ,
[ "|]" member? not ] satisfy repeat1 ,
"]]" token hide ,
- ] seq* [ first f make-link ] action ;
+ ] seq* [ first dup make-link ] action ;
MEMO: labelled-link ( -- parser )
[
"]]" token hide ,
] seq* [ first2 make-link ] action ;
-MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
+MEMO: link ( -- parser )
+ [ image-link , simple-link , labelled-link , ] choice* ;
DEFER: line
MEMO: list-item ( -- parser )
[
- "-" token hide , line ,
+ "-" token hide , ! text ,
+ [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
] seq* [ "li" surround-with-foo ] action ;
MEMO: list ( -- parser )
MEMO: line ( -- parser )
[
+ nl table 2seq ,
+ nl list 2seq ,
text , strong , emphasis , link ,
superscript , subscript , inline-code ,
escaped-char , delimiter , eq ,
[ { 1 { 2 { 3 } } } ] [
1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
] unit-test
+
+{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
+
+[ { { { 3 } } } ] [
+ 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
+
+[ { { { 3 } } } ] [
+ 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
shallow-fry
] if* ;
+: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
+
+: count-inputs ( quot -- n )
+ [
+ {
+ { [ dup callable? ] [ count-inputs ] }
+ { [ dup fry-specifier? ] [ drop 1 ] }
+ [ drop 0 ]
+ } cond
+ ] map sum ;
+
: fry ( quot -- quot' )
[
[
dup callable? [
- [
- [ { , namespaces:, @ } member? ] filter length
- \ , <repetition> %
- ]
- [ fry % ] bi
+ [ count-inputs \ , <repetition> % ] [ fry % ] bi
] [ namespaces:, ] if
] each
] [ ] make deep-fry ;
+++ /dev/null
-Slava Pestov
-Matthew Willis
-Chris Double
--- /dev/null
+IN: html.components.tests
+USING: tools.test kernel io.streams.string
+io.streams.null accessors inspector html.streams
+html.components namespaces ;
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ 3 "hi" set-value ] unit-test
+
+[ 3 ] [ "hi" value ] unit-test
+
+TUPLE: color red green blue ;
+
+[ ] [ 1 2 3 color boa from-tuple ] 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
+ ] with-string-writer
+] unit-test
+
+[ ] [ "<jimmy>" "red" set-value ] unit-test
+
+[ "<jimmy>" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
+ [
+ "red" hidden render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "'jimmy'" "red" set-value ] unit-test
+
+[ "<input type='text' size='5' name='red' value=''jimmy''/>" ] [
+ [
+ "red" <field> 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ "<input type='password' size='5' name='red' value=''/>" ] [
+ [
+ "red" <password> 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ ] [
+ [
+ "green" <textarea> render
+ ] with-null-writer
+] unit-test
+
+[ ] [
+ [
+ "green" <textarea> 25 >>rows 30 >>cols render
+ ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ "new york" "city1" set-value ] unit-test
+
+[ ] [ { "new york" "los angeles" "chicago" } "cities" set-value ] unit-test
+
+[ ] [
+ [
+ "city1"
+ <choice>
+ "cities" >>choices
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [ { "los angeles" "new york" } "city2" set-value ] unit-test
+
+[ ] [
+ [
+ "city2"
+ <choice>
+ "cities" >>choices
+ t >>multiple
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [
+ [
+ "city2"
+ <choice>
+ "cities" >>choices
+ t >>multiple
+ 5 >>size
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ t "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
+ [
+ "delivery"
+ <checkbox>
+ "Delivery" >>label
+ render
+ ] with-string-writer
+] unit-test
+
+[ ] [ f "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
+ [
+ "delivery"
+ <checkbox>
+ "Delivery" >>label
+ render
+ ] with-string-writer
+] unit-test
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ "<a href='http://www.apple.com/foo&bar'><Link Title></a>" ] [
+ [ "link" link render ] with-string-writer
+] unit-test
+
+[ ] [
+ "<html>arbitrary <b>markup</b> for the win!</html>" "html" set-value
+] unit-test
+
+[ "<html>arbitrary <b>markup</b> for the win!</html>" ] [
+ [ "html" html render ] with-string-writer
+] unit-test
+
+[ ] [ "int x = 4;" "code" set-value ] unit-test
+
+[ ] [ "java" "mode" set-value ] unit-test
+
+[ "<span class='KEYWORD3'>int</span> x <span class='OPERATOR'>=</span> <span class='DIGIT'>4</span>;\n" ] [
+ [ "code" <code> "mode" >>mode render ] with-string-writer
+] unit-test
+
+[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
+
+[ "<ul><li>foo</li><li>bar</li></ul>" ] [
+ [ "farkup" farkup render ] with-string-writer
+] unit-test
+
+[ ] [ { 1 2 3 } "object" set-value ] unit-test
+
+[ t ] [
+ [ "object" inspector render ] with-string-writer
+ [ "object" value [ describe ] with-html-stream ] with-string-writer
+ =
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [
+ "factor" [
+ "concatenative" "model" set-value
+ ] nest-values
+] unit-test
+
+[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces io math.parser assocs classes
+classes.tuple words arrays sequences sequences.lib splitting
+mirrors hashtables combinators continuations math strings
+fry locals calendar calendar.format xml.entities validators
+html.elements html.streams xmode.code2html farkup inspector
+lcs.diff2html ;
+IN: html.components
+
+SYMBOL: values
+
+: value values get at ;
+
+: set-value values get set-at ;
+
+: blank-values H{ } clone values set ;
+
+: prepare-value ( name object -- value name object )
+ [ [ value ] keep ] dip ; inline
+
+: from-assoc ( assoc -- ) values get swap update ;
+
+: from-tuple ( tuple -- ) <mirror> from-assoc ;
+
+: deposit-values ( destination names -- )
+ [ dup value ] H{ } map>assoc update ;
+
+: deposit-slots ( destination names -- )
+ [ <mirror> ] dip deposit-values ;
+
+: with-each-index ( seq quot -- )
+ '[
+ [
+ blank-values 1+ "index" 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-assoc-values ( assoc quot -- )
+ '[ blank-values , from-assoc @ ] with-scope ; inline
+
+: with-tuple-values ( assoc quot -- )
+ '[ blank-values , from-tuple @ ] with-scope ; inline
+
+: nest-values ( name quot -- )
+ swap [
+ [
+ H{ } clone [ values set call ] keep
+ ] 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 -- )
+ over named-validation-messages get at [
+ [ value>> ] [ message>> ] bi
+ [ -rot render* ] dip
+ render-error
+ ] [
+ prepare-value render*
+ ] if* ;
+
+<PRIVATE
+
+: render-input ( value name type -- )
+ <input =type =name object>string =value input/> ;
+
+PRIVATE>
+
+SINGLETON: label
+
+M: label render* 2drop object>string escape-string write ;
+
+SINGLETON: hidden
+
+M: hidden render* drop "hidden" render-input ;
+
+: render-field ( value name size type -- )
+ <input
+ =type
+ [ object>string =size ] when*
+ =name
+ object>string =value
+ input/> ;
+
+TUPLE: field size ;
+
+: <field> ( -- field )
+ field new ;
+
+M: field render* size>> "text" render-field ;
+
+TUPLE: password size ;
+
+: <password> ( -- password )
+ password new ;
+
+M: password render*
+ #! Don't send passwords back to the user
+ [ drop "" ] 2dip size>> "password" render-field ;
+
+! Text areas
+TUPLE: textarea rows cols ;
+
+: <textarea> ( -- renderer )
+ textarea new ;
+
+M: textarea render*
+ <textarea
+ [ rows>> [ object>string =rows ] when* ]
+ [ cols>> [ object>string =cols ] when* ] bi
+ =name
+ textarea>
+ object>string escape-string write
+ </textarea> ;
+
+! Choice
+TUPLE: choice size multiple choices ;
+
+: <choice> ( -- choice )
+ choice new ;
+
+: render-option ( text selected? -- )
+ <option [ "true" =selected ] when option>
+ object>string escape-string write
+ </option> ;
+
+: render-options ( options selected -- )
+ '[ dup , member? render-option ] each ;
+
+M: choice render*
+ <select
+ swap =name
+ dup size>> [ object>string =size ] when*
+ dup multiple>> [ "true" =multiple ] when
+ select>
+ [ choices>> value ] [ multiple>> ] bi
+ [ swap ] [ swap 1array ] if
+ render-options
+ </select> ;
+
+! Checkboxes
+TUPLE: checkbox label ;
+
+: <checkbox> ( -- checkbox )
+ checkbox new ;
+
+M: checkbox render*
+ <input
+ "checkbox" =type
+ swap =name
+ swap [ "true" =selected ] when
+ input>
+ label>> escape-string write
+ </input> ;
+
+! Link components
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link
+
+M: link render*
+ 2drop
+ <a dup link-href =href a>
+ link-title object>string escape-string write
+ </a> ;
+
+! XMode code component
+TUPLE: code mode ;
+
+: <code> ( -- code )
+ code new ;
+
+M: code render*
+ [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
+
+! Farkup component
+SINGLETON: farkup
+
+M: farkup render*
+ 2drop string-lines "\n" join convert-farkup write ;
+
+! Inspector component
+SINGLETON: inspector
+
+M: inspector render*
+ 2drop [ describe ] with-html-stream ;
+
+! Diff component
+SINGLETON: comparison
+
+M: comparison render*
+ 2drop htmlize-diff ;
+
+! HTML component
+SINGLETON: html
+
+M: html render* 2drop write ;
IN: html.elements.tests
-USING: tools.test html html.elements io.streams.string ;
-
-: make-html-string
- [ with-html-stream ] with-string-writer ;
+USING: tools.test html.elements io.streams.string ;
[ "<a href='h&o'>" ]
-[ [ <a "h&o" =href a> ] make-html-string ] unit-test
+[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
: print-html ( str -- )
write-html "\n" write-html ;
+<<
+
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
dup "=" prepend swap
[ write-attr ] curry attribute-effect html-word ;
+! Define some closed HTML tags
+[
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option" "style" "input"
+] [ define-closed-html-word ] each
+
+! Define some open HTML tags
+[
+ "input"
+ "br"
+ "link"
+ "img"
+] [ define-open-html-word ] each
+
+! Define some attributes
[
- ! Define some closed HTML tags
- [
- "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
- "ol" "li" "form" "a" "p" "html" "head" "body" "title"
- "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
- "script" "div" "span" "select" "option" "style" "input"
- ] [ define-closed-html-word ] each
-
- ! Define some open HTML tags
- [
- "input"
- "br"
- "link"
- "img"
- ] [ define-open-html-word ] each
-
- ! Define some attributes
- [
- "method" "action" "type" "value" "name"
- "size" "href" "class" "border" "rows" "cols"
- "id" "onclick" "style" "valign" "accesskey"
- "src" "language" "colspan" "onchange" "rel"
- "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media" "title" "multiple"
- ] [ define-attribute-word ] each
-] with-compilation-unit
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+ "media" "title" "multiple"
+] [ define-attribute-word ] each
+
+>>
+
+: xhtml-preamble ( -- )
+ "<?xml version=\"1.0\"?>" write-html
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
+
+: simple-page ( title quot -- )
+ #! Call the quotation, with all output going to the
+ #! body of an html page with the given title.
+ xhtml-preamble
+ <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
+ <head> <title> swap write </title> </head>
+ <body> call </body>
+ </html> ;
+
+: render-error ( message -- )
+ <span "error" =class span> escape-string write </span> ;
+++ /dev/null
-USING: html http io io.streams.string io.styles kernel
-namespaces tools.test xml.writer sbufs sequences html.private ;
-IN: html.tests
-
-: make-html-string
- [ with-html-stream ] with-string-writer ; inline
-
-[ [ ] make-html-string ] must-infer
-
-[ ] [
- 512 <sbuf> <html-stream> drop
-] unit-test
-
-[ "" ] [
- [ "" write ] make-html-string
-] unit-test
-
-[ "a" ] [
- [ CHAR: a write1 ] make-html-string
-] unit-test
-
-[ "<" ] [
- [ "<" write ] make-html-string
-] unit-test
-
-[ "<" ] [
- [ "<" H{ } output-stream get format-html-span ] make-html-string
-] unit-test
-
-TUPLE: funky town ;
-
-M: funky browser-link-href
- "http://www.funky-town.com/" swap funky-town append ;
-
-[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
- [
- "<" "austin" funky boa write-object
- ] make-html-string
-] unit-test
-
-[ "<span style='font-family: monospace; '>car</span>" ]
-[
- [
- "car"
- H{ { font "monospace" } }
- format
- ] make-html-string
-] unit-test
-
-[ "<span style='color: #ff00ff; '>car</span>" ]
-[
- [
- "car"
- H{ { foreground { 1 0 1 1 } } }
- format
- ] make-html-string
-] unit-test
-
-[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
-[
- [
- H{ { page-color { 1 0 1 1 } } }
- [ "cdr" write ] with-nesting
- ] make-html-string
-] unit-test
-
-[
- "<div style='white-space: pre; font-family: monospace; '></div>"
-] [
- [ H{ } [ ] with-nesting nl ] make-html-string
-] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic assocs help http io io.styles io.files continuations
-io.streams.string kernel math math.order math.parser namespaces
-quotations assocs sequences strings words html.elements
-xml.entities sbufs continuations destructors ;
-IN: html
-
-GENERIC: browser-link-href ( presented -- href )
-
-M: object browser-link-href drop f ;
-
-TUPLE: html-stream last-div? ;
-
-! A hack: stream-nl after with-nesting or tabular-output is
-! ignored, so that HTML stream output looks like UI pane output
-: test-last-div? ( stream -- ? )
- dup html-stream-last-div?
- f rot set-html-stream-last-div? ;
-
-: not-a-div ( stream -- stream )
- dup test-last-div? drop ; inline
-
-: a-div ( stream -- straem )
- t over set-html-stream-last-div? ; inline
-
-: <html-stream> ( stream -- stream )
- html-stream construct-delegate ;
-
-<PRIVATE
-
-TUPLE: html-sub-stream style stream ;
-
-: (html-sub-stream) ( style stream -- stream )
- html-sub-stream boa
- 512 <sbuf> <html-stream> over set-delegate ;
-
-: <html-sub-stream> ( style stream class -- stream )
- >r (html-sub-stream) r> construct-delegate ; inline
-
-: end-sub-stream ( substream -- string style stream )
- dup delegate >string
- over html-sub-stream-style
- rot html-sub-stream-stream ;
-
-: delegate-write ( string -- )
- output-stream get delegate stream-write ;
-
-: object-link-tag ( style quot -- )
- presented pick at [
- browser-link-href [
- <a =href a> call </a>
- ] [ call ] if*
- ] [ call ] if* ; inline
-
-: hex-color, ( triplet -- )
- 3 head-slice
- [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
-
-: fg-css, ( color -- )
- "color: #" % hex-color, "; " % ;
-
-: bg-css, ( color -- )
- "background-color: #" % hex-color, "; " % ;
-
-: style-css, ( flag -- )
- dup
- { italic bold-italic } member?
- "font-style: " % "italic" "normal" ? % "; " %
- { bold bold-italic } member?
- "font-weight: " % "bold" "normal" ? % "; " % ;
-
-: size-css, ( size -- )
- "font-size: " % # "pt; " % ;
-
-: font-css, ( font -- )
- "font-family: " % % "; " % ;
-
-: apply-style ( style key quot -- style gadget )
- >r over at r> when* ; inline
-
-: make-css ( style quot -- str )
- "" make nip ; inline
-
-: span-css-style ( style -- str )
- [
- foreground [ fg-css, ] apply-style
- background [ bg-css, ] apply-style
- font [ font-css, ] apply-style
- font-style [ style-css, ] apply-style
- font-size [ size-css, ] apply-style
- ] make-css ;
-
-: span-tag ( style quot -- )
- over span-css-style dup empty? [
- drop call
- ] [
- <span =style span> call </span>
- ] if ; inline
-
-: format-html-span ( string style stream -- )
- [
- [ [ drop delegate-write ] span-tag ] object-link-tag
- ] with-output-stream* ;
-
-TUPLE: html-span-stream ;
-
-M: html-span-stream dispose
- end-sub-stream not-a-div format-html-span ;
-
-: border-css, ( border -- )
- "border: 1px solid #" % hex-color, "; " % ;
-
-: padding-css, ( padding -- ) "padding: " % # "px; " % ;
-
-: pre-css, ( margin -- )
- [ "white-space: pre; font-family: monospace; " % ] unless ;
-
-: div-css-style ( style -- str )
- [
- page-color [ bg-css, ] apply-style
- border-color [ border-css, ] apply-style
- border-width [ padding-css, ] apply-style
- wrap-margin over at pre-css,
- ] make-css ;
-
-: div-tag ( style quot -- )
- swap div-css-style dup empty? [
- drop call
- ] [
- <div =style div> call </div>
- ] if ; inline
-
-: format-html-div ( string style stream -- )
- [
- [ [ delegate-write ] div-tag ] object-link-tag
- ] with-output-stream* ;
-
-TUPLE: html-block-stream ;
-
-M: html-block-stream dispose ( quot style stream -- )
- end-sub-stream a-div format-html-div ;
-
-: border-spacing-css,
- "padding: " % first2 max 2 /i # "px; " % ;
-
-: table-style ( style -- str )
- [
- table-border [ border-css, ] apply-style
- table-gap [ border-spacing-css, ] apply-style
- ] make-css ;
-
-: table-attrs ( style -- )
- table-style " border-collapse: collapse;" append =style ;
-
-: do-escaping ( string style -- string )
- html swap at [ escape-string ] unless ;
-
-PRIVATE>
-
-! Stream protocol
-M: html-stream stream-write1 ( char stream -- )
- >r 1string r> stream-write ;
-
-M: html-stream stream-write ( str stream -- )
- not-a-div >r escape-string r> delegate stream-write ;
-
-M: html-stream make-span-stream ( style stream -- stream' )
- html-span-stream <html-sub-stream> ;
-
-M: html-stream stream-format ( str style stream -- )
- >r html over at [ >r escape-string r> ] unless r>
- format-html-span ;
-
-M: html-stream make-block-stream ( style stream -- stream' )
- html-block-stream <html-sub-stream> ;
-
-M: html-stream stream-write-table ( grid style stream -- )
- a-div [
- <table dup table-attrs table> swap [
- <tr> [
- <td "top" =valign swap table-style =style td>
- >string write-html
- </td>
- ] with each </tr>
- ] with each </table>
- ] with-output-stream* ;
-
-M: html-stream make-cell-stream ( style stream -- stream' )
- (html-sub-stream) ;
-
-M: html-stream stream-nl ( stream -- )
- dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
-
-! Utilities
-: with-html-stream ( quot -- )
- output-stream get <html-stream> swap with-output-stream* ; inline
-
-: xhtml-preamble
- "<?xml version=\"1.0\"?>" write-html
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
-
-: html-document ( body-quot head-quot -- )
- #! head-quot is called to produce output to go
- #! in the html head portion of the document.
- #! body-quot is called to produce output to go
- #! in the html body portion of the document.
- xhtml-preamble
- <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head> call </head>
- <body> call </body>
- </html> ;
-
-: default-css ( -- )
- <link
- "stylesheet" =rel "text/css" =type
- "/responder/resources/extra/html/stylesheet.css" =href
- link/> ;
-
-: simple-html-document ( title quot -- )
- swap [
- <title> write </title>
- default-css
- ] html-document ;
-
-: vertical-layout ( list -- )
- #! Given a list of HTML components, arrange them vertically.
- <table>
- [ <tr> <td> call </td> </tr> ] each
- </table> ;
-
-: horizontal-layout ( list -- )
- #! Given a list of HTML components, arrange them horizontally.
- <table>
- <tr "top" =valign tr> [ <td> call </td> ] each </tr>
- </table> ;
-
-: button ( label -- )
- #! Output an HTML submit button with the given label.
- <input "submit" =type =value input/> ;
-
-: paragraph ( str -- )
- #! Output the string as an html paragraph
- <p> write </p> ;
-
-: simple-page ( title quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title.
- <html>
- <head> <title> swap write </title> </head>
- <body> call </body>
- </html> ;
-
-: styled-page ( title stylesheet-quot quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title. stylesheet-quot
- #! is called to generate the required stylesheet.
- <html>
- <head>
- <title> rot write </title>
- swap call
- </head>
- <body> call </body>
- </html> ;
-
-: render-error ( message -- )
- <span "error" =class span> escape-string write </span> ;
--- /dev/null
+Slava Pestov
+Matthew Willis
+Chris Double
--- /dev/null
+USING: html.streams html.streams.private
+io io.streams.string io.styles kernel
+namespaces tools.test xml.writer sbufs sequences inspector ;
+IN: html.streams.tests
+
+: make-html-string
+ [ with-html-stream ] with-string-writer ; inline
+
+[ [ ] make-html-string ] must-infer
+
+[ ] [
+ 512 <sbuf> <html-stream> drop
+] unit-test
+
+[ "" ] [
+ [ "" write ] make-html-string
+] unit-test
+
+[ "a" ] [
+ [ CHAR: a write1 ] make-html-string
+] unit-test
+
+[ "<" ] [
+ [ "<" write ] make-html-string
+] unit-test
+
+[ "<" ] [
+ [ "<" H{ } output-stream get format-html-span ] make-html-string
+] unit-test
+
+TUPLE: funky town ;
+
+M: funky browser-link-href
+ "http://www.funky-town.com/" swap funky-town append ;
+
+[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
+ [
+ "<" "austin" funky boa write-object
+ ] make-html-string
+] unit-test
+
+[ "<span style='font-family: monospace; '>car</span>" ]
+[
+ [
+ "car"
+ H{ { font "monospace" } }
+ format
+ ] make-html-string
+] unit-test
+
+[ "<span style='color: #ff00ff; '>car</span>" ]
+[
+ [
+ "car"
+ H{ { foreground { 1 0 1 1 } } }
+ format
+ ] make-html-string
+] unit-test
+
+[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
+[
+ [
+ H{ { page-color { 1 0 1 1 } } }
+ [ "cdr" write ] with-nesting
+ ] make-html-string
+] unit-test
+
+[
+ "<div style='white-space: pre; font-family: monospace; '></div>"
+] [
+ [ H{ } [ ] with-nesting nl ] make-html-string
+] unit-test
+
+[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: generic assocs help http io io.styles io.files continuations
+io.streams.string kernel math math.order math.parser namespaces
+quotations assocs sequences strings words html.elements
+xml.entities sbufs continuations destructors accessors ;
+IN: html.streams
+
+GENERIC: browser-link-href ( presented -- href )
+
+M: object browser-link-href drop f ;
+
+TUPLE: html-stream stream last-div ;
+
+! stream-nl after with-nesting or tabular-output is
+! ignored, so that HTML stream output looks like
+! UI pane output
+: last-div? ( stream -- ? )
+ [ f ] change-last-div drop ;
+
+: not-a-div ( stream -- stream )
+ f >>last-div ; inline
+
+: a-div ( stream -- straem )
+ t >>last-div ; inline
+
+: <html-stream> ( stream -- stream )
+ f html-stream boa ;
+
+<PRIVATE
+
+TUPLE: html-sub-stream < html-stream style parent ;
+
+: new-html-sub-stream ( style stream class -- stream )
+ new
+ 512 <sbuf> >>stream
+ swap >>parent
+ swap >>style ; inline
+
+: end-sub-stream ( substream -- string style stream )
+ [ stream>> >string ] [ style>> ] [ parent>> ] tri ;
+
+: object-link-tag ( style quot -- )
+ presented pick at [
+ browser-link-href [
+ <a =href a> call </a>
+ ] [ call ] if*
+ ] [ call ] if* ; inline
+
+: hex-color, ( triplet -- )
+ 3 head-slice
+ [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+
+: fg-css, ( color -- )
+ "color: #" % hex-color, "; " % ;
+
+: bg-css, ( color -- )
+ "background-color: #" % hex-color, "; " % ;
+
+: style-css, ( flag -- )
+ dup
+ { italic bold-italic } member?
+ "font-style: " % "italic" "normal" ? % "; " %
+ { bold bold-italic } member?
+ "font-weight: " % "bold" "normal" ? % "; " % ;
+
+: size-css, ( size -- )
+ "font-size: " % # "pt; " % ;
+
+: font-css, ( font -- )
+ "font-family: " % % "; " % ;
+
+: apply-style ( style key quot -- style gadget )
+ >r over at r> when* ; inline
+
+: make-css ( style quot -- str )
+ "" make nip ; inline
+
+: span-css-style ( style -- str )
+ [
+ foreground [ fg-css, ] apply-style
+ background [ bg-css, ] apply-style
+ font [ font-css, ] apply-style
+ font-style [ style-css, ] apply-style
+ font-size [ size-css, ] apply-style
+ ] make-css ;
+
+: span-tag ( style quot -- )
+ over span-css-style dup empty? [
+ drop call
+ ] [
+ <span =style span> call </span>
+ ] if ; inline
+
+: format-html-span ( string style stream -- )
+ stream>> [
+ [ [ drop write ] span-tag ] object-link-tag
+ ] with-output-stream* ;
+
+TUPLE: html-span-stream < html-sub-stream ;
+
+M: html-span-stream dispose
+ end-sub-stream not-a-div format-html-span ;
+
+: border-css, ( border -- )
+ "border: 1px solid #" % hex-color, "; " % ;
+
+: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+
+: pre-css, ( margin -- )
+ [ "white-space: pre; font-family: monospace; " % ] unless ;
+
+: div-css-style ( style -- str )
+ [
+ page-color [ bg-css, ] apply-style
+ border-color [ border-css, ] apply-style
+ border-width [ padding-css, ] apply-style
+ wrap-margin over at pre-css,
+ ] make-css ;
+
+: div-tag ( style quot -- )
+ swap div-css-style dup empty? [
+ drop call
+ ] [
+ <div =style div> call </div>
+ ] if ; inline
+
+: format-html-div ( string style stream -- )
+ stream>> [
+ [ [ write ] div-tag ] object-link-tag
+ ] with-output-stream* ;
+
+TUPLE: html-block-stream < html-sub-stream ;
+
+M: html-block-stream dispose ( quot style stream -- )
+ end-sub-stream a-div format-html-div ;
+
+: border-spacing-css,
+ "padding: " % first2 max 2 /i # "px; " % ;
+
+: table-style ( style -- str )
+ [
+ table-border [ border-css, ] apply-style
+ table-gap [ border-spacing-css, ] apply-style
+ ] make-css ;
+
+: table-attrs ( style -- )
+ table-style " border-collapse: collapse;" append =style ;
+
+: do-escaping ( string style -- string )
+ html swap at [ escape-string ] unless ;
+
+PRIVATE>
+
+! Stream protocol
+M: html-stream stream-flush
+ stream>> stream-flush ;
+
+M: html-stream stream-write1
+ >r 1string r> stream-write ;
+
+M: html-stream stream-write
+ not-a-div >r escape-string r> stream>> stream-write ;
+
+M: html-stream stream-format
+ >r html over at [ >r escape-string r> ] unless r>
+ format-html-span ;
+
+M: html-stream stream-nl
+ dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
+
+M: html-stream make-span-stream
+ html-span-stream new-html-sub-stream ;
+
+M: html-stream make-block-stream
+ html-block-stream new-html-sub-stream ;
+
+M: html-stream make-cell-stream
+ html-sub-stream new-html-sub-stream ;
+
+M: html-stream stream-write-table
+ a-div stream>> [
+ <table dup table-attrs table> swap [
+ <tr> [
+ <td "top" =valign swap table-style =style td>
+ stream>> >string write
+ </td>
+ ] with each </tr>
+ ] with each </table>
+ ] with-output-stream* ;
+
+M: html-stream dispose stream>> dispose ;
+
+: with-html-stream ( quot -- )
+ output-stream get <html-stream> swap with-output-stream* ; inline
--- /dev/null
+HTML reader, writer and utilities
+++ /dev/null
-a:link { text-decoration: none; color: black; }
-a:visited { text-decoration: none; color: black; }
-a:active { text-decoration: none; color: black; }
-a:hover { text-decoration: underline; color: black; }
+++ /dev/null
-HTML reader, writer and utilities
--- /dev/null
+USING: html.templates html.templates.chloe
+tools.test io.streams.string kernel sequences ascii boxes
+namespaces xml html.components
+splitting unicode.categories ;
+IN: html.templates.chloe.tests
+
+[ f ] [ f parse-query-attr ] unit-test
+
+[ f ] [ "" parse-query-attr ] unit-test
+
+[ H{ { "a" "b" } } ] [
+ blank-values
+ "b" "a" set-value
+ "a" parse-query-attr
+] unit-test
+
+[ H{ { "a" "b" } { "c" "d" } } ] [
+ blank-values
+ "b" "a" set-value
+ "d" "c" set-value
+ "a,c" parse-query-attr
+] unit-test
+
+: run-template
+ with-string-writer [ "\r\n\t" member? not ] filter
+ "?>" split1 nip ; inline
+
+: test-template ( name -- template )
+ "resource:extra/html/templates/chloe/test/"
+ swap
+ ".xml" 3append <chloe> ;
+
+[ "Hello world" ] [
+ [
+ "test1" test-template call-template
+ ] run-template
+] unit-test
+
+[ "Blah blah" "Hello world" ] [
+ [
+ <box> title set
+ [
+ "test2" test-template call-template
+ ] run-template
+ title get box>
+ ] with-scope
+] unit-test
+
+[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
+ [
+ [
+ "test2" test-template call-template
+ ] "test3" test-template with-boilerplate
+ ] run-template
+] unit-test
+
+: test4-aux? t ;
+
+[ "True" ] [
+ [
+ "test4" test-template call-template
+ ] run-template
+] unit-test
+
+: test5-aux? f ;
+
+[ "" ] [
+ [
+ "test5" test-template call-template
+ ] 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
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ ] [ "int x = 5;" "code" set-value ] unit-test
+
+[ ] [ "c" "mode" set-value ] unit-test
+
+[ ] [ { 1 2 3 } "inspector" set-value ] unit-test
+
+[ ] [ "<p>a paragraph</p>" "html" set-value ] unit-test
+
+[ ] [ "sheeple" "field" set-value ] unit-test
+
+[ ] [ "a password" "password" set-value ] unit-test
+
+[ ] [ "a\nb\nc" "textarea" set-value ] unit-test
+
+[ ] [ "new york" "choice" set-value ] unit-test
+
+[ ] [ { "new york" "detroit" "minneapolis" } "choices" set-value ] unit-test
+
+[ ] [
+ [
+ "test8" test-template call-template
+ ] run-template drop
+] unit-test
+
+[ ] [ { 1 2 3 } "numbers" set-value ] unit-test
+
+[ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
+ [
+ "test9" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
+
+TUPLE: person first-name last-name ;
+
+[ ] [
+ {
+ T{ person f "RBaxter" "Unknown" }
+ T{ person f "Doug" "Coleman" }
+ } "people" set-value
+] 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
+ ] run-template [ blank? not ] filter
+] unit-test
+
+[ ] [
+ {
+ H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } }
+ H{ { "first-name" "Doug" } { "last-name" "Coleman" } }
+ } "people" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
+ [
+ "test11" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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
+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 ;
+IN: html.templates.chloe
+
+! Chloe is Ed's favorite web designer
+
+TUPLE: chloe path ;
+
+C: <chloe> chloe
+
+DEFER: process-template
+
+: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
+
+: chloe-attrs-only ( assoc -- assoc' )
+ [ drop name-url chloe-ns = ] assoc-filter ;
+
+: non-chloe-attrs-only ( assoc -- assoc' )
+ [ drop name-url chloe-ns = not ] assoc-filter ;
+
+: chloe-tag? ( tag -- ? )
+ {
+ { [ dup tag? not ] [ f ] }
+ { [ dup url>> chloe-ns = not ] [ f ] }
+ [ 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 ;
+
+: children>string ( tag -- string )
+ [ process-tag-children ] with-string-writer ;
+
+: title-tag ( tag -- )
+ children>string set-title ;
+
+: write-title-tag ( tag -- )
+ drop
+ "head" tags get member? "title" tags get member? not and
+ [ <title> write-title </title> ] [ write-title ] if ;
+
+: style-tag ( tag -- )
+ dup "include" optional-attr dup [
+ swap children>string empty? [
+ "style tag cannot have both an include attribute and a body" throw
+ ] unless
+ utf8 file-contents
+ ] [
+ drop children>string
+ ] if add-style ;
+
+: write-style-tag ( tag -- )
+ 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 ;
+
+: (each-tag) ( tag quot -- )
+ [
+ [ "values" required-attr value ] keep
+ '[ , process-tag-children ]
+ ] dip call ; inline
+
+: each-tag ( tag -- )
+ [ with-each-value ] (each-tag) ;
+
+: each-tuple-tag ( tag -- )
+ [ with-each-tuple ] (each-tag) ;
+
+: each-assoc-tag ( tag -- )
+ [ with-each-assoc ] (each-tag) ;
+
+: (bind-tag) ( tag quot -- )
+ [
+ [ "name" required-attr value ] keep
+ '[ , process-tag-children ]
+ ] dip call ; inline
+
+: bind-tuple-tag ( tag -- )
+ [ with-tuple-values ] (bind-tag) ;
+
+: bind-assoc-tag ( tag -- )
+ [ with-assoc-values ] (bind-tag) ;
+
+: error-message-tag ( tag -- )
+ children>string render-error ;
+
+: validation-messages-tag ( tag -- )
+ drop render-validation-messages ;
+
+: singleton-component-tag ( tag class -- )
+ [ "name" required-attr ] dip render ;
+
+: attrs>slots ( tag tuple -- )
+ [ attrs>> ] [ <mirror> ] bi*
+ '[
+ swap tag>> dup "name" =
+ [ 2drop ] [ , set-at ] if
+ ] assoc-each ;
+
+: tuple-component-tag ( tag class -- )
+ [ drop "name" required-attr ]
+ [ new [ attrs>slots ] keep ]
+ 2bi render ;
+
+: 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 ;
+
+: process-tag ( tag -- )
+ {
+ [ name-tag >lower tags get push ]
+ [ write-start-tag ]
+ [ process-tag-children ]
+ [ write-end-tag ]
+ [ drop tags get pop* ]
+ } cleave ;
+
+: process-template ( xml -- )
+ {
+ { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
+ { [ dup [ tag? ] is? ] [ process-tag ] }
+ { [ t ] [ write-item ] }
+ } cond ;
+
+: process-chloe ( xml -- )
+ [
+ V{ } clone tags set
+
+ nested-template? get [
+ process-template
+ ] [
+ {
+ [ xml-prolog write-prolog ]
+ [ xml-before write-chunk ]
+ [ process-template ]
+ [ xml-after write-chunk ]
+ } cleave
+ ] if
+ ] with-scope ;
+
+M: chloe call-template*
+ path>> utf8 <file-reader> read-xml process-chloe ;
+
+INSTANCE: chloe template
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ Hello world
+</t:chloe>
--- /dev/null
+<?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>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <table>
+ <t:each-assoc t:values="people">
+ <tr>
+ <td><t:label t:name="first-name"/></td>
+ <td><t:label t:name="last-name"/></td>
+ </tr>
+ </t:each-assoc>
+ </table>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+ Blah blah
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <html>
+ <head>
+ <t:write-title />
+ </head>
+ <body>
+ <t:call-next-template />
+ </body>
+ </html>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if t:code="html.templates.chloe.tests:test4-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if t:code="html.templates.chloe.tests:test5-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if t:var="html.templates.chloe.tests:test6-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if t:var="html.templates.chloe.tests:test7-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<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>
+
+</t:chloe>
--- /dev/null
+<?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>
--- /dev/null
+Slava Pestov
+Matthew Willis
--- /dev/null
+USING: io io.files io.streams.string io.encodings.utf8
+html.templates html.templates.fhtml kernel
+tools.test sequences parser ;
+IN: html.templates.fhtml.tests
+
+: test-template ( path -- ? )
+ "resource:extra/html/templates/fhtml/test/"
+ prepend
+ [
+ ".fhtml" append <fhtml> [ call-template ] with-string-writer
+ ] keep
+ ".html" append utf8 file-contents = ;
+
+[ t ] [ "example" test-template ] unit-test
+[ t ] [ "bug" test-template ] unit-test
+[ t ] [ "stack" test-template ] unit-test
+
+[
+ [ ] [ "<%\n%>" parse-template drop ] unit-test
+] with-file-vocabs
--- /dev/null
+! Copyright (C) 2005 Alex Chapman
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations sequences kernel namespaces debugger
+combinators math quotations generic strings splitting
+accessors assocs fry
+parser io io.files io.streams.string io.encodings.utf8
+html.elements
+html.templates ;
+IN: html.templates.fhtml
+
+! We use a custom lexer so that %> ends a token even if not
+! followed by whitespace
+TUPLE: template-lexer < lexer ;
+
+: <template-lexer> ( lines -- lexer )
+ template-lexer new-lexer ;
+
+M: template-lexer skip-word
+ [
+ {
+ { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
+ { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
+ [ f skip ]
+ } cond
+ ] change-lexer-column ;
+
+DEFER: <% delimiter
+
+: check-<% ( lexer -- col )
+ "<%" over line-text>> rot column>> start* ;
+
+: found-<% ( accum lexer col -- accum )
+ [
+ over line-text>>
+ [ column>> ] 2dip subseq parsed
+ \ write-html parsed
+ ] 2keep 2 + >>column drop ;
+
+: still-looking ( accum lexer -- accum )
+ [
+ [ line-text>> ] [ column>> ] bi tail
+ parsed \ print-html parsed
+ ] keep next-line ;
+
+: parse-%> ( accum lexer -- accum )
+ dup still-parsing? [
+ dup check-<%
+ [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
+ ] [
+ drop
+ ] if ;
+
+: %> lexer get parse-%> ; parsing
+
+: parse-template-lines ( lines -- quot )
+ <template-lexer> [
+ V{ } clone lexer get parse-%> f (parse-until)
+ ] with-parser ;
+
+: parse-template ( string -- quot )
+ [
+ "quiet" on
+ parser-notes off
+ "html.templates.fhtml" use+
+ string-lines parse-template-lines
+ ] with-file-vocabs ;
+
+: eval-template ( string -- )
+ parse-template call ;
+
+TUPLE: fhtml path ;
+
+C: <fhtml> fhtml
+
+M: fhtml call-template* ( filename -- )
+ '[ , path>> utf8 file-contents eval-template ] assert-depth ;
+
+INSTANCE: fhtml template
--- /dev/null
+<%
+ USING: prettyprint ;
+ ! Hello world
+ 5 pprint
+%>
--- /dev/null
+<% USING: math ; %>
+
+<html>
+ <head><title>Simple Embedded Factor Example</title></head>
+ <body>
+ <% 5 [ %><p>I like repetition</p><% ] times %>
+ </body>
+</html>
--- /dev/null
+
+
+<html>
+ <head><title>Simple Embedded Factor Example</title></head>
+ <body>
+ <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
+ </body>
+</html>
+
--- /dev/null
+The stack: <% USING: prettyprint ; .s %>
--- /dev/null
+The stack:
+
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel fry io io.encodings.utf8 io.files
+debugger prettyprint continuations namespaces boxes sequences
+arrays strings html.elements io.streams.string quotations ;
+IN: html.templates
+
+MIXIN: template
+
+GENERIC: call-template* ( template -- )
+
+M: string call-template* write ;
+
+M: callable call-template* call ;
+
+M: object call-template* output-stream get stream-copy ;
+
+ERROR: template-error template error ;
+
+M: template-error error.
+ "Error while processing template " write
+ [ template>> short. ":" print nl ]
+ [ error>> error. ]
+ bi ;
+
+: call-template ( template -- )
+ [ call-template* ] [ \ template-error boa rethrow ] recover ;
+
+SYMBOL: title
+
+: set-title ( string -- )
+ title get >box ;
+
+: write-title ( -- )
+ title get value>> write ;
+
+SYMBOL: style
+
+: add-style ( string -- )
+ "\n" style get push-all
+ style get push-all ;
+
+: write-style ( -- )
+ style get >string write ;
+
+SYMBOL: atom-feed
+
+: set-atom-feed ( title url -- )
+ 2array atom-feed get >box ;
+
+: write-atom-feed ( -- )
+ atom-feed get value>> [
+ <link "alternate" =rel "application/atom+xml" =type
+ [ first =title ] [ second =href ] bi
+ link/>
+ ] when* ;
+
+SYMBOL: nested-template?
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+ next-template get write-html ;
+
+M: f call-template* drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+ [
+ title get [ <box> title set ] unless
+ atom-feed get [ <box> atom-feed set ] unless
+ style get [ SBUF" " clone style set ] unless
+
+ [
+ [
+ nested-template? on
+ call-template
+ ] with-string-writer
+ next-template set
+ ]
+ [ call-template ]
+ bi*
+ ] with-scope ; inline
+
+: template-convert ( template output -- )
+ utf8 [ call-template ] with-file-writer ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
- >r http-get r> latin1 [ write ] with-file-writer ;
+ [ http-get ] dip latin1 [ write ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
[ ] [
[
<dispatcher>
- <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
+ <action> [ [ "Hi" write ] <text-content> ] >>display
<login>
<sessions>
"" add-responder
io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets io.sockets.secure
-unicode.case unicode.categories qualified ;
+unicode.case unicode.categories qualified
+
+html.templates ;
EXCLUDE: fry => , ;
2dup length 2 - >= [
2drop
] [
- >r 1+ dup 2 + r> subseq hex> [ , ] when*
+ [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
- 2dup url-decode-hex >r 3 + r> ;
+ 2dup url-decode-hex [ 3 + ] dip ;
: url-decode-+-or-other ( index str ch -- index str )
- dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
+ dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
: url-decode-iter ( index str -- )
2dup length >= [
dup [
"&" split H{ } clone [
[
- >r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
+ [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
add-query-param
] curry each
] keep
] assoc-map
[
[
- >r url-encode r>
+ [ url-encode ] dip
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
- " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
+ " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
over unparse-content-type "content-type" pick set-at
write-header ;
-GENERIC: write-response-body* ( body -- )
-
-M: f write-response-body* drop ;
-
-M: string write-response-body* write ;
-
-M: callable write-response-body* call ;
-
-M: object write-response-body* output-stream get stream-copy ;
-
: write-response-body ( response -- response )
- dup body>> write-response-body* ;
+ dup body>> call-template ;
M: response write-response ( respose -- )
write-response-version
swap method>> "HEAD" = [ write-response-body ] unless ;
: get-cookie ( request/response name -- cookie/f )
- >r cookies>> r> '[ , _ name>> = ] find nip ;
+ [ cookies>> ] dip '[ , _ name>> = ] find nip ;
: delete-cookie ( request/response name -- )
- over cookies>> >r get-cookie r> delete ;
+ over cookies>> [ get-cookie ] dip delete ;
: put-cookie ( request/response cookie -- request/response )
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
-USING: http.server.actions http.server.validators
+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
-[
- "a" [ v-number ] { { "a" "123" } } validate-param
- [ 123 ] [ "a" get ] unit-test
-] with-scope
-
<action>
- [ "a" get "b" get + ] >>display
- { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
+ [ "a" param "b" param [ string>number ] bi@ + ] >>display
"action-1" set
: lf>crlf "\n" split "\r\n" join ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors sequences kernel assocs combinators\r
-http.server http.server.validators http hashtables namespaces\r
-fry continuations locals boxes xml.entities html.elements io ;\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: validation-message\r
+SYMBOL: rest-param\r
\r
-: render-validation-message ( -- )\r
- validation-message get value>> [\r
- <span "error" =class span>\r
- escape-string write\r
- </span>\r
- ] when* ;\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 init display submit get-params post-params ;\r
+TUPLE: action rest-param init display validate submit ;\r
\r
-: <action>\r
- action new\r
+: new-action ( class -- action )\r
+ new\r
[ ] >>init\r
[ <400> ] >>display\r
+ [ ] >>validate\r
[ <400> ] >>submit ;\r
\r
-:: validate-param ( name validator assoc -- )\r
- name assoc at validator with-validator name set ; inline\r
-\r
-: action-params ( validators -- error? )\r
- validation-failed? off\r
- params get '[ , validate-param ] assoc-each\r
- validation-failed? get ;\r
-\r
-: handle-get ( -- response )\r
- action get get-params>> action-params [ <400> ] [\r
- action get [ init>> call ] [ display>> call ] bi\r
- ] if ;\r
+: <action> ( -- action )\r
+ action new-action ;\r
\r
-: handle-post ( -- response )\r
- action get post-params>> action-params\r
- [ <400> ] [ action get submit>> call ] if ;\r
+: handle-get ( action -- response )\r
+ blank-values\r
+ [ init>> call ]\r
+ [ display>> call ]\r
+ bi ;\r
\r
: validation-failed ( -- * )\r
- action get display>> call exit-with ;\r
+ request get method>> "POST" =\r
+ [ action get display>> call ] [ <400> ] if exit-with ;\r
\r
-: validation-failed-with ( string -- * )\r
- validation-message get >box\r
- validation-failed ;\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
- , [ CHAR: / = ] right-trim empty? [\r
- , action set\r
- request get\r
- <box> validation-message set\r
- [ request-params params set ]\r
- [\r
- method>> {\r
- { "GET" [ handle-get ] }\r
- { "HEAD" [ handle-get ] }\r
- { "POST" [ handle-post ] }\r
- } case\r
- ] bi\r
- ] [\r
- <404>\r
- ] if\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.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors namespaces combinators words
-assocs locals db.tuples arrays splitting strings qualified
-
-http.server.templating.chloe
-http.server.boilerplate
-http.server.auth.providers
-http.server.auth.providers.db
-http.server.auth.login
-http.server.auth
-http.server.forms
-http.server.components.inspector
-http.server.validators
-http.server.sessions
-http.server.actions
-http.server.crud
-http.server ;
-EXCLUDE: http.server.components => string? number? ;
-IN: http.server.auth.admin
-
-: admin-template ( name -- template )
- "resource:extra/http/server/auth/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 ;
-
-: <capabilities> ( id -- component )
- capabilities get words>strings <menu> ;
-
-: <new-user-form> ( -- form )
- "user" <form>
- "new-user" admin-template >>edit-template
- "username" <string> add-field
- "realname" <string> add-field
- "new-password" <password> t >>required add-field
- "verify-password" <password> t >>required add-field
- "email" <email> add-field
- "capabilities" <capabilities> add-field ;
-
-: <edit-user-form> ( -- form )
- "user" <form>
- "edit-user" admin-template >>edit-template
- "user-summary" admin-template >>summary-template
- "username" <string> hidden >>renderer add-field
- "realname" <string> add-field
- "new-password" <password> add-field
- "verify-password" <password> add-field
- "email" <email> add-field
- "profile" <inspector> add-field
- "capabilities" <capabilities> add-field ;
-
-: <user-list-form> ( -- form )
- "user-list" <form>
- "user-list" admin-template >>view-template
- "list" <edit-user-form> +unordered+ <list> add-field ;
-
-:: <new-user-action> ( form ctor next -- action )
- <action>
- [
- blank-values
-
- "username" get ctor call
-
- {
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- [ profile>> "profile" set-value ]
- } cleave
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- blank-values
-
- form validate-form
-
- same-password-twice
-
- user new "username" value >>username select-tuple
- [ user-exists ] when
-
- "username" value <user>
- "realname" value >>realname
- "email" value >>email
- "new-password" value >>encoded-password
- H{ } clone >>profile
-
- insert-tuple
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <edit-user-action> ( form ctor next -- action )
- <action>
- { { "username" [ v-required ] } } >>get-params
-
- [
- blank-values
-
- "username" get ctor call select-tuple
-
- {
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- [ profile>> "profile" set-value ]
- [ capabilities>> words>strings "capabilities" set-value ]
- } cleave
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- blank-values
-
- form validate-form
-
- "username" value <user> select-tuple
- "realname" value >>realname
- "email" value >>email
-
- { "new-password" "verify-password" }
- [ value empty? ] all? [
- same-password-twice
- "new-password" value >>encoded-password
- ] unless
-
- "capabilities" value {
- { [ dup string? ] [ 1array ] }
- { [ dup array? ] [ ] }
- } cond strings>words >>capabilities
-
- update-tuple
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <delete-user-action> ( ctor next -- action )
- <action>
- { { "username" [ ] } } >>post-params
-
- [
- "username" get
- [ <user> select-tuple 1 >>deleted update-tuple ]
- [ logout-all-sessions ]
- bi
-
- next f <standard-redirect>
- ] >>submit ;
-
-TUPLE: user-admin < dispatcher ;
-
-SYMBOL: can-administer-users?
-
-can-administer-users? define-capability
-
-:: <user-admin> ( -- responder )
- [let | ctor [ [ <user> ] ] |
- user-admin new-dispatcher
- <user-list-form> ctor <list-action> "" add-responder
- <new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
- <edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
- ctor "$user-admin" <delete-user-action> "delete" add-responder
- <boilerplate>
- "admin" admin-template >>template
- { can-administer-users? } <protected>
- ] ;
-
-: make-admin ( username -- )
- <user>
- select-tuple
- [ can-administer-users? suffix ] change-capabilities
- update-tuple ;
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <div class="navbar">
- <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:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
- </div>
-
- <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 User</t:title>
-
- <t:form t:action="$user-admin/edit" t:for="username">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:view t:component="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label big-field-label">Capabilities:</th>
- <td><t:edit t:component="capabilities" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Profile:</th>
- <td><t:view t:component="profile" /></td>
- </tr>
-
- </table>
-
- <p>
- <button type="submit" class="link-button link">Update</button>
- <t:validation-message />
- </p>
-
- </t:form>
-
- <t:button t:action="$user-admin/delete" t:for="username" 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 User</t:title>
-
- <t:form t:action="$user-admin/new">
-
- <table>
-
- <tr>
- <th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
- </tr>
-
- <tr>
- <th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label big-field-label">Capabilities:</th>
- <td><t:edit t:component="capabilities" /></td>
- </tr>
-
- </table>
-
- <p>
- <button type="submit" class="link-button link">Create</button>
- <t:validation-message />
- </p>
-
- </t:form>
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Users</t:title>
-
- <t:summary t:component="list" />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:a t:href="$user-admin/edit" t:query="username">
- <t:view t:component="username" />
- </t:a>
-
-</t:chloe>
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs namespaces kernel sequences\r
+USING: accessors assocs namespaces kernel sequences sets\r
http.server\r
http.server.sessions\r
http.server.auth.providers ;\r
\r
V{ } clone capabilities set-global\r
\r
-: define-capability ( word -- ) capabilities get push-new ;\r
+: define-capability ( word -- ) capabilities get adjoin ;\r
<tr>
<th class="field-label">User name:</th>
- <td><t:view t:component="username" /></td>
+ <td><t:label t:name="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
+ <td><t:field t:name="realname" /></td>
</tr>
<tr>
<tr>
<th class="field-label">Current password:</th>
- <td><t:edit t:component="password" /></td>
+ <td><t:password t:name="password" /></td>
</tr>
<tr>
<tr>
<th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
+ <td><t:password t:name="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
+ <td><t:password t:name="verify-password" /></td>
</tr>
<tr>
<tr>
<th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
+ <td><t:field t:name="email" /></td>
</tr>
<tr>
<p>
<input type="submit" value="Update" />
- <t:validation-message />
+ <t:validation-messages />
</p>
</t:form>
! 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 locals qualified random\r
+fry arrays threads qualified random validators\r
io\r
io.sockets\r
io.encodings.utf8\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.components\r
http.server.flows\r
-http.server.forms\r
http.server.sessions\r
-http.server.boilerplate\r
-http.server.templating\r
-http.server.templating.chloe\r
-http.server.validators ;\r
-IN: http.server.auth.login\r
+http.server.boilerplate ;\r
QUALIFIED: smtp\r
+IN: http.server.auth.login\r
\r
TUPLE: login < dispatcher users checksum ;\r
\r
3append <chloe> ;\r
\r
! ! ! Login\r
-\r
-: <login-form>\r
- "login" <form>\r
- "login" login-template >>edit-template\r
- "username" <username>\r
- t >>required\r
- add-field\r
- "password" <password>\r
- t >>required\r
- add-field ;\r
-\r
: successful-login ( user -- response )\r
- username>> set-uid\r
- "$login" end-flow ;\r
-\r
-: login-failed "invalid username or password" validation-failed-with ;\r
-\r
-:: <login-action> ( -- action )\r
- [let | form [ <login-form> ] |\r
- <action>\r
- [ blank-values ] >>init\r
+ username>> set-uid "$login" end-flow ;\r
\r
- [ form edit-form ] >>display\r
+: login-failed ( -- * )\r
+ "invalid username or password" validation-error\r
+ validation-failed ;\r
\r
- [\r
- blank-values\r
+: <login-action> ( -- action )\r
+ <action>\r
+ [ "login" login-template <html-content> ] >>display\r
\r
- form validate-form\r
+ [\r
+ {\r
+ { "username" [ v-required ] }\r
+ { "password" [ v-required ] }\r
+ } validate-params\r
\r
- "password" value "username" value check-login\r
- [ successful-login ] [ login-failed ] if*\r
- ] >>submit\r
- ] ;\r
+ "password" value\r
+ "username" value check-login\r
+ [ successful-login ] [ login-failed ] if*\r
+ ] >>submit ;\r
\r
! ! ! New user registration\r
\r
-: <register-form> ( -- form )\r
- "register" <form>\r
- "register" login-template >>edit-template\r
- "username" <username>\r
- t >>required\r
- add-field\r
- "realname" <string> add-field\r
- "new-password" <password>\r
- t >>required\r
- add-field\r
- "verify-password" <password>\r
- t >>required\r
- add-field\r
- "email" <email> add-field\r
- "captcha" <captcha> add-field ;\r
-\r
-: password-mismatch "passwords do not match" validation-failed-with ;\r
-\r
-: user-exists "username taken" validation-failed-with ;\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
- [let | form [ <register-form> ] |\r
- <action>\r
- [ blank-values ] >>init\r
-\r
- [ form edit-form ] >>display\r
+: <register-action> ( -- action )\r
+ <page-action>\r
+ "register" login-template >>template\r
\r
- [\r
- blank-values\r
-\r
- form validate-form\r
-\r
- same-password-twice\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
- "username" value <user>\r
- "realname" value >>realname\r
- "new-password" value >>encoded-password\r
- "email" value >>email\r
- H{ } clone >>profile\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
+ users new-user [ user-exists ] unless*\r
\r
- successful-login\r
+ login get init-user-profile\r
\r
- login get init-user-profile\r
- ] >>submit\r
- ] ;\r
+ successful-login\r
+ ] >>submit ;\r
\r
! ! ! Editing user profile\r
\r
-: <edit-profile-form> ( -- form )\r
- "edit-profile" <form>\r
- "edit-profile" login-template >>edit-template\r
- "username" <username> add-field\r
- "realname" <string> add-field\r
- "password" <password> add-field\r
- "new-password" <password> add-field\r
- "verify-password" <password> add-field\r
- "email" <email> add-field ;\r
-\r
-:: <edit-profile-action> ( -- action )\r
- [let | form [ <edit-profile-form> ] |\r
- <action>\r
- [\r
- blank-values\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
+: <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
- [ form edit-form ] >>display\r
+ [ "edit-profile" login-template <html-content> ] >>display\r
\r
- [\r
- blank-values\r
- uid "username" set-value\r
+ [\r
+ uid "username" set-value\r
\r
- form validate-form\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
- logged-in-user get\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
- { "password" "new-password" "verify-password" }\r
- [ value empty? ] all? [\r
- same-password-twice\r
+ same-password-twice\r
+ ] when\r
+ ] >>validate\r
\r
- "password" value uid check-login\r
- [ login-failed ] unless\r
+ [\r
+ logged-in-user get\r
\r
- "new-password" value >>encoded-password\r
- ] unless\r
+ "new-password" value dup empty?\r
+ [ drop ] [ >>encoded-password ] if\r
\r
- "realname" value >>realname\r
- "email" value >>email\r
+ "realname" value >>realname\r
+ "email" value >>email\r
\r
- t >>changed?\r
+ t >>changed?\r
\r
- drop\r
+ drop\r
\r
- "$login" end-flow\r
- ] >>submit\r
- ] ;\r
+ "$login" end-flow\r
+ ] >>submit ;\r
\r
! ! ! Password recovery\r
\r
'[ , password-email smtp:send-email ]\r
"E-mail send thread" spawn drop ;\r
\r
-: <recover-form-1> ( -- form )\r
- "register" <form>\r
- "recover-1" login-template >>edit-template\r
- "username" <username>\r
- t >>required\r
- add-field\r
- "email" <email>\r
- t >>required\r
- add-field\r
- "captcha" <captcha> add-field ;\r
-\r
-:: <recover-action-1> ( -- action )\r
- [let | form [ <recover-form-1> ] |\r
- <action>\r
- [ blank-values ] >>init\r
-\r
- [ form edit-form ] >>display\r
-\r
- [\r
- blank-values\r
-\r
- form validate-form\r
-\r
- "email" value "username" value\r
- users issue-ticket [\r
- send-password-email\r
- ] when*\r
-\r
- "recover-2" login-template serve-template\r
- ] >>submit\r
- ] ;\r
-\r
-: <recover-form-3>\r
- "new-password" <form>\r
- "recover-3" login-template >>edit-template\r
- "username" <username>\r
- hidden >>renderer\r
- t >>required\r
- add-field\r
- "new-password" <password>\r
- t >>required\r
- add-field\r
- "verify-password" <password>\r
- t >>required\r
- add-field\r
- "ticket" <string>\r
- hidden >>renderer\r
- t >>required\r
- add-field ;\r
-\r
-:: <recover-action-3> ( -- action )\r
- [let | form [ <recover-form-3> ] |\r
- <action>\r
- [\r
- { "username" [ v-required ] }\r
- { "ticket" [ v-required ] }\r
- ] >>get-params\r
+: <recover-action-1> ( -- action )\r
+ <action>\r
+ [ "recover-1" login-template <html-content> ] >>display\r
\r
- [\r
- [\r
- "username" [ get ] keep set\r
- "ticket" [ get ] keep set\r
- ] H{ } make-assoc values set\r
- ] >>init\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "email" [ v-email ] }\r
+ { "captcha" [ v-captcha ] }\r
+ } validate-params\r
+ ] >>validate\r
\r
- [ <recover-form-3> edit-form ] >>display\r
+ [\r
+ "email" value "username" value\r
+ users issue-ticket [\r
+ send-password-email\r
+ ] when*\r
\r
- [\r
- blank-values\r
+ "recover-2" login-template <html-content>\r
+ ] >>submit ;\r
\r
- form validate-form\r
+: <recover-action-3> ( -- action )\r
+ <action>\r
+ [\r
+ {\r
+ { "username" [ v-username ] }\r
+ { "ticket" [ v-required ] }\r
+ } validate-params\r
+ ] >>init\r
\r
- same-password-twice\r
+ [ "recover-3" login-template <html-content> ] >>display\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 serve-template\r
- ] [\r
- <400>\r
- ] if*\r
- ] >>submit\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
<tr>
<th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
+ <td><t:field t:name="username" /></td>
</tr>
<tr>
<th class="field-label">Password:</th>
- <td><t:edit t:component="password" /></td>
+ <td><t:password t:name="password" /></td>
</tr>
</table>
<p>
<input type="submit" value="Log in" />
- <t:validation-message />
+ <t:validation-messages />
</p>
<table>
- <tr>
- <th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:edit t:component="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>
+ <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>
<table>
- <t:edit t:component="username" />
- <t:edit t:component="ticket" />
+ <t:hidden t:name="username" />
+ <t:hidden t:name="ticket" />
<tr>
- <th class="field-label">Password:</th>
- <td><t:edit t:component="new-password" /></td>
+ <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:edit t:component="verify-password" /></td>
+ <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>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
</tr>
</table>
<p>
<input type="submit" value="Set password" />
- <t:validation-message />
+ <t:validation-messages />
</p>
</t:form>
<table>
- <tr>
- <th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
- </tr>
-
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
-
- <tr>
- <th class="field-label">Password:</th>
- <td><t:edit t:component="new-password" /></td>
- </tr>
-
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:edit t:component="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:edit t:component="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:edit t:component="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>
+ <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-message />
+ <t:validation-messages />
</p>
M: users-in-memory update-user ( user provider -- ) 2drop ;\r
\r
M: users-in-memory new-user ( user provider -- user/f )\r
- >r dup username>> r> assoc>>\r
- 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;\r
+ [ dup username>> ] dip assoc>>\r
+ 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;\r
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces boxes sequences strings
-io io.streams.string arrays locals
-html.elements
-http
-http.server
-http.server.sessions
-http.server.templating ;
+USING: accessors kernel namespaces http.server html.templates
+locals ;
IN: http.server.boilerplate
TUPLE: boilerplate < filter-responder template ;
: <boilerplate> f boilerplate boa ;
-SYMBOL: title
-
-: set-title ( string -- )
- title get >box ;
-
-: write-title ( -- )
- title get value>> write ;
-
-SYMBOL: style
-
-: add-style ( string -- )
- "\n" style get push-all
- style get push-all ;
-
-: write-style ( -- )
- style get >string write ;
-
-SYMBOL: atom-feed
-
-: set-atom-feed ( title url -- )
- 2array atom-feed get >box ;
-
-: write-atom-feed ( -- )
- atom-feed get value>> [
- <link "alternate" =rel "application/atom+xml" =type
- [ first =title ] [ second =href ] bi
- link/>
- ] when* ;
-
-SYMBOL: nested-template?
-
-SYMBOL: next-template
-
-: call-next-template ( -- )
- next-template get write-html ;
-
-M: f call-template* drop call-next-template ;
-
-: with-boilerplate ( body template -- )
- [
- title get [ <box> title set ] unless
- atom-feed get [ <box> atom-feed set ] unless
- style get [ SBUF" " clone style set ] unless
-
- [
- [
- nested-template? on
- write-response-body*
- ] with-string-writer
- next-template set
- ]
- [ call-template ]
- bi*
- ] with-scope ; inline
-
M:: boilerplate call-responder* ( path responder -- )
path responder call-next-method
dup content-type>> "text/html" = [
! Copyright (C) 2004 Chris Double.\r
! Copyright (C) 2006, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: html http http.server io kernel math namespaces\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
[ restore-request store-current-show ] when* ;\r
\r
: show-final ( quot -- * )\r
- >r redirect-to-here store-current-show r>\r
+ [ redirect-to-here store-current-show ] dip\r
call exit-with ; inline\r
\r
: resuming-callback ( responder request -- id )\r
] with-exit-continuation ;\r
\r
: show-page ( quot -- )\r
- >r redirect-to-here store-current-show r>\r
+ [ redirect-to-here store-current-show ] dip\r
[\r
[ ] t register-callback swap call exit-with\r
] callcc1 restore-request ; inline\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: splitting kernel io sequences xmode.code2html accessors
-http.server.components html xml.entities ;
-IN: http.server.components.code
-
-TUPLE: code-renderer < text-renderer mode ;
-
-: <code-renderer> ( mode -- renderer )
- code-renderer new-text-renderer
- swap >>mode ;
-
-M: code-renderer render-view*
- [
- [ string-lines ] [ mode>> value ] bi* htmlize-lines
- ] with-html-stream ;
-
-: <code> ( id mode -- component )
- swap <text>
- swap <code-renderer> >>renderer ;
+++ /dev/null
-IN: http.server.components.tests\r
-USING: http.server.components http.server.forms\r
-http.server.validators namespaces tools.test kernel accessors\r
-tuple-syntax mirrors\r
-http http.server.actions http.server.templating.fhtml\r
-io.streams.string io.streams.null ;\r
-\r
-validation-failed? off\r
-\r
-[ 3 ] [ "3" "n" <number> validate ] unit-test\r
-\r
-[ 123 ] [\r
- ""\r
- "n" <number>\r
- 123 >>default\r
- validate\r
-] unit-test\r
-\r
-[ f ] [ validation-failed? get ] unit-test\r
-\r
-[ t ] [ "3x" "n" <number> validate validation-error? ] unit-test\r
-\r
-[ t ] [ validation-failed? get ] unit-test\r
-\r
-[ "" ] [ "" "email" <email> validate ] unit-test\r
-\r
-[ "slava@jedit.org" ] [ "slava@jedit.org" "email" <email> validate ] unit-test\r
-\r
-[ "slava@jedit.org" ] [\r
- "slava@jedit.org"\r
- "email" <email>\r
- t >>required\r
- validate\r
-] unit-test\r
-\r
-[ t ] [\r
- "a"\r
- "email" <email>\r
- t >>required\r
- validate validation-error?\r
-] unit-test\r
-\r
-[ t ] [ "a" "email" <email> validate validation-error? ] unit-test\r
-\r
-TUPLE: test-tuple text number more-text ;\r
-\r
-: <test-tuple> test-tuple new ;\r
-\r
-: <test-form> ( -- form )\r
- "test" <form>\r
- "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template\r
- "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template\r
- "text" <string>\r
- t >>required\r
- add-field\r
- "number" <number>\r
- 123 >>default\r
- t >>required\r
- 0 >>min-value\r
- 10 >>max-value\r
- add-field\r
- "more-text" <text>\r
- "hi" >>default\r
- add-field ;\r
-\r
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test\r
-\r
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test\r
-\r
-[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [\r
- <test-tuple> from-tuple\r
- <test-form> set-defaults\r
- values-tuple\r
-] unit-test\r
-\r
-[\r
- H{\r
- { "text" "fdafsa" }\r
- { "number" "xxx" }\r
- { "more-text" "" }\r
- } params set\r
-\r
- H{ } clone values set\r
-\r
- [ t ] [ <test-form> (validate-form) ] unit-test\r
-\r
- [ "fdafsa" ] [ "text" value ] unit-test\r
-\r
- [ t ] [ "number" value validation-error? ] unit-test\r
-] with-scope\r
-\r
-[\r
- [ ] [\r
- "n" <number>\r
- 0 >>min-value\r
- 10 >>max-value\r
- "n" set\r
- ] unit-test\r
-\r
- [ "123" ] [\r
- "123" "n" get validate value>>\r
- ] unit-test\r
- \r
- [ ] [ "i" <integer> "i" set ] unit-test\r
-\r
- [ 3 ] [\r
- "3" "i" get validate\r
- ] unit-test\r
- \r
- [ t ] [\r
- "3.9" "i" get validate validation-error?\r
- ] unit-test\r
-\r
- H{ } clone values set\r
-\r
- [ ] [ 3 "i" set-value ] unit-test\r
-\r
- [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test\r
-\r
- [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test\r
-\r
- [ ] [ "t" <text> "t" set ] unit-test\r
-\r
- [ ] [ "hello world" "t" set-value ] unit-test\r
-\r
- [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test\r
-] with-scope\r
-\r
-[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test\r
-\r
-[ ] [ "password" <password> "p" set ] unit-test\r
-\r
-[ ] [ "pub-date" <date> "d" set ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel io math.parser assocs classes
-words classes.tuple arrays sequences splitting mirrors
-hashtables fry locals combinators continuations math
-calendar.format html html.elements xml.entities
-http.server.validators ;
-IN: http.server.components
-
-! Renderer protocol
-GENERIC: render-summary* ( value renderer -- )
-GENERIC: render-view* ( value renderer -- )
-GENERIC: render-edit* ( value id renderer -- )
-
-M: object render-summary* render-view* ;
-
-TUPLE: field type ;
-
-C: <field> field
-
-M: field render-view*
- drop escape-string write ;
-
-M: field render-edit*
- <input type>> =type =name =value input/> ;
-
-TUPLE: hidden < field ;
-
-: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
-
-! Component protocol
-SYMBOL: components
-
-TUPLE: component id required default renderer ;
-
-: component ( name -- component )
- dup components get at
- [ ] [ "No such component: " prepend throw ] ?if ;
-
-GENERIC: init ( component -- component )
-
-M: component init ;
-
-GENERIC: validate* ( value component -- result )
-GENERIC: component-string ( value component -- string )
-
-SYMBOL: values
-
-: value values get at ;
-
-: set-value values get set-at ;
-
-: blank-values H{ } clone values set ;
-
-: from-tuple <mirror> values set ;
-
-: values-tuple values get mirror-object ;
-
-: render-view-or-summary ( component -- value renderer )
- [ id>> value ] [ component-string ] [ renderer>> ] tri ;
-
-: render-view ( component -- )
- render-view-or-summary render-view* ;
-
-: render-summary ( component -- )
- render-view-or-summary render-summary* ;
-
-<PRIVATE
-
-: render-edit-string ( string component -- )
- [ id>> ] [ renderer>> ] bi render-edit* ;
-
-: render-edit-error ( component -- )
- [ id>> value ] keep
- [ [ value>> ] dip render-edit-string ]
- [ drop reason>> render-error ] 2bi ;
-
-: value-or-default ( component -- value )
- [ id>> value ] [ default>> ] bi or ;
-
-: render-edit-value ( component -- )
- [ value-or-default ]
- [ component-string ]
- [ render-edit-string ]
- tri ;
-
-PRIVATE>
-
-: render-edit ( component -- )
- dup id>> value validation-error?
- [ render-edit-error ] [ render-edit-value ] if ;
-
-: validate ( value component -- result )
- '[
- ,
- over empty? [
- [ default>> [ v-default ] when* ]
- [ required>> [ v-required ] when ]
- bi
- ] [ validate* ] if
- ] with-validator ;
-
-: new-component ( id class renderer -- component )
- swap new
- swap >>renderer
- swap >>id
- init ; inline
-
-! String input fields
-TUPLE: string < component one-line min-length max-length ;
-
-: new-string ( id class -- component )
- "text" <field> new-component
- t >>one-line ; inline
-
-: <string> ( id -- component )
- string new-string ;
-
-M: string validate*
- [ one-line>> [ v-one-line ] when ]
- [ min-length>> [ v-min-length ] when* ]
- [ max-length>> [ v-max-length ] when* ]
- tri ;
-
-M: string component-string
- drop ;
-
-! Username fields
-TUPLE: username < string ;
-
-M: username init
- 2 >>min-length
- 20 >>max-length ;
-
-: <username> ( id -- component )
- username new-string ;
-
-M: username validate*
- call-next-method v-one-word ;
-
-! E-mail fields
-TUPLE: email < string ;
-
-: <email> ( id -- component )
- email new-string
- 5 >>min-length
- 60 >>max-length ;
-
-M: email validate*
- call-next-method dup empty? [ v-email ] unless ;
-
-! URL fields
-TUPLE: url < string ;
-
-: <url> ( id -- component )
- url new-string
- 5 >>min-length
- 60 >>max-length ;
-
-M: url validate*
- call-next-method dup empty? [ v-url ] unless ;
-
-! Don't send passwords back to the user
-TUPLE: password-renderer < field ;
-
-: password-renderer T{ password-renderer f "password" } ;
-
-: blank-password >r >r drop "" r> r> ;
-
-M: password-renderer render-edit*
- blank-password call-next-method ;
-
-! Password fields
-TUPLE: password < string ;
-
-M: password init
- 6 >>min-length
- 60 >>max-length ;
-
-: <password> ( id -- component )
- password new-string
- password-renderer >>renderer ;
-
-M: password validate*
- call-next-method v-one-word ;
-
-! Number fields
-TUPLE: number < string min-value max-value ;
-
-: <number> ( id -- component )
- number new-string ;
-
-M: number validate*
- [ v-number ] [
- [ min-value>> [ v-min-value ] when* ]
- [ max-value>> [ v-max-value ] when* ]
- bi
- ] bi* ;
-
-M: number component-string
- drop dup [ number>string ] when ;
-
-! Integer fields
-TUPLE: integer < number ;
-
-: <integer> ( id -- component )
- integer new-string ;
-
-M: integer validate*
- call-next-method v-integer ;
-
-! Simple captchas
-TUPLE: captcha < string ;
-
-: <captcha> ( id -- component )
- captcha new-string ;
-
-M: captcha validate*
- drop v-captcha ;
-
-! Text areas
-TUPLE: text-renderer rows cols ;
-
-: new-text-renderer ( class -- renderer )
- new
- 60 >>cols
- 20 >>rows ;
-
-: <text-renderer> ( -- renderer )
- text-renderer new-text-renderer ;
-
-M: text-renderer render-view*
- drop escape-string write ;
-
-M: text-renderer render-edit*
- <textarea
- [ rows>> [ number>string =rows ] when* ]
- [ cols>> [ number>string =cols ] when* ] bi
- [ =id ]
- [ =name ] bi
- textarea>
- escape-string write
- </textarea> ;
-
-TUPLE: text < string ;
-
-: new-text ( id class -- component )
- new-string
- f >>one-line
- <text-renderer> >>renderer ;
-
-: <text> ( id -- component )
- text new-text ;
-
-! HTML text component
-TUPLE: html-text-renderer < text-renderer ;
-
-: <html-text-renderer> ( -- renderer )
- html-text-renderer new-text-renderer ;
-
-M: html-text-renderer render-view*
- drop escape-string write ;
-
-TUPLE: html-text < text ;
-
-: <html-text> ( id -- component )
- html-text new-text
- <html-text-renderer> >>renderer ;
-
-! Date component
-TUPLE: date < string ;
-
-: <date> ( id -- component )
- date new-string ;
-
-M: date component-string
- drop timestamp>string ;
-
-! Link components
-
-GENERIC: link-title ( obj -- string )
-GENERIC: link-href ( obj -- url )
-
-SINGLETON: link-renderer
-
-M: link-renderer render-view*
- drop <a dup link-href =href a> link-title escape-string write </a> ;
-
-TUPLE: link < string ;
-
-: <link> ( id -- component )
- link new-string
- link-renderer >>renderer ;
-
-! List components
-SYMBOL: +plain+
-SYMBOL: +ordered+
-SYMBOL: +unordered+
-
-TUPLE: list-renderer component type ;
-
-C: <list-renderer> list-renderer
-
-: render-plain-list ( seq component quot -- )
- '[ , component>> renderer>> @ ] each ; inline
-
-: render-li-list ( seq component quot -- )
- '[ <li> @ </li> ] render-plain-list ; inline
-
-: render-ordered-list ( seq quot component -- )
- <ol> render-li-list </ol> ; inline
-
-: render-unordered-list ( seq quot component -- )
- <ul> render-li-list </ul> ; inline
-
-: render-list ( value renderer quot -- )
- over type>> {
- { +plain+ [ render-plain-list ] }
- { +ordered+ [ render-ordered-list ] }
- { +unordered+ [ render-unordered-list ] }
- } case ; inline
-
-M: list-renderer render-view*
- [ render-view* ] render-list ;
-
-M: list-renderer render-summary*
- [ render-summary* ] render-list ;
-
-TUPLE: list < component ;
-
-: <list> ( id component type -- list )
- <list-renderer> list swap new-component ;
-
-M: list component-string drop ;
-
-! Choice
-TUPLE: choice-renderer choices ;
-
-C: <choice-renderer> choice-renderer
-
-M: choice-renderer render-view*
- drop escape-string write ;
-
-: render-option ( text selected? -- )
- <option [ "true" =selected ] when option>
- escape-string write
- </option> ;
-
-: render-options ( options selected -- )
- '[ dup , member? render-option ] each ;
-
-M: choice-renderer render-edit*
- <select swap =name select>
- choices>> swap 1array render-options
- </select> ;
-
-TUPLE: choice < string ;
-
-: <choice> ( id choices -- component )
- swap choice new-string
- swap <choice-renderer> >>renderer ;
-
-! Menu
-TUPLE: menu-renderer choices size ;
-
-: <menu-renderer> ( choices -- renderer )
- 5 menu-renderer boa ;
-
-M:: menu-renderer render-edit* ( value id renderer -- )
- <select
- renderer size>> [ number>string =size ] when*
- id =name
- "true" =multiple
- select>
- renderer choices>> value render-options
- </select> ;
-
-TUPLE: menu < string ;
-
-: <menu> ( id choices -- component )
- swap menu new-string
- swap <menu-renderer> >>renderer ;
-
-! Checkboxes
-TUPLE: checkbox-renderer label ;
-
-C: <checkbox-renderer> checkbox-renderer
-
-M: checkbox-renderer render-edit*
- <input
- "checkbox" =type
- swap =id
- swap [ "true" =selected ] when
- input>
- label>> escape-string write
- </input> ;
-
-TUPLE: checkbox < string ;
-
-: <checkbox> ( id label -- component )
- checkbox swap <checkbox-renderer> new-component ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: splitting kernel io sequences farkup accessors\r
-http.server.components xml.entities ;\r
-IN: http.server.components.farkup\r
-\r
-TUPLE: farkup-renderer < text-renderer ;\r
-\r
-: <farkup-renderer> ( -- renderer )\r
- farkup-renderer new-text-renderer ;\r
-\r
-M: farkup-renderer render-view*\r
- drop string-lines "\n" join convert-farkup write ;\r
-\r
-: <farkup> ( id -- component )\r
- <text>\r
- <farkup-renderer> >>renderer ;\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: splitting kernel io sequences inspector accessors
-http.server.components xml.entities html ;
-IN: http.server.components.inspector
-
-SINGLETON: inspector-renderer
-
-M: inspector-renderer render-view*
- drop [ describe ] with-html-stream ;
-
-TUPLE: inspector < component ;
-
-M: inspector component-string drop ;
-
-: <inspector> ( id -- component )
- inspector inspector-renderer new-component ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces db.tuples math.parser
-accessors fry locals hashtables
-http.server
-http.server.actions
-http.server.components
-http.server.forms
-http.server.validators ;
-IN: http.server.crud
-
-:: <view-action> ( form ctor -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
-
- [ "id" get ctor call select-tuple from-tuple ] >>init
-
- [ form view-form ] >>display ;
-
-: <id-redirect> ( id next -- response )
- swap number>string "id" associate <standard-redirect> ;
-
-:: <edit-action> ( form ctor next -- action )
- <action>
- { { "id" [ [ v-number ] v-optional ] } } >>get-params
-
- [
- "id" get ctor call
-
- "id" get
- [ select-tuple from-tuple ]
- [ from-tuple form set-defaults ]
- if
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- f ctor call from-tuple
-
- form validate-form
-
- values-tuple
- "id" value [ update-tuple ] [ insert-tuple ] if
-
- "id" value next <id-redirect>
- ] >>submit ;
-
-:: <delete-action> ( ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>post-params
-
- [
- "id" get ctor call delete-tuples
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <list-action> ( form ctor -- action )
- <action>
- [
- blank-values
-
- f ctor call select-tuples "list" set-value
-
- form view-form
- ] >>display ;
\r
TUPLE: db-persistence < filter-responder pool ;\r
\r
-: <db-persistence> ( responder db params -- responder' )\r
+: <db-persistence> ( responder params db -- responder' )\r
<db-pool> db-persistence boa ;\r
\r
M: db-persistence call-responder*\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs namespaces io.files sequences fry
-http.server
-http.server.actions
-http.server.components
-http.server.validators
-http.server.templating ;
-IN: http.server.forms
-
-TUPLE: form < component
-view-template edit-template summary-template
-components ;
-
-M: form init V{ } clone >>components ;
-
-: <form> ( id -- form )
- form f new-component
- dup >>renderer ;
-
-: add-field ( form component -- form )
- dup id>> pick components>> set-at ;
-
-: set-components ( form -- )
- components>> components set ;
-
-: with-form ( form quot -- )
- [ [ set-components ] [ call ] bi* ] with-scope ; inline
-
-: set-defaults ( form -- )
- [
- components get [
- swap values get [
- swap default>> or
- ] change-at
- ] assoc-each
- ] with-form ;
-
-: <form-response> ( form template -- response )
- [ components>> components set ] [ <html-content> ] bi* ;
-
-: view-form ( form -- response )
- dup view-template>> <form-response> ;
-
-: edit-form ( form -- response )
- dup edit-template>> <form-response> ;
-
-: validate-param ( id component -- )
- [ [ params get at ] [ validate ] bi* ]
- [ drop set-value ] 2bi ;
-
-: (validate-form) ( form -- error? )
- [
- validation-failed? off
- components get [ validate-param ] assoc-each
- validation-failed? get
- ] with-form ;
-
-: validate-form ( form -- )
- (validate-form) [ validation-failed ] when ;
-
-: render-form ( value form template -- )
- [
- [ from-tuple ]
- [ set-components ]
- [ call-template ]
- tri*
- ] with-scope ;
-
-M: form component-string drop ;
-
-M: form render-summary*
- dup summary-template>> render-form ;
-
-M: form render-view*
- dup view-template>> render-form ;
-
-M: form render-edit*
- nip dup edit-template>> render-form ;
M: mock-responder call-responder*
nip
path>> on
- "text/plain" <content> ;
+ [ ] <text-content> ;
: check-dispatch ( tag path -- ? )
H{ } clone base-paths set
M: path-check-responder call-responder*
drop
- "text/plain" <content> swap >array >>body ;
+ >array <text-content> ;
[ { "c" } ] [
H{ } clone base-paths set
M: base-path-check-responder call-responder*
2drop
"$funny-dispatcher" resolve-base-path
- "text/plain" <content> swap >>body ;
+ <text-content> ;
[ ] [
<dispatcher>
! 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 html.elements accessors math.parser combinators.lib
-tools.vocabs debugger continuations random combinators
-destructors io.encodings.8-bit fry classes words ;
+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 ;
IN: http.server
! path is a sequence of path component strings
{ "POST" [ post-data>> ] }
} case ;
-: <content> ( content-type -- response )
+: <content> ( body content-type -- response )
<response>
200 >>code
"Document follows" >>message
- swap >>content-type ;
+ swap >>content-type
+ swap >>body ;
-: <html-content> ( quot -- response )
- "text/html" <content> swap >>body ;
+: <text-content> ( body -- response )
+ "text/plain" <content> ;
+
+: <html-content> ( body -- response )
+ "text/html" <content> ;
+
+: <xml-content> ( body -- response )
+ "text/xml" <content> ;
+
+: <feed-content> ( feed -- response )
+ '[ , feed>xml ] "text/xml" <content> ;
+
+: <json-content> ( obj -- response )
+ '[ , >json ] "application/json" <content> ;
TUPLE: trivial-responder response ;
: resolve-base-path ( string -- string' )
"$" ?head [
[
- "/" split1 >r
- base-path [ "/" % % ] each "/" %
- r> %
+ "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
request-url ;
: replace-last-component ( path with -- path' )
- >r "/" last-split1 drop "/" r> 3append ;
+ [ "/" last-split1 drop "/" ] dip 3append ;
: relative-redirect ( to query -- url )
request get clone
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
- { [ over "$" head? ] [ >r resolve-base-path r> derive-url ] }
+ { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
[ relative-redirect ]
} cond ;
[ nip ] [ drop default>> ] if
] [
over first over responders>> at*
- [ >r drop rest-slice r> ] [ drop default>> ] if
+ [ [ drop rest-slice ] dip ] [ drop default>> ] if
] if ;
M: dispatcher call-responder* ( path dispatcher -- response )
] with-destructors ;
: httpd ( port -- )
- internet-server "http.server"
- latin1 [ handle-client ] with-server ;
+ dup integer? [ internet-server ] when
+ "http.server" latin1
+ [ handle-client ] with-server ;
-: httpd-main ( -- ) 8888 httpd ;
+: httpd-main ( -- )
+ 8888 httpd ;
MAIN: httpd-main
\r
: with-session\r
[\r
- >r [ save-session-after ] [ session set ] bi r> call\r
+ [ [ save-session-after ] [ session set ] bi ] dip call\r
] with-destructors ; inline\r
\r
TUPLE: foo ;\r
M: foo call-responder*\r
2drop\r
"x" [ 1+ ] schange\r
- "text/html" <content> [ "x" sget pprint ] >>body ;\r
+ [ "x" sget pprint ] <html-content> ;\r
\r
: url-responder-mock-test\r
[\r
\r
: <exiting-action>\r
<action>\r
- [\r
- "text/plain" <content> exit-with\r
- ] >>display ;\r
+ [ [ ] <text-content> exit-with ] >>display ;\r
\r
[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors\r
\r
! Copyright (C) 2004, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: calendar html io io.files kernel math math.order\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
-logging calendar.format accessors io.encodings.binary fry ;\r
+html.templates.fhtml logging calendar.format accessors\r
+io.encodings.binary fry xml.entities destructors ;\r
IN: http.server.static\r
\r
! special maps mime types to quots with effect ( path -- )\r
swap >>root\r
H{ } clone >>special ;\r
\r
+: (serve-static) ( path mime-type -- response )\r
+ [ [ binary <file-reader> &dispose ] dip <content> ]\r
+ [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi\r
+ [ "content-length" set-header ]\r
+ [ "last-modified" set-header ] bi* ;\r
+\r
: <static> ( root -- responder )\r
- [\r
- <content>\r
- swap [\r
- file-info\r
- [ size>> "content-length" set-header ]\r
- [ modified>> "last-modified" set-header ] bi\r
- ]\r
- [ '[ , binary <file-reader> output-stream get stream-copy ] >>body ] bi\r
- ] <file-responder> ;\r
+ [ (serve-static) ] <file-responder> ;\r
\r
: serve-static ( filename mime-type -- response )\r
over modified-since?\r
\r
: file. ( name dirp -- )\r
[ "/" append ] when\r
- dup <a =href a> write </a> ;\r
+ dup <a =href a> escape-string write </a> ;\r
\r
: directory. ( path -- )\r
dup file-name [\r
- [ <h1> file-name write </h1> ]\r
+ [ <h1> file-name escape-string write </h1> ]\r
[\r
<ul>\r
directory sort-keys\r
[ <li> file. </li> ] assoc-each\r
</ul>\r
] bi\r
- ] simple-html-document ;\r
+ ] simple-page ;\r
\r
: list-directory ( directory -- response )\r
file-responder get allow-listings>> [\r
file-responder set\r
".." over member?\r
[ drop <400> ] [ "/" join serve-object ] if ;\r
+\r
+! file responder integration\r
+: enable-fhtml ( responder -- responder )\r
+ [ <fhtml> <html-content> ]\r
+ "application/x-factor-server-page"\r
+ pick special>> set-at ;\r
+++ /dev/null
-USING: http.server.templating http.server.templating.chloe
-http.server.components http.server.boilerplate tools.test
-io.streams.string kernel sequences ascii boxes namespaces xml
-splitting ;
-IN: http.server.templating.chloe.tests
-
-[ f ] [ f parse-query-attr ] unit-test
-
-[ f ] [ "" parse-query-attr ] unit-test
-
-[ H{ { "a" "b" } } ] [
- blank-values
- "b" "a" set-value
- "a" parse-query-attr
-] unit-test
-
-[ H{ { "a" "b" } { "c" "d" } } ] [
- blank-values
- "b" "a" set-value
- "d" "c" set-value
- "a,c" parse-query-attr
-] unit-test
-
-: run-template
- with-string-writer [ "\r\n\t" member? not ] filter
- "?>" split1 nip ; inline
-
-: test-template ( name -- template )
- "resource:extra/http/server/templating/chloe/test/"
- swap
- ".xml" 3append <chloe> ;
-
-[ "Hello world" ] [
- [
- "test1" test-template call-template
- ] run-template
-] unit-test
-
-[ "Blah blah" "Hello world" ] [
- [
- <box> title set
- [
- "test2" test-template call-template
- ] run-template
- title get box>
- ] with-scope
-] unit-test
-
-[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
- [
- [
- "test2" test-template call-template
- ] "test3" test-template with-boilerplate
- ] run-template
-] unit-test
-
-: test4-aux? t ;
-
-[ "True" ] [
- [
- "test4" test-template call-template
- ] run-template
-] unit-test
-
-: test5-aux? f ;
-
-[ "" ] [
- [
- "test5" test-template call-template
- ] 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
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-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 html html.elements
-multiline xml xml.data xml.writer xml.utilities
-http.server
-http.server.auth
-http.server.flows
-http.server.actions
-http.server.components
-http.server.sessions
-http.server.templating
-http.server.boilerplate ;
-IN: http.server.templating.chloe
-
-! Chloe is Ed's favorite web designer
-
-TUPLE: chloe path ;
-
-C: <chloe> chloe
-
-DEFER: process-template
-
-: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-
-: chloe-attrs-only ( assoc -- assoc' )
- [ drop name-url chloe-ns = ] assoc-filter ;
-
-: non-chloe-attrs-only ( assoc -- assoc' )
- [ drop name-url chloe-ns = not ] assoc-filter ;
-
-: chloe-tag? ( tag -- ? )
- {
- { [ dup tag? not ] [ f ] }
- { [ dup url>> chloe-ns = not ] [ f ] }
- [ 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 ;
-
-: children>string ( tag -- string )
- [ [ process-template ] each ] with-string-writer ;
-
-: title-tag ( tag -- )
- children>string set-title ;
-
-: write-title-tag ( tag -- )
- drop
- "head" tags get member? "title" tags get member? not and
- [ <title> write-title </title> ] [ write-title ] if ;
-
-: style-tag ( tag -- )
- dup "include" optional-attr dup [
- swap children>string empty? [
- "style tag cannot have both an include attribute and a body" throw
- ] unless
- utf8 file-contents
- ] [
- drop children>string
- ] if add-style ;
-
-: write-style-tag ( tag -- )
- 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 ;
-
-: component-attr ( tag -- name )
- "component" required-attr ;
-
-: view-tag ( tag -- )
- component-attr component render-view ;
-
-: edit-tag ( tag -- )
- component-attr component render-edit ;
-
-: summary-tag ( tag -- )
- component-attr component render-summary ;
-
-: 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 ;
-
-: process-tag-children ( tag -- )
- [ process-template ] each ;
-
-: 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 [ component render-edit ] 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
- {
- [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
- [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
- [ >r children>string 1array r> "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 ;
-
-: error-message-tag ( tag -- )
- children>string render-error ;
-
-: process-chloe-tag ( tag -- )
- dup name-tag {
- { "chloe" [ [ process-template ] each ] }
- { "title" [ title-tag ] }
- { "write-title" [ write-title-tag ] }
- { "style" [ style-tag ] }
- { "write-style" [ write-style-tag ] }
- { "atom" [ atom-tag ] }
- { "write-atom" [ write-atom-tag ] }
- { "view" [ view-tag ] }
- { "edit" [ edit-tag ] }
- { "summary" [ summary-tag ] }
- { "a" [ a-tag ] }
- { "form" [ form-tag ] }
- { "button" [ button-tag ] }
- { "error-message" [ error-message-tag ] }
- { "validation-message" [ drop render-validation-message ] }
- { "if" [ if-tag ] }
- { "comment" [ drop ] }
- { "call-next-template" [ drop call-next-template ] }
- [ "Unknown chloe tag: " swap append throw ]
- } case ;
-
-: process-tag ( tag -- )
- {
- [ name-tag >lower tags get push ]
- [ write-start-tag ]
- [ process-tag-children ]
- [ write-end-tag ]
- [ drop tags get pop* ]
- } cleave ;
-
-: process-template ( xml -- )
- {
- { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
- { [ dup [ tag? ] is? ] [ process-tag ] }
- { [ t ] [ write-item ] }
- } cond ;
-
-: process-chloe ( xml -- )
- [
- V{ } clone tags set
-
- nested-template? get [
- process-template
- ] [
- {
- [ xml-prolog write-prolog ]
- [ xml-before write-chunk ]
- [ process-template ]
- [ xml-after write-chunk ]
- } cleave
- ] if
- ] with-scope ;
-
-M: chloe call-template*
- path>> utf8 <file-reader> read-xml process-chloe ;
-
-INSTANCE: chloe template
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- Hello world
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Hello world</t:title>
- Blah blah
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Hello world</t:title>
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <html>
- <head>
- <t:write-title />
- </head>
- <body>
- <t:call-next-template />
- </body>
- </html>
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:if t:code="http.server.templating.chloe.tests:test4-aux?">
- True
- </t:if>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:if t:code="http.server.templating.chloe.tests:test5-aux?">
- True
- </t:if>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:if t:var="http.server.templating.chloe.tests:test6-aux?">
- True
- </t:if>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:if t:var="http.server.templating.chloe.tests:test7-aux?">
- True
- </t:if>
-
-</t:chloe>
+++ /dev/null
-Slava Pestov
-Matthew Willis
+++ /dev/null
-USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating http.server.templating.fhtml kernel
-tools.test sequences parser ;
-IN: http.server.templating.fhtml.tests
-
-: test-template ( path -- ? )
- "resource:extra/http/server/templating/fhtml/test/"
- prepend
- [
- ".fhtml" append <fhtml> [ call-template ] with-string-writer
- ] keep
- ".html" append utf8 file-contents = ;
-
-[ t ] [ "example" test-template ] unit-test
-[ t ] [ "bug" test-template ] unit-test
-[ t ] [ "stack" test-template ] unit-test
-
-[
- [ ] [ "<%\n%>" parse-template drop ] unit-test
-] with-file-vocabs
+++ /dev/null
-! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: continuations sequences kernel namespaces debugger
-combinators math quotations generic strings splitting
-accessors assocs fry
-parser io io.files io.streams.string io.encodings.utf8 source-files
-html html.elements
-http.server.static http.server http.server.templating ;
-IN: http.server.templating.fhtml
-
-: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
-
-! We use a custom lexer so that %> ends a token even if not
-! followed by whitespace
-TUPLE: template-lexer < lexer ;
-
-: <template-lexer> ( lines -- lexer )
- template-lexer new-lexer ;
-
-M: template-lexer skip-word
- [
- {
- { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
- { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
- [ f skip ]
- } cond
- ] change-lexer-column ;
-
-DEFER: <% delimiter
-
-: check-<% ( lexer -- col )
- "<%" over line-text>> rot column>> start* ;
-
-: found-<% ( accum lexer col -- accum )
- [
- over line-text>>
- >r >r column>> r> r> subseq parsed
- \ write-html parsed
- ] 2keep 2 + >>column drop ;
-
-: still-looking ( accum lexer -- accum )
- [
- [ line-text>> ] [ column>> ] bi tail
- parsed \ print-html parsed
- ] keep next-line ;
-
-: parse-%> ( accum lexer -- accum )
- dup still-parsing? [
- dup check-<%
- [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
- ] [
- drop
- ] if ;
-
-: %> lexer get parse-%> ; parsing
-
-: parse-template-lines ( lines -- quot )
- <template-lexer> [
- V{ } clone lexer get parse-%> f (parse-until)
- ] with-parser ;
-
-: parse-template ( string -- quot )
- [
- use [ clone ] change
- templating-vocab use+
- string-lines parse-template-lines
- ] with-scope ;
-
-: eval-template ( string -- ) parse-template call ;
-
-: html-error. ( error -- )
- <pre> error. </pre> ;
-
-TUPLE: fhtml path ;
-
-C: <fhtml> fhtml
-
-M: fhtml call-template* ( filename -- )
- '[
- , path>> [
- "quiet" on
- parser-notes off
- templating-vocab use+
- ! so that reload works properly
- dup source-file file set
- utf8 file-contents
- [ eval-template ] [ html-error. drop ] recover
- ] with-file-vocabs
- ] assert-depth ;
-
-! file responder integration
-: enable-fhtml ( responder -- responder )
- [ <fhtml> serve-template ]
- "application/x-factor-server-page"
- pick special>> set-at ;
-
-INSTANCE: fhtml template
+++ /dev/null
-<%
- USING: prettyprint ;
- ! Hello world
- 5 pprint
-%>
+++ /dev/null
-<% USING: math ; %>
-
-<html>
- <head><title>Simple Embedded Factor Example</title></head>
- <body>
- <% 5 [ %><p>I like repetition</p><% ] times %>
- </body>
-</html>
+++ /dev/null
-
-
-<html>
- <head><title>Simple Embedded Factor Example</title></head>
- <body>
- <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
- </body>
-</html>
-
+++ /dev/null
-The stack: <% USING: prettyprint ; .s %>
+++ /dev/null
-The stack:
-
+++ /dev/null
-USING: accessors kernel fry io io.encodings.utf8 io.files
-http http.server debugger prettyprint continuations ;
-IN: http.server.templating
-
-MIXIN: template
-
-GENERIC: call-template* ( template -- )
-
-ERROR: template-error template error ;
-
-M: template-error error.
- "Error while processing template " write
- [ template>> pprint ":" print nl ]
- [ error>> error. ]
- bi ;
-
-: call-template ( template -- )
- [ call-template* ] [ template-error ] recover ;
-
-M: template write-response-body* call-template ;
-
-: template-convert ( template output -- )
- utf8 [ call-template ] with-file-writer ;
-
-! responder integration
-: serve-template ( template -- response )
- '[ , call-template ] <html-content> ;
+++ /dev/null
-IN: http.server.validators.tests
-USING: kernel sequences tools.test http.server.validators
-accessors ;
-
-[ "foo" v-number ] must-fail
-[ 123 ] [ "123" v-number ] unit-test
-
-[ "slava@factorcode.org" ] [
- "slava@factorcode.org" v-email
-] unit-test
-
-[ "slava+foo@factorcode.org" ] [
- "slava+foo@factorcode.org" v-email
-] unit-test
-
-[ "slava@factorcode.o" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "sla@@factorcode.o" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "slava@factorcodeorg" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "http://www.factorcode.org" ]
-[ "http://www.factorcode.org" v-url ] unit-test
-
-[ "http:/www.factorcode.org" v-url ]
-[ "invalid URL" = ] must-fail-with
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces sets
-math.parser assocs regexp fry unicode.categories sequences ;
-IN: http.server.validators
-
-SYMBOL: validation-failed?
-
-TUPLE: validation-error value reason ;
-
-C: <validation-error> validation-error
-
-: with-validator ( value quot -- result )
- [ validation-failed? on <validation-error> ] recover ; inline
-
-: v-default ( str def -- str )
- over empty? spin ? ;
-
-: v-required ( str -- str )
- dup empty? [ "required" throw ] when ;
-
-: v-optional ( str quot -- str )
- over empty? [ 2drop f ] [ call ] if ; inline
-
-: v-min-length ( str n -- str )
- over length over < [
- [ "must be at least " % # " characters" % ] "" make
- throw
- ] [
- drop
- ] if ;
-
-: v-max-length ( str n -- str )
- over length over > [
- [ "must be no more than " % # " characters" % ] "" make
- throw
- ] [
- drop
- ] if ;
-
-: v-number ( str -- n )
- dup string>number [ ] [ "must be a number" throw ] ?if ;
-
-: v-integer ( n -- n )
- dup integer? [ "must be an integer" throw ] unless ;
-
-: v-min-value ( x n -- x )
- 2dup < [
- [ "must be at least " % # ] "" make throw
- ] [
- drop
- ] if ;
-
-: v-max-value ( x n -- x )
- 2dup > [
- [ "must be no more than " % # ] "" make throw
- ] [
- drop
- ] if ;
-
-: v-regexp ( str what regexp -- str )
- >r over r> matches?
- [ drop ] [ "invalid " prepend throw ] if ;
-
-: v-email ( str -- str )
- #! From http://www.regular-expressions.info/email.html
- "e-mail"
- R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
- v-regexp ;
-
-: v-url ( str -- str )
- "URL"
- R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
- v-regexp ;
-
-: v-captcha ( str -- str )
- dup empty? [ "must remain blank" throw ] unless ;
-
-: v-one-line ( str -- str )
- dup "\r\n" intersect empty?
- [ "must be a single line" throw ] unless ;
-
-: v-one-word ( str -- str )
- dup [ alpha? ] all?
- [ "must be a single word" throw ] unless ;
+++ /dev/null
-Doug Coleman
-Slava Pestov
--- /dev/null
+Doug Coleman
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators concurrency.mailboxes concurrency.futures io
+ io.encodings.8-bit io.sockets kernel namespaces sequences
+ sequences.lib splitting threads calendar classes.tuple
+ ascii assocs accessors destructors ;
+IN: irc.client
+
+! ======================================
+! Setup and running objects
+! ======================================
+
+SYMBOL: current-irc-client
+
+: irc-port 6667 ; ! Default irc port
+
+! "setup" objects
+TUPLE: irc-profile server port nickname password ;
+C: <irc-profile> irc-profile
+
+TUPLE: irc-channel-profile name password ;
+: <irc-channel-profile> ( -- irc-channel-profile ) irc-channel-profile new ;
+
+! "live" objects
+TUPLE: nick name channels log ;
+C: <nick> nick
+
+TUPLE: irc-client profile nick stream in-messages out-messages join-messages
+ listeners is-running ;
+: <irc-client> ( profile -- irc-client )
+ f V{ } clone V{ } clone <nick>
+ f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
+
+TUPLE: irc-listener in-messages out-messages ;
+: <irc-listener> ( -- irc-listener )
+ <mailbox> <mailbox> irc-listener boa ;
+
+! ======================================
+! Message objects
+! ======================================
+
+SINGLETON: irc-end ! Message used when the client isn't running anymore
+
+TUPLE: irc-message line prefix command parameters trailing timestamp ;
+TUPLE: logged-in < irc-message name ;
+TUPLE: ping < irc-message ;
+TUPLE: join < irc-message ;
+TUPLE: part < irc-message name channel ;
+TUPLE: quit < irc-message ;
+TUPLE: privmsg < irc-message name ;
+TUPLE: kick < irc-message channel who ;
+TUPLE: roomlist < irc-message channel names ;
+TUPLE: nick-in-use < irc-message asterisk name ;
+TUPLE: notice < irc-message type ;
+TUPLE: mode < irc-message name channel mode ;
+TUPLE: unhandled < irc-message ;
+
+<PRIVATE
+
+! ======================================
+! Shortcuts
+! ======================================
+
+: irc-client> ( -- irc-client ) current-irc-client get ;
+: irc-stream> ( -- stream ) irc-client> stream>> ;
+: irc-write ( s -- ) irc-stream> stream-write ;
+: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
+
+! ======================================
+! IRC client messages
+! ======================================
+
+: /NICK ( nick -- )
+ "NICK " irc-write irc-print ;
+
+: /LOGIN ( nick -- )
+ dup /NICK
+ "USER " irc-write irc-write
+ " hostname servername :irc.factor" irc-print ;
+
+: /CONNECT ( server port -- stream )
+ <inet> latin1 <client> drop ;
+
+: /JOIN ( channel password -- )
+ "JOIN " irc-write
+ [ " :" swap 3append ] when* irc-print ;
+
+: /PART ( channel text -- )
+ [ "PART " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: /KICK ( channel who -- )
+ [ "KICK " irc-write irc-write ] dip
+ " " irc-write irc-print ;
+
+: /PRIVMSG ( nick line -- )
+ [ "PRIVMSG " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: /ACTION ( nick line -- )
+ [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
+
+: /QUIT ( text -- )
+ "QUIT :" irc-write irc-print ;
+
+: /PONG ( text -- )
+ "PONG " irc-write irc-print ;
+
+! ======================================
+! Server message handling
+! ======================================
+
+USE: prettyprint
+
+GENERIC: handle-incoming-irc ( irc-message -- )
+
+M: irc-message handle-incoming-irc ( irc-message -- )
+ . ;
+
+M: logged-in handle-incoming-irc ( logged-in -- )
+ name>> irc-client> nick>> (>>name) ;
+
+M: ping handle-incoming-irc ( ping -- )
+ trailing>> /PONG ;
+
+M: nick-in-use handle-incoming-irc ( nick-in-use -- )
+ name>> "_" append /NICK ;
+
+M: privmsg handle-incoming-irc ( privmsg -- )
+ dup name>> irc-client> listeners>> at
+ [ in-messages>> mailbox-put ] [ drop ] if* ;
+
+M: join handle-incoming-irc ( join -- )
+ irc-client> join-messages>> mailbox-put ;
+
+! ======================================
+! Client message handling
+! ======================================
+
+GENERIC: handle-outgoing-irc ( obj -- )
+
+M: privmsg handle-outgoing-irc ( privmsg -- )
+ [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+
+! ======================================
+! Message parsing
+! ======================================
+
+: split-at-first ( seq separators -- before after )
+ dupd [ member? ] curry find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
+: parse-name ( string -- string )
+ remove-heading-: "!" split-at-first drop ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head?
+ [ remove-heading-: " " split1 ]
+ [ f swap ]
+ if ;
+
+: split-trailing ( string -- string string/f )
+ ":" split1 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now irc-message boa ;
+
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
+
+! ======================================
+! Reader/Writer
+! ======================================
+
+: stream-readln-or-close ( stream -- str/f )
+ dup stream-readln [ nip ] [ dispose f ] if* ;
+
+: handle-reader-message ( irc-message -- )
+ irc-client> in-messages>> mailbox-put ;
+
+: handle-stream-close ( -- )
+ irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ;
+
+: reader-loop ( -- )
+ irc-client> stream>> stream-readln-or-close [
+ parse-irc-line handle-reader-message
+ ] [
+ handle-stream-close
+ ] if* ;
+
+: writer-loop ( -- )
+ irc-client> out-messages>> mailbox-get handle-outgoing-irc ;
+
+! ======================================
+! Processing loops
+! ======================================
+
+: in-multiplexer-loop ( -- )
+ irc-client> in-messages>> mailbox-get handle-incoming-irc ;
+
+! FIXME: Hack, this should be handled better
+GENERIC: add-name ( name obj -- obj )
+M: object add-name nip ;
+M: privmsg add-name swap >>name ;
+
+: listener-loop ( name -- ) ! FIXME: take different values from the stack?
+ dup irc-client> listeners>> at [
+ out-messages>> mailbox-get add-name
+ irc-client> out-messages>>
+ mailbox-put
+ ] [ drop ] if* ;
+
+: spawn-irc-loop ( quot name -- )
+ [ [ irc-client> is-running>> ] compose ] dip
+ spawn-server drop ;
+
+: spawn-irc ( -- )
+ [ reader-loop ] "irc-reader-loop" spawn-irc-loop
+ [ writer-loop ] "irc-writer-loop" spawn-irc-loop
+ [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
+
+! ======================================
+! Listener join request handling
+! ======================================
+
+: make-registered-listener ( join -- listener )
+ <irc-listener> swap trailing>>
+ dup [ listener-loop ] curry "listener" spawn-irc-loop
+ [ irc-client> listeners>> set-at ] curry keep ;
+
+: make-join-future ( name -- future )
+ [ [ swap trailing>> = ] curry ! compare name with channel name
+ irc-client> join-messages>> 60 seconds rot mailbox-get-timeout?
+ make-registered-listener ]
+ curry future ;
+
+PRIVATE>
+
+: (connect-irc) ( irc-client -- )
+ [ profile>> [ server>> ] keep port>> /CONNECT ] keep
+ swap >>stream
+ t >>is-running drop ;
+
+: connect-irc ( irc-client -- )
+ dup current-irc-client [
+ [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
+ spawn-irc
+ ] with-variable ;
+
+: listen-to ( irc-client name -- future )
+ swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ;
+
+! shorcut for privmsgs, etc
+: sender>> ( obj -- string )
+ prefix>> parse-name ;
--- /dev/null
+An IRC client framework
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators channels concurrency.messaging fry io
- io.encodings.8-bit io.sockets kernel math namespaces sequences
- sequences.lib splitting strings threads
- continuations destructors classes.tuple ascii accessors ;
-IN: irc
-
-! utils
-: split-at-first ( seq separators -- before after )
- dupd '[ , member? ] find
- [ cut rest ]
- [ swap ]
- if ;
-
-: spawn-server-linked ( quot name -- thread )
- >r '[ , [ ] [ ] while ] r>
- spawn-linked ;
-! ---
-
-! Default irc port
-: irc-port 6667 ;
-
-! Message used when the client isn't running anymore
-SINGLETON: irc-end
-
-! "setup" objects
-TUPLE: irc-profile server port nickname password default-channels ;
-C: <irc-profile> irc-profile
-
-TUPLE: irc-channel-profile name password auto-rejoin ;
-C: <irc-channel-profile> irc-channel-profile
-
-! "live" objects
-TUPLE: nick name channels log ;
-C: <nick> nick
-
-TUPLE: irc-client profile nick stream stream-channel controller-channel
- listeners is-running ;
-: <irc-client> ( profile -- irc-client )
- f V{ } clone V{ } clone <nick>
- f <channel> <channel> V{ } clone f irc-client boa ;
-
-USE: prettyprint
-TUPLE: irc-listener channel ;
-! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
-! tener la opción de dejar de correr un client??
-: <irc-listener> ( quot -- irc-listener )
- <channel> irc-listener boa swap
- [
- [ channel>> '[ , from ] ]
- [ '[ , curry f spawn drop ] ]
- bi* compose "irc-listener" spawn-server-linked drop
- ] [ drop ] 2bi ;
-
-! TUPLE: irc-channel name topic members log attributes ;
-! C: <irc-channel> irc-channel
-
-! the delegate of all irc messages
-TUPLE: irc-message line prefix command parameters trailing timestamp ;
-C: <irc-message> irc-message
-
-! "irc message" objects
-TUPLE: logged-in < irc-message name ;
-C: <logged-in> logged-in
-
-TUPLE: ping < irc-message ;
-C: <ping> ping
-
-TUPLE: join_ < irc-message ;
-C: <join> join_
-
-TUPLE: part < irc-message name channel ;
-C: <part> part
-
-TUPLE: quit ;
-C: <quit> quit
-
-TUPLE: privmsg < irc-message name ;
-C: <privmsg> privmsg
-
-TUPLE: kick < irc-message channel who ;
-C: <kick> kick
-
-TUPLE: roomlist < irc-message channel names ;
-C: <roomlist> roomlist
-
-TUPLE: nick-in-use < irc-message name ;
-C: <nick-in-use> nick-in-use
-
-TUPLE: notice < irc-message type ;
-C: <notice> notice
-
-TUPLE: mode < irc-message name channel mode ;
-C: <mode> mode
-
-TUPLE: unhandled < irc-message ;
-C: <unhandled> unhandled
-
-SYMBOL: irc-client
-: irc-client> ( -- irc-client ) irc-client get ;
-: irc-stream> ( -- stream ) irc-client> stream>> ;
-
-: remove-heading-: ( seq -- seq ) dup ":" head? [ rest ] when ;
-
-: parse-name ( string -- string )
- remove-heading-: "!" split-at-first drop ;
-
-: sender>> ( obj -- string )
- prefix>> parse-name ;
-
-: split-prefix ( string -- string/f string )
- dup ":" head?
- [ remove-heading-: " " split1 ]
- [ f swap ]
- if ;
-
-: split-trailing ( string -- string string/f )
- ":" split1 ;
-
-: string>irc-message ( string -- object )
- dup split-prefix split-trailing
- [ [ blank? ] trim " " split unclip swap ] dip
- now <irc-message> ;
-
-: me? ( name -- ? )
- irc-client> nick>> name>> = ;
-
-: irc-write ( s -- )
- irc-stream> stream-write ;
-
-: irc-print ( s -- )
- irc-stream> [ stream-print ] keep stream-flush ;
-
-! Irc commands
-
-: NICK ( nick -- )
- "NICK " irc-write irc-print ;
-
-: LOGIN ( nick -- )
- dup NICK
- "USER " irc-write irc-write
- " hostname servername :irc.factor" irc-print ;
-
-: CONNECT ( server port -- stream )
- <inet> latin1 <client> drop ;
-
-: JOIN ( channel password -- )
- "JOIN " irc-write
- [ " :" swap 3append ] when* irc-print ;
-
-: PART ( channel text -- )
- [ "PART " irc-write irc-write ] dip
- " :" irc-write irc-print ;
-
-: KICK ( channel who -- )
- [ "KICK " irc-write irc-write ] dip
- " " irc-write irc-print ;
-
-: PRIVMSG ( nick line -- )
- [ "PRIVMSG " irc-write irc-write ] dip
- " :" irc-write irc-print ;
-
-: SAY ( nick line -- )
- PRIVMSG ;
-
-: ACTION ( nick line -- )
- [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
-
-: QUIT ( text -- )
- "QUIT :" irc-write irc-print ;
-
-: join-channel ( channel-profile -- )
- [ name>> ] keep password>> JOIN ;
-
-: irc-connect ( irc-client -- )
- [ profile>> [ server>> ] keep port>> CONNECT ] keep
- swap >>stream t >>is-running drop ;
-
-GENERIC: handle-irc ( obj -- )
-
-M: object handle-irc ( obj -- )
- drop ;
-
-M: logged-in handle-irc ( obj -- )
- name>>
- irc-client> [ nick>> swap >>name drop ] keep
- profile>> default-channels>> [ join-channel ] each ;
-
-M: ping handle-irc ( obj -- )
- "PONG " irc-write
- trailing>> irc-print ;
-
-M: nick-in-use handle-irc ( obj -- )
- name>> "_" append NICK ;
-
-: parse-irc-line ( string -- message )
- string>irc-message
- dup command>> {
- { "PING" [ \ ping ] }
- { "NOTICE" [ \ notice ] }
- { "001" [ \ logged-in ] }
- { "433" [ \ nick-in-use ] }
- { "JOIN" [ \ join_ ] }
- { "PART" [ \ part ] }
- { "PRIVMSG" [ \ privmsg ] }
- { "QUIT" [ \ quit ] }
- { "MODE" [ \ mode ] }
- { "KICK" [ \ kick ] }
- [ drop \ unhandled ]
- } case
- [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
-
-! Reader
-: handle-reader-message ( irc-client irc-message -- )
- dup handle-irc swap stream-channel>> to ;
-
-: reader-loop ( irc-client -- )
- dup stream>> stream-readln [
- dup print parse-irc-line handle-reader-message
- ] [
- f >>is-running
- dup stream>> dispose
- irc-end over controller-channel>> to
- stream-channel>> irc-end swap to
- ] if* ;
-
-! Controller commands
-GENERIC: handle-command ( obj -- )
-
-M: object handle-command ( obj -- )
- . ;
-
-TUPLE: send-message to text ;
-C: <send-message> send-message
-M: send-message handle-command ( obj -- )
- dup to>> swap text>> SAY ;
-
-TUPLE: send-action to text ;
-C: <send-action> send-action
-M: send-action handle-command ( obj -- )
- dup to>> swap text>> ACTION ;
-
-TUPLE: send-quit text ;
-C: <send-quit> send-quit
-M: send-quit handle-command ( obj -- )
- text>> QUIT ;
-
-: irc-listen ( irc-client quot -- )
- [ listeners>> ] [ <irc-listener> ] bi* swap push ;
-
-! Controller loop
-: controller-loop ( irc-client -- )
- controller-channel>> from handle-command ;
-
-! Multiplexer
-: multiplex-message ( irc-client message -- )
- swap listeners>> [ channel>> ] map
- [ '[ , , to ] "message" spawn drop ] each-with ;
-
-: multiplexer-loop ( irc-client -- )
- dup stream-channel>> from multiplex-message ;
-
-! process looping and starting
-: (spawn-irc-loop) ( irc-client quot name -- )
- [ over >r curry r> '[ @ , is-running>> ] ] dip
- spawn-server-linked drop ;
-
-: spawn-irc-loop ( irc-client quot name -- )
- '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
- f spawn drop ;
-
-: spawn-irc ( irc-client -- )
- [ [ reader-loop ] "reader-loop" spawn-irc-loop ]
- [ [ controller-loop ] "controller-loop" spawn-irc-loop ]
- [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
- tri ;
-
-: do-irc ( irc-client -- )
- irc-client [
- irc-client>
- [ irc-connect ]
- [ profile>> nickname>> LOGIN ]
- [ spawn-irc ]
- tri
- ] with-variable ;
\ No newline at end of file
+++ /dev/null
-An IRC client framework
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: lcs html.elements kernel qualified ;
+FROM: accessors => item>> ;
+FROM: io => write ;
+FROM: sequences => each empty? ;
+FROM: xml.entities => escape-string ;
+IN: lcs.diff2html
+
+GENERIC: diff-line ( obj -- )
+
+: write-item ( item -- )
+ item>> dup empty? [ drop " " ] [ escape-string ] if write ;
+
+M: retain diff-line
+ <tr>
+ dup [
+ <td "retain" =class td>
+ write-item
+ </td>
+ ] bi@
+ </tr> ;
+
+M: insert diff-line
+ <tr>
+ <td> </td>
+ <td "insert" =class td>
+ write-item
+ </td>
+ </tr> ;
+
+M: delete diff-line
+ <tr>
+ <td "delete" =class td>
+ write-item
+ </td>
+ <td> </td>
+ </tr> ;
+
+: htmlize-diff ( diff -- )
+ <table "comparison" =class table>
+ <tr> <th> "Old" write </th> <th> "New" write </th> </tr>
+ [ diff-line ] each
+ </table> ;
[
init-env
- "#f" [ f ] lisp-define
+ "#f" [ f ] lisp-define
"#t" [ t ] lisp-define
"+" "math" "+" define-primitve
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math bake locals locals.private accessors
-vectors syntax lisp.parser assocs parser sequences.lib words quotations ;
+vectors syntax lisp.parser assocs parser sequences.lib words quotations
+fry ;
IN: lisp
DEFER: convert-form
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( s-exp -- quot )
- [ convert-form ] map [ ] [ compose ] reduce ; inline
+ [ ] [ convert-form compose ] reduce ; inline
: convert-if ( s-exp -- quot )
- rest [ convert-form ] map reverse first3 [ % , , if ] bake ;
-
+ rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
+
: convert-begin ( s-exp -- quot )
- rest [ convert-form ] map >quotation [ , [ funcall ] each ] bake ;
-
+ rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ;
+
: convert-cond ( s-exp -- quot )
- rest [ body>> >array [ convert-form ] map first2 swap `{ [ % funcall ] , } bake ]
- map >array [ , cond ] bake ;
-
+ rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
+ { } map-as '[ , cond ] ;
+
: convert-general-form ( s-exp -- quot )
- unclip convert-form swap convert-body [ , % funcall ] bake ;
+ unclip convert-form swap convert-body swap '[ , @ funcall ] ;
! words for convert-lambda
<PRIVATE
: localize-body ( assoc body -- assoc newbody )
- [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
+ [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
[ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
] map ;
-
+
: localize-lambda ( body vars -- newbody newvars )
- make-locals dup push-locals swap
- [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
+ make-locals dup push-locals swap
+ [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
: split-lambda ( s-exp -- body vars )
- first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
-
+ first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
+
: rest-lambda ( body vars -- quot )
- "&rest" swap [ remove ] [ index ] 2bi
- [ localize-lambda <lambda> ] dip
- [ , cut swap [ % , ] bake , compose ] bake ;
-
+ "&rest" swap [ index ] [ remove ] 2bi
+ localize-lambda <lambda>
+ '[ , cut '[ @ , ] , compose ] ;
+
: normal-lambda ( body vars -- quot )
- localize-lambda <lambda> [ , compose ] bake ;
+ localize-lambda <lambda> '[ , compose ] ;
PRIVATE>
-
+
: convert-lambda ( s-exp -- quot )
- split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ;
-
+ split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
+
: convert-quoted ( s-exp -- quot )
- second [ , ] bake ;
-
+ second 1quotation ;
+
: convert-list-form ( s-exp -- quot )
- dup first dup lisp-symbol?
+ dup first dup lisp-symbol?
[ name>>
{ { "lambda" [ convert-lambda ] }
{ "quote" [ convert-quoted ] }
[ drop convert-general-form ]
} case ]
[ drop convert-general-form ] if ;
-
+
: convert-form ( lisp-form -- quot )
- { { [ dup s-exp? ] [ body>> convert-list-form ] }
- { [ dup lisp-symbol? ] [ [ , lookup-var ] bake ] }
- [ [ , ] bake ]
- } cond ;
-
+ { { [ dup s-exp? ] [ body>> 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-expr parse-result-ast convert-form lambda-rewrite call ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env
ERROR: no-such-var var ;
: init-env ( -- )
- H{ } clone lisp-env set ;
+ H{ } clone lisp-env set ;
: lisp-define ( name quot -- )
- swap lisp-env get set-at ;
-
+ 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 throw ] ?if ;
+
: lookup-var ( lisp-symbol -- quot )
- name>> lisp-get ;
-
+ name>> lisp-get ;
+
: funcall ( quot sym -- * )
- dup lisp-symbol? [ lookup-var ] when call ; inline
-
+ dup lisp-symbol? [ lookup-var ] when call ; inline
+
: define-primitve ( name vocab word -- )
- swap lookup [ [ , ] compose call ] bake lisp-define ;
\ No newline at end of file
+ swap lookup 1quotation '[ , compose call ] lisp-define ;
\ No newline at end of file
[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
+
+:: a-word-with-locals ( a b -- ) ;
+
+: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
+
+[ ] [ new-definition eval ] unit-test
+
+[ t ] [
+ [ \ a-word-with-locals see ] with-string-writer
+ new-definition =
+] unit-test
M: lambda-word definition
"lambda" word-prop body>> ;
+M: lambda-word reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-macro macro lambda-word ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
"lambda" word-prop body>> ;
+M: lambda-macro reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-method method-body lambda-word ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop body>> ;
+M: lambda-method reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-memoized memoized lambda-word ;
M: lambda-memoized definer drop \ MEMO:: \ ; ;
M: lambda-memoized definition
"lambda" word-prop body>> ;
+M: lambda-memoized reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect
IN: macros.tests
USING: tools.test macros math kernel arrays
-vectors ;
+vectors io.streams.string prettyprint parser ;
+MACRO: see-test ( a b -- c ) + ;
+
+[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- c ) + ;\n" ]
+[ [ \ see-test see ] with-string-writer ]
+unit-test
+
+[ t ] [
+ "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
+ [ \ see-test see ] with-string-writer =
+] unit-test
M: macro definition "macro" word-prop ;
+M: macro reset-word
+ [ f "macro" set-word-prop ] [ call-next-method ] bi ;
+
: macro-expand ( ... word -- quot ) "macro" word-prop call ;
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
[ 0.0 ] [ 0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test
+[ t ] [ 10 atan real? ] unit-test
+[ f ] [ 10 atanh real? ] unit-test
+
+[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
+[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
+[ t ] [ 10 asinh sinh 10 1.e-10 ~ ] unit-test
+
[ 100 ] [ 100 100 gcd nip ] unit-test
[ 100 ] [ 1000 100 gcd nip ] unit-test
[ 100 ] [ 100 1000 gcd nip ] unit-test
M: number (^)
swap >polar 3dup ^theta >r ^mag r> polar> ;
+: [-1,1]? ( x -- ? )
+ dup complex? [ drop f ] [ abs 1 <= ] if ; inline
+
+: >=1? ( x -- ? )
+ dup complex? [ drop f ] [ 1 >= ] if ; inline
+
: exp ( x -- y ) >rect swap fexp swap polar> ; inline
: log ( x -- y ) >polar swap flog swap rect> ; inline
: cos ( x -- y )
- >float-rect 2dup
- fcosh swap fcos * -rot
- fsinh swap fsin neg * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcosh swap fcos * -rot
+ fsinh swap fsin neg * rect>
+ ] [ fcos ] if ; foldable
: sec ( x -- y ) cos recip ; inline
: cosh ( x -- y )
- >float-rect 2dup
- fcos swap fcosh * -rot
- fsin swap fsinh * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcos swap fcosh * -rot
+ fsin swap fsinh * rect>
+ ] [ fcosh ] if ; foldable
: sech ( x -- y ) cosh recip ; inline
: sin ( x -- y )
- >float-rect 2dup
- fcosh swap fsin * -rot
- fsinh swap fcos * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcosh swap fsin * -rot
+ fsinh swap fcos * rect>
+ ] [ fsin ] if ; foldable
: cosec ( x -- y ) sin recip ; inline
: sinh ( x -- y )
- >float-rect 2dup
- fcos swap fsinh * -rot
- fsin swap fcosh * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcos swap fsinh * -rot
+ fsin swap fcosh * rect>
+ ] [ fsinh ] if ; foldable
: cosech ( x -- y ) sinh recip ; inline
-: tan ( x -- y ) dup sin swap cos / ; inline
+: tan ( x -- y )
+ dup complex? [ dup sin swap cos / ] [ ftan ] if ; inline
-: tanh ( x -- y ) dup sinh swap cosh / ; inline
+: tanh ( x -- y )
+ dup complex? [ dup sinh swap cosh / ] [ ftanh ] if ; inline
-: cot ( x -- y ) dup cos swap sin / ; inline
+: cot ( x -- y ) tan recip ; inline
-: coth ( x -- y ) dup cosh swap sinh / ; inline
+: coth ( x -- y ) tanh recip ; inline
-: acosh ( x -- y ) dup sq 1- sqrt + log ; inline
+: acosh ( x -- y )
+ dup >=1? [ facosh ] [ dup sq 1- sqrt + log ] if ; inline
: asech ( x -- y ) recip acosh ; inline
-: asinh ( x -- y ) dup sq 1+ sqrt + log ; inline
+: asinh ( x -- y )
+ dup complex? [ dup sq 1+ sqrt + log ] [ fasinh ] if ; inline
: acosech ( x -- y ) recip asinh ; inline
-: atanh ( x -- y ) dup 1+ swap 1- neg / log 2 / ; inline
+: atanh ( x -- y )
+ dup [-1,1]? [ fatanh ] [ dup 1+ swap 1- neg / log 2 / ] if ; inline
: acoth ( x -- y ) recip atanh ; inline
-: [-1,1]? ( x -- ? )
- dup complex? [ drop f ] [ abs 1 <= ] if ; inline
-
: i* ( x -- y ) >rect neg swap rect> ;
: -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y )
- dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
+ dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
: acos ( x -- y )
- dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
+ dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
inline
: atan ( x -- y )
- dup [-1,1]? [ >float fatan ] [ i* atanh i* ] if ; inline
+ dup complex? [ i* atanh i* ] [ fatan ] if ; inline
: asec ( x -- y ) recip acos ; inline
"double" "libm" "atan" { "double" } alien-invoke ;
foldable
+: facosh ( x -- y )
+ "double" "libm" "acosh" { "double" } alien-invoke ;
+ foldable
+
+: fasinh ( x -- y )
+ "double" "libm" "asinh" { "double" } alien-invoke ;
+ foldable
+
+: fatanh ( x -- y )
+ "double" "libm" "atanh" { "double" } alien-invoke ;
+ foldable
+
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
foldable
"double" "libm" "sin" { "double" } alien-invoke ;
foldable
+: ftan ( x -- y )
+ "double" "libm" "tan" { "double" } alien-invoke ;
+ foldable
+
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ;
foldable
"double" "libm" "sinh" { "double" } alien-invoke ;
foldable
+: ftanh ( x -- y )
+ "double" "libm" "tanh" { "double" } alien-invoke ;
+ foldable
+
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ;
foldable
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel memoize tools.test parser ;
+USING: math kernel memoize tools.test parser
+prettyprint io.streams.string sequences ;
IN: memoize.tests
MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail
+
+MEMO: see-test ( a -- b ) reverse ;
+
+[ "USING: memoize sequences ;\nIN: memoize.tests\nMEMO: see-test ( a -- b ) reverse ;\n" ]
+[ [ \ see-test see ] with-string-writer ]
+unit-test
+
+[ ] [ "IN: memoize.tests : fib ;" eval ] unit-test
+
+[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
PREDICATE: memoized < word "memoize" word-prop ;
M: memoized definer drop \ MEMO: \ ; ;
+
M: memoized definition "memo-quot" word-prop ;
+M: memoized reset-word
+ [ { "memoize" "memo-quot" } reset-props ]
+ [ call-next-method ]
+ bi ;
+
: memoize-quot ( quot effect -- memo-quot )
gensym swap dupd "declared-effect" set-word-prop
dup rot define-memoized 1quotation ;
combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
debugger io compiler.units kernel.private effects accessors
-hashtables sorting shuffle math.order ;
+hashtables sorting shuffle math.order sets ;
IN: multi-methods
! PART I: Converting hook specializers
]
[
[ pair? ] filter
- [ keys [ hooks get push-new ] each ] keep
+ [ keys [ hooks get adjoin ] each ] keep
] bi append ;
: canonicalize-specializer-2 ( specializer -- specializer' )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: index ( seq obj -- i ) swap sequences:index ;
+: index-of ( obj seq -- i ) sequences:index ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: 1st 0 at ;
: 2nd 1 at ;
: 3rd 2 at ;
dup sprite-loc gl-translate
GL_TEXTURE_2D over sprite-texture glBindTexture
init-texture
- GL_QUADS [ dup sprite-dim2 four-sides ] do-state
- dup sprite-dim { 1 0 } v*
- swap sprite-loc v- gl-translate
+ GL_QUADS [ sprite-dim2 four-sides ] do-state
GL_TEXTURE_2D 0 glBindTexture ;
: rect-vertices ( lower-left upper-right -- )
"QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
HELP: QUALIFIED-WITH:
-{ $syntax "QUALIFIED-WITH: vocab prefix" }
-{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." }
+{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
+{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
{ $examples { $code
"QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
HELP: FROM:
{ $syntax "FROM: vocab => words ... ;" }
-{ $description "Imports the specified words from vocab." }
+{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." }
{ $examples { $code
"FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
HELP: EXCLUDE:
{ $syntax "EXCLUDE: vocab => words ... ;" }
-{ $description "Imports everything from vocab excluding the specified words" }
+{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
{ $examples { $code
- "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
+ "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ;
HELP: RENAME:
{ $syntax "RENAME: word vocab => newname " }
-{ $description "Imports word from vocab, but renamed to newname." }
+{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
{ $examples { $code
"RENAME: + math => -"
"2 3 - ! => 5" } } ;
C: <entry> entry
+: try-parsing-timestamp ( string -- timestamp )
+ [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
+
: rss1.0-entry ( tag -- entry )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named children>string ] keep
- [ "description" tag-named children>string ] keep
- f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named dup [ children>string rfc822>timestamp ] when
- <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 ] keep
- "link" tag-named children>string
- ] keep
- "item" tags-named [ rss1.0-entry ] map <feed> ;
+ [ "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 ] keep
- [ "link" tag-named ] keep
- [ "guid" tag-named dupd ? children>string ] keep
- [ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string rfc822>timestamp <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 ] keep
- [ "link" tag-named children>string ] keep
- "item" tags-named [ rss2.0-entry ] map <feed> ;
+ [ "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 ] keep
- [ "link" tag-named "href" swap at ] keep
- [
- { "content" "summary" } any-tag-named
- dup tag-children [ string? not ] contains?
- [ tag-children [ write-chunk ] with-string-writer ]
- [ children>string ] if
- ] keep
- { "published" "updated" "issued" "modified" } any-tag-named
- children>string rfc3339>timestamp <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 ] keep
- [ "link" tag-named "href" swap at ] keep
- "entry" tags-named [ atom1.0-entry ] map <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 {
-USING: html kernel semantic-db tangle.html tools.test ;
+USING: kernel semantic-db tangle.html tools.test ;
IN: tangle.html.tests
[ "test" ] [ "test" >html ] unit-test
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors html html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
+USING: accessors html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
IN: tangle.html
TUPLE: element attributes ;
: with-tangle ( tangle quot -- )
[ [ db>> ] [ seq>> ] bi ] dip with-db ;
-: <text-response> ( text -- response )
- "text/plain" <content> swap >>body ;
-
: node-response ( id -- response )
- load-node [ node-content <text-response> ] [ <404> ] if* ;
+ load-node [ node-content <text-content> ] [ <404> ] if* ;
: display-node ( params -- response )
[
: submit-node ( params -- response )
[
"node_content" swap at* [
- create-node id>> number>string <text-response>
+ create-node id>> number>string <text-content>
] [
drop <400>
] if
C: <path-responder> path-responder
M: path-responder call-responder* ( path responder -- response )
- drop path>file [ node-content <text-response> ] [ <404> ] if* ;
-
-: <json-response> ( obj -- response )
- "application/json" <content> swap >json >>body ;
+ drop path>file [ node-content <text-content> ] [ <404> ] if* ;
TUPLE: tangle-dispatcher < dispatcher tangle ;
<path-responder> >>default
"resource:extra/tangle/resources" <static> "resources" add-responder
<node-responder> "node" add-responder
- <action> [ all-node-ids <json-response> ] >>display "all" add-responder ;
+ <action> [ all-node-ids <json-content> ] >>display "all" add-responder ;
M: tangle-dispatcher call-responder* ( path dispatcher -- response )
dup tangle>> [
! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test trees.splay math namespaces assocs
-sequences random ;
+sequences random sets ;
IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- )
100 [ drop 100 random swap at drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
- <splay> [ [ dupd set-at ] curry each ] keep ;
+ <splay> [ [ conjoin ] curry each ] keep ;
[ t ] [
100 make-numeric-splay-tree dup randomize-numeric-splay-tree
{ $description "Renders a character and outputs a pointer to the bitmap." } ;
HELP: <char-sprite>
-{ $values { "font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
+{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
HELP: (draw-string)
USING: alien alien.accessors alien.c-types arrays io kernel libc
math math.vectors namespaces opengl opengl.gl prettyprint assocs
sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.render ui.backend byte-arrays ;
+ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
+locals ;
IN: ui.freetype
] bind ;
M: freetype-renderer free-fonts ( world -- )
- dup world-handle select-gl-context
- world-fonts [ nip second free-sprites ] assoc-each ;
+ [ handle>> select-gl-context ]
+ [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
: ttf-name ( font style -- name )
2array H{
#! We use FT_New_Memory_Face, not FT_New_Face, since
#! FT_New_Face only takes an ASCII path name and causes
#! problems on localized versions of Windows
- freetype -rot 0 f <void*> [
+ [ freetype ] 2dip 0 f <void*> [
FT_New_Memory_Face freetype-error
] keep *void* ;
: font-units>pixels ( n font -- n )
face-size face-size-y-scale FT_MulFix ;
-: init-ascent ( font face -- )
- dup face-y-max swap font-units>pixels swap set-font-ascent ;
+: init-ascent ( font face -- font )
+ dup face-y-max swap font-units>pixels >>ascent ; inline
-: init-descent ( font face -- )
- dup face-y-min swap font-units>pixels swap set-font-descent ;
+: init-descent ( font face -- font )
+ dup face-y-min swap font-units>pixels >>descent ; inline
-: init-font ( font -- )
- dup font-handle 2dup init-ascent dupd init-descent
- dup font-ascent over font-descent - ft-ceil
- swap set-font-height ;
+: init-font ( font -- font )
+ dup handle>> init-ascent
+ dup handle>> init-descent
+ dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
-: <font> ( handle -- font )
- H{ } clone
- { set-font-handle set-font-widths } font construct
- dup init-font ;
+: set-char-size ( handle size -- )
+ 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
-: (open-font) ( font -- open-font )
- first3 >r open-face dup 0 r> 6 shift
- dpi get-global dpi get-global FT_Set_Char_Size
- freetype-error <font> ;
+: <font> ( handle -- font )
+ font new
+ H{ } clone >>widths
+ over first2 open-face >>handle
+ dup handle>> rot third set-char-size
+ init-font ;
M: freetype-renderer open-font ( font -- open-font )
- freetype drop open-fonts get [ (open-font) ] cache ;
+ freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph )
>r font-handle dup r> 0 FT_Load_Char
load-glyph dup
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
-: copy-pixel ( bit tex -- bit tex )
- 255 f pick set-alien-unsigned-1 1+
- f pick alien-unsigned-1
- f pick set-alien-unsigned-1 >r 1+ r> 1+ ;
-
-: (copy-row) ( bit tex bitend texend -- bitend texend )
- >r pick over >= [
- 2nip r>
- ] [
- >r copy-pixel r> r> (copy-row)
- ] if ;
-
-: copy-row ( bit tex width width2 -- bitend texend width width2 )
- [ pick + >r pick + r> (copy-row) ] 2keep ;
-
-: copy-bitmap ( glyph texture -- )
- over glyph-bitmap-rows >r
- over glyph-bitmap-width dup next-power-of-2 2 *
- >r >r >r glyph-bitmap-buffer alien-address r> r> r> r>
- [ copy-row ] times 2drop 2drop ;
+:: copy-pixel ( i j bitmap texture -- i j )
+ 255 j texture set-char-nth
+ i bitmap char-nth j 1 + texture set-char-nth
+ i 1 + j 2 + ; inline
+
+:: (copy-row) ( i j bitmap texture end -- )
+ i end < [
+ i j bitmap texture copy-pixel
+ bitmap texture end (copy-row)
+ ] when ; inline
+
+:: copy-row ( i j bitmap texture width width2 -- i j )
+ i j bitmap texture i width + (copy-row)
+ i width +
+ j width2 + ; inline
+
+:: copy-bitmap ( glyph texture -- )
+ [let* | bitmap [ glyph glyph-bitmap-buffer ]
+ rows [ glyph glyph-bitmap-rows ]
+ width [ glyph glyph-bitmap-width ]
+ width2 [ width next-power-of-2 2 * ] |
+ 0 0
+ rows [ bitmap texture width width2 copy-row ] times
+ 2drop
+ ] ;
: bitmap>texture ( glyph sprite -- id )
tuck sprite-size2 * 2 * [
- alien-address [ copy-bitmap ] keep <alien> gray-texture
+ [ copy-bitmap ] keep gray-texture
] with-malloc ;
: glyph-texture-loc ( glyph font -- loc )
font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
: glyph-texture-size ( glyph -- dim )
- dup glyph-bitmap-width next-power-of-2
- swap glyph-bitmap-rows next-power-of-2 2array ;
+ [ glyph-bitmap-width next-power-of-2 ]
+ [ glyph-bitmap-rows next-power-of-2 ]
+ bi 2array ;
-: <char-sprite> ( font char -- sprite )
+: <char-sprite> ( open-font char -- sprite )
over >r render-glyph dup r> glyph-texture-loc
over glyph-size pick glyph-texture-size <sprite>
[ bitmap>texture ] keep [ init-sprite ] keep ;
-: draw-char ( open-font char sprites -- )
- [ dupd <char-sprite> ] cache nip
- sprite-dlist glCallList ;
+:: char-sprite ( open-font sprites char -- sprite )
+ char sprites [ open-font swap <char-sprite> ] cache ;
+
+: draw-char ( open-font sprites char loc -- )
+ GL_MODELVIEW [
+ 0 0 glTranslated
+ char-sprite sprite-dlist glCallList
+ ] do-matrix ;
+
+: char-widths ( open-font string -- widths )
+ [ char-width ] with { } map-as ;
+
+: scan-sums ( seq -- seq' )
+ 0 [ + ] accumulate nip ;
-: (draw-string) ( open-font sprites string loc -- )
+:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [
- [
- [ >r 2dup r> swap draw-char ] each 2drop
+ loc [
+ string open-font string char-widths scan-sums [
+ [ open-font sprites ] 2dip draw-char
+ ] 2each
] with-translation
] do-enabled ;
-: font-sprites ( open-font world -- pair )
- world-fonts [ open-font H{ } clone 2array ] cache ;
+: font-sprites ( font world -- open-font sprites )
+ world-fonts [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- )
- >r >r world get font-sprites first2 r> r> (draw-string) ;
+ >r >r world get font-sprites r> r> (draw-string) ;
: run-char-widths ( open-font string -- widths )
- [ char-width ] with { } map-as
- dup 0 [ + ] accumulate nip swap 2 v/n v+ ;
+ char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
M: freetype-renderer x>offset ( x open-font string -- n )
dup >r run-char-widths [ <= ] with find drop
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
-concurrency.mailboxes ui.tools.workspace accessors ;
+concurrency.mailboxes ui.tools.workspace accessors sets ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
] with-output-stream* ;
: add-interactor-history ( str interactor -- )
- over empty? [ 2drop ] [ interactor-history push-new ] if ;
+ over empty? [ 2drop ] [ interactor-history adjoin ] if ;
: interactor-continue ( obj interactor -- )
mailbox>> mailbox-put ;
[ execute ] 2with each ;\r
\r
[ f f f f ] [ "hello" "hi" test-equality ] unit-test\r
-[ t f f f ] [ "hello" "h\8ello" test-equality ] unit-test\r
+[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test\r
[ 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
--- /dev/null
+IN: validators.tests
+USING: kernel sequences tools.test validators accessors
+namespaces assocs ;
+
+: with-validation ( quot -- messages )
+ [
+ init-validation
+ call
+ validation-messages get
+ named-validation-messages get >alist append
+ ] with-scope ; inline
+
+[ "" v-one-line ] must-fail
+[ "hello world" ] [ "hello world" v-one-line ] unit-test
+[ "hello\nworld" v-one-line ] must-fail
+
+[ "" v-one-word ] must-fail
+[ "hello" ] [ "hello" v-one-word ] unit-test
+[ "hello world" v-one-word ] must-fail
+
+[ "foo" v-number ] must-fail
+[ 123 ] [ "123" v-number ] unit-test
+[ 123 ] [ "123" v-integer ] unit-test
+
+[ "1.0" v-integer ] [ "must be an integer" = ] must-fail-with
+
+[ "slava@factorcode.org" ] [
+ "slava@factorcode.org" v-email
+] unit-test
+
+[ "slava+foo@factorcode.org" ] [
+ "slava+foo@factorcode.org" v-email
+] unit-test
+
+[ "slava@factorcode.o" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "sla@@factorcode.o" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "slava@factorcodeorg" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "http://www.factorcode.org" ]
+[ "http://www.factorcode.org" v-url ] unit-test
+
+[ "http:/www.factorcode.org" v-url ]
+[ "invalid URL" = ] must-fail-with
+
+[ 4561261212345467 ] [ "4561261212345467" v-credit-card ] unit-test
+
+[ 4561261212345467 ] [ "4561-2612-1234-5467" v-credit-card ] unit-test
+
+[ 0 ] [ "0000000000000000" v-credit-card ] unit-test
+
+[ "000000000" v-credit-card ] must-fail
+
+[ "0000000000000000000000000" v-credit-card ] must-fail
+
+[ "4561_2612_1234_5467" v-credit-card ] must-fail
+
+[ "4561-2621-1234-5467" v-credit-card ] must-fail
+
+
+[ 14 V{ } ] [
+ [
+ "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation
+] unit-test
+
+[ f t ] [
+ [
+ "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation first
+ [ first "age" = ]
+ [ second validation-error? ]
+ [ second value>> "140" = ]
+ tri and and
+] unit-test
+
+TUPLE: person name age ;
+
+person {
+ { "name" [ ] }
+ { "age" [ v-number 13 v-min-value 100 v-max-value ] }
+} define-validators
+
+[ t t ] [
+ [
+ { { "age" "" } } required-values
+ validation-failed?
+ ] with-validation first
+ [ first "age" = ]
+ [ second validation-error? ]
+ [ second message>> "required" = ]
+ tri and and
+] unit-test
+
+[ H{ { "a" 123 } } f V{ } ] [
+ [
+ H{
+ { "a" "123" }
+ { "b" "c" }
+ { "c" "d" }
+ }
+ H{
+ { "a" [ v-integer ] }
+ } validate-values
+ validation-failed?
+ ] with-validation
+] unit-test
+
+[ t "foo" ] [
+ [
+ "foo" validation-error
+ validation-failed?
+ ] with-validation first message>>
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations sequences sequences.lib math
+namespaces sets math.parser math.ranges assocs regexp fry
+unicode.categories arrays hashtables words combinators mirrors
+classes quotations xmode.catalog ;
+IN: validators
+
+: v-default ( str def -- str )
+ over empty? spin ? ;
+
+: v-required ( str -- str )
+ dup empty? [ "required" throw ] when ;
+
+: v-optional ( str quot -- str )
+ over empty? [ 2drop f ] [ call ] if ; inline
+
+: v-min-length ( str n -- str )
+ over length over < [
+ [ "must be at least " % # " characters" % ] "" make
+ throw
+ ] [
+ drop
+ ] if ;
+
+: v-max-length ( str n -- str )
+ over length over > [
+ [ "must be no more than " % # " characters" % ] "" make
+ throw
+ ] [
+ drop
+ ] if ;
+
+: v-number ( str -- n )
+ dup string>number [ ] [ "must be a number" throw ] ?if ;
+
+: v-integer ( str -- n )
+ v-number dup integer? [ "must be an integer" throw ] unless ;
+
+: v-min-value ( x n -- x )
+ 2dup < [
+ [ "must be at least " % # ] "" make throw
+ ] [
+ drop
+ ] if ;
+
+: v-max-value ( x n -- x )
+ 2dup > [
+ [ "must be no more than " % # ] "" make throw
+ ] [
+ drop
+ ] if ;
+
+: v-regexp ( str what regexp -- str )
+ >r over r> matches?
+ [ drop ] [ "invalid " prepend throw ] if ;
+
+: v-email ( str -- str )
+ #! From http://www.regular-expressions.info/email.html
+ 60 v-max-length
+ "e-mail"
+ R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
+ v-regexp ;
+
+: v-url ( str -- str )
+ "URL"
+ R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
+ v-regexp ;
+
+: v-captcha ( str -- str )
+ dup empty? [ "must remain blank" throw ] unless ;
+
+: v-one-line ( str -- str )
+ v-required
+ dup "\r\n" intersect empty?
+ [ "must be a single line" throw ] unless ;
+
+: v-one-word ( str -- str )
+ v-required
+ dup [ alpha? ] all?
+ [ "must be a single word" throw ] unless ;
+
+: v-username ( str -- str )
+ 2 v-min-length 16 v-max-length v-one-word ;
+
+: v-password ( str -- str )
+ 6 v-min-length 40 v-max-length v-one-line ;
+
+: v-mode ( str -- str )
+ dup mode-names member? [
+ "not a valid syntax mode" throw
+ ] unless ;
+
+: luhn? ( n -- ? )
+ string>digits <reversed>
+ [ odd? [ 2 * 10 /mod + ] when ] map-index
+ sum 10 mod 0 = ;
+
+: v-credit-card ( str -- n )
+ "- " diff
+ dup CHAR: 0 CHAR: 9 [a,b] diff empty? [
+ 13 v-min-length
+ 16 v-max-length
+ dup luhn? [ string>number ] [
+ "card number check failed" throw
+ ] if
+ ] [
+ "invalid credit card number format" throw
+ ] if ;
+
+SYMBOL: validation-messages
+SYMBOL: named-validation-messages
+
+: init-validation ( -- )
+ V{ } clone validation-messages set
+ H{ } clone named-validation-messages set ;
+
+: (validation-message) ( obj -- )
+ validation-messages get push ;
+
+: (validation-message-for) ( obj name -- )
+ named-validation-messages get set-at ;
+
+TUPLE: validation-message message ;
+
+C: <validation-message> validation-message
+
+: validation-message ( string -- )
+ <validation-message> (validation-message) ;
+
+: validation-message-for ( string name -- )
+ [ <validation-message> ] dip (validation-message-for) ;
+
+TUPLE: validation-error message value ;
+
+C: <validation-error> validation-error
+
+: validation-error ( message -- )
+ f <validation-error> (validation-message) ;
+
+: validation-error-for ( message value name -- )
+ [ <validation-error> ] dip (validation-message-for) ;
+
+: validation-failed? ( -- ? )
+ validation-messages get [ validation-error? ] contains?
+ named-validation-messages get [ nip validation-error? ] assoc-contains?
+ or ;
+
+: define-validators ( class validators -- )
+ >hashtable "validators" set-word-prop ;
+
+: validate ( value name quot -- result )
+ '[ drop @ ] [ -rot validation-error-for f ] recover ; inline
+
+: required-values ( assoc -- )
+ [ swap [ v-required ] validate drop ] assoc-each ;
+
+: validate-values ( assoc validators -- assoc' )
+ swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;
-USING: math kernel accessors http.server http.server.actions
-http.server.sessions http.server.templating
-http.server.templating.fhtml locals ;
+USING: math kernel accessors html.components
+http.server http.server.actions
+http.server.sessions html.templates.chloe fry ;
IN: webapps.counter
SYMBOL: count
TUPLE: counter-app < dispatcher ;
-M: counter-app init-session*
- drop 0 count sset ;
+M: counter-app init-session* drop 0 count sset ;
-:: <counter-action> ( quot -- action )
- <action> [
- count quot schange
- "" f <standard-redirect>
- ] >>display ;
+: <counter-action> ( quot -- action )
+ <action>
+ swap '[ count , schange "" f <standard-redirect> ] >>submit ;
: counter-template ( -- template )
- "resource:extra/webapps/counter/counter.fhtml" <fhtml> ;
+ "resource:extra/webapps/counter/counter.xml" <chloe> ;
: <display-action> ( -- action )
- <action> [ counter-template serve-template ] >>display ;
+ <page-action>
+ [ count sget "counter" set-value ] >>init
+ counter-template >>template ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
+++ /dev/null
-<% USING: io math.parser http.server.sessions webapps.counter ; %>
-
-<html>
- <body>
- <h1><% count sget number>string write %></h1>
-
- <a href="inc">++</a>
- <a href="dec">--</a>
- </body>
-</html>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+
+ <body>
+ <h1><t:label t:name="counter" /></h1>
+
+ <t:button t:action="$counter-app/inc">++</t:button>
+ <t:button t:action="$counter-app/dec">--</t:button>
+ </body>
+
+</t:chloe>
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs io.files io.sockets
+io.server
namespaces db db.sqlite smtp
http.server
http.server.db
http.server.flows
http.server.sessions
-http.server.auth.admin
http.server.auth.login
http.server.auth.providers.db
http.server.boilerplate
-http.server.templating.chloe
+html.templates.chloe
webapps.pastebin
webapps.planet
-webapps.todo ;
+webapps.todo
+webapps.wiki
+webapps.user-admin ;
IN: webapps.factor-website
: test-db "resource:test.db" sqlite-db ;
init-annotations-table
init-blog-table
+ init-postings-table
init-todo-table
+
+ init-articles-table
+ init-revisions-table
] with-db ;
: <factor-website> ( -- responder )
- <dispatcher>
+ <dispatcher>
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
+ <wiki> "wiki" add-responder
<user-admin> "user-admin" add-responder
<login>
users-in-db >>users
<factor-website> main-responder set-global ;
-: start-factor-website
+: start-factor-website ( -- )
test-db start-expiring-sessions
- "planet" main-responder get responders>> at test-db start-update-task
+ test-db start-update-task
8812 httpd ;
.error { color: #a00; }
+.errors li { color: #a00; }
+
.field-label {
text-align: right;
}
}
.description {
- border: 1px dashed #ccc;
- background-color: #f5f5f5;
padding: 5px;
color: #000;
}
+.description pre {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+}
+
.description p:first-child {
margin-top: 0px;
}
.description p:last-child {
margin-bottom: 0px;
}
+
+.description table, .description td {
+ border-color: #666;
+ border-style: solid;
+}
+
+.description table {
+ border-width: 0 0 1px 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+.description td {
+ margin: 0;
+ padding: 4px;
+ border-width: 1px 1px 0 0;
+}
+
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h2>Annotation: <t:view t:component="summary" /></h2>
-
- <table>
- <tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
- <tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
- </table>
-
- <pre class="description"><t:view t:component="contents" /></pre>
-
- <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New Annotation</t:title>
-
- <t:form t:action="$pastebin/annotate" t:for="id">
-
- <table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
- <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="contents" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:edit t:component="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>
-
- <input type="SUBMIT" value="Done" />
- </t:form>
-
-</t:chloe>
<t:form t:action="$pastebin/new-paste">
<table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
- <tr><th class="field-label big-field-label">Description: </th><td><t:edit t:component="contents" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:edit t:component="captcha" /></td></tr>
+ <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">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>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Pastebin</t:title>
-
- <table width="100%">
- <th align="left" width="50%">Summary:</th>
- <th align="left" width="100">Paste by:</th>
- <th align="left" width="200">Date:</th>
-
- <t:summary t:component="pastes" />
- </table>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <tr>
- <td><t:a t:href="$pastebin/view-paste" t:query="id"><t:view t:component="summary" /></t:a></td>
- <td><t:view t:component="author" /></td>
- <td><t:view t:component="date" /></td>
- </tr>
-
-</t:chloe>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Paste: <t:view t:component="summary" /></t:title>
+ <t:atom t:title="Paste - Atom" t:href="$pastebin/paste.atom" t:query="id" />
+
+ <t:title>Paste: <t:label t:name="summary" /></t:title>
<table>
- <tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
- <tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
+ <tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:label t:name="mode" /></td></tr>
+ <tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:view t:component="contents" /></pre>
+ <pre class="description"><t:code t:name="contents" t:mode="modes" /></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:view t:component="annotations" />
+ <t:each-tuple t:values="annotations">
+
+ <h2>Annotation: <t:label t:name="summary" /></h2>
+
+ <table>
+ <tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:label t:name="mode" /></td></tr>
+ <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="mode"/></pre>
+
+ <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
+
+ </t:each-tuple>
+
+ <t:bind-assoc t:name="new-annotation">
+
+ <h2>New Annotation</h2>
+
+ <t:form t:action="$pastebin/new-annotation" t:for="id">
+
+ <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">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>
+
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+
+ </t:bind-assoc>
+
</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <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="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+
+ </t:if>
+
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
+! Copyright (C) 2007, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
-hashtables sequences.lib locals db.types db.tuples db
-calendar calendar.format rss xml.writer
-xmode.catalog
+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
http.server
-http.server.crud
http.server.actions
-http.server.components
-http.server.components.code
-http.server.templating.chloe
http.server.auth
http.server.auth.login
-http.server.boilerplate
-http.server.validators
-http.server.forms ;
+http.server.boilerplate ;
IN: webapps.pastebin
-: <mode> ( id -- component )
- modes keys natural-sort <choice> ;
+! ! !
+! DOMAIN MODEL
+! ! !
-: pastebin-template ( name -- template )
- "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
+TUPLE: paste id summary author mode date contents annotations ;
-TUPLE: paste id summary author mode date contents annotations captcha ;
-
-paste "PASTE"
+\ paste "PASTE"
{
{ "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
: <paste> ( id -- paste )
- paste new
+ \ paste new
swap >>id ;
: pastes ( -- pastes )
f <paste> select-tuples ;
-TUPLE: annotation aid id summary author mode contents date captcha ;
+TUPLE: annotation aid id summary author mode contents date ;
annotation "ANNOTATION"
{
dup id>> f <annotation> select-tuples >>annotations
] unless ;
-: <annotation-form> ( -- form )
- "annotation" <form>
- "annotation" pastebin-template >>view-template
- "id" <integer>
- hidden >>renderer
- add-field
- "aid" <integer>
- hidden >>renderer
- add-field
- "summary" <string> add-field
- "author" <string> add-field
- "mode" <mode> add-field
- "contents" "mode" <code> add-field
- "date" <date> add-field ;
-
-: <new-annotation-form> ( -- form )
- "annotation" <form>
- "new-annotation" pastebin-template >>edit-template
- "id" <integer>
- hidden >>renderer
- t >>required add-field
- "summary" <string>
- t >>required add-field
- "author" <string>
- t >>required
- add-field
- "mode" <mode>
- "factor" >>default
- t >>required
- add-field
- "contents" "mode" <code>
- t >>required add-field
- "captcha" <captcha> add-field ;
-
-: <paste-form> ( -- form )
- "paste" <form>
- "paste" pastebin-template >>view-template
- "paste-summary" pastebin-template >>summary-template
- "id" <integer>
- hidden >>renderer add-field
- "summary" <string> add-field
- "author" <string> add-field
- "mode" <mode> add-field
- "date" <date> add-field
- "contents" "mode" <code> add-field
- "annotations" <annotation-form> +plain+ <list> add-field ;
-
-: <new-paste-form> ( -- form )
- "paste" <form>
- "new-paste" pastebin-template >>edit-template
- "summary" <string>
- t >>required add-field
- "author" <string>
- t >>required add-field
- "mode" <mode>
- "factor" >>default
- t >>required
- add-field
- "contents" "mode" <code>
- t >>required add-field
- "captcha" <captcha> add-field ;
-
-: <paste-list-form> ( -- form )
- "pastebin" <form>
- "paste-list" pastebin-template >>view-template
- "pastes" <paste-form> +plain+ <list> add-field ;
-
-:: <paste-list-action> ( -- action )
- [let | form [ <paste-list-form> ] |
- <action>
- [
- blank-values
-
- pastes "pastes" set-value
-
- form view-form
- ] >>display
- ] ;
-
-:: <annotate-action> ( form ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
+: paste ( id -- paste )
+ <paste> select-tuple fetch-annotations ;
- [
- "id" get f ctor call
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
- from-tuple form set-defaults
- ] >>init
+! ! !
+! LINKS, ETC
+! ! !
- [ form edit-form ] >>display
+: pastebin-link ( -- url )
+ "$pastebin/list" f link>string ;
- [
- f f ctor call from-tuple
+GENERIC: entity-link ( entity -- url )
- form validate-form
+M: paste entity-link
+ id>> "id" associate "$pastebin/paste" swap link>string ;
- values-tuple insert-tuple
+M: annotation entity-link
+ [ id>> "id" associate "$pastebin/paste" swap link>string ]
+ [ aid>> number>string "#" prepend ] bi
+ append ;
- "id" value next <id-redirect>
- ] >>submit ;
+: pastebin-template ( name -- template )
+ "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
+
+! ! !
+! PASTE LIST
+! ! !
-: pastebin-feed-entries ( -- entries )
- pastes <reversed> 20 short head [
- [ summary>> ]
- [ "$pastebin/view-paste" swap id>> "id" associate link>string ]
- [ date>> ] tri
- f swap <entry>
+: <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
- "http://paste.factorcode.org" >>link
- pastebin-feed-entries >>entries ;
+ pastebin-link >>link
+ pastes pastebin-feed-entries >>entries ;
-: <feed-action> ( -- action )
- <action>
- [
- "text/xml" <content>
- [ pastebin-feed feed>xml write-xml ] >>body
- ] >>display ;
+: <pastebin-feed-action> ( -- action )
+ <feed-action> [ pastebin-feed ] >>feed ;
-:: <view-paste-action> ( form ctor -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
+! ! !
+! PASTES
+! ! !
- [ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init
+: <paste-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value paste from-tuple
+
+ "id" value
+ "new-annotation" [
+ "id" set-value
+ mode-names "modes" set-value
+ "factor" "mode" set-value
+ ] nest-values
+ ] >>init
- [ form view-form ] >>display ;
+ "paste" pastebin-template >>template ;
-:: <delete-paste-action> ( ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>post-params
+: 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 ;
+
+: <paste-feed-action> ( -- action )
+ <feed-action>
+ [ validate-integer-id ] >>init
+ [ "id" value paste annotations>> paste-feed ] >>feed ;
+
+: validate-paste ( -- )
+ {
+ { "summary" [ v-one-line ] }
+ { "author" [ v-one-line ] }
+ { "mode" [ v-mode ] }
+ { "contents" [ v-required ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params ;
+
+: deposit-paste-slots ( tuple -- )
+ now >>date
+ { "summary" "author" "mode" "contents" } deposit-slots ;
+
+: <new-paste-action> ( -- action )
+ <page-action>
[
- "id" get ctor call delete-tuples
+ "factor" "mode" set-value
+ mode-names "modes" set-value
+ ] >>init
- "id" get f <annotation> delete-tuples
+ "new-paste" pastebin-template >>template
+
+ [
+ validate-paste
- next f <permanent-redirect>
+ f <paste>
+ [ deposit-paste-slots ]
+ [ insert-tuple ]
+ [ id>> "$pastebin/paste" <id-redirect> ]
+ tri
] >>submit ;
-:: <delete-annotation-action> ( ctor next -- action )
+: <delete-paste-action> ( -- action )
<action>
- { { "aid" [ v-number ] } } >>post-params
+ [ validate-integer-id ] >>validate
[
- f "aid" get ctor call select-tuple
- [ delete-tuples ] [ id>> next <id-redirect> ] bi
+ "id" value <paste> delete-tuples
+ "id" value f <annotation> delete-tuples
+ "$pastebin/list" f <permanent-redirect>
] >>submit ;
-:: <new-paste-action> ( form ctor next -- action )
- <action>
- [
- f ctor call from-tuple
+! ! !
+! ANNOTATIONS
+! ! !
- form set-defaults
- ] >>init
+: <new-annotation-action> ( -- action )
+ <page-action>
+ [ validate-paste ] >>validate
- [ form edit-form ] >>display
+ [ "id" param "$pastebin/paste" <id-redirect> ] >>display
[
- f ctor call from-tuple
-
- form validate-form
+ f f <annotation>
+ {
+ [ deposit-paste-slots ]
+ [ { "id" } deposit-slots ]
+ [ insert-tuple ]
+ [
+ ! Add anchor here
+ id>> "$pastebin/paste" <id-redirect>
+ ]
+ } cleave
+ ] >>submit ;
- values-tuple insert-tuple
+: <delete-annotation-action> ( -- action )
+ <action>
+ [ { { "aid" [ v-number ] } } validate-params ] >>validate
- "id" value next <id-redirect>
+ [
+ f "aid" value <annotation> select-tuple
+ [ delete-tuples ]
+ [ id>> "$pastebin/paste" <id-redirect> ]
+ bi
] >>submit ;
TUPLE: pastebin < dispatcher ;
: <pastebin> ( -- responder )
pastebin new-dispatcher
- <paste-list-action> "list" add-main-responder
- <feed-action> "feed.xml" add-responder
- <paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
- [ <paste> ] "$pastebin/list" <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
- [ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
- <paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
- <new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
- <new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
+ <pastebin-action> "list" add-main-responder
+ <pastebin-feed-action> "list.atom" add-responder
+ <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
+ <new-annotation-action> "new-annotation" add-responder
+ <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<boilerplate>
- "pastebin" pastebin-template >>template ;
+ "pastebin-common" pastebin-template >>template ;
-: init-pastes-table paste ensure-table ;
+: init-pastes-table \ paste ensure-table ;
: init-annotations-table annotation ensure-table ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Pastebin - Atom" t:href="$pastebin/feed.xml" />
-
- <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:a t:href="$pastebin/feed.xml">Atom Feed</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:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
-
- </t:if>
-
- </div>
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
+ <t:atom t:title="Pastebin - Atom" t:href="$pastebin/list.atom" />
+
+ <t:title>Pastebin</t:title>
+
+ <table width="100%">
+ <th align="left" width="50%">Summary:</th>
+ <th align="left" width="100">Paste by:</th>
+ <th align="left" width="200">Date:</th>
+
+ <t:each-tuple t:values="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>
+ </table>
</t:chloe>
<t:title>Planet Factor Administration</t:title>
- <t:summary t:component="blogroll" />
+ <ul>
+ <t:each-tuple t:values="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>
+ </ul>
<p>
- <t:a t:href="$planet-factor/admin/edit-blog">Add Blog</t:a>
- | <t:a t:href="$planet-factor/admin/update">Update</t:a>
+ <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>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:a t:href="$planet-factor/admin/edit-blog" t:query="id"><t:view t:component="name" /></t:a>
-
-</t:chloe>
<tr>
<th class="field-label">Blog name:</th>
- <td><t:edit t:component="name" /></td>
+ <td><t:field t:name="name" /></td>
</tr>
<tr>
<th class="field-label">Home page:</th>
- <td><t:edit t:component="www-url" /></td>
+ <td><t:field t:name="www-url" /></td>
</tr>
<tr>
<th class="field-label">Feed:</th>
- <td><t:edit t:component="feed-url" /></td>
+ <td><t:field t:name="feed-url" /></td>
</tr>
</table>
</t:form>
<t:button t:action="$planet-factor/admin/delete-blog" 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:each-tuple t:values="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>
+ </p>
+
+ </t:each-tuple>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Blog</t:title>
+
+ <t:form t:action="$planet-factor/admin/new-blog">
+
+ <table>
+
+ <tr>
+ <th class="field-label">Blog name:</th>
+ <td><t:field t:name="name" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Home page:</th>
+ <td><t:field t:name="www-url" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Feed:</th>
+ <td><t:field t:name="feed-url" /></td>
+ </tr>
+
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style t:include="resource:extra/webapps/planet/planet.css" />
+
+ <div class="navbar">
+ <t:a t:href="$planet-factor/list">Front Page</t:a>
+ | <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:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ </t:if>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences sorting locals math math.order
+USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
-sequences.lib db.types db.tuples db fry
+sequences.lib db.types db.tuples db fry locals hashtables
+html.components html.templates.chloe
rss xml.writer
+validators
http.server
-http.server.crud
-http.server.forms
http.server.actions
http.server.boilerplate
-http.server.templating.chloe
-http.server.components
http.server.auth.login
http.server.auth ;
IN: webapps.planet
-TUPLE: planet-factor < dispatcher postings ;
-
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
} define-persistent
+! TUPLE: posting < entry id ;
+TUPLE: posting id title link description pub-date ;
+
+posting "POSTINGS"
+{
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ }
+ { "link" "LINK" { VARCHAR 256 } +not-null+ }
+ { "description" "DESCRIPTION" TEXT +not-null+ }
+ { "pub-date" "DATE" TIMESTAMP +not-null+ }
+} define-persistent
+
: init-blog-table blog ensure-table ;
+: init-postings-table posting ensure-table ;
+
: <blog> ( id -- todo )
blog new
swap >>id ;
: blogroll ( -- seq )
- f <blog> select-tuples [ [ name>> ] compare ] sort ;
-
-: <entry-form> ( -- form )
- "entry" <form>
- "entry" planet-template >>view-template
- "entry-summary" planet-template >>summary-template
- "title" <string> add-field
- "description" <html-text> add-field
- "pub-date" <date> add-field ;
-
-: <blog-form> ( -- form )
- "blog" <form>
- "edit-blog" planet-template >>edit-template
- "blog-admin-link" planet-template >>summary-template
- "id" <integer>
- hidden >>renderer
- add-field
- "name" <string>
- t >>required
- add-field
- "www-url" <url>
- t >>required
- add-field
- "feed-url" <url>
- t >>required
- add-field ;
-
-: <planet-factor-form> ( -- form )
- "planet-factor" <form>
- "postings" planet-template >>view-template
- "postings-summary" planet-template >>summary-template
- "postings" <entry-form> +plain+ <list> add-field
- "blogroll" "blog" <link> +unordered+ <list> add-field ;
-
-: <admin-form> ( -- form )
- "admin" <form>
- "admin" planet-template >>view-template
- "blogroll" <blog-form> +unordered+ <list> add-field ;
-
-:: <edit-blogroll-action> ( planet -- action )
- [let | form [ <admin-form> ] |
- <action>
- [
- blank-values
-
- blogroll "blogroll" set-value
-
- form view-form
- ] >>display
- ] ;
-
-:: <planet-action> ( planet -- action )
- [let | form [ <planet-factor-form> ] |
- <action>
- [
- blank-values
-
- planet postings>> "postings" set-value
- blogroll "blogroll" set-value
-
- form view-form
- ] >>display
- ] ;
-
-:: planet-feed ( planet -- feed )
+ f <blog> select-tuples
+ [ [ name>> ] compare ] sort ;
+
+: postings ( -- seq )
+ posting new select-tuples
+ [ [ pub-date>> ] compare invert-comparison ] sort ;
+
+: <edit-blogroll-action> ( -- action )
+ <page-action>
+ [ blogroll "blogroll" set-value ] >>init
+ "admin" planet-template >>template ;
+
+: <planet-action> ( -- action )
+ <page-action>
+ [
+ blogroll "blogroll" set-value
+ postings "postings" set-value
+ ] >>init
+
+ "planet" planet-template >>template ;
+
+: planet-feed ( -- feed )
feed new
"Planet Factor" >>title
"http://planet.factorcode.org" >>link
- planet postings>> 16 short head >>entries ;
+ postings >>entries ;
-:: <feed-action> ( planet -- action )
- <action>
- [
- "text/xml" <content>
- [ planet planet-feed feed>xml write-xml ] >>body
- ] >>display ;
+: <planet-feed-action> ( -- action )
+ <feed-action> [ planet-feed ] >>feed ;
-: <posting> ( name entry -- entry' )
- clone [ ": " swap 3append ] change-title ;
+:: <posting> ( entry name -- entry' )
+ posting new
+ name ": " entry title>> 3append >>title
+ entry link>> >>link
+ entry description>> >>description
+ entry pub-date>> >>pub-date ;
: fetch-feed ( url -- feed )
download-feed entries>> ;
\ fetch-feed DEBUG add-error-logging
: fetch-blogroll ( blogroll -- entries )
- dup
- [ feed-url>> fetch-feed ] parallel-map
- [ >r name>> r> [ <posting> ] with map ] 2map concat ;
+ [ [ feed-url>> fetch-feed ] parallel-map ] [ [ name>> ] map ] bi
+ [ '[ , <posting> ] map ] 2map concat ;
: sort-entries ( entries -- entries' )
- [ [ pub-date>> ] compare ] sort <reversed> ;
+ [ [ pub-date>> ] compare invert-comparison ] sort ;
+
+: update-cached-postings ( -- )
+ blogroll fetch-blogroll sort-entries 8 short head [
+ posting new delete-tuples
+ [ insert-tuple ] each
+ ] with-transaction ;
-: update-cached-postings ( planet -- )
- "webapps.planet" [
- blogroll fetch-blogroll sort-entries 8 short head
- >>postings drop
- ] with-logging ;
+: <update-action> ( -- action )
+ <action>
+ [
+ update-cached-postings
+ "" f <permanent-redirect>
+ ] >>submit ;
-:: <update-action> ( planet -- action )
+: <delete-blog-action> ( -- action )
<action>
+ [ validate-integer-id ] >>validate
+
[
- planet update-cached-postings
- "" f <temporary-redirect>
- ] >>display ;
+ "id" value <blog> delete-tuples
+ "$planet-factor/admin" f <standard-redirect>
+ ] >>submit ;
+
+: validate-blog ( -- )
+ {
+ { "name" [ v-one-line ] }
+ { "www-url" [ v-url ] }
+ { "feed-url" [ v-url ] }
+ } validate-params ;
-:: <planet-factor-admin> ( planet-factor -- responder )
- [let | blog-form [ <blog-form> ]
- blog-ctor [ [ <blog> ] ] |
- <dispatcher>
- planet-factor <edit-blogroll-action> >>default
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
- planet-factor <update-action> "update" add-responder
+: deposit-blog-slots ( blog -- )
+ { "name" "www-url" "feed-url" } deposit-slots ;
- ! Administrative CRUD
- blog-ctor "$planet-factor/admin" <delete-action> "delete-blog" add-responder
- blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder
- ] ;
+: <new-blog-action> ( -- action )
+ <page-action>
+ "new-blog" planet-template >>template
+
+ [ validate-blog ] >>validate
+
+ [
+ f <blog>
+ [ deposit-blog-slots ]
+ [ insert-tuple ]
+ [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ]
+ tri
+ ] >>submit ;
+
+: <edit-blog-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <blog> select-tuple from-tuple
+ ] >>init
+
+ "edit-blog" planet-template >>template
+
+ [
+ validate-integer-id
+ validate-blog
+ ] >>validate
+
+ [
+ f <blog>
+ [ deposit-blog-slots ]
+ [ update-tuple ]
+ [ id>> "$planet-factor/admin" <id-redirect> ]
+ tri
+ ] >>submit ;
+
+TUPLE: planet-factor-admin < dispatcher ;
+
+: <planet-factor-admin> ( -- responder )
+ planet-factor-admin new-dispatcher
+ <edit-blogroll-action> "blogroll" add-main-responder
+ <update-action> "update" add-responder
+ <new-blog-action> "new-blog" add-responder
+ <edit-blog-action> "edit-blog" add-responder
+ <delete-blog-action> "delete-blog" add-responder ;
SYMBOL: can-administer-planet-factor?
can-administer-planet-factor? define-capability
+TUPLE: planet-factor < dispatcher ;
+
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
-
dup <planet-action> "list" add-main-responder
- dup <feed-action> "feed.xml" add-responder
-
dup <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
+ <planet-action> "list" add-main-responder
+ <feed-action> "feed.xml" add-responder
+ <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate>
- "planet" planet-template >>template ;
+ "planet-common" planet-template >>template ;
-: start-update-task ( planet db seq -- )
- '[
- , , , [
- dup filter-responder? [ responder>> ] when
- update-cached-postings
- ] with-db
- ] 10 minutes every drop ;
+: start-update-task ( db params -- )
+ '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:style t:include="resource:extra/webapps/planet/planet.css" />
+ <t:title>Planet Factor</t:title>
- <div class="navbar">
- <t:a t:href="$planet-factor/list">Front Page</t:a>
- | <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
- | <t:a t:href="$planet-factor/admin">Admin</t:a>
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td>
- <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:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
- </t:if>
- </div>
+ <t:each-tuple t:values="postings">
- <h1><t:write-title /></h1>
+ <h2 class="posting-title">
+ <t:a t:value="link" t:session="none"><t:label t:name="title" /></t:a>
+ </h2>
- <t:call-next-template />
+ <p class="posting-body">
+ <t:html t:name="description" />
+ </p>
+
+ <p class="posting-date">
+ <t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
+ </p>
+
+ </t:each-tuple>
+
+ </td>
+
+ <td valign="top" width="25%" class="infobox">
+
+ <h2>Blogroll</h2>
+
+ <ul>
+ <t:each t:values="blogroll">
+ <li>
+ <t:link t:name="value"/>
+ </li>
+ </t:each>
+ </ul>
+
+ </td>
+ </tr>
+ </table>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:summary t:component="postings" />
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Planet Factor</t:title>
-
- <table width="100%" cellpadding="10">
- <tr>
- <td> <t:view t:component="postings" /> </td>
-
- <td valign="top" width="25%" class="infobox">
- <h2>Blogroll</h2>
-
- <t:summary t:component="blogroll" />
- </td>
- </tr>
- </table>
-
-</t:chloe>
<t:form t:action="$todo-list/edit" t:for="id">
<table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Priority: </th><td><t:edit t:component="priority" /></td></tr>
- <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="description" /></td></tr>
+ <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:title>My Todo List</t:title>
<table class="todo-list">
- <tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
- <t:summary t:component="list" />
+
+ <tr>
+ <th>Summary</th>
+ <th>Priority</th>
+ <th>View</th>
+ <th>Edit</th>
+ </tr>
+
+ <t:each-tuple t:values="items">
+
+ <tr>
+ <td>
+ <t:label t:name="summary" />
+ </td>
+ <td>
+ <t:label t:name="priority" />
+ </td>
+ <td>
+ <t:a t:href="$todo-list/view" t:query="id">View</t:a>
+ </td>
+ <td>
+ <t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
+ </td>
+ </tr>
+
+ </t:each-tuple>
+
</table>
</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <tr>
- <td>
- <t:view t:component="summary" />
- </td>
- <td>
- <t:view t:component="priority" />
- </td>
- <td>
- <t:a t:href="$todo-list/view" t:query="id">View</t:a>
- </td>
- <td>
- <t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
- </td>
- </tr>
-
-</t:chloe>
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals sequences namespaces
-db db.types db.tuples
+USING: accessors kernel sequences namespaces
+db db.types db.tuples validators hashtables
+html.components
+html.templates.chloe
http.server.sessions
-http.server.components
-http.server.components.farkup
-http.server.forms
-http.server.templating.chloe
http.server.boilerplate
-http.server.crud
http.server.auth
http.server.actions
http.server.db
: todo-template ( name -- template )
"resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
-: <todo-form> ( -- form )
- "todo" <form>
- "view-todo" todo-template >>view-template
- "edit-todo" todo-template >>edit-template
- "todo-summary" todo-template >>summary-template
- "id" <integer>
- hidden >>renderer
- add-field
- "summary" <string>
- t >>required
- add-field
- "priority" <integer>
- t >>required
- 0 >>default
- 0 >>min-value
- 10 >>max-value
- add-field
- "description" <farkup>
- add-field ;
-
-: <todo-list-form> ( -- form )
- "todo-list" <form>
- "todo-list" todo-template >>view-template
- "list" <todo-form> +plain+ <list>
- add-field ;
+: <view-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <todo> select-tuple from-tuple
+ ] >>init
+
+ "view-todo" todo-template >>template ;
+
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
+
+: validate-todo ( -- )
+ {
+ { "summary" [ v-one-line ] }
+ { "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
+ { "description" [ v-required ] }
+ } validate-params ;
+
+: <new-action> ( -- action )
+ <page-action>
+ [ 0 "priority" set-value ] >>init
+
+ "edit-todo" todo-template >>template
+
+ [ validate-todo ] >>validate
+
+ [
+ f <todo>
+ dup { "summary" "description" } deposit-slots
+ [ insert-tuple ]
+ [ id>> "$todo-list/view" <id-redirect> ]
+ bi
+ ] >>submit ;
+
+: <edit-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <todo> select-tuple from-tuple
+ ] >>init
+
+ "edit-todo" todo-template >>template
+
+ [
+ validate-integer-id
+ validate-todo
+ ] >>validate
+
+ [
+ f <todo>
+ dup { "id" "summary" "priority" "description" } deposit-slots
+ [ update-tuple ]
+ [ id>> "$todo-list/view" <id-redirect> ]
+ bi
+ ] >>submit ;
+
+: <delete-action> ( -- action )
+ <action>
+ [ validate-integer-id ] >>validate
+
+ [
+ "id" get <todo> delete-tuples
+ "$todo-list/list" f <standard-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> ( -- responder )
- [let | todo-form [ <todo-form> ]
- list-form [ <todo-list-form> ]
- ctor [ [ <todo> ] ] |
- todo-list new-dispatcher
- list-form ctor <list-action> "list" add-main-responder
- todo-form ctor <view-action> "view" add-responder
- todo-form ctor "$todo-list/view" <edit-action> "edit" add-responder
- ctor "$todo-list/list" <delete-action> "delete" add-responder
- <boilerplate>
- "todo" todo-template >>template
- f <protected>
- ] ;
+: <todo-list> ( -- responder )
+ todo-list new-dispatcher
+ <list-action> "list" add-main-responder
+ <view-action> "view" add-responder
+ <new-action> "new" add-responder
+ <edit-action> "edit" add-responder
+ <delete-action> "delete" add-responder
+ <boilerplate>
+ "todo" todo-template >>template
+ f <protected> ;
| <t:a t:href="$login/edit-profile" t:flow="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:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
<t:title>View Item</t:title>
<table>
- <tr><th class="field-label">Summary: </th><td><t:view t:component="summary" /></td></tr>
- <tr><th class="field-label">Priority: </th><td><t:view t:component="priority" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:label t:name="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:label t:name="priority" /></td></tr>
</table>
<div class="description">
- <t:view t:component="description" />
+ <t:farkup t:name="description" />
</div>
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit User</t:title>
+
+ <t:form t:action="$user-admin/edit" t:for="username">
+
+ <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>
+ <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>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </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>
+ </tr>
+
+ <tr>
+ <th class="field-label">Profile:</th>
+ <td><t:inspector t:name="profile" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+ <button type="submit" class="link-button link">Update</button>
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+
+ <t:button t:action="$user-admin/delete" t:for="username" 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 User</t:title>
+
+ <t:form t:action="$user-admin/new">
+
+ <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>
+ <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>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </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>
+ </tr>
+
+ </table>
+
+ <p>
+ <button type="submit" class="link-button link">Create</button>
+ <t:validation-messages />
+ </p>
+
+ </t:form>
+</t:chloe>
--- /dev/null
+! 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
+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 ;
+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 ;
+
+: <user-list-action> ( -- action )
+ <page-action>
+ [ f <user> select-tuples "users" set-value ] >>init
+ "user-list" admin-template >>template ;
+
+: <new-user-action> ( -- action )
+ <page-action>
+ [
+ "username" param <user> from-tuple
+ capabilities get words>strings "all-capabilities" set-value
+ ] >>init
+
+ "new-user" admin-template >>template
+
+ [
+ capabilities get words>strings "all-capabilities" set-value
+
+ {
+ { "username" [ v-username ] }
+ { "realname" [ v-one-line ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "capabilities" [ ] }
+ } validate-params
+
+ same-password-twice
+
+ user new "username" value >>username select-tuple
+ [ user-exists ] when
+ ] >>validate
+
+ [
+ "username" value <user>
+ "realname" value >>realname
+ "email" value >>email
+ "new-password" value >>encoded-password
+ H{ } clone >>profile
+
+ insert-tuple
+
+ "$user-admin" f <standard-redirect>
+ ] >>submit ;
+
+: validate-username ( -- )
+ { { "username" [ v-username ] } } validate-params ;
+
+: <edit-user-action> ( -- action )
+ <page-action>
+ [
+ validate-username
+
+ "username" value <user> select-tuple
+ [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi
+
+ capabilities get words>strings "all-capabilities" set-value
+ ] >>init
+
+ "edit-user" admin-template >>template
+
+ [
+ capabilities get words>strings "all-capabilities" set-value
+
+ {
+ { "username" [ v-username ] }
+ { "realname" [ v-one-line ] }
+ { "new-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "capabilities" [ ] }
+ } validate-params
+
+ "new-password" "verify-password"
+ [ value empty? not ] either? [
+ same-password-twice
+ ] when
+ ] >>validate
+
+ [
+ "username" value <user> select-tuple
+ "realname" value >>realname
+ "email" value >>email
+
+ "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>
+ ] >>submit ;
+
+: <delete-user-action> ( -- action )
+ <action>
+ [
+ validate-username
+
+ [ <user> select-tuple 1 >>deleted update-tuple ]
+ [ logout-all-sessions ]
+ bi
+
+ "$user-admin" f <standard-redirect>
+ ] >>submit ;
+
+TUPLE: user-admin < dispatcher ;
+
+SYMBOL: can-administer-users?
+
+can-administer-users? define-capability
+
+: <user-admin> ( -- responder )
+ user-admin new-dispatcher
+ <user-list-action> "list" add-main-responder
+ <new-user-action> "new" add-responder
+ <edit-user-action> "edit" add-responder
+ <delete-user-action> "delete" add-responder
+ <boilerplate>
+ "user-admin" admin-template >>template
+ { can-administer-users? } <protected> ;
+
+: make-admin ( username -- )
+ <user>
+ select-tuple
+ [ can-administer-users? suffix ] change-capabilities
+ update-tuple ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <div class="navbar">
+ <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:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ </div>
+
+ <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>Users</t:title>
+
+ <ul>
+
+ <t:each-tuple t:values="users">
+ <li>
+ <t:a t:href="$user-admin/edit" t:query="username">
+ <t:label t:name="username" />
+ </t:a>
+ </li>
+ </t:each-tuple>
+
+ </ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>All Articles</t:title>
+
+ <ul>
+ <t:each-tuple t:values="articles">
+ <li>
+ <t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recent Changes</t:title>
+
+ <ul>
+ <t:each-tuple t:values="changes">
+ <li>
+ <t:a t:href="title" 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>
+ </ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<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>
+
+ <table>
+ <tr>
+ <th class="field-label">Old revision:</th>
+ <t:bind-tuple 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>
+ </tr>
+ <tr>
+ <th class="field-label">New revision:</th>
+ <t:bind-tuple 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>
+ </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>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit: <t:label t:name="title" /></t:title>
+
+ <t:form t:action="$wiki/edit" t:for="title">
+
+ <p>
+ <t:textarea t:name="content" t:rows="30" t:cols="80" />
+ </p>
+
+ <p>
+ <input type="submit" value="Save" />
+ </p>
+
+ </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: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>
+
+ <h2>View Differences</h2>
+
+ <form action="diff" method="get">
+ <table>
+ <tr>
+ <th class="field-label">Old revision:</th>
+
+ <td>
+ <select name="old-id">
+ <t:each-tuple t:values="revisions">
+ <option> <t:label t:name="id" /> </option>
+ </t:each-tuple>
+ </select>
+ </td>
+ </tr>
+ <tr>
+ <th class="field-label">New revision:</th>
+
+ <td>
+ <select name="new-id">
+ <t:each-tuple t:values="revisions">
+ <option> <t:label t:name="id" /> </option>
+ </t:each-tuple>
+ </select>
+ </td>
+ </tr>
+ </table>
+
+ <input type="submit" value="View" />
+ </form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edits by <t:label t:name="author" /></t:title>
+
+ <ul>
+ <t:each-tuple t:values="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>
+ </ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title><t:label t:name="title" /></t:title>
+
+ <div class="description">
+ <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>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style t:include="resource:extra/webapps/wiki/wiki.css" />
+
+ <div class="navbar">
+
+ <t:a t:href="$wiki">Front Page</t:a>
+ | <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="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+
+ </t:if>
+
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+.comparison table, {
+ border-color: #666;
+ border-style: solid;
+}
+
+.comparison th {
+ border-width: 1px;
+ border-color: #666;
+ border-style: solid;
+}
+
+.comparison table {
+ border-width: 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+
+.insert {
+ background-color: #9f9;
+}
+
+.delete {
+ background-color: #f99;
+}
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! 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
+http.server
+http.server.actions
+http.server.auth
+http.server.auth.login
+http.server.boilerplate
+validators
+db.types db.tuples lcs farkup ;
+IN: webapps.wiki
+
+TUPLE: article title revision ;
+
+article "ARTICLES" {
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
+ ! { "AUTHOR" INTEGER +not-null+ } ! uid
+ ! { "PROTECTED" BOOLEAN +not-null+ }
+ { "revision" "REVISION" INTEGER +not-null+ } ! revision id
+} define-persistent
+
+: <article> ( title -- article ) article new swap >>title ;
+
+: init-articles-table article ensure-table ;
+
+TUPLE: revision id title author date content ;
+
+revision "REVISIONS" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ } ! article id
+ { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
+ { "date" "DATE" TIMESTAMP +not-null+ }
+ { "content" "CONTENT" TEXT +not-null+ }
+} define-persistent
+
+: <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 ;
+
+: <main-article-action> ( -- action )
+ <action>
+ [ "Front Page" "$wiki/view" <title-redirect> ] >>display ;
+
+: <view-article-action> ( -- action )
+ <action>
+ "title" >>rest-param
+
+ [
+ validate-title
+ "view?title=" relative-link-prefix set
+ ] >>init
+
+ [
+ "title" value dup <article> select-tuple [
+ revision>> <revision> select-tuple from-tuple
+ "view" wiki-template <html-content>
+ ] [
+ "$wiki/edit" <title-redirect>
+ ] ?if
+ ] >>display ;
+
+: <view-revision-action> ( -- action )
+ <page-action>
+ [
+ { { "id" [ v-integer ] } } validate-params
+ "id" value <revision>
+ select-tuple from-tuple
+ ] >>init
+
+ "view" wiki-template >>template ;
+
+: add-revision ( revision -- )
+ [ insert-tuple ]
+ [
+ dup title>> <article> select-tuple [
+ swap id>> >>revision update-tuple
+ ] [
+ [ title>> ] [ id>> ] bi article boa insert-tuple
+ ] if*
+ ] bi ;
+
+: <edit-article-action> ( -- action )
+ <page-action>
+ [
+ validate-title
+ "title" value <article> select-tuple [
+ revision>> <revision> select-tuple from-tuple
+ ] when*
+ ] >>init
+
+ "edit" wiki-template >>template
+
+ [
+ validate-title
+ { { "content" [ v-required ] } } validate-params
+
+ f <revision>
+ "title" value >>title
+ now >>date
+ logged-in-user get username>> >>author
+ "content" value >>content
+ [ add-revision ]
+ [ title>> "$wiki/view" <title-redirect> ] bi
+ ] >>submit ;
+
+: <list-revisions-action> ( -- action )
+ <page-action>
+ [
+ validate-title
+ f <revision> "title" value >>title select-tuples
+ [ [ date>> ] compare invert-comparison ] sort
+ "revisions" set-value
+ ] >>init
+
+ "revisions" wiki-template >>template ;
+
+: <list-changes-action> ( -- action )
+ <page-action>
+ [
+ f <revision> select-tuples
+ [ [ date>> ] compare invert-comparison ] sort
+ "changes" set-value
+ ] >>init
+
+ "changes" wiki-template >>template ;
+
+: <delete-action> ( -- action )
+ <action>
+ [ validate-title ] >>validate
+
+ [
+ "title" value <article> delete-tuples
+ f <revision> "title" value >>title delete-tuples
+ "" f <standard-redirect>
+ ] >>submit ;
+
+: <diff-action> ( -- action )
+ <page-action>
+ [
+ {
+ { "old-id" [ v-integer ] }
+ { "new-id" [ v-integer ] }
+ } validate-params
+
+ "old-id" "new-id"
+ [ value <revision> select-tuple ] bi@
+ [ [ "old" set-value ] [ "new" set-value ] bi* ]
+ [ [ content>> string-lines ] bi@ diff "diff" set-value ]
+ 2bi
+ ] >>init
+
+ "diff" wiki-template >>template ;
+
+: <list-articles-action> ( -- action )
+ <page-action>
+ [
+ f <article> select-tuples
+ [ [ title>> ] compare ] sort
+ "articles" set-value
+ ] >>init
+
+ "articles" wiki-template >>template ;
+
+: <user-edits-action> ( -- action )
+ <page-action>
+ [
+ { { "author" [ v-username ] } } validate-params
+ f <revision> "author" value >>author
+ select-tuples "user-edits" set-value
+ ] >>init
+
+ "user-edits" wiki-template >>template ;
+
+TUPLE: wiki < dispatcher ;
+
+: <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
+ <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
+ <boilerplate>
+ "wiki-common" wiki-template >>template ;
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 ;
+words globs combinators io.encodings.utf8 sorting ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
swap child-tags [ parse-mode-tag ] with each
] keep ;
-: load-catalog ( -- modes )
+MEMO: modes ( -- modes )
"resource:extra/xmode/modes/catalog"
file>xml parse-modes-tag ;
-: modes ( -- assoc )
- \ modes get-global [
- load-catalog dup \ modes set-global
- ] unless* ;
+MEMO: mode-names ( -- modes )
+ modes keys natural-sort ;
: reset-catalog ( -- )
- f \ modes set-global ;
+ \ modes reset-memoized ;
MEMO: (load-mode) ( name -- rule-sets )
modes at [
-USING: xmode.tokens xmode.marker xmode.catalog kernel html
+USING: xmode.tokens xmode.marker xmode.catalog kernel
html.elements io io.files sequences words io.encodings.utf8
-namespaces ;
+namespaces xml.entities ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- )
[
dup token-str swap token-id [
- <span word-name =class span> write </span>
+ <span word-name =class span> escape-string write </span>
] [
write
] if*
: default-stylesheet ( -- )
<style>
"resource:extra/xmode/code2html/stylesheet.css"
- utf8 file-contents write
+ utf8 file-contents escape-string write
</style> ;
: htmlize-stream ( path stream -- )
<html>
<head>
default-stylesheet
- <title> dup write </title>
+ <title> dup escape-string write </title>
</head>
<body>
<pre>
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: io.files io.encodings.utf8 namespaces http.server\r
-http.server.static http xmode.code2html kernel html sequences\r
+USING: io io.files io.encodings.utf8 namespaces http.server\r
+http.server.static http xmode.code2html kernel sequences\r
accessors fry ;\r
IN: xmode.code2html.responder\r
\r
: <sources> ( root -- responder )\r
[\r
drop\r
- "text/html" <content> swap\r
- [ "last-modified" set-header ]\r
- [\r
- '[\r
- ,\r
- dup file-name swap utf8\r
- <file-reader>\r
- [ htmlize-stream ] with-html-stream\r
- ] >>body\r
- ] bi\r
+ dup '[\r
+ , utf8 [\r
+ , file-name input-stream get htmlize-stream\r
+ ] with-file-reader\r
+ ] <html-content>\r
] <file-responder> ;\r
/* Used during compaction */
struct _F_BLOCK *forwarding;
-
- /* Alignment padding */
- CELL padding[4];
} F_BLOCK;
typedef struct {
projects / factor.git / commitdiff