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

core/alien/strings/strings-docs.factor

@@ -3,14 +3,14 @@ debugger ;
 IN: alien.strings
 
 HELP: string>alien
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } }
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
 { $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
 { $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
 
 { string>alien alien>string malloc-string } related-words
 
 HELP: alien>string
-{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string" string } }
+{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
 { $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
 
 HELP: malloc-string

core/alien/strings/strings.factor

@@ -6,7 +6,7 @@ io.streams.byte-array io.streams.memory io.encodings.utf8
 io.encodings.utf16 system alien strings cpu.architecture ;
 IN: alien.strings
 
-GENERIC# alien>string 1 ( alien encoding -- string/f )
+GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
 
 M: c-ptr alien>string
     >r <memory-stream> r> <decoder>

core/combinators/combinators.factor

@@ -150,7 +150,7 @@ M: hashtable hashcode*
         drop
     ] [
         dup length 4 <=
-        over keys [ word? ] contains? or
+        over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
         [
             linear-case-quot
         ] [

core/debugger/debugger.factor

@@ -6,7 +6,7 @@ strings io.styles vectors words system splitting math.parser
 classes.tuple continuations continuations.private combinators
 generic.math io.streams.duplex classes.builtin classes
 compiler.units generic.standard vocabs threads threads.private
-init kernel.private libc io.encodings accessors ;
+init kernel.private libc io.encodings mirrors accessors ;
 IN: debugger
 
 GENERIC: error. ( error -- )
@@ -289,6 +289,12 @@ M: encode-error summary drop "Character encoding error" ;
 
 M: decode-error summary drop "Character decoding error" ;
 
+M: no-such-slot summary drop "No such slot" ;
+
+M: immutable-slot summary drop "Slot is immutable" ;
+
+M: bad-create summary drop "Bad parameters to create" ;
+
 <PRIVATE
 
 : init-debugger ( -- )

core/mirrors/mirrors-docs.factor

@@ -37,10 +37,6 @@ HELP: <mirror>
     }
 } ;
 
-HELP: >mirror<
-{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
-
 HELP: make-mirror
 { $values { "obj" object } { "assoc" assoc } }
 { $description "Creates an assoc which reflects the internal structure of the object." } ;

core/mirrors/mirrors-tests.factor

@@ -1,4 +1,4 @@
-USING: mirrors tools.test assocs kernel arrays ;
+USING: mirrors tools.test assocs kernel arrays accessors ;
 IN: mirrors.tests
 
 TUPLE: foo bar baz ;
@@ -14,3 +14,15 @@ C: <foo> foo
 [ 3 ] [
     3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
 ] unit-test
+
+[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
+    [ no-such-slot? ]
+    [ name>> "hi" = ]
+    [ object>> foo? ] tri and and
+] must-fail-with
+
+[ 3 "numerator" 1/2 <mirror> set-at ] [
+    [ immutable-slot? ]
+    [ name>> "numerator" = ]
+    [ object>> 1/2 = ] tri and and
+] must-fail-with

core/mirrors/mirrors.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs hashtables kernel sequences generic words
 arrays classes slots slots.private classes.tuple math vectors
-quotations sorting prettyprint ;
+quotations sorting prettyprint accessors ;
 IN: mirrors
 
 : all-slots ( class -- slots )
@@ -16,33 +16,32 @@ TUPLE: mirror object slots ;
 : <mirror> ( object -- mirror )
     dup object-slots mirror boa ;
 
-: >mirror< ( mirror -- obj slots )
+ERROR: no-such-slot object name ;
-    dup mirror-object swap mirror-slots ;
 
-: mirror@ ( slot-name mirror -- obj slot-spec )
+ERROR: immutable-slot object name ;
-    >mirror< swapd slot-named ;
 
 M: mirror at*
-    mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
+    [ nip object>> ] [ slots>> slot-named ] 2bi
+    dup [ offset>> slot t ] [ 2drop f f ] if ;
 
 M: mirror set-at ( val key mirror -- )
-    mirror@ dup [
+    [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
-        dup slot-spec-writer [
+        dup writer>> [
-            slot-spec-offset set-slot
+            nip offset>> set-slot
         ] [
-            "Immutable slot" throw
+            drop immutable-slot
         ] if
     ] [
-        "No such slot" throw
+        drop no-such-slot
     ] if ;
 
 M: mirror delete-at ( key mirror -- )
     f -rot set-at ;
 
 M: mirror >alist ( mirror -- alist )
-    >mirror<
+    [ slots>> [ name>> ] map ]
-    [ [ slot-spec-offset slot ] with map ] keep
+    [ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
-    [ slot-spec-name ] map swap zip ;
+    zip ;
 
 M: mirror assoc-size mirror-slots length ;
 
@@ -50,7 +49,7 @@ INSTANCE: mirror assoc
 
 : sort-assoc ( assoc -- alist )
     >alist
-    [ dup first unparse-short swap ] { } map>assoc
+    [ [ first unparse-short ] keep ] { } map>assoc
     sort-keys values ;
 
 GENERIC: make-mirror ( obj -- assoc )

core/optimizer/known-words/known-words.factor

@@ -60,7 +60,8 @@ sequences.private combinators ;
     [ value-literal sequence? ] [ drop f ] if ;
 
 : member-quot ( seq -- newquot )
-    [ [ t ] ] { } map>assoc [ drop f ] suffix [ nip case ] curry ;
+    [ literalize [ t ] ] { } map>assoc
+    [ drop f ] suffix [ nip case ] curry ;
 
 : expand-member ( #call -- )
     dup node-in-d peek value-literal member-quot f splice-quot ;

core/optimizer/optimizer-tests.factor

@@ -1,9 +1,9 @@
 USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
+kernel.private math optimizer generator prettyprint sequences
-strings tools.test vectors words sequences.private quotations
+sbufs strings tools.test vectors words sequences.private
-optimizer.backend classes classes.algebra inference.dataflow
+quotations optimizer.backend classes classes.algebra
-classes.tuple.private continuations growable optimizer.inlining
+inference.dataflow classes.tuple.private continuations growable
-namespaces hints ;
+optimizer.inlining namespaces hints ;
 IN: optimizer.tests
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@@ -349,3 +349,10 @@ USE: sequences.private
     1 2 3.0 3 counter-example ;
 
 [ 2 4 6.0 0 ] [ counter-example' ] unit-test
+
+: member-test { + - * / /i } member? ;
+
+\ member-test must-infer
+[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
+[ t ] [ \ + member-test ] unit-test
+[ f ] [ \ append member-test ] unit-test

core/parser/parser-docs.factor

@@ -51,9 +51,11 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors"
 ARTICLE: "vocabulary-search" "Vocabulary search path"
 "When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order."
 $nl
-"For a source file the vocabulary search path starts off with two vocabularies:"
+"For a source file the vocabulary search path starts off with one vocabulary:"
-{ $code "syntax\nscratchpad" }
+{ $code "syntax" }
-"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words. The " { $vocab-link "scratchpad" } " vocabulary is the default vocabulary for new word definitions."
+"The " { $vocab-link "syntax" } " vocabulary consists of a set of parsing words for reading Factor data and defining new words."
+$nl
+"In the listener, the " { $vocab-link "scratchpad" } " is the default vocabulary for new word definitions. However, when loading source files, there is no default vocabulary. Defining words before declaring a vocabulary with " { $link POSTPONE: IN: } " results in an error."
 $nl
 "At the interactive listener, the default search path contains many more vocabularies. Details on the default search path and parser invocation are found in " { $link "parser" } "."
 $nl
@@ -294,6 +296,10 @@ HELP: use
 HELP: in
 { $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
 
+HELP: current-vocab
+{ $values { "str" "a vocabulary" } }
+{ $description "Returns the vocabulary stored in the " { $link in } " symbol. Throws an error if the current vocabulary is " { $link f } "." } ;
+
 HELP: (use+)
 { $values { "vocab" "an assoc mapping strings to words" } }
 { $description "Adds an assoc at the front of the search path." }
@@ -323,7 +329,7 @@ HELP: set-in
 $parsing-note ;
 
 HELP: create-in
-{ $values { "string" "a word name" } { "word" "a new word" } }
+{ $values { "str" "a word name" } { "word" "a new word" } }
 { $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." }
 $parsing-note ;
 
@@ -451,7 +457,7 @@ HELP: bootstrap-syntax
 
 HELP: with-file-vocabs
 { $values { "quot" quotation } }
-{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of the " { $snippet "syntax" } " vocabulary together with the " { $snippet "scratchpad" } " vocabulary." } ;
+{ $description "Calls the quotation in a scope with the initial the vocabulary search path for parsing a file. This consists of just the " { $snippet "syntax" } " vocabulary." } ;
 
 HELP: parse-fresh
 { $values { "lines" "a sequence of strings" } { "quot" quotation } }

core/parser/parser-tests.factor

@@ -3,6 +3,7 @@ io.streams.string namespaces classes effects source-files
 assocs sequences strings io.files definitions continuations
 sorting classes.tuple compiler.units debugger vocabs
 vocabs.loader accessors ;
+
 IN: parser.tests
 
 [
@@ -429,3 +430,5 @@ must-fail-with
 [
     "USE: this-better-not-exist" eval
 ] must-fail
+
+[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with

core/parser/parser.factor

@@ -233,8 +233,16 @@ PREDICATE: unexpected-eof < unexpected
 : parse-tokens ( end -- seq )
     100 <vector> swap (parse-tokens) >array ;
 
-: create-in ( string -- word )
+ERROR: no-current-vocab ;
-    in get create dup set-word dup save-location ;
+
+M: no-current-vocab summary ( obj -- )
+    drop "Current vocabulary is f, use IN:" ;
+
+: current-vocab ( -- str )
+    in get [ no-current-vocab ] unless* ;
+
+: create-in ( str -- word )
+    current-vocab create dup set-word dup save-location ;
 
 : CREATE ( -- word ) scan create-in ;
 
@@ -243,7 +251,7 @@ PREDICATE: unexpected-eof < unexpected
 : CREATE-WORD ( -- word ) CREATE dup reset-generic ;
 
 : create-class-in ( word -- word )
-    in get create
+    current-vocab create
     dup save-class-location
     dup predicate-word dup set-word save-location ;
 
@@ -440,8 +448,7 @@ SYMBOL: bootstrap-syntax
 
 : with-file-vocabs ( quot -- )
     [
-        "scratchpad" in set
+        f in set { "syntax" } set-use
-        { "syntax" "scratchpad" } set-use
         bootstrap-syntax get [ use get push ] when*
         call
     ] with-scope ; inline

extra/bit-vectors/bit-vectors-docs.factor

@@ -3,7 +3,7 @@ bit-vectors.private combinators ;
 IN: bit-vectors
 
 ARTICLE: "bit-vectors" "Bit vectors"
-"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
+"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
 $nl
 "Bit vectors form a class:"
 { $subsection bit-vector }
@@ -19,7 +19,7 @@ $nl
 ABOUT: "bit-vectors"
 
 HELP: bit-vector
-{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
+{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
 
 HELP: <bit-vector>
 { $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }

extra/byte-vectors/byte-vectors-docs.factor

@@ -19,7 +19,7 @@ $nl
 ABOUT: "byte-vectors"
 
 HELP: byte-vector
-{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;
 
 HELP: <byte-vector>
 { $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }

extra/calendar/calendar-tests.factor

@@ -2,6 +2,10 @@ USING: arrays calendar kernel math sequences tools.test
 continuations system ;
 IN: calendar.tests
 
+\ time+ must-infer
+\ time* must-infer
+\ time- must-infer
+
 [ f ] [ 2004 12 32 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
 [ f ] [ 2004  2 30 0   0  0 instant <timestamp> valid-timestamp? ] unit-test
 [ f ] [ 2003  2 29 0   0  0 instant <timestamp> valid-timestamp? ] unit-test

extra/calendar/calendar.factor

@@ -211,12 +211,14 @@ M: duration time+
     #! Uses average month/year length since dt loses calendar
     #! data
     0 swap
-    [ year>> + ] keep
+    {
-    [ month>> months-per-year / + ] keep
+        [ year>> + ]
-    [ day>> days-per-year / + ] keep
+        [ month>> months-per-year / + ]
-    [ hour>> hours-per-year / + ] keep
+        [ day>> days-per-year / + ]
-    [ minute>> minutes-per-year / + ] keep
+        [ hour>> hours-per-year / + ]
-    second>> seconds-per-year / + ;
+        [ minute>> minutes-per-year / + ]
+        [ second>> seconds-per-year / + ]
+    } cleave ;
 
 M: duration <=> [ dt>years ] compare ;
 
@@ -252,14 +254,21 @@ M: timestamp time-
     #! Exact calendar-time difference
     (time-) seconds ;
 
+: time* ( obj1 obj2 -- obj3 )
+    dup real? [ swap ] when
+    dup real? [ * ] [
+        {
+            [   year>> * ]
+            [  month>> * ]
+            [    day>> * ]
+            [   hour>> * ]
+            [ minute>> * ]
+            [ second>> * ]
+        } 2cleave <duration>
+    ] if ;
+
 : before ( dt -- -dt )
-    [ year>>   neg ] keep
+    -1 time* ;
-    [ month>>  neg ] keep
-    [ day>>    neg ] keep
-    [ hour>>   neg ] keep
-    [ minute>> neg ] keep
-      second>> neg
-    <duration> ;
 
 M: duration time-
     before time+ ;

extra/calendar/format/format-tests.factor

@@ -1,26 +1,45 @@
-USING: calendar.format calendar kernel tools.test
+USING: calendar.format calendar kernel math tools.test
-io.streams.string ;
+io.streams.string accessors io ;
 IN: calendar.format.tests
 
 [ 0 ] [
-    "Z" [ read-rfc3339-gmt-offset ] with-string-reader
+    "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
 ] unit-test
 
 [ 1 ] [
-    "+01" [ read-rfc3339-gmt-offset ] with-string-reader
+    "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
 ] unit-test
 
 [ -1 ] [
-    "-01" [ read-rfc3339-gmt-offset ] with-string-reader
+    "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
 ] unit-test
 
 [ -1-1/2 ] [
-    "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+    "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
 ] unit-test
 
 [ 1+1/2 ] [
-    "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+    "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
 ] unit-test
 
 [ ] [ now timestamp>rfc3339 drop ] unit-test
 [ ] [ now timestamp>rfc822 drop ] unit-test
+
+[ 8/1000 -4 ] [
+    "2008-04-19T04:56:00.008-04:00" rfc3339>timestamp
+    [ second>> ] [ gmt-offset>> hour>> ] bi
+] unit-test
+
+[ T{ duration f 0 0 0 0 0 0 } ] [
+    "GMT" parse-rfc822-gmt-offset
+] unit-test
+
+[ T{ duration f 0 0 0 -5 0 0 } ] [
+    "-0500" parse-rfc822-gmt-offset
+] unit-test
+
+[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [
+    "Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp
+] unit-test
+
+[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test

extra/calendar/format/format.factor

@@ -1,5 +1,6 @@
 USING: math math.parser kernel sequences io calendar
-accessors arrays io.streams.string combinators accessors ;
+accessors arrays io.streams.string splitting
+combinators accessors debugger ;
 IN: calendar.format
 
 GENERIC: day. ( obj -- )
@@ -58,11 +59,11 @@ M: timestamp year. ( timestamp -- )
     [ hour>> write-00 ] [ minute>> write-00 ] bi ;
 
 : write-gmt-offset ( gmt-offset -- )
-    dup instant <=> {
+    dup instant <=> sgn {
-        { [ dup 0 = ] [ 2drop "GMT" write ] }
+        {  0 [ drop "GMT" write ] }
-        { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }
+        { -1 [ "-" write before (write-gmt-offset) ] }
-        { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }
+        {  1 [ "+" write (write-gmt-offset) ] }
-    } cond ;
+    } case ;
 
 : timestamp>rfc822 ( timestamp -- str )
     #! RFC822 timestamp format
@@ -83,20 +84,22 @@ M: timestamp year. ( timestamp -- )
     [ minute>> write-00 ] bi ;
 
 : write-rfc3339-gmt-offset ( duration -- )
-    dup instant <=> {
+    dup instant <=> sgn {
-        { [ dup 0 = ] [ 2drop "Z" write ] }
+        {  0 [ drop "Z" write ] }
-        { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
+        { -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
-        { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }
+        {  1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] }
-    } cond ;
+    } case ;
     
 : (timestamp>rfc3339) ( timestamp -- )
-    dup year>> number>string write CHAR: - write1
+    {
-    dup month>> write-00 CHAR: - write1
+        [ year>> number>string write CHAR: - write1 ]
-    dup day>> write-00 CHAR: T write1
+        [ month>> write-00 CHAR: - write1 ]
-    dup hour>> write-00 CHAR: : write1
+        [ day>> write-00 CHAR: T write1 ]
-    dup minute>> write-00 CHAR: : write1
+        [ hour>> write-00 CHAR: : write1 ]
-    dup second>> >fixnum write-00
+        [ minute>> write-00 CHAR: : write1 ]
-    gmt-offset>> write-rfc3339-gmt-offset ;
+        [ second>> >fixnum write-00 ]
+        [ gmt-offset>> write-rfc3339-gmt-offset ]
+    } cleave ;
 
 : timestamp>rfc3339 ( timestamp -- str )
     [ (timestamp>rfc3339) ] with-string-writer ;
@@ -106,14 +109,20 @@ M: timestamp year. ( timestamp -- )
 
 : read-00 2 read string>number ;
 
+: read-000 3 read string>number ;
+
 : read-0000 4 read string>number ;
 
-: read-rfc3339-gmt-offset ( -- n )
+: signed-gmt-offset ( dt ch -- dt' )
-    read1 dup CHAR: Z = [ drop 0 ] [
+    { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
-        { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
+
-        read-00
+: read-rfc3339-gmt-offset ( ch -- dt )
-        read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
+    dup CHAR: Z = [ drop instant ] [
-        60 / + *
+        >r
+        read-00 hours
+        read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
+        time+
+        r> signed-gmt-offset
     ] if ;
 
 : read-ymd ( -- y m d )
@@ -126,26 +135,61 @@ M: timestamp year. ( timestamp -- )
     read-ymd
     "Tt" expect
     read-hms
-    read-rfc3339-gmt-offset ! timezone
+    read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
+    read-rfc3339-gmt-offset
     <timestamp> ;
 
 : rfc3339>timestamp ( str -- timestamp )
     [ (rfc3339>timestamp) ] with-string-reader ;
 
+ERROR: invalid-rfc822-date ;
+
+: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ;
+
+: read-token ( seps -- token )
+    [ read-until ] keep member? check-rfc822-date drop ;
+
+: read-sp ( -- token ) " " read-token ;
+
+: checked-number ( str -- n )
+    string>number check-rfc822-date ;
+
+: parse-rfc822-gmt-offset ( string -- dt )
+    dup "GMT" = [ drop instant ] [
+        unclip >r
+        2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
+        r> signed-gmt-offset
+    ] if ;
+
+: (rfc822>timestamp) ( -- timestamp )
+    timestamp new
+        "," read-token day-abbreviations3 member? check-rfc822-date drop
+        read1 CHAR: \s assert=
+        read-sp checked-number >>day
+        read-sp month-abbreviations index check-rfc822-date >>month
+        read-sp checked-number >>year
+        ":" read-token checked-number >>hour
+        ":" read-token checked-number >>minute
+        " " read-token checked-number >>second
+        readln parse-rfc822-gmt-offset >>gmt-offset ;
+
+: rfc822>timestamp ( str -- timestamp )
+    [ (rfc822>timestamp) ] with-string-reader ;
+
 : (ymdhms>timestamp) ( -- timestamp )
-    read-ymd " " expect read-hms 0 <timestamp> ;
+    read-ymd " " expect read-hms instant <timestamp> ;
 
 : ymdhms>timestamp ( str -- timestamp )
     [ (ymdhms>timestamp) ] with-string-reader ;
 
 : (hms>timestamp) ( -- timestamp )
-    f f f read-hms f <timestamp> ;
+    f f f read-hms instant <timestamp> ;
 
 : hms>timestamp ( str -- timestamp )
     [ (hms>timestamp) ] with-string-reader ;
 
 : (ymd>timestamp) ( -- timestamp )
-    read-ymd f f f f <timestamp> ;
+    read-ymd f f f instant <timestamp> ;
 
 : ymd>timestamp ( str -- timestamp )
     [ (ymd>timestamp) ] with-string-reader ;

extra/columns/columns-docs.factor

@@ -14,7 +14,7 @@ HELP: <column> ( seq n -- column )
 { $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
 { $examples
     { $example
-        "USING: arrays prettyprint sequences ;"
+        "USING: arrays prettyprint columns ;"
         "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
         "{ 1 4 7 }"
     }

extra/db/db-tests.factor

@@ -3,3 +3,4 @@ USING: tools.test db kernel ;
 
 { 1 0 } [ [ drop ] query-each ] must-infer-as
 { 1 1 } [ [ ] query-map ] must-infer-as
+{ 2 0 } [ [ ] with-db ] must-infer-as

extra/db/db.factor

@@ -131,6 +131,7 @@ M: nonthrowable execute-statement* ( statement type -- )
 : with-db ( db seq quot -- )
     >r make-db db-open db r>
     [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
+    inline
 
 : default-query ( query -- result-set )
     query-results [ [ sql-row ] query-map ] with-disposal ;

extra/db/postgresql/lib/lib.factor

@@ -69,6 +69,11 @@ M: postgresql-result-null summary ( obj -- str )
 : malloc-byte-array/length
     [ malloc-byte-array dup free-always ] [ length ] bi ;
 
+: default-param-value
+    number>string* dup [
+        utf8 malloc-string dup free-always
+    ] when 0 ;
+
 : param-values ( statement -- seq seq2 )
     [ bind-params>> ] [ in-params>> ] bi
     [
@@ -77,11 +82,11 @@ M: postgresql-result-null summary ( obj -- str )
                 dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
             ] }
             { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
-            [
+            { DATE [ dup [ timestamp>ymd ] when default-param-value ] }
-                drop number>string* dup [
+            { TIME [ dup [ timestamp>hms ] when default-param-value ] }
-                    utf8 malloc-string dup free-always
+            { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
-                ] when 0
+            { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
-            ]
+            [ drop default-param-value ]
         } case 2array
     ] 2map flip dup empty? [
         drop f f

extra/db/sqlite/ffi/ffi.factor

@@ -108,6 +108,7 @@ LIBRARY: sqlite
 FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
 FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
 FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
 FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
 FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
 FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;

extra/db/sqlite/lib/lib.factor

@@ -97,10 +97,10 @@ IN: db.sqlite.lib
         { TEXT [ sqlite-bind-text-by-name ] }
         { VARCHAR [ sqlite-bind-text-by-name ] }
         { DOUBLE [ sqlite-bind-double-by-name ] }
-        { DATE [ sqlite-bind-text-by-name ] }
+        { DATE [ timestamp>ymd sqlite-bind-text-by-name ] }
-        { TIME [ sqlite-bind-text-by-name ] }
+        { TIME [ timestamp>hms sqlite-bind-text-by-name ] }
-        { DATETIME [ sqlite-bind-text-by-name ] }
+        { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
-        { TIMESTAMP [ sqlite-bind-text-by-name ] }
+        { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
         { BLOB [ sqlite-bind-blob-by-name ] }
         { FACTOR-BLOB [
             object>bytes

extra/db/sqlite/sqlite.factor

@@ -124,7 +124,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
             dup type>> lookup-create-type 0%
             modifiers 0%
         ] interleave ");" 0%
-    ] query-make dup sql>> . ;
+    ] query-make ;
 
 M: sqlite-db drop-sql-statement ( class -- statement )
     [ "drop table " 0% 0% ";" 0% drop ] query-make ;

extra/db/tuples/tuples-tests.factor

@@ -40,7 +40,7 @@ SYMBOL: person4
 
     [ 1 ] [ person1 get person-the-id ] unit-test
 
-    200 person1 get set-person-the-number
+    [ ] [ 200 person1 get set-person-the-number ] unit-test
 
     [ ] [ person1 get update-tuple ] unit-test
 
@@ -80,9 +80,9 @@ SYMBOL: person4
             "teddy"
             10
             3.14
-            T{ timestamp f 2008 3 5 16 24 11 0 }
+            T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
-            T{ timestamp f 2008 11 22 f f f f }
+            T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
-            T{ timestamp f f f f 12 34 56 f }
+            T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
             B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
         }
     ] [ T{ person f 3 } select-tuple ] unit-test
@@ -96,9 +96,9 @@ SYMBOL: person4
             "eddie"
             10
             3.14
-            T{ timestamp f 2008 3 5 16 24 11 0 }
+            T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
-            T{ timestamp f 2008 11 22 f f f f }
+            T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
-            T{ timestamp f f f f 12 34 56 f }
+            T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
             f
             H{ { 1 2 } { 3 4 } { 5 "lol" } }
         }
@@ -121,8 +121,16 @@ SYMBOL: person4
     } define-persistent
     "billy" 10 3.14 f f f f f <person> person1 set
     "johnny" 10 3.14 f f f f f <person> person2 set
-    "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
+    "teddy" 10 3.14
-    "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
+        T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+        T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+        T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+        B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
+    "eddie" 10 3.14
+        T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+        T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+        T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+        f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
 
 : assigned-person-schema ( -- )
     person "PERSON"
@@ -139,8 +147,17 @@ SYMBOL: person4
     } define-persistent
     1 "billy" 10 3.14 f f f f f <assigned-person> person1 set
     2 "johnny" 10 3.14 f f f f f <assigned-person> person2 set
-    3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <assigned-person> person3 set
+    3 "teddy" 10 3.14
-    4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
+        T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+        T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+        T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+        B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
+        f <assigned-person> person3 set
+    4 "eddie" 10 3.14
+        T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+        T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+        T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+        f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
 
 TUPLE: paste n summary author channel mode contents timestamp annotations ;
 TUPLE: annotation n paste-id summary author mode contents ;
@@ -363,3 +380,6 @@ TUPLE: does-not-persist ;
 \ delete-tuple must-infer
 \ select-tuple must-infer
 \ define-persistent must-infer
+\ ensure-table must-infer
+\ create-table must-infer
+\ drop-table must-infer

extra/db/tuples/tuples.factor

@@ -105,7 +105,7 @@ M: retryable execute-statement* ( statement type -- )
         [ with-disposal ] curry each
     ] [
         with-disposal
-    ] if ;
+    ] if ; inline
 
 : create-table ( class -- )
     create-sql-statement [ execute-statement ] with-disposals ;

extra/float-vectors/float-vectors-docs.factor

@@ -3,7 +3,7 @@ float-vectors.private combinators ;
 IN: float-vectors
 
 ARTICLE: "float-vectors" "Float vectors"
-"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
+"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
 $nl
 "Float vectors form a class:"
 { $subsection float-vector }
@@ -19,7 +19,7 @@ $nl
 ABOUT: "float-vectors"
 
 HELP: float-vector
-{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;
+{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ;
 
 HELP: <float-vector>
 { $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }

extra/fry/fry-tests.factor

@@ -44,3 +44,7 @@ sequences ;
 : funny-dip '[ @ _ ] call ; inline
 
 [ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
+
+[ { 1 2 3 } ] [
+    3 1 '[ , [ , + ] map ] call
+] unit-test

extra/fry/fry.factor

@@ -9,41 +9,54 @@ IN: fry
 : @ "Only valid inside a fry" throw ;
 : _ "Only valid inside a fry" throw ;
 
-DEFER: (fry)
+DEFER: (shallow-fry)
 
-: ((fry)) ( accum quot adder -- result )
+: ((shallow-fry)) ( accum quot adder -- result )
-    >r [ ] swap (fry) r>
+    >r [ ] swap (shallow-fry) r>
     append swap dup empty? [ drop ] [
         [ swap compose ] curry append
     ] if ; inline
 
-: (fry) ( accum quot -- result )
+: (shallow-fry) ( accum quot -- result )
     dup empty? [
         drop 1quotation
     ] [
         unclip {
-            { \ , [ [ curry ] ((fry)) ] }
+            { \ , [ [ curry ] ((shallow-fry)) ] }
-            { \ @ [ [ compose ] ((fry)) ] }
+            { \ @ [ [ compose ] ((shallow-fry)) ] }
 
             ! to avoid confusion, remove if fry goes core
-            { \ namespaces:, [ [ curry ] ((fry)) ] }
+            { \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
 
-            [ swap >r suffix r> (fry) ]
+            [ swap >r suffix r> (shallow-fry) ]
         } case
     ] if ;
 
-: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
+: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
 
-: fry ( quot -- quot' )
+: deep-fry ( quot -- quot' )
     { _ } last-split1 [
         [
-            trivial-fry %
+            shallow-fry %
             [ >r ] %
-            fry %
+            deep-fry %
             [ [ dip ] curry r> compose ] %
         ] [ ] make
     ] [
-        trivial-fry
+        shallow-fry
     ] if* ;
 
+: fry ( quot -- quot' )
+    [
+        [
+            dup callable? [
+                [
+                    [ { , namespaces:, @ } member? ] subset length
+                    \ , <repetition> %
+                ]
+                [ deep-fry % ] bi
+            ] [ namespaces:, ] if
+        ] each
+    ] [ ] make deep-fry ;
+
 : '[ \ ] parse-until fry over push-all ; parsing

extra/hardware-info/windows/windows.factor

@@ -1,7 +1,7 @@
 USING: alien alien.c-types kernel libc math namespaces
 windows windows.kernel32 windows.advapi32
 words combinators vocabs.loader hardware-info.backend
-system ;
+system alien.strings ;
 IN: hardware-info.windows
 
 : system-info ( -- SYSTEM_INFO )

extra/http/client/client-tests.factor

@@ -6,9 +6,9 @@ tuple-syntax namespaces ;
 [ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
 
 [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
-[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
-[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt/" download-name ] unit-test
-[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
+[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
 
 [
     TUPLE{ request
@@ -18,7 +18,7 @@ tuple-syntax namespaces ;
         port: 80
         version: "1.1"
         cookies: V{ }
-        header: H{ }
+        header: H{ { "connection" "close" } }
     }
 ] [
     [

extra/http/client/client.factor

@@ -3,9 +3,17 @@
 USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files io.timeouts strings
 splitting calendar continuations accessors vectors
-io.encodings.8-bit io.encodings.binary fry ;
+io.encodings.8-bit io.encodings.binary fry debugger inspector ;
 IN: http.client
 
+: max-redirects 10 ;
+
+ERROR: too-many-redirects ;
+
+M: too-many-redirects summary
+    drop
+    [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
+
 DEFER: http-request
 
 <PRIVATE
@@ -29,22 +37,29 @@ DEFER: http-request
 : relative-redirect ( path -- request )
     request get swap store-path ;
 
+SYMBOL: redirects
+
+: absolute-url? ( url -- ? )
+    [ "http://" head? ] [ "https://" head? ] bi or ;
+
 : do-redirect ( response -- response stream )
     dup response-code 300 399 between? [
         stdio get dispose
+        redirects inc
+        redirects get max-redirects < [
             header>> "location" swap at
-        dup "http://" head? [
+            dup absolute-url? [
                 absolute-redirect
             ] [
                 relative-redirect
             ] if "GET" >>method http-request
+        ] [
+            too-many-redirects
+        ] if
     ] [
         stdio get
     ] if ;
 
-: request-addr ( request -- addr )
-    dup host>> swap port>> <inet> ;
-
 : close-on-error ( stream quot -- )
     '[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
 
@@ -61,28 +76,55 @@ PRIVATE>
         ] close-on-error
     ] with-variable ;
 
+: read-chunks ( -- )
+    read-crlf ";" split1 drop hex> dup { f 0 } member?
+    [ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
+
+: do-chunked-encoding ( response stream -- response stream/string )
+    over "transfer-encoding" header "chunked" = [
+        [ [ read-chunks ] "" make ] with-stream
+    ] when ;
+
 : <get-request> ( url -- request )
     <request> request-with-url "GET" >>method ;
 
-: http-get-stream ( url -- response stream )
+: string-or-contents ( stream/string -- string )
-    <get-request> http-request ;
+    dup string? [ contents ] unless ;
+
+: http-get-stream ( url -- response stream/string )
+    <get-request> http-request do-chunked-encoding ;
 
 : success? ( code -- ? ) 200 = ;
 
-: check-response ( response -- )
+ERROR: download-failed response body ;
-    code>> success?
+
-    [ "HTTP download failed" throw ] unless ;
+M: download-failed error.
+    "HTTP download failed:" print nl
+    [
+        response>>
+            write-response-code
+            write-response-message nl
+        drop
+    ]
+    [ body>> write ] bi ;
+
+: check-response ( response string -- string )
+    over code>> success? [ nip ] [ download-failed ] if ;
 
 : http-get ( url -- string )
-    http-get-stream contents swap check-response ;
+    http-get-stream string-or-contents check-response ;
 
 : download-name ( url -- name )
     file-name "?" split1 drop "/" ?tail drop ;
 
 : download-to ( url file -- )
     #! Downloads the contents of a URL to a file.
-    swap http-get-stream swap check-response
+    swap http-get-stream check-response
-    [ swap latin1 <file-writer> stream-copy ] with-disposal ;
+    dup string? [
+        latin1 [ write ] with-file-writer
+    ] [
+        [ swap latin1 <file-writer> stream-copy ] with-disposal
+    ] if ;
 
 : download ( url -- )
     dup download-name download-to ;
@@ -95,4 +137,4 @@ PRIVATE>
     swap >>post-data-type ;
 
 : http-post ( content-type content url -- response string )
-    <post-request> http-request contents ;
+    <post-request> http-request do-chunked-encoding string-or-contents ;

extra/http/http-tests.factor

@@ -24,6 +24,8 @@ IN: http.tests
 [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
 [ "/bar" ] [ "/bar" url>path ] unit-test
 
+: lf>crlf "\n" split "\r\n" join ;
+
 STRING: read-request-test-1
 GET http://foo/bar HTTP/1.1
 Some-Header: 1
@@ -45,7 +47,7 @@ blah
         cookies: V{ }
     }
 ] [
-    read-request-test-1 [
+    read-request-test-1 lf>crlf [
         read-request
     ] with-string-reader
 ] unit-test
@@ -59,7 +61,7 @@ blah
 ;
 
 read-request-test-1' 1array [
-    read-request-test-1
+    read-request-test-1 lf>crlf
     [ read-request ] with-string-reader
     [ write-request ] with-string-writer
     ! normalize crlf
@@ -69,6 +71,7 @@ read-request-test-1' 1array [
 STRING: read-request-test-2
 HEAD  http://foo/bar   HTTP/1.1
 Host: www.sex.com
+
 ;
 
 [
@@ -83,7 +86,7 @@ Host: www.sex.com
         cookies: V{ }
     }
 ] [
-    read-request-test-2 [
+    read-request-test-2 lf>crlf [
         read-request
     ] with-string-reader
 ] unit-test
@@ -104,7 +107,7 @@ blah
         cookies: V{ }
     }
 ] [
-    read-response-test-1
+    read-response-test-1 lf>crlf
     [ read-response ] with-string-reader
 ] unit-test
 
@@ -117,7 +120,7 @@ content-type: text/html
 ;
 
 read-response-test-1' 1array [
-    read-response-test-1
+    read-response-test-1 lf>crlf
     [ read-response ] with-string-reader
     [ write-response ] with-string-writer
     ! normalize crlf
@@ -130,19 +133,26 @@ read-response-test-1' 1array [
 ] unit-test
 
 ! Live-fire exercise
-USING: http.server http.server.static http.server.actions
+USING: http.server http.server.static http.server.sessions
-http.client io.server io.files io accessors namespaces threads
+http.server.actions http.server.auth.login http.client
+io.server io.files io accessors namespaces threads
 io.encodings.ascii ;
 
+: add-quit-action
+    <action>
+        [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+    "quit" add-responder ;
+
 [ ] [
     [
         <dispatcher>
-            <action>
+            add-quit-action
-                [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
-            "quit" add-responder
             <dispatcher>
                 "extra/http/test" resource-path <static> >>default
             "nested" add-responder
+            <action>
+                [ "redirect-loop" f <permanent-redirect> ] >>display
+            "redirect-loop" add-responder
         main-responder set
 
         [ 1237 httpd ] "HTTPD test" spawn drop
@@ -159,11 +169,62 @@ io.encodings.ascii ;
     "localhost" 1237 <inet> ascii <client> [
         "GET nested HTTP/1.0\r\n" write flush
         "\r\n" write flush
-        readln drop
+        read-crlf drop
-        read-header USE: prettyprint
+        read-header
-    ] with-stream dup . "location" swap at "/" head?
+    ] with-stream "location" swap at "/" head?
 ] unit-test
 
+[ "http://localhost:1237/redirect-loop" http-get ]
+[ too-many-redirects? ] must-fail-with
+
 [ "Goodbye" ] [
     "http://localhost:1237/quit" http-get
 ] unit-test
+
+! Dispatcher bugs
+[ ] [
+    [
+        <dispatcher>
+            <action> <protected>
+            <login>
+            <url-sessions> "" add-responder
+            add-quit-action
+            <dispatcher>
+                <action> "a" add-main-responder
+            "d" add-responder
+        main-responder set
+
+        [ 1237 httpd ] "HTTPD test" spawn drop
+    ] with-scope
+] unit-test
+
+[ ] [ 1000 sleep ] unit-test
+
+: 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
+
+! This should give a 404 not an infinite redirect loop
+[ "http://localhost:1237/d/blah" http-get ] [ 404? ] must-fail-with
+
+! This should give a 404 not an infinite redirect loop
+[ "http://localhost:1237/blah/" http-get ] [ 404? ] must-fail-with
+
+[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test
+
+[ ] [
+    [
+        <dispatcher>
+            <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
+            <login> <url-sessions>
+            "" add-responder
+            add-quit-action
+        main-responder set
+
+        [ 1237 httpd ] "HTTPD test" spawn drop
+    ] with-scope
+] unit-test
+
+[ ] [ 1000 sleep ] unit-test
+
+[ "Hi" ] [ "http://localhost:1237/" http-get ] unit-test
+
+[ "Goodbye" ] [ "http://localhost:1237/quit" http-get ] unit-test

extra/http/http.factor

@@ -1,10 +1,18 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry hashtables io io.streams.string kernel math sets
+USING: accessors kernel combinators math namespaces
-namespaces math.parser assocs sequences strings splitting ascii
+
-io.encodings.utf8 io.encodings.string namespaces unicode.case
+assocs sequences splitting sorting sets debugger
-combinators vectors sorting accessors calendar
+strings vectors hashtables quotations arrays byte-arrays
-calendar.format quotations arrays combinators.lib byte-arrays ;
+math.parser calendar calendar.format
+
+io io.streams.string io.encodings.utf8 io.encodings.string
+io.sockets
+
+unicode.case unicode.categories qualified ;
+
+EXCLUDE: fry => , ;
+
 IN: http
 
 : http-port 80 ; inline
@@ -13,11 +21,12 @@ IN: http
     #! In a URL, can this character be used without
     #! URL-encoding?
     {
-        [ dup letter? ]
+        { [ dup letter? ] [ t ] }
-        [ dup LETTER? ]
+        { [ dup LETTER? ] [ t ] }
-        [ dup digit? ]
+        { [ dup digit? ] [ t ] }
-        [ dup "/_-.:" member? ]
+        { [ dup "/_-.:" member? ] [ t ] }
-    } || nip ; foldable
+        [ f ]
+    } cond nip ; foldable
 
 : push-utf8 ( ch -- )
     1string utf8 encode
@@ -75,8 +84,15 @@ IN: http
         ] if
     ] if ;
 
+: read-lf ( -- string )
+    "\n" read-until CHAR: \n assert= ;
+
+: read-crlf ( -- string )
+    "\r" read-until
+    [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
+
 : read-header-line ( -- )
-    readln dup
+    read-crlf dup
     empty? [ drop ] [ header-line read-header-line ] if ;
 
 : read-header ( -- assoc )
@@ -175,13 +191,17 @@ post-data
 post-data-type
 cookies ;
 
+: set-header ( request/response value key -- request/response )
+    pick header>> set-at ;
+
 : <request>
     request new
         "1.1" >>version
         http-port >>port
         H{ } clone >>header
         H{ } clone >>query
-        V{ } clone >>cookies ;
+        V{ } clone >>cookies
+        "close" "connection" set-header ;
 
 : query-param ( request key -- value )
     swap query>> at ;
@@ -220,7 +240,7 @@ cookies ;
     dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
 
 : read-request-version ( request -- request )
-    readln [ CHAR: \s = ] left-trim
+    read-crlf [ CHAR: \s = ] left-trim
     parse-version
     >>version ;
 
@@ -295,9 +315,15 @@ SYMBOL: max-post-request
         "application/x-www-form-urlencoded" >>post-data-type
     ] if ;
 
+: request-addr ( request -- addr )
+    [ host>> ] [ port>> ] bi <inet> ;
+
+: request-host ( request -- string )
+    [ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
+
 : write-request-header ( request -- request )
     dup header>> >hashtable
-    over host>> [ "host" pick set-at ] when*
+    over host>> [ over request-host "host" pick set-at ] when
     over post-data>> [ length "content-length" pick set-at ] when*
     over post-data-type>> [ "content-type" pick set-at ] when*
     over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
@@ -330,9 +356,6 @@ SYMBOL: max-post-request
         tri
     ] with-string-writer ;
 
-: set-header ( request/response value key -- request/response )
-    pick header>> set-at ;
-
 GENERIC: write-response ( response -- )
 
 GENERIC: write-full-response ( request response -- )
@@ -365,7 +388,7 @@ body ;
     >>code ;
 
 : read-response-message
-    readln >>message ;
+    read-crlf >>message ;
 
 : read-response-header
     read-header >>header

extra/http/server/actions/actions-tests.factor

@@ -1,7 +1,7 @@
-IN: http.server.actions.tests
 USING: http.server.actions http.server.validators
 tools.test math math.parser multiline namespaces http
-io.streams.string http.server sequences accessors ;
+io.streams.string http.server sequences splitting accessors ;
+IN: http.server.actions.tests
 
 [
     "a" [ v-number ] { { "a" "123" } } validate-param
@@ -13,6 +13,8 @@ io.streams.string http.server sequences accessors ;
     { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
 "action-1" set
 
+: lf>crlf "\n" split "\r\n" join ;
+
 STRING: action-request-test-1
 GET http://foo/bar?a=12&b=13 HTTP/1.1
 
@@ -20,28 +22,8 @@ blah
 ;
 
 [ 25 ] [
-    action-request-test-1 [ read-request ] with-string-reader
+    action-request-test-1 lf>crlf
+    [ read-request ] with-string-reader
     request set
-    "/blah"
+    { } "action-1" get call-responder
-    "action-1" get call-responder
-] unit-test
-
-<action>
-    [ +append-path get "xxx" get "X" <repetition> concat append ] >>submit
-    { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params
-"action-2" set
-
-STRING: action-request-test-2
-POST http://foo/bar/baz HTTP/1.1
-content-length: 5
-content-type: application/x-www-form-urlencoded
-
-xxx=4
-;
-
-[ "/blahXXXX" ] [
-    action-request-test-2 [ read-request ] with-string-reader
-    request set
-    "/blah"
-    "action-2" get call-responder
 ] unit-test

extra/http/server/actions/actions.factor

@@ -5,7 +5,7 @@ http.server http.server.validators http hashtables namespaces
 fry continuations locals ;
 IN: http.server.actions
 
-SYMBOL: +append-path
+SYMBOL: +path+
 
 SYMBOL: params
 
@@ -39,12 +39,15 @@ TUPLE: action init display submit get-params post-params ;
 
 M: action call-responder ( path action -- response )
     '[
-        , ,
+        , [ CHAR: / = ] right-trim empty? [
-        [ +append-path associate request-params assoc-union params set ]
+            , action set
-        [ action set ] bi*
+            request-params params set
             request get method>> {
                 { "GET" [ handle-get ] }
                 { "HEAD" [ handle-get ] }
                 { "POST" [ handle-post ] }
             } case
+        ] [
+            <404>
+        ] if
     ] with-exit-continuation ;

extra/http/server/auth/login/login.factor

@@ -60,7 +60,7 @@ M: user-saver dispose
 
 : successful-login ( user -- response )
     logged-in-user sset
-    post-login-url sget "" or f <permanent-redirect>
+    post-login-url sget "$login" or f <permanent-redirect>
     f post-login-url sset ;
 
 :: <login-action> ( -- action )
@@ -162,10 +162,12 @@ SYMBOL: previous-page
         <action>
             [
                 blank-values
+
                 logged-in-user sget
-                dup username>> "username" set-value
+                [ username>> "username" set-value ]
-                dup realname>> "realname" set-value
+                [ realname>> "realname" set-value ]
-                dup email>> "email" set-value
+                [ email>> "email" set-value ]
+                tri
             ] >>init
 
             [ form edit-form ] >>display
@@ -190,6 +192,8 @@ SYMBOL: previous-page
                 "realname" value >>realname
                 "email" value >>email
 
+                drop
+
                 user-profile-changed? on
 
                 previous-page sget f <permanent-redirect>
@@ -329,7 +333,7 @@ SYMBOL: lost-password-from
     <action>
         [
             f logged-in-user sset
-            "login" f <permanent-redirect>
+            "$login/login" f <permanent-redirect>
         ] >>submit ;
 
 ! ! ! Authentication logic
@@ -340,7 +344,7 @@ C: <protected> protected
 
 : show-login-page ( -- response )
     request get request-url post-login-url sset
-    "login" f <permanent-redirect> ;
+    "$login/login" f <temporary-redirect> ;
 
 M: protected call-responder ( path responder -- response )
     logged-in-user sget dup [
@@ -363,7 +367,7 @@ M: login call-responder ( path responder -- response )
 
 : <login> ( responder -- auth )
     login new-dispatcher
-        swap <protected> >>default
+        swap >>default
         <login-action> <login-boilerplate> "login" add-responder
         <logout-action> <login-boilerplate> "logout" add-responder
         no-users >>users ;

extra/http/server/boilerplate/boilerplate.factor

@@ -48,7 +48,7 @@ SYMBOL: next-template
 : call-next-template ( -- )
     next-template get write ;
 
-M: f call-template drop call-next-template ;
+M: f call-template* drop call-next-template ;
 
 : with-boilerplate ( body template -- )
     [

extra/http/server/callbacks/callbacks-tests.factor

@@ -8,7 +8,7 @@ splitting kernel hashtables continuations ;
         <request> "GET" >>method request set
         [
             exit-continuation set
-            "xxx"
+            { }
             <action> [ [ "hello" print 123 ] show-final ] >>display
             <callback-responder>
             call-responder
@@ -31,7 +31,7 @@ splitting kernel hashtables continuations ;
         [
             exit-continuation set
             <request> "GET" >>method request set
-            "" "r" get call-responder
+            { } "r" get call-responder
         ] callcc1
 
         body>> first
@@ -44,7 +44,7 @@ splitting kernel hashtables continuations ;
 
         [
             exit-continuation set
-            "/"
+            { }
             "r" get call-responder
         ] callcc1
 
@@ -57,7 +57,7 @@ splitting kernel hashtables continuations ;
 
         [
             exit-continuation set
-            "/"
+            { }
             "r" get call-responder
         ] callcc1
     ] unit-test

extra/http/server/components/code/code.factor

@@ -0,0 +1,18 @@
+! 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 ;
+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 ;
+
+: <code> ( id mode -- component )
+    swap <text>
+        swap <code-renderer> >>renderer ;

extra/http/server/components/components.factor

@@ -280,6 +280,22 @@ TUPLE: date < 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 write </a> ;
+
+TUPLE: link < string ;
+
+: <link> ( id -- component )
+    link new-string
+        link-renderer >>renderer ;
+
 ! List components
 SYMBOL: +plain+
 SYMBOL: +ordered+
@@ -289,17 +305,20 @@ TUPLE: list-renderer component type ;
 
 C: <list-renderer> list-renderer
 
-: render-plain-list ( seq quot component -- )
+: render-plain-list ( seq component quot -- )
-    swap '[ , @ ] each ; inline
+    '[ , component>> renderer>> @ ] each ; inline
+
+: render-li-list ( seq component quot -- )
+    '[ <li> @ </li> ] render-plain-list ; inline
 
 : render-ordered-list ( seq quot component -- )
-    swap <ol> '[ <li> , @ </li> ] each </ol> ; inline
+    <ol> render-li-list </ol> ; inline
 
 : render-unordered-list ( seq quot component -- )
-    swap <ul> '[ <li> , @ </li> ] each </ul> ; inline
+    <ul> render-li-list </ul> ; inline
 
 : render-list ( value renderer quot -- )
-    swap [ component>> ] [ type>> ] bi {
+    over type>> {
         { +plain+     [ render-plain-list ] }
         { +ordered+   [ render-ordered-list ] }
         { +unordered+ [ render-unordered-list ] }
@@ -317,3 +336,26 @@ TUPLE: list < component ;
     <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 write ;
+
+M: choice-renderer render-edit*
+    <select swap =name select>
+        choices>> [
+            <option [ = [ "true" =selected ] when ] keep option>
+                write
+            </option>
+        ] with each
+    </select> ;
+
+TUPLE: choice < string ;
+
+: <choice> ( id choices -- component )
+    swap choice new-string
+        swap <choice-renderer> >>renderer ;

extra/http/server/forms/forms.factor

@@ -78,4 +78,4 @@ M: form render-view*
     dup view-template>> render-form ;
 
 M: form render-edit*
-    dup edit-template>> render-form ;
+    nip dup edit-template>> render-form ;

extra/http/server/server-tests.factor

@@ -1,7 +1,9 @@
 USING: http.server tools.test kernel namespaces accessors
-io http math sequences assocs ;
+io http math sequences assocs arrays classes words ;
 IN: http.server.tests
 
+\ find-responder must-infer
+
 [
     <request>
     "www.apple.com" >>host
@@ -29,7 +31,9 @@ M: mock-responder call-responder
     "text/plain" <content> ;
 
 : check-dispatch ( tag path -- ? )
+    H{ } clone base-paths set
     over off
+    split-path
     main-responder get call-responder
     write-response get ;
 
@@ -44,11 +48,11 @@ M: mock-responder call-responder
     main-responder set
 
     [ "foo" ] [
-        "foo" main-responder get find-responder path>> nip
+        { "foo" } main-responder get find-responder path>> nip
     ] unit-test
 
     [ "bar" ] [
-        "bar" main-responder get find-responder path>> nip
+        { "bar" } main-responder get find-responder path>> nip
     ] unit-test
 
     [ t ] [ "foo" "foo" check-dispatch ] unit-test
@@ -60,14 +64,6 @@ M: mock-responder call-responder
     [ t ] [ "123" "baz/123" check-dispatch ] unit-test
     [ t ] [ "123" "baz///123" check-dispatch ] unit-test
 
-    [ t ] [
-        <request>
-        "baz" >>path
-        request set
-        "baz" main-responder get call-responder
-        dup code>> 300 399 between? >r
-        header>> "location" swap at "baz/" tail? r> and
-    ] unit-test
 ] with-scope
 
 [
@@ -77,3 +73,67 @@ M: mock-responder call-responder
 
     [ "/default" ] [ "/default" main-responder get find-responder drop ] unit-test
 ] with-scope
+
+! Make sure path for default responder isn't chopped
+TUPLE: path-check-responder ;
+
+C: <path-check-responder> path-check-responder
+
+M: path-check-responder call-responder
+    drop
+    "text/plain" <content> swap >array >>body ;
+
+[ { "c" } ] [
+    H{ } clone base-paths set
+
+    { "b" "c" }
+    <dispatcher>
+        <dispatcher>
+            <path-check-responder> >>default
+        "b" add-responder
+    call-responder
+    body>>
+] unit-test
+
+! Test that "" dispatcher works with default>>
+[ ] [
+    <dispatcher>
+        "" <mock-responder> "" add-responder
+        "bar" <mock-responder> "bar" add-responder
+        "baz" <mock-responder> >>default
+    main-responder set
+
+    [ t ] [ "" "" check-dispatch ] unit-test
+    [ f ] [ "" "quux" check-dispatch ] unit-test
+    [ t ] [ "baz" "quux" check-dispatch ] unit-test
+    [ f ] [ "foo" "bar" check-dispatch ] unit-test
+    [ t ] [ "bar" "bar" check-dispatch ] unit-test
+    [ t ] [ "baz" "xxx" check-dispatch ] unit-test
+] unit-test
+
+TUPLE: funny-dispatcher < dispatcher ;
+
+: <funny-dispatcher> funny-dispatcher new-dispatcher ;
+
+TUPLE: base-path-check-responder ;
+
+C: <base-path-check-responder> base-path-check-responder
+
+M: base-path-check-responder call-responder
+    2drop
+    "$funny-dispatcher" resolve-base-path
+    "text/plain" <content> swap >>body ;
+
+[ ] [
+    <dispatcher>
+        <dispatcher>
+            <funny-dispatcher>
+                <base-path-check-responder> "c" add-responder
+            "b" add-responder
+        "a" add-responder
+    main-responder set
+] unit-test
+
+[ "/a/b/" ] [
+    "a/b/c" split-path main-responder get call-responder body>>
+] unit-test

extra/http/server/server.factor

@@ -4,9 +4,11 @@ USING: assocs kernel namespaces io io.timeouts strings splitting
 threads http sequences prettyprint io.server logging calendar
 html.elements accessors math.parser combinators.lib
 tools.vocabs debugger html continuations random combinators
-destructors io.encodings.8-bit fry ;
+destructors io.encodings.8-bit fry classes words ;
 IN: http.server
 
+! path is a sequence of path component strings
+
 GENERIC: call-responder ( path responder -- response )
 
 : request-params ( -- assoc )
@@ -52,13 +54,39 @@ SYMBOL: 404-responder
 
 [ <404> ] <trivial-responder> 404-responder set-global
 
+SYMBOL: base-paths
+
+: invert-slice ( slice -- slice' )
+    dup slice? [
+        [ seq>> ] [ from>> ] bi head-slice
+    ] [
+        drop { }
+    ] if ;
+
+: add-base-path ( path dispatcher -- )
+    [ invert-slice ] [ class word-name ] bi*
+    base-paths get set-at ;
+
 SYMBOL: link-hook
 
 : modify-query ( query -- query )
     link-hook get [ ] or call ;
 
+: base-path ( string -- path )
+    dup base-paths get at
+    [ ] [ "No such responder: " swap append throw ] ?if ;
+
+: resolve-base-path ( string -- string' )
+    "$" ?head [
+        [
+            "/" split1 >r
+            base-path [ "/" % % ] each "/" %
+            r> %
+        ] "" make
+    ] when ;
+
 : link>string ( url query -- url' )
-    modify-query (link>string) ;
+    [ resolve-base-path ] [ modify-query ] bi* (link>string) ;
 
 : write-link ( url query -- )
     link>string write ;
@@ -73,6 +101,7 @@ SYMBOL: form-hook
     request get clone
     swap [ >>query ] when*
     swap url-encode >>path
+    [ modify-query ] change-query
     request-url ;
 
 : replace-last-component ( path with -- path' )
@@ -82,13 +111,14 @@ SYMBOL: form-hook
     request get clone
     swap [ >>query ] when*
     swap [ '[ , replace-last-component ] change-path ] when*
-    dup query>> modify-query >>query
+    [ modify-query ] change-query
     request-url ;
 
 : derive-url ( to query -- url )
     {
         { [ over "http://" head? ] [ link>string ] }
         { [ over "/" head? ] [ absolute-redirect ] }
+        { [ over "$" head? ] [ >r resolve-base-path r> derive-url ] }
         [ relative-redirect ]
     } cond ;
 
@@ -113,22 +143,17 @@ TUPLE: dispatcher default responders ;
 : <dispatcher> ( -- dispatcher )
     dispatcher new-dispatcher ;
 
-: split-path ( path -- rest first )
-    [ CHAR: / = ] left-trim "/" split1 swap ;
-
 : find-responder ( path dispatcher -- path responder )
-    over split-path pick responders>> at*
+    over empty? [
-    [ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
+        "" over responders>> at*
-
+        [ nip ] [ drop default>> ] if
-: redirect-with-/ ( -- response )
+    ] [
-    request get path>> "/" append f <permanent-redirect> ;
+        over first over responders>> at*
+        [ >r drop 1 tail-slice r> ] [ drop default>> ] if
+    ] if ;
 
 M: dispatcher call-responder ( path dispatcher -- response )
-    over [
+    [ add-base-path ] [ find-responder call-responder ] 2bi ;
-        find-responder call-responder
-    ] [
-        2drop redirect-with-/
-    ] if ;
 
 TUPLE: vhost-dispatcher default responders ;
 
@@ -142,15 +167,13 @@ TUPLE: vhost-dispatcher default responders ;
 M: vhost-dispatcher call-responder ( path dispatcher -- response )
     find-vhost call-responder ;
 
-: set-main ( dispatcher name -- dispatcher )
-    '[ , f <permanent-redirect> ] <trivial-responder>
-    >>default ;
-
 : add-responder ( dispatcher responder path -- dispatcher )
     pick responders>> set-at ;
 
 : add-main-responder ( dispatcher responder path -- dispatcher )
-    [ add-responder ] keep set-main ;
+    [ add-responder drop ]
+    [ drop "" add-responder drop ]
+    [ 2drop ] 3tri ;
 
 SYMBOL: main-responder
 
@@ -160,23 +183,30 @@ drop
 
 SYMBOL: development-mode
 
-: <500> ( error -- response )
+: http-error. ( error -- )
-    500 "Internal server error" <trivial-response>
+    "Internal server error" [
-    swap '[
-        , "Internal server error" [
         development-mode get [
             [ print-error nl :c ] with-html-stream
         ] [
             500 "Internal server error"
             trivial-response-body
         ] if
-        ] simple-page
+    ] simple-page ;
-    ] >>body ;
+
+: <500> ( error -- response )
+    500 "Internal server error" <trivial-response>
+    swap '[ , http-error. ] >>body ;
 
 : do-response ( response -- )
     dup write-response
     request get method>> "HEAD" =
-    [ drop ] [ write-response-body ] if ;
+    [ drop ] [
+        '[
+            , write-response-body
+        ] [
+            http-error.
+        ] recover
+    ] if ;
 
 LOG: httpd-hit NOTICE
 
@@ -190,11 +220,15 @@ SYMBOL: exit-continuation
 : with-exit-continuation ( quot -- )
     '[ exit-continuation set @ ] callcc1 exit-continuation off ;
 
+: split-path ( string -- path )
+    "/" split [ empty? not ] subset ;
+
 : do-request ( request -- response )
     [
+        H{ } clone base-paths set
         [ log-request ]
         [ request set ]
-        [ path>> main-responder get call-responder ] tri
+        [ path>> split-path main-responder get call-responder ] tri
         [ <404> ] unless*
     ] [
         [ \ do-request log-error ]

extra/http/server/sessions/sessions-tests.factor

@@ -61,7 +61,7 @@ M: foo call-responder
     <request>
         "GET" >>method
     request set
-    "/etc" "manager" get call-responder
+    { "etc" } "manager" get call-responder
     response set
 ] unit-test
 
@@ -76,7 +76,7 @@ M: foo call-responder
             "id" get session-id-key set-query-param
             "/" >>path
         request set
-        "/" "manager" get call-responder
+        { } "manager" get call-responder
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
 
@@ -96,7 +96,7 @@ M: foo call-responder
     "GET" >>method
     "/" >>path
     request set
-    "/etc" "manager" get call-responder response set
+    { "etc" } "manager" get call-responder response set
     [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
     response get
 ] with-destructors
@@ -111,7 +111,7 @@ response set
             "cookies" get >>cookies
             "/" >>path
         request set
-        "/" "manager" get call-responder
+        { } "manager" get call-responder
         [ write-response-body drop ] with-string-writer
     ] with-destructors ;
 
@@ -134,7 +134,7 @@ response set
         request set
 
         [
-            "/" <exiting-action> <cookie-sessions>
+            { } <exiting-action> <cookie-sessions>
             call-responder
         ] with-destructors response set
     ] unit-test

extra/http/server/static/static.factor

@@ -69,32 +69,24 @@ TUPLE: file-responder root hook special ;
     swap '[ , directory. ] >>body ;
 
 : find-index ( filename -- path )
-    { "index.html" "index.fhtml" } [ append-path ] with map
+    "index.html" append-path dup exists? [ drop f ] unless ;
-    [ exists? ] find nip ;
 
 : serve-directory ( filename -- response )
-    dup "/" tail? [
+    request get path>> "/" tail? [
-        dup find-index
+        dup
-        [ serve-file ] [ list-directory ] ?if
+        find-index [ serve-file ] [ list-directory ] ?if
     ] [
-        drop request get redirect-with-/
+        drop
+        request get path>> "/" append f <permanent-redirect>
     ] if ;
 
 : serve-object ( filename -- response )
-    serving-path dup exists? [
+    serving-path dup exists?
-        dup directory? [ serve-directory ] [ serve-file ] if
+    [ dup directory? [ serve-directory ] [ serve-file ] if ]
-    ] [
+    [ drop <404> ]
-        drop <404>
+    if ;
-    ] if ;
 
 M: file-responder call-responder ( path responder -- response )
     file-responder set
-    dup [
+    ".." over member?
-        ".." over subseq? [
+    [ drop <400> ] [ "/" join serve-object ] if ;
-            drop <400>
-        ] [
-            serve-object
-        ] if
-    ] [
-        drop redirect-with-/
-    ] if ;

extra/http/server/templating/chloe/chloe.factor

@@ -104,7 +104,8 @@ SYMBOL: tags
 : form-start-tag ( tag -- )
     <form
     "POST" =method
-    tag-attrs print-attrs
+    [ "action" required-attr resolve-base-path =action ]
+    [ tag-attrs [ drop name-tag "action" = not ] assoc-subset print-attrs ] bi
     form>
     hidden-form-field ;
 
@@ -153,6 +154,7 @@ SYMBOL: tags
         { "form" [ form-tag ] }
         { "error" [ error-tag ] }
         { "if" [ if-tag ] }
+        { "comment" [ drop ] }
         { "call-next-template" [ drop call-next-template ] }
         [ "Unknown chloe tag: " swap append throw ]
     } case ;
@@ -189,7 +191,7 @@ SYMBOL: tags
         ] if
     ] with-scope ;
 
-M: chloe call-template
+M: chloe call-template*
     path>> utf8 <file-reader> read-xml process-chloe ;
 
 INSTANCE: chloe template

extra/http/server/templating/fhtml/fhtml.factor

@@ -76,7 +76,7 @@ TUPLE: fhtml path ;
 
 C: <fhtml> fhtml
 
-M: fhtml call-template ( filename -- )
+M: fhtml call-template* ( filename -- )
     '[
         , path>> [
             "quiet" on

extra/http/server/templating/templating.factor

@@ -1,10 +1,21 @@
-USING: accessors kernel fry io.encodings.utf8 io.files
+USING: accessors kernel fry io io.encodings.utf8 io.files
-http http.server ;
+http http.server debugger prettyprint continuations ;
 IN: http.server.templating
 
 MIXIN: template
 
-GENERIC: call-template ( 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 ;
 

extra/io/mmap/mmap-tests.factor

@@ -2,9 +2,11 @@ USING: io io.mmap io.files kernel tools.test continuations
 sequences io.encodings.ascii accessors ;
 IN: io.mmap.tests
 
-[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
+[ "resource:mmap-test-file.txt" delete-file ] ignore-errors
-[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
+[ ] [ "12345" "resource:mmap-test-file.txt" ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ ] [ "resource:mmap-test-file.txt" dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
+[ 5 ] [ "resource:mmap-test-file.txt" dup file-info size>> [ length ] with-mapped-file ] unit-test
-[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
+[ "22345" ] [ "resource:mmap-test-file.txt" ascii file-contents ] unit-test
-[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
+[ "resource:mmap-test-file.txt" delete-file ] ignore-errors
+
+

extra/io/mmap/mmap.factor

@@ -21,7 +21,10 @@ M: mapped-file set-nth-unsafe
 
 INSTANCE: mapped-file sequence
 
-HOOK: <mapped-file> io-backend ( path length -- mmap )
+HOOK: (mapped-file) io-backend ( path length -- mmap )
+
+: <mapped-file> ( path length -- mmap )
+    >r normalize-path r> (mapped-file) ;
 
 HOOK: close-mapped-file io-backend ( mmap -- )
 

extra/io/unix/mmap/mmap.factor

@@ -10,7 +10,7 @@ IN: io.unix.mmap
     >r f -roll r> open-r/w [ 0 mmap ] keep
     over MAP_FAILED = [ close (io-error) ] when ;
 
-M: unix <mapped-file> ( path length -- obj )
+M: unix (mapped-file) ( path length -- obj )
     swap >r
     dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
     r> mmap-open f mapped-file boa ;

extra/io/windows/mmap/mmap.factor

@@ -70,7 +70,7 @@ M: wince with-privileges
         dup close-later
     ] with-privileges ;
     
-M: windows <mapped-file> ( path length -- mmap )
+M: windows (mapped-file) ( path length -- mmap )
     [
         swap
         GENERIC_WRITE GENERIC_READ bitor

extra/io/windows/nt/monitors/monitors.factor

@@ -98,7 +98,7 @@ TUPLE: win32-monitor < monitor port ;
 
 M:: winnt (monitor) ( path recursive? mailbox -- monitor )
     [
-        path mailbox win32-monitor new-monitor
+        path normalize-path mailbox win32-monitor new-monitor
             path open-directory \ win32-monitor-port <buffered-port>
                 recursive? >>recursive
             >>port

extra/math/miller-rabin/miller-rabin.factor

@@ -1,4 +1,4 @@
-USING: combinators combinators.lib io locals kernel math
+eSING: combinators combinators.lib io locals kernel math
 math.functions math.ranges namespaces random sequences
 hashtables sets ;
 IN: math.miller-rabin
@@ -76,7 +76,9 @@ TUPLE: miller-rabin-bounds ;
 : find-relative-prime ( n -- p )
     dup random find-relative-prime* ;
 
+ERROR: too-few-primes ;
+
 : unique-primes ( numbits n -- seq )
     #! generate two primes
-    over 5 < [ "not enough primes below 5 bits" throw ] when
+    over 5 < [ too-few-primes ] when
     [ [ drop random-prime ] with map ] [ all-unique? ] generate ;

extra/project-euler/100/100.factor

@@ -0,0 +1,7 @@
+USING: kernel sequences math.functions math ;
+IN: project-euler.100
+
+: euler100 ( -- n )
+    1 1
+    [ dup dup 1- * 2 * 10 24 ^ <= ]
+    [ tuck 6 * swap - 2 - ] [ ] while nip ;

extra/project-euler/151/151.factor

@@ -0,0 +1,40 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences combinators kernel sequences.lib math assocs namespaces ;
+IN: project-euler.151
+
+SYMBOL: table
+
+: (pick-sheet) ( seq i -- newseq )
+    [
+        <=> sgn
+        {
+            { -1 [ ] }
+            {  0 [ 1- ] }
+            {  1 [ 1+ ] }
+        } case
+    ] curry map-index ;
+
+DEFER: (euler151)
+
+: pick-sheet ( seq i -- res )
+    2dup swap nth dup zero? [
+        3drop 0
+    ] [
+        [ (pick-sheet) (euler151) ] dip *
+    ] if ;
+
+: (euler151) ( x -- y )
+    table get [ {
+        { { 0 0 0 1 } [ 0 ] }
+        { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1+ ] }
+        { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1+ ] }
+        { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1+ ] }
+        [ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
+     } case ] cache ;
+
+: euler151 ( -- n )
+    [
+        H{ } clone table set
+        { 1 1 1 1 } (euler151)
+    ] with-scope ;

extra/project-euler/190/190.factor

@@ -0,0 +1,48 @@
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.lib math math.functions math.ranges locals ;
+IN: project-euler.190
+
+! PROBLEM
+! -------
+
+! http://projecteuler.net/index.php?section=problems&id=190
+
+! Let Sm = (x1, x2, ... , xm) be the m-tuple of positive real numbers
+! with x1 + x2 + ... + xm = m for which Pm = x1 * x22 * ... * xmm is
+! maximised.
+
+! For example, it can be verified that [P10] = 4112 ([ ] is the integer
+! part function).
+
+! Find Σ[Pm] for 2 ≤ m ≤ 15.
+
+! SOLUTION
+! --------
+
+! Pm = x1 * x2^2 * x3^3 * ... * xm^m
+! fm = x1 + x2 + x3 + ... + xm - m = 0
+! Gm === Pm - L * fm
+! dG/dx_i = 0 = i * Pm / xi - L
+! xi = i * Pm / L
+
+! Sum(i=1 to m) xi = m
+! Sum(i=1 to m) i * Pm / L = m
+! Pm / L * Sum(i=1 to m) i = m
+! Pm / L * m*(m+1)/2 = m
+! Pm / L = 2 / (m+1)
+
+! xi = i * (2 / (m+1)) = 2*i/(m+1)
+
+<PRIVATE
+
+: PI ( seq quot -- n )
+    [ * ] compose 1 swap reduce ; inline
+
+PRIVATE>
+
+:: P_m ( m -- P_m )
+    m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
+
+: euler190 ( -- n )
+    2 15 [a,b] [ P_m truncate ] sigma ;

extra/rss/rss-tests.factor

@@ -5,7 +5,7 @@ IN: rss.tests
 : load-news-file ( filename -- feed )
     #! Load an news syndication file and process it, returning
     #! it as an feed tuple.
-    utf8 <file-reader> read-feed ;
+    utf8 file-contents read-feed ;
 
 [ T{
     feed
@@ -36,7 +36,7 @@ IN: rss.tests
             "http://example.org/2005/04/02/atom"
             "\n         <div xmlns=\"http://www.w3.org/1999/xhtml\">\n           <p><i>[Update: The Atom draft is finished.]</i></p>\n         </div>\n       "
 
-            T{ timestamp f 2003 12 13 8 29 29 -4 }
+            T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
         }
     }
 } ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test

extra/rss/rss.factor

@@ -23,7 +23,7 @@ C: <entry> entry
     [ "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 rfc3339>timestamp ] when
+    tag-named dup [ children>string rfc822>timestamp ] when
     <entry> ;
 
 : rss1.0 ( xml -- feed )
@@ -39,7 +39,7 @@ C: <entry> entry
     [ "link" tag-named ] keep
     [ "guid" tag-named dupd ? children>string ] keep
     [ "description" tag-named children>string ] keep
-    "pubDate" tag-named children>string rfc3339>timestamp <entry> ;
+    "pubDate" tag-named children>string rfc822>timestamp <entry> ;
 
 : rss2.0 ( xml -- feed )
     "channel" tag-named 
@@ -71,16 +71,12 @@ C: <entry> entry
         { "feed" [ atom1.0 ] }
     } case ;
 
-: read-feed ( stream -- feed )
+: read-feed ( string -- feed )
-    [ read-xml ] with-html-entities xml>feed ;
+    [ string>xml xml>feed ] with-html-entities ;
 
 : download-feed ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
-    http-get-stream swap code>> success? [
+    http-get read-feed ;
-        read-feed
-    ] [
-        dispose "Error retrieving newsfeed file" throw
-    ] if ;
 
 ! Atom generation
 : simple-tag, ( content name -- )

extra/sequences/lib/lib.factor

@@ -52,7 +52,7 @@ MACRO: firstn ( n -- )
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : sigma ( seq quot -- n )
-    [ rot slip + ] curry 0 swap reduce ; inline
+    [ + ] compose 0 swap reduce ; inline
 
 : count ( seq quot -- n )
     [ 1 0 ? ] compose sigma ; inline
@@ -131,6 +131,10 @@ MACRO: firstn ( n -- )
     [ find drop [ head-slice ] when* ] curry
     [ dup ] swap compose keep like ;
 
+: replicate ( seq quot -- newseq )
+    #! quot: ( -- obj )
+    [ drop ] swap compose map ; inline
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 <PRIVATE
@@ -236,3 +240,6 @@ PRIVATE>
 
 : remove-nth ( seq n -- seq' )
     cut-slice 1 tail-slice append ;
+
+: short ( seq n -- seq n' )
+    over length min ; inline

extra/smtp/smtp.factor

@@ -131,7 +131,7 @@ M: email clone
         "-" %
         millis #
         "@" %
-        smtp-domain get %
+        smtp-domain get [ host-name ] unless* %
         ">" %
     ] "" make ;
 

extra/ui/cocoa/views/views.factor

@@ -126,6 +126,13 @@ CLASS: {
     { +name+ "FactorView" }
     { +protocols+ { "NSTextInput" } }
 }
+
+! Rendering
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+    [ 3drop window relayout-1 ]
+}
+
 ! Events
 { "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
     [ 3drop 1 ]

extra/webapps/factor-website/factor-website.factor

@@ -0,0 +1,71 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences assocs io.files io.sockets
+namespaces db db.sqlite smtp
+http.server
+http.server.db
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db
+http.server.boilerplate
+http.server.templating.chloe
+webapps.pastebin
+webapps.planet
+webapps.todo ;
+IN: webapps.factor-website
+
+: test-db "test.db" resource-path sqlite-db ;
+
+: factor-template ( path -- template )
+    "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
+
+: <factor-boilerplate> ( responder -- responder' )
+    <login>
+        users-in-db >>users
+        allow-registration
+        allow-password-recovery
+        allow-edit-profile
+    <boilerplate>
+        "page" factor-template >>template
+    <url-sessions>
+        sessions-in-db >>sessions
+    test-db <db-persistence> ;
+
+: <pastebin-app> ( -- responder )
+    <pastebin> <factor-boilerplate> ;
+
+: <planet-app> ( -- responder )
+    <planet-factor> <factor-boilerplate> ;
+
+: <todo-app> ( -- responder )
+    <todo-list> <protected> <factor-boilerplate> ;
+
+: init-factor-db ( -- )
+    test-db [
+        init-users-table
+        init-sessions-table
+
+        init-pastes-table
+        init-annotations-table
+
+        init-blog-table
+
+        init-todo-table
+    ] with-db ;
+
+: <factor-website> ( -- responder )
+    <dispatcher>
+        <todo-app> "todo" add-responder
+        <pastebin-app> "pastebin" add-responder
+        <planet-app> "planet" add-responder ;
+
+: init-factor-website ( -- )
+    "factorcode.org" 25 <inet> smtp-server set-global
+    "todo@factorcode.org" lost-password-from set-global
+
+    init-factor-db
+
+    <factor-website> main-responder set-global
+
+    "planet" main-responder get responders>> at start-update-task ;

extra/webapps/factor-website/page.xml

@@ -10,34 +10,26 @@
 		<head>
 			<t:write-title />
 
-			<t:write-atom />
+			<t:style include="resource:extra/xmode/code2html/stylesheet.css" />
 
 			<t:style>
+				body, button {
+					font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+					color:#444;
+				}
+
 				.link-button {
 					padding: 0px;
 					background: none;
 					border: none;
 				}
 
-				.inline {
-					display: inline;
-				}
-
-				body, button {
-					font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
-					color:#444;
-				}
-
 				a, .link {
 					color: #222;
 					border-bottom:1px dotted #666;
 					text-decoration:none;
 				}
 
-				h1 a {
-					border: none;
-				}
-
 				a:hover, .link:hover {
 					border-bottom:1px solid #66a;
 				}
@@ -47,15 +39,34 @@
 				.field-label {
 					text-align: right;
 				}
+
+				.inline {
+					display: inline;
+				}
+				
+				.navbar {
+					background-color: #eee;
+					padding: 5px;
+					border: 1px solid #ccc;
+				}
+
+				.big-field-label {
+					vertical-align: top;
+				}
+				
+				.description {
+					border: 1px dashed #ccc;
+					background-color: #f5f5f5;
+					padding: 5px;
+					font-size: 150%;
+					color: #000000;
+				}
 			</t:style>
 
 			<t:write-style />
 		</head>
 
 		<body>
-
-			<h1><t:a href="planet"><t:write-title /></t:a></h1>
-
 			<t:call-next-template />
 		</body>
 

extra/webapps/pastebin/annotation.xml

@@ -0,0 +1,23 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<h2>Annotation: <t:view component="summary" /></h2>
+
+	<table>
+		<tr><th class="field-label">Author:  </th><td><t:view component="author"  /></td></tr>
+		<tr><th class="field-label">Mode:    </th><td><t:view component="mode"    /></td></tr>
+		<tr><th class="field-label">Date:    </th><td><t:view component="date"    /></td></tr>
+	</table>
+
+	<div class="description">
+		<t:view component="contents" />
+	</div>
+
+	<t:form action="$pastebin/delete-annotation" class="inline">
+		<t:edit component="id" />
+		<t:edit component="aid" />
+		<button class="link-button link">Delete Annotation</button>
+	</t:form>
+
+</t:chloe>

extra/webapps/pastebin/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/webapps/pastebin/new-annotation.xml

@@ -0,0 +1,25 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>New Annotation</t:title>
+
+	<t:form action="$pastebin/annotate">
+		<t:edit component="id" />
+
+		<table>
+			<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
+			<tr><th class="field-label">Author: </th><td><t:edit component="author" /></td></tr>
+			<tr><th class="field-label">Mode: </th><td><t:edit component="mode" /></td></tr>
+			<tr><th class="field-label big-field-label">Description:</th><td><t:edit component="contents" /></td></tr>
+			<tr><th class="field-label">Captcha: </th><td><t:edit 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>

extra/webapps/pastebin/new-paste.xml

@@ -0,0 +1,23 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>New Paste</t:title>
+
+	<t:form action="$pastebin/new-paste">
+
+		<table>
+			<tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
+			<tr><th class="field-label">Author: </th><td><t:edit component="author" /></td></tr>
+			<tr><th class="field-label">Mode: </th><td><t:edit component="mode" /></td></tr>
+			<tr><th class="field-label big-field-label">Description: </th><td><t:edit component="contents" /></td></tr>
+			<tr><th class="field-label">Captcha: </th><td><t:edit 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="Submit" />
+	</t:form>
+</t:chloe>

extra/webapps/pastebin/paste-list.xml

@@ -0,0 +1,15 @@
+<?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 component="pastes" />
+	</table>
+
+</t:chloe>

extra/webapps/pastebin/paste-summary.xml

@@ -0,0 +1,11 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<tr>
+		<td><t:a href="view-paste" query="id"><t:view component="summary" /></t:a></td>
+		<td><t:view component="author" /></td>
+		<td><t:view component="date" /></td>
+	</tr>
+
+</t:chloe>

extra/webapps/pastebin/paste.xml

@@ -0,0 +1,27 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Pastebin</t:title>
+
+	<h2>Paste: <t:view component="summary" /></h2>
+
+	<table>
+		<tr><th class="field-label">Author:  </th><td><t:view component="author"  /></td></tr>
+		<tr><th class="field-label">Mode:    </th><td><t:view component="mode"    /></td></tr>
+		<tr><th class="field-label">Date:    </th><td><t:view component="date"    /></td></tr>
+	</table>
+
+	<div class="description">
+		<t:view component="contents" />
+	</div>
+
+	<t:form action="$pastebin/delete-paste" class="inline">
+		<t:edit component="id" />
+		<button class="link-button link">Delete Paste</button>
+	</t:form>
+	|
+	<t:a href="$pastebin/annotate" query="id">Annotate</t:a>
+
+	<t:view component="annotations" />
+</t:chloe>

extra/webapps/pastebin/pastebin.css

@@ -0,0 +1,7 @@
+pre.code {
+	border:1px dashed #ccc;
+	background-color:#f5f5f5;
+	padding:5px;
+	font-size:150%;
+	color:#000000;
+}

extra/webapps/pastebin/pastebin.factor

@@ -0,0 +1,253 @@
+USING: namespaces assocs sorting sequences kernel accessors
+hashtables sequences.lib locals db.types db.tuples db
+calendar calendar.format rss xml.writer
+xmode.catalog
+http.server
+http.server.crud
+http.server.actions
+http.server.components
+http.server.components.code
+http.server.templating.chloe
+http.server.boilerplate
+http.server.validators
+http.server.forms ;
+IN: webapps.pastebin
+
+: <mode> ( id -- component )
+    modes keys natural-sort <choice> ;
+
+: pastebin-template ( name -- template )
+    "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
+
+TUPLE: paste id summary author mode date contents annotations captcha ;
+
+paste "PASTE"
+{
+    { "id" "ID" INTEGER +native-id+ }
+    { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
+    { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
+    { "mode" "MODE" { VARCHAR 256 } +not-null+ }
+    { "date" "DATE" DATETIME +not-null+ }
+    { "contents" "CONTENTS" TEXT +not-null+ }
+} define-persistent
+
+: <paste> ( id -- paste )
+    paste new
+        swap >>id ;
+
+: pastes ( -- pastes )
+    f <paste> select-tuples ;
+
+TUPLE: annotation aid id summary author mode contents date captcha ;
+
+annotation "ANNOTATION"
+{
+    { "aid" "AID" INTEGER +native-id+ }
+    { "id" "ID" INTEGER +not-null+ }
+    { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
+    { "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
+    { "mode" "MODE" { VARCHAR 256 } +not-null+ }
+    { "date" "DATE" DATETIME +not-null+ }
+    { "contents" "CONTENTS" TEXT +not-null+ }
+} define-persistent
+
+: <annotation> ( id aid -- annotation )
+    annotation new
+        swap >>aid
+        swap >>id ;
+
+: fetch-annotations ( paste -- paste )
+    dup annotations>> [
+        dup id>> f <annotation> select-tuples >>annotations
+    ] unless ;
+
+: <annotation-form> ( -- form )
+    "paste" <form>
+        "id" <integer>
+            hidden >>renderer
+            add-field
+        "aid" <integer>
+            hidden >>renderer
+            add-field
+        "annotation" pastebin-template >>view-template
+        "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 )
+    "paste" <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
+
+        [
+            "id" get f ctor call
+
+            from-tuple form set-defaults
+        ] >>init
+
+        [ form edit-form ] >>display
+
+        [
+            f f ctor call from-tuple
+
+            form validate-form
+
+            values-tuple insert-tuple
+
+            "id" value next <id-redirect>
+        ] >>submit ;
+
+: pastebin-feed-entries ( -- entries )
+    pastes <reversed> 20 short head [
+        [ summary>> ]
+        [ "$pastebin/view-paste" swap id>> "id" associate link>string ]
+        [ date>> ] tri
+        f swap <entry>
+    ] map ;
+
+: pastebin-feed ( -- feed )
+    feed new
+        "Factor Pastebin" >>title
+        "http://paste.factorcode.org" >>link
+        pastebin-feed-entries >>entries ;
+
+: <feed-action> ( -- action )
+    <action>
+        [
+            "text/xml" <content>
+            [ pastebin-feed feed>xml write-xml ] >>body
+        ] >>display ;
+
+:: <view-paste-action> ( form ctor -- action )
+    <action>
+        { { "id" [ v-number ] } } >>get-params
+
+        [ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init
+
+        [ form view-form ] >>display ;
+
+:: <delete-paste-action> ( ctor next -- action )
+    <action>
+        { { "id" [ v-number ] } } >>post-params
+
+        [
+            "id" get ctor call delete-tuple
+
+            "id" get f <annotation> select-tuples [ delete-tuple ] each
+
+            next f <permanent-redirect>
+        ] >>submit ;
+
+:: <delete-annotation-action> ( ctor next -- action )
+    <action>
+        { { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
+
+        [
+            "id" get "aid" get ctor call delete-tuple
+
+            "id" get next <id-redirect>
+        ] >>submit ;
+
+:: <new-paste-action> ( form ctor next -- action )
+    <action>
+        [
+            f ctor call from-tuple
+
+            form set-defaults
+        ] >>init
+
+        [ form edit-form ] >>display
+
+        [
+            f ctor call from-tuple
+
+            form validate-form
+
+            values-tuple insert-tuple
+
+            "id" value next <id-redirect>
+        ] >>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> "delete-paste" add-responder
+                   [ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> "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
+    <boilerplate>
+        "pastebin" pastebin-template >>template ;
+
+: init-pastes-table paste ensure-table ;
+
+: init-annotations-table annotation ensure-table ;

extra/webapps/pastebin/pastebin.xml

@@ -0,0 +1,29 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:atom title="Pastebin - Atom" href="$pastebin/feed.xml" />
+
+	<t:style include="resource:extra/webapps/pastebin/pastebin.css" />
+
+	<div class="navbar">
+		  <t:a href="$pastebin/list">Pastes</t:a>
+		| <t:a href="$pastebin/new-paste">New Paste</t:a>
+		| <t:a href="$pastebin/feed.xml">Atom Feed</t:a>
+
+		<t:comment>
+		<t:if code="http.server.auth.login:allow-edit-profile?">
+			| <t:a href="$login/edit-profile">Edit Profile</t:a>
+		</t:if>
+
+		<t:form action="$login/logout" class="inline">
+			| <button type="submit" class="link-button link">Logout</button>
+		</t:form>
+		</t:comment>
+	</div>
+
+	<h1><t:write-title /></h1>
+
+        <t:call-next-template />
+
+</t:chloe>

extra/webapps/planet/admin.xml

@@ -0,0 +1,14 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Planet Factor Administration</t:title>
+
+	<t:summary component="blogroll" />
+
+	<p>
+		<t:a href="$planet-factor/admin/edit-blog">Add Blog</t:a>
+		| <t:a href="$planet-factor/admin/update">Update</t:a>
+	</p>
+
+</t:chloe>

extra/webapps/planet/blog-admin-link.xml

@@ -2,6 +2,6 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:a href="view-blog" query="id"><t:view component="name" /></t:a>
+	<t:a href="$planet-factor/admin/edit-blog" query="id"><t:view component="name" /></t:a>
 
 </t:chloe>

extra/webapps/planet/edit-blog.xml

@@ -4,7 +4,7 @@
 
 	<t:title>Edit Blog</t:title>
 
-	<t:form action="edit-blog">
+	<t:form action="$planet-factor/admin/edit-blog">
 
 		<t:edit component="id" />
 
@@ -21,8 +21,8 @@
 			</tr>
 
 			<tr>
-				<th class="field-label">Atom feed:</th>
+				<th class="field-label">Feed:</th>
-				<td><t:edit component="atom-url" /></td>
+				<td><t:edit component="feed-url" /></td>
 			</tr>
 
 		</table>
@@ -31,9 +31,7 @@
 
 	</t:form>
 
-	<t:a href="view" query="id">View</t:a>
+	<t:form action="$planet-factor/admin/delete-blog" class="inline">
-	|
-	<t:form action="delete-blog" class="inline">
 		<t:edit component="id" />
 		<button type="submit" class="link-button link">Delete</button>
 	</t:form>

extra/webapps/planet/entry.xml

@@ -2,8 +2,16 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<h2 class="posting-title"><t:view component="title" /></h2>
+	<h2 class="posting-title">
-	<p class="posting-body"> <t:view component="description" /> </p>
+		<t:a value="link"><t:view component="title" /></t:a>
-	<p class="posting-date"> <t:view component="pub-date" /> </p>
+	</h2>
+
+	<p class="posting-body">
+		<t:view component="description" />
+	</p>
+
+	<p class="posting-date">
+		<t:a value="link"><t:view component="pub-date" /></t:a>
+	</p>
 
 </t:chloe>

extra/webapps/planet/planet.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sorting locals math
-calendar alarms logging concurrency.combinators
+calendar alarms logging concurrency.combinators namespaces
-db.types db.tuples db
+sequences.lib db.types db.tuples db
 rss xml.writer
 http.server
 http.server.crud
@@ -10,17 +10,27 @@ http.server.forms
 http.server.actions
 http.server.boilerplate
 http.server.templating.chloe
-http.server.components ;
+http.server.components
+http.server.auth.login ;
 IN: webapps.planet
 
-TUPLE: blog id name www-url atom-url ;
+TUPLE: planet-factor < dispatcher postings ;
+
+: planet-template ( name -- template )
+    "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+
+TUPLE: blog id name www-url feed-url ;
+
+M: blog link-title name>> ;
+
+M: blog link-href www-url>> ;
 
 blog "BLOGS"
 {
     { "id" "ID" INTEGER +native-id+ }
     { "name" "NAME" { VARCHAR 256 } +not-null+ }
     { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
-    { "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ }
+    { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
 } define-persistent
 
 : init-blog-table blog ensure-table ;
@@ -29,8 +39,8 @@ blog "BLOGS"
     blog new
         swap >>id ;
 
-: planet-template ( name -- template )
+: blogroll ( -- seq )
-    "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+    f <blog> select-tuples [ [ name>> ] compare ] sort ;
 
 : <entry-form> ( -- form )
     "entry" <form>
@@ -43,8 +53,7 @@ blog "BLOGS"
 : <blog-form> ( -- form )
     "blog" <form>
         "edit-blog" planet-template >>edit-template
-        "view-blog" planet-template >>view-template
+        "blog-admin-link" planet-template >>summary-template
-        "blog-summary" planet-template >>summary-template
         "id" <integer>
             hidden >>renderer
             add-field
@@ -54,21 +63,33 @@ blog "BLOGS"
         "www-url" <url>
             t >>required
             add-field
-        "atom-url" <url>
+        "feed-url" <url>
             t >>required
             add-field ;
 
 : <planet-factor-form> ( -- form )
     "planet-factor" <form>
-        "planet" planet-template >>view-template
+        "postings" planet-template >>view-template
-        "mini-planet" planet-template >>summary-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 ;
 
-: blogroll ( -- seq )
+:: <edit-blogroll-action> ( planet -- action )
-    f <blog> select-tuples [ [ name>> ] compare ] sort ;
+    [let | form [ <admin-form> ] |
+        <action>
+            [
+                blank-values
 
-TUPLE: planet-factor < dispatcher postings ;
+                blogroll "blogroll" set-value
+
+                form view-form
+            ] >>display
+    ] ;
 
 :: <planet-action> ( planet -- action )
     [let | form [ <planet-factor-form> ] |
@@ -83,14 +104,11 @@ TUPLE: planet-factor < dispatcher postings ;
             ] >>display
     ] ;
 
-: safe-head ( seq n -- seq' )
-    over length min head ;
-
 :: planet-feed ( planet -- feed )
     feed new
-        "[ planet-factor ]" >>title
+        "Planet Factor" >>title
         "http://planet.factorcode.org" >>link
-        planet postings>> 30 safe-head >>entries ;
+        planet postings>> 16 short head >>entries ;
 
 :: <feed-action> ( planet -- action )
     <action>
@@ -109,7 +127,7 @@ TUPLE: planet-factor < dispatcher postings ;
 
 : fetch-blogroll ( blogroll -- entries )
     dup
-    [ atom-url>> fetch-feed ] parallel-map
+    [ feed-url>> fetch-feed ] parallel-map
     [ >r name>> r> [ <posting> ] with map ] 2map concat ;
 
 : sort-entries ( entries -- entries' )
@@ -117,7 +135,8 @@ TUPLE: planet-factor < dispatcher postings ;
 
 : update-cached-postings ( planet -- )
     "webapps.planet" [
-        blogroll fetch-blogroll sort-entries >>postings drop
+        blogroll fetch-blogroll sort-entries 8 short head
+        >>postings drop
     ] with-logging ;
 
 :: <update-action> ( planet -- action )
@@ -127,48 +146,26 @@ TUPLE: planet-factor < dispatcher postings ;
             "" f <temporary-redirect>
         ] >>display ;
 
-: start-update-task ( planet -- )
+:: <planet-factor-admin> ( planet-factor -- responder )
-    [ update-cached-postings ] curry 10 minutes every drop ;
-
-:: <planet-factor> ( -- responder )
     [let | blog-form [ <blog-form> ]
            blog-ctor [ [ <blog> ] ] |
-        planet-factor new-dispatcher
+        <dispatcher>
-            dup <planet-action> >>default
+            planet-factor <edit-blogroll-action> >>default
-            dup <feed-action> "feed.xml" add-responder
+
-            dup <update-action> "update" add-responder
+            planet-factor <update-action> "update" add-responder
 
             ! Administrative CRUD
-                      blog-ctor ""          <delete-action> "delete-blog" add-responder
+                      blog-ctor "$planet-factor/admin"          <delete-action> "delete-blog" add-responder
-            blog-form blog-ctor             <view-action>   "view-blog"   add-responder
+            blog-form blog-ctor "$planet-factor/admin" <edit-action>   "edit-blog"   add-responder
-            blog-form blog-ctor "view-blog" <edit-action>   "edit-blog"   add-responder
     ] ;
 
-USING: namespaces io.files io.sockets
+: <planet-factor> ( -- responder )
-db.sqlite smtp
+    planet-factor new-dispatcher
-http.server.db
+        dup <planet-action> "list" add-main-responder
-http.server.sessions
+        dup <feed-action> "feed.xml" add-responder
-http.server.auth.login
+        dup <planet-factor-admin> <protected> "admin" add-responder
-http.server.auth.providers.db
-http.server.sessions.storage.db ;
-
-: test-db "planet.db" resource-path sqlite-db ;
-
-: <planet-app> ( -- responder )
-    <planet-factor>
     <boilerplate>
-        "page" planet-template >>template
+        "planet" planet-template >>template ;
-    ! <url-sessions>
-    !     sessions-in-db >>sessions
-    test-db <db-persistence> ;
 
-: init-planet ( -- )
+: start-update-task ( planet -- )
-    ! test-db [
+    [ update-cached-postings ] curry 10 minutes every drop ;
-    !     init-blog-table
-        ! init-users-table
-        ! init-sessions-table
-    ! ] with-db
-
-    <dispatcher>
-        <planet-app> "planet" add-responder
-    main-responder set-global ;

extra/webapps/planet/planet.xml

@@ -2,36 +2,29 @@
 
 <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
 
-	<t:title>Planet Factor</t:title>
+<t:comment>
-
+	<t:atom title="Planet Factor - Atom" href="$planet/feed.xml" />
-	<t:atom title="Planet Factor - Atom" href="feed.xml" />
+</t:comment>
-
 	<t:style include="resource:extra/webapps/planet/planet.css" />
 
-	<table width="100%" cellpadding="10">
+	<div class="navbar">
-		<tr>
+		  <t:a href="$planet-factor/list">Front Page</t:a>
-			<td> <t:view component="postings" /> </td>
+		| <t:a href="$planet-factor/feed.xml">Atom Feed</t:a>
+		| <t:a href="$planet-factor/admin">Admin</t:a>
 
-			<td valign="top" width="25%" class="infobox">
+		<t:comment>
-				<p>
+		<t:if code="http.server.auth.login:allow-edit-profile?">
-					<strong>planet-factor</strong> is an Atom feed aggregator that collects the
+			| <t:a href="$login/edit-profile">Edit Profile</t:a>
-					contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It was inspired by
+		</t:if>
-					<a href="http://planet.lisp.org">Planet Lisp</a>.
-				</p>
-				<p>
-					<img src="http://planet.lisp.org/feed-icon-14x14.png" />
-					<a href="feed.xml"> Syndicate </a>
-				</p>
 
-				<h2>Blogroll</h2>
+		<t:form action="$login/logout" class="inline">
+			| <button type="submit" class="link-button link">Logout</button>
+		</t:form>
+		</t:comment>
+	</div>
 
-				<t:summary component="blogroll" />
+	<h1><t:write-title /></h1>
 
-				Admin: <t:a href="edit-blog">Add Blog</t:a>
+        <t:call-next-template />
-				|
-				<t:a href="update">Update</t:a>
-			</td>
-		</tr>
-	</table>
 
 </t:chloe>

extra/webapps/planet/postings.xml

@@ -0,0 +1,19 @@
+<?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 component="postings" /> </td>
+  
+                        <td valign="top" width="25%" class="infobox">
+                                <h2>Blogroll</h2>
+  
+                                <t:summary component="blogroll" />
+                        </td>
+                </tr>
+        </table>
+
+</t:chloe>

extra/webapps/planet/view-blog.xml

@@ -1,41 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-	<t:title>View Blog</t:title>
-
-	<table>
-
-		<tr>
-			<th class="field-label">Blog name:</th>
-			<td><t:view component="name" /></td>
-		</tr>
-
-		<tr>
-			<th class="field-label">Home page:</th>
-			<td>
-				<t:a value="www-url">
-					<t:view component="www-url" />
-				</t:a>
-			</td>
-		</tr>
-
-		<tr>
-			<th class="field-label">Atom feed:</th>
-			<td>
-				<t:a value="atom-url">
-					<t:view component="atom-url" />
-				</t:a>
-			</td>
-		</tr>
-
-	</table>
-
-	<t:a href="edit-blog" query="id">Edit</t:a>
-	|
-	<t:form action="delete-blog" class="inline">
-		<t:edit component="id" />
-		<button type="submit" class="link-button link">Delete</button>
-	</t:form>
-
-</t:chloe>

extra/webapps/todo/edit-todo.xml

@@ -4,7 +4,7 @@
 
 	<t:title>Edit Item</t:title>
 
-	<t:form action="edit">
+	<t:form action="$todo-list/edit">
 		<t:edit component="id" />
 
 		<table>
@@ -16,9 +16,9 @@
 		<input type="SUBMIT" value="Done" />
 	</t:form>
 
-	<t:a href="view" query="id">View</t:a>
+	<t:a href="$todo-list/view" query="id">View</t:a>
 	|
-	<t:form action="delete" class="inline">
+	<t:form action="$todo-list/delete" class="inline">
 		<t:edit component="id" />
 		<button type="submit" class="link-button link">Delete</button>
 	</t:form>

extra/webapps/todo/page.xml

@@ -1,45 +0,0 @@
-<?xml version='1.0' ?>
-
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
-	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-
-<html xmlns="http://www.w3.org/1999/xhtml">
-
-	<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-		<head>
-			<t:write-title />
-
-			<t:style>
-				body, button {
-					font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
-					color:#444;
-				}
-
-				a, .link {
-					color: #222;
-					border-bottom:1px dotted #666;
-					text-decoration:none;
-				}
-				
-				a:hover, .link:hover {
-					border-bottom:1px solid #66a;
-				}
-
-				.error { color: #a00; }
-				
-				.field-label {
-					text-align: right;
-				}
-			</t:style>
-
-			<t:write-style />
-		</head>
-
-		<body>
-			<t:call-next-template />
-		</body>
-
-	</t:chloe>
-
-</html>

extra/webapps/todo/todo-summary.xml

@@ -10,10 +10,10 @@
 			<t:view component="priority" />
 		</td>
 		<td>
-			<t:a href="view" query="id">View</t:a>
+			<t:a href="$todo-list/view" query="id">View</t:a>
 		</td>
 		<td>
-			<t:a href="edit" query="id">Edit</t:a>
+			<t:a href="$todo-list/edit" query="id">Edit</t:a>
 		</td>
 	</tr>
 

extra/webapps/todo/todo.css

@@ -1,31 +1,3 @@
-.big-field-label {
-	vertical-align: top;
-}
-
-.description {
-	border: 1px dashed #ccc;
-	background-color: #f5f5f5;
-	padding: 5px;
-	font-size: 150%;
-	color: #000000;
-}
-
-.link-button {
-	padding: 0px;
-	background: none;
-	border: none;
-}
-
-.navbar {
-	background-color: #eeeeee;
-	padding: 5px;
-	border: 1px solid #ccc;
-}
-
-.inline {
-	display: inline;
-}
-
 pre {
 	font-size: 75%;
 }

extra/webapps/todo/todo.factor

@@ -1,11 +1,12 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals sequences
+USING: accessors kernel locals sequences namespaces
 db db.types db.tuples
 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
+http.server.auth.login
 http.server ;
 IN: webapps.todo
 
@@ -56,58 +57,17 @@ todo "TODO"
         "list" <todo-form> +plain+ <list>
         add-field ;
 
-TUPLE: todo-responder < dispatcher ;
+TUPLE: todo-list < dispatcher ;
 
-:: <todo-responder> ( -- responder )
+:: <todo-list> ( -- responder )
     [let | todo-form [ <todo-form> ]
            list-form [ <todo-list-form> ]
            ctor [ [ <todo> ] ] |
-        todo-responder new-dispatcher
+        todo-list new-dispatcher
             list-form ctor        <list-action>   "list"   add-main-responder
             todo-form ctor        <view-action>   "view"   add-responder
-            todo-form ctor "view" <edit-action>   "edit"   add-responder
+            todo-form ctor "$todo-list/view" <edit-action>   "edit"   add-responder
-                      ctor "list" <delete-action> "delete" add-responder
+                      ctor "$todo-list/list" <delete-action> "delete" add-responder
         <boilerplate>
             "todo" todo-template >>template
     ] ;
-
-! What follows below is somewhat akin to a 'deployment descriptor'
-! for the todo application. The <todo-responder> can be integrated
-! into an existing web app that provides session management and
-! login facilities, or <todo-app> can be used to run a
-! self-contained todo instance.
-USING: namespaces io.files io.sockets
-db.sqlite smtp
-http.server.sessions
-http.server.auth.login
-http.server.auth.providers.db
-http.server.sessions.storage.db ;
-
-: test-db "todo.db" resource-path sqlite-db ;
-
-: <todo-app> ( -- responder )
-    <todo-responder>
-    <login>
-        users-in-db >>users
-        allow-registration
-        allow-password-recovery
-        allow-edit-profile
-    <boilerplate>
-        "page" todo-template >>template
-    <url-sessions>
-        sessions-in-db >>sessions
-    test-db <db-persistence> ;
-
-: init-todo ( -- )
-    "factorcode.org" 25 <inet> smtp-server set-global
-    "todo@factorcode.org" lost-password-from set-global
-
-    test-db [
-        init-todo-table
-        init-users-table
-        init-sessions-table
-    ] with-db
-
-    <dispatcher>
-        <todo-app> "todo" add-responder
-    main-responder set-global ;

extra/webapps/todo/todo.xml

@@ -4,17 +4,15 @@
 
 	<t:style include="resource:extra/webapps/todo/todo.css" />
 
-	<t:style include="resource:extra/xmode/code2html/stylesheet.css" />
-
 	<div class="navbar">
-		  <t:a href="list">List Items</t:a>
+		  <t:a href="$todo-list/list">List Items</t:a>
-		| <t:a href="edit">Add Item</t:a>
+		| <t:a href="$todo-list/edit">Add Item</t:a>
 
 		<t:if code="http.server.auth.login:allow-edit-profile?">
-			| <t:a href="edit-profile">Edit Profile</t:a>
+			| <t:a href="$login/edit-profile">Edit Profile</t:a>
 		</t:if>
 
-		<t:form action="logout" class="inline">
+		<t:form action="$login/logout" class="inline">
 			| <button type="submit" class="link-button link">Logout</button>
 		</t:form>
 	</div>

extra/webapps/todo/view-todo.xml

@@ -13,9 +13,9 @@
 		<t:view component="description" />
 	</div>
 
-	<t:a href="edit" query="id">Edit</t:a>
+	<t:a href="$todo-list/edit" query="id">Edit</t:a>
 	|
-	<t:form action="delete" class="inline">
+	<t:form action="$todo-list/delete" class="inline">
 		<t:edit component="id" />
 		<button class="link-button link">Delete</button>
 	</t:form>

extra/windows/windows.factor

@@ -30,10 +30,10 @@ FUNCTION: void* error_message ( DWORD id ) ;
 : win32-error ( -- )
     GetLastError (win32-error) ;
 
-: win32-error=0/f { 0 f } member? [ win32-error ] when ;
+: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
-: win32-error>0 0 > [ win32-error ] when ;
+: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
-: win32-error<0 0 < [ win32-error ] when ;
+: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
-: win32-error<>0 zero? [ win32-error ] unless ;
+: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
 
 : invalid-handle? ( handle -- )
     INVALID_HANDLE_VALUE = [

vm/ffi_test.c

@@ -255,7 +255,7 @@ static int global_var;
 
 void ffi_test_36_point_5(void)
 {
-	printf("int_ffi_test_36_point_5\n");
+	printf("ffi_test_36_point_5\n");
 	global_var = 0;
 }
 

vm/ffi_test.h

@@ -62,7 +62,7 @@ struct test_struct_12 { int a; double x; };
 
 DLLEXPORT double ffi_test_36(struct test_struct_12 x);
 
-DLLEXPORT void int_ffi_test_36_point_5(void);
+DLLEXPORT void ffi_test_36_point_5(void);
 
 DLLEXPORT int ffi_test_37(int (*f)(int, int, int));