! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private slots.private math assocs
-math.private sequences sequences.private vectors ;
+ math.private sequences sequences.private vectors ;
IN: hashtables
<PRIVATE
2 fixnum+fast over wrap ; inline
: (key@) ( key keys i -- array n ? )
- 3dup swap array-nth dup ((tombstone)) eq? [
- 2drop probe (key@)
- ] [
- dup ((empty)) eq? [
- 3drop nip f f
- ] [
- = [ rot drop t ] [ probe (key@) ] if
- ] if
- ] if ; inline
+ 3dup swap array-nth
+ dup ((empty)) eq?
+ [ 3drop nip f f ]
+ [
+ =
+ [ rot drop t ]
+ [ probe (key@) ]
+ if
+ ]
+ if ; inline
: key@ ( key hash -- array n ? )
hash-array 2dup hash@ (key@) ; inline
TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info )
+HOOK: link-info io-backend ( path -- info )
SYMBOL: +regular-file+
SYMBOL: +directory+
[ { + } ] [ \ quot-uses-b uses ] unit-test
-[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ]
+"undef-test" "words.tests" lookup [
+ [ forget ] with-compilation-unit
+] when*
+
+[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
[ [ undefined? ] is? ] must-fail-with
[ ] [
: record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ;
-: do-make-clean ( -- desc ) { "make" "clean" } try-process ;
+: do-make-clean ( -- ) { "make" "clean" } try-process ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
\r
: pad-00 number>string 2 CHAR: 0 pad-left ;\r
\r
+: pad-0000 number>string 4 CHAR: 0 pad-left ;\r
+\r
: write-00 pad-00 write ;\r
\r
+: write-0000 pad-0000 write ;\r
+\r
: (timestamp>string) ( timestamp -- )\r
dup day-of-week day-abbreviations3 nth write ", " write\r
dup day>> number>string write bl\r
60 / + *\r
] if ;\r
\r
+: read-ymd ( -- y m d )\r
+ read-0000 "-" expect read-00 "-" expect read-00 ;\r
+\r
+: read-hms ( -- h m s )\r
+ read-00 ":" expect read-00 ":" expect read-00 ;\r
+\r
: (rfc3339>timestamp) ( -- timestamp )\r
- read-0000 ! year\r
- "-" expect\r
- read-00 ! month\r
- "-" expect\r
- read-00 ! day\r
+ read-ymd\r
"Tt" expect\r
- read-00 ! hour\r
- ":" expect\r
- read-00 ! minute\r
- ":" expect\r
- read-00 ! second\r
+ read-hms\r
read-rfc3339-gmt-offset ! timezone\r
<timestamp> ;\r
\r
: rfc3339>timestamp ( str -- timestamp )\r
[ (rfc3339>timestamp) ] with-string-reader ;\r
\r
+: (ymdhms>timestamp) ( -- timestamp )\r
+ read-ymd " " expect read-hms 0 <timestamp> ;\r
+\r
+: ymdhms>timestamp ( str -- timestamp )\r
+ [ (ymdhms>timestamp) ] with-string-reader ;\r
+\r
+: (hms>timestamp) ( -- timestamp )\r
+ f f f read-hms f <timestamp> ;\r
+\r
+: hms>timestamp ( str -- timestamp )\r
+ [ (hms>timestamp) ] with-string-reader ;\r
+\r
+: (ymd>timestamp) ( -- timestamp )\r
+ read-ymd f f f f <timestamp> ;\r
+\r
+: ymd>timestamp ( str -- timestamp )\r
+ [ (ymd>timestamp) ] with-string-reader ;\r
+\r
+: (timestamp>ymd) ( timestamp -- )\r
+ dup timestamp-year write-0000\r
+ "-" write\r
+ dup timestamp-month write-00\r
+ "-" write\r
+ timestamp-day write-00 ;\r
+\r
+: timestamp>ymd ( timestamp -- str )\r
+ [ (timestamp>ymd) ] with-string-writer ;\r
+\r
+: (timestamp>hms)\r
+ dup timestamp-hour write-00\r
+ ":" write\r
+ dup timestamp-minute write-00\r
+ ":" write\r
+ timestamp-second >integer write-00 ;\r
+\r
+: timestamp>hms ( timestamp -- str )\r
+ [ (timestamp>hms) ] with-string-writer ;\r
+\r
+: timestamp>ymdhms ( timestamp -- str )\r
+ >gmt\r
+ [\r
+ dup (timestamp>ymd)\r
+ " " write\r
+ (timestamp>hms)\r
+ ] with-string-writer ;\r
+\r
: file-time-string ( timestamp -- string )\r
[\r
[ month>> month-abbreviations nth write ] keep bl\r
TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
-TUPLE: result-set sql params handle n max ;
+TUPLE: result-set sql in-params out-params handle n max ;
: <statement> ( sql in out -- statement )
{ (>>sql) (>>in-params) (>>out-params) } statement construct ;
GENERIC: #rows ( result-set -- n )
GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
+GENERIC# row-column-typed 1 ( result-set n -- sql )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
0 >>n drop ;
: <result-set> ( query handle tuple -- result-set )
- >r >r { sql>> in-params>> } get-slots r>
- { (>>sql) (>>params) (>>handle) } result-set
+ >r >r { sql>> in-params>> out-params>> } get-slots r>
+ { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
construct r> construct-delegate ;
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
+: sql-row-typed ( result-set -- seq )
+ dup #columns [ row-column-typed ] with map ;
+
: query-each ( statement quot -- )
over more-rows? [
[ call ] 2keep over advance-row query-each
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
-continuations db.types ;
+continuations db.types calendar.format serialize
+io.streams.string byte-arrays ;
+USE: tools.walker
IN: db.sqlite.lib
: sqlite-error ( n -- * )
: sqlite-bind-null ( handle i -- )
sqlite3_bind_null sqlite-check-result ;
+: sqlite-bind-blob ( handle i byte-array -- )
+ dup length SQLITE_TRANSIENT
+ sqlite3_bind_blob sqlite-check-result ;
+
: sqlite-bind-text-by-name ( handle name text -- )
parameter-index sqlite-bind-text ;
: sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ;
+: sqlite-bind-blob-by-name ( handle name blob -- )
+ parameter-index sqlite-bind-blob ;
+
: sqlite-bind-null-by-name ( handle name obj -- )
parameter-index drop sqlite-bind-null ;
: sqlite-bind-type ( handle key value type -- )
+ over [ drop NULL ] unless
dup array? [ first ] when
{
{ INTEGER [ sqlite-bind-int-by-name ] }
- { BIG_INTEGER [ sqlite-bind-int64-by-name ] }
+ { BIG-INTEGER [ sqlite-bind-int64-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
- { TIMESTAMP [ sqlite-bind-double-by-name ] }
+ { DATE [ sqlite-bind-text-by-name ] }
+ { TIME [ sqlite-bind-text-by-name ] }
+ { DATETIME [ sqlite-bind-text-by-name ] }
+ { TIMESTAMP [ sqlite-bind-text-by-name ] }
+ { BLOB [ sqlite-bind-blob-by-name ] }
+ { FACTOR-BLOB [
+ [ serialize ] with-string-writer >byte-array
+ sqlite-bind-blob-by-name
+ ] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
- ! { NULL [ sqlite-bind-null-by-name ] }
+ { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
: sqlite-#columns ( query -- int )
sqlite3_column_count ;
-! TODO
: sqlite-column ( handle index -- string )
sqlite3_column_text ;
+: sqlite-column-blob ( handle index -- byte-array/f )
+ [ sqlite3_column_bytes ] 2keep
+ pick zero? [
+ 3drop f
+ ] [
+ sqlite3_column_blob swap memory>byte-array
+ ] if ;
+
: sqlite-column-typed ( handle index type -- obj )
+ dup array? [ first ] when
{
+ { +native-id+ [ sqlite3_column_int64 ] }
{ INTEGER [ sqlite3_column_int ] }
- { BIG_INTEGER [ sqlite3_column_int64 ] }
+ { BIG-INTEGER [ sqlite3_column_int64 ] }
{ TEXT [ sqlite3_column_text ] }
+ { VARCHAR [ sqlite3_column_text ] }
{ DOUBLE [ sqlite3_column_double ] }
- { TIMESTAMP [ sqlite3_column_double ] }
+ { DATE [ sqlite3_column_text dup [ ymd>timestamp ] when ] }
+ { TIME [ sqlite3_column_text dup [ hms>timestamp ] when ] }
+ { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
+ { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
+ { BLOB [ sqlite-column-blob ] }
+ { FACTOR-BLOB [
+ sqlite-column-blob [ deserialize ] with-string-reader
+ ] }
+ ! { NULL [ 2drop f ] }
[ no-sql-type ]
} case ;
-! TODO
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
continuations db.types db.tuples unicode.case ;
IN: db.sqlite.tests
-: db-path "extra/db/sqlite/test.db" resource-path ;
+: db-path "test.db" temp-file ;
: test.db db-path sqlite-db ;
[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
M: sqlite-result-set row-column ( result-set n -- obj )
>r result-set-handle r> sqlite-column ;
-M: sqlite-result-set row-column-typed ( result-set n type -- obj )
- >r result-set-handle r> sqlite-column-typed ;
+M: sqlite-result-set row-column-typed ( result-set n -- obj )
+ dup pick result-set-out-params nth sql-spec-type
+ >r >r result-set-handle r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
[ result-set-handle sqlite-next ] keep
" where " 0%
find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
+: where-clause ( specs -- )
+ " where " 0%
+ [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
+
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
"update " 0%
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
- dup empty? [
- drop
- ] [
- " where " 0%
- [ ", " 0% ]
- [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
- ] if
- ";" 0%
+ dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
M: sqlite-db modifier-table ( -- hashtable )
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
+ { DATE "date" }
+ { TIME "time" }
+ { DATETIME "datetime" }
{ TIMESTAMP "timestamp" }
{ DOUBLE "real" }
+ { BLOB "blob" }
+ { FACTOR-BLOB "blob" }
} ;
M: sqlite-db create-type-table
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.tuples
-db.types continuations namespaces db.postgresql math
-prettyprint tools.walker db.sqlite ;
+db.types continuations namespaces math
+prettyprint tools.walker db.sqlite calendar
+math.intervals ;
IN: db.tuples.tests
-TUPLE: person the-id the-name the-number the-real ;
-: <person> ( name age real -- person )
+TUPLE: person the-id the-name the-number the-real ts date time blob ;
+: <person> ( name age real ts date time blob -- person )
{
set-person-the-name
set-person-the-number
set-person-the-real
+ set-person-ts
+ set-person-date
+ set-person-time
+ set-person-blob
} person construct ;
-: <assigned-person> ( id name number the-real -- obj )
+: <assigned-person> ( id name age real ts date time blob -- person )
<person> [ set-person-the-id ] keep ;
-SYMBOL: the-person1
-SYMBOL: the-person2
+SYMBOL: person1
+SYMBOL: person2
+SYMBOL: person3
+SYMBOL: person4
: test-tuples ( -- )
[ person drop-table ] [ drop ] recover
[ ] [ person create-table ] unit-test
[ person create-table ] must-fail
- [ ] [ the-person1 get insert-tuple ] unit-test
+ [ ] [ person1 get insert-tuple ] unit-test
- [ 1 ] [ the-person1 get person-the-id ] unit-test
+ [ 1 ] [ person1 get person-the-id ] unit-test
- 200 the-person1 get set-person-the-number
+ 200 person1 get set-person-the-number
- [ ] [ the-person1 get update-tuple ] unit-test
+ [ ] [ person1 get update-tuple ] unit-test
[ T{ person f 1 "billy" 200 3.14 } ]
[ T{ person f 1 } select-tuple ] unit-test
- [ ] [ the-person2 get insert-tuple ] unit-test
+ [ ] [ person2 get insert-tuple ] unit-test
[
{
T{ person f 1 "billy" 200 3.14 }
}
] [ T{ person f } select-tuples ] unit-test
+ [
+ {
+ T{ person f 2 "johnny" 10 3.14 }
+ }
+ ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
- [ ] [ the-person1 get delete-tuple ] unit-test
+
+ [ ] [ person1 get delete-tuple ] unit-test
[ f ] [ T{ person f 1 } select-tuple ] unit-test
+
+ [ ] [ person3 get insert-tuple ] unit-test
+
+ [
+ T{
+ person
+ f
+ 3
+ "teddy"
+ 10
+ 3.14
+ T{ timestamp f 2008 3 5 16 24 11 0 }
+ T{ timestamp f 2008 11 22 f f f f }
+ T{ timestamp f f f f 12 34 56 f }
+ B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
+ }
+ ] [ T{ person f 3 } select-tuple ] unit-test
+
[ ] [ person drop-table ] unit-test ;
: make-native-person-table ( -- )
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+ { "ts" "TS" TIMESTAMP }
+ { "date" "D" DATE }
+ { "time" "T" TIME }
+ { "blob" "B" BLOB }
} define-persistent
- "billy" 10 3.14 <person> the-person1 set
- "johnny" 10 3.14 <person> the-person2 set ;
+ "billy" 10 3.14 f f f f <person> person1 set
+ "johnny" 10 3.14 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 } <person> person3 set ;
: assigned-person-schema ( -- )
person "PERSON"
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
+ { "ts" "TS" TIMESTAMP }
+ { "date" "D" DATE }
+ { "time" "T" TIME }
+ { "blob" "B" BLOB }
} define-persistent
- 1 "billy" 10 3.14 <assigned-person> the-person1 set
- 2 "johnny" 10 3.14 <assigned-person> the-person2 set ;
-
+ 1 "billy" 10 3.14 f f f f <assigned-person> person1 set
+ 2 "johnny" 10 3.14 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 } <assigned-person> person3 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
! [ ] [ annotation create-table ] unit-test
! ] with-db
-
: test-sqlite ( quot -- )
- >r "tuples-test.db" resource-path sqlite-db r> with-db ;
+ >r "tuples-test.db" temp-file sqlite-db r> with-db ;
-: test-postgresql ( -- )
- >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
+! : test-postgresql ( -- )
+! >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
-! [ make-native-person-table ] test-sqlite
+TUPLE: serialize-me id data ;
+
+: test-serialize ( -- )
+ serialize-me "SERIALIZED"
+ {
+ { "id" "ID" +native-id+ }
+ { "data" "DATA" FACTOR-BLOB }
+ } define-persistent
+ [ serialize-me drop-table ] [ drop ] recover
+ [ ] [ serialize-me create-table ] unit-test
+
+ [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
+ [
+ { T{ serialize-me f 1 H{ { 1 2 } } } }
+ ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
+
+! [ test-serialize ] test-sqlite
+
+TUPLE: exam id name score ;
+
+: test-ranges ( -- )
+ exam "EXAM"
+ {
+ { "id" "ID" +native-id+ }
+ { "name" "NAME" TEXT }
+ { "score" "SCORE" INTEGER }
+ } define-persistent
+ [ exam drop-table ] [ drop ] recover
+ [ ] [ exam create-table ] unit-test
+
+ [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
+ [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
+
+ [
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test
+ ;
+
+! [ test-ranges ] test-sqlite
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
-HOOK: row-column-typed db ( result-set n type -- sql )
HOOK: insert-tuple* db ( tuple statement -- )
: resulting-tuple ( row out-params -- tuple )
dup first sql-spec-class construct-empty [
[
- >r [ sql-spec-type sql-type>factor-type ] keep
- sql-spec-slot-name r> set-slot-named
+ >r sql-spec-slot-name r> set-slot-named
] curry 2each
] keep ;
: query-tuples ( statement -- seq )
[ statement-out-params ] keep query-results [
- [ sql-row swap resulting-tuple ] with query-map
+ [ sql-row-typed swap resulting-tuple ] with query-map
] with-disposal ;
: query-modify-tuple ( tuple statement -- )
- [ query-results [ sql-row ] with-disposal ] keep
+ [ query-results [ sql-row-typed ] with-disposal ] keep
statement-out-params rot [
- >r [ sql-spec-type sql-type>factor-type ] keep
- sql-spec-slot-name r> set-slot-named
+ >r sql-spec-slot-name r> set-slot-named
] curry 2each ;
: sql-props ( class -- columns table )
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators ;
+mirrors tuples combinators calendar.format serialize
+io.streams.string ;
IN: db.types
HOOK: modifier-table db ( -- hash )
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOL: INTEGER
-SYMBOL: BIG_INTEGER
+SYMBOL: BIG-INTEGER
SYMBOL: DOUBLE
SYMBOL: REAL
SYMBOL: BOOLEAN
SYMBOL: TEXT
SYMBOL: VARCHAR
-SYMBOL: TIMESTAMP
SYMBOL: DATE
+SYMBOL: TIME
+SYMBOL: DATETIME
+SYMBOL: TIMESTAMP
+SYMBOL: BLOB
+SYMBOL: FACTOR-BLOB
+SYMBOL: NULL
: spec>tuple ( class spec -- tuple )
[ ?first3 ] keep 3 ?tail*
} sql-spec construct
dup normalize-spec ;
-: sql-type-hash ( -- assoc )
- H{
- { INTEGER "integer" }
- { TEXT "text" }
- { VARCHAR "varchar" }
- { DOUBLE "real" }
- { TIMESTAMP "timestamp" }
- } ;
-
TUPLE: no-sql-type ;
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
>r dup sql-spec-type swap sql-spec-slot-name r>
get-slot-named swap
] curry { } map>assoc ;
-
-: sql-type>factor-type ( obj type -- obj )
- dup array? [ first ] when
- {
- { +native-id+ [ string>number ] }
- { INTEGER [ string>number ] }
- { DOUBLE [ string>number ] }
- { REAL [ string>number ] }
- { TEXT [ ] }
- { VARCHAR [ ] }
- [ "no conversion from sql type to factor type" throw ]
- } case ;
-USING: help.markup help.syntax libc kernel ;
+USING: help.markup help.syntax libc kernel continuations ;
IN: destructors
HELP: free-always
HELP: with-destructors
{ $values { "quot" "a quotation" } }
-{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link destruct } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
+{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $examples
{ $code "[ 10 malloc free-always ] with-destructors" }
C: <dummy-destructor> dummy-destructor
-M: dummy-destructor destruct ( obj -- )
+M: dummy-destructor dispose ( obj -- )
dummy-destructor-obj t swap set-dummy-obj-destroyed? ;
: destroy-always
sequences system vectors ;
IN: destructors
-GENERIC: destruct ( obj -- )
-
SYMBOL: error-destructors
SYMBOL: always-destructors
TUPLE: destructor object destroyed? ;
-M: destructor destruct
+M: destructor dispose
dup destructor-destroyed? [
drop
] [
- dup destructor-object destruct
+ dup destructor-object dispose
t swap set-destructor-destroyed?
] if ;
<destructor> always-destructors get push ;
: do-always-destructors ( -- )
- always-destructors get [ destruct ] each ;
+ always-destructors get [ dispose ] each ;
: do-error-destructors ( -- )
- error-destructors get [ destruct ] each ;
+ error-destructors get [ dispose ] each ;
: with-destructors ( quot -- )
[
C: <memory-destructor> memory-destructor
-M: memory-destructor destruct ( obj -- )
+M: memory-destructor dispose ( obj -- )
memory-destructor-alien free ;
: free-always ( alien -- )
HOOK: destruct-handle io-backend ( obj -- )
-M: handle-destructor destruct ( obj -- )
+M: handle-destructor dispose ( obj -- )
handle-destructor-alien destruct-handle ;
: close-always ( handle -- )
HOOK: destruct-socket io-backend ( obj -- )
-M: socket-destructor destruct ( obj -- )
+M: socket-destructor dispose ( obj -- )
socket-destructor-alien destruct-socket ;
: close-socket-always ( handle -- )
[ "<p><strong>foo</strong>\n</p><h1>aheading</h1>\n<p>adfasd</p>" ]
[ "*foo*\n=aheading=\nadfasd" convert-farkup ] unit-test
+
+[ "<p>=foo\n</p>" ] [ "=foo\n" convert-farkup ] unit-test
+[ "<h1>foo</h1>\n" ] [ "=foo=\n" convert-farkup ] unit-test
+[ "<p>lol</p><h1>foo</h1>\n" ] [ "lol=foo=\n" convert-farkup ] unit-test
+++ /dev/null
-Slava Pestov
-Doug Coleman
+++ /dev/null
-USING: kernel sequences namespaces math tools.test furnace furnace.validator ;
-IN: furnace.tests
-
-TUPLE: test-tuple m n ;
-
-[ H{ { "m" 3 } { "n" 2 } } ]
-[
- [ T{ test-tuple f 3 2 } explode-tuple ] H{ } make-assoc
-] unit-test
-
-[
- { 3 }
-] [
- H{ { "n" "3" } } { { "n" v-number } }
- [ action-param drop ] with map
-] unit-test
-
-: foo ;
-
-\ foo { { "foo" "2" v-default } { "bar" v-required } } define-action
-
-[ t ] [ [ 1 2 foo ] action-call? ] unit-test
-[ f ] [ [ 2 + ] action-call? ] unit-test
-
-[
- { "2" "hello" }
-] [
- [
- H{
- { "bar" "hello" }
- } \ foo query>seq
- ] with-scope
-] unit-test
-
-[
- H{ { "foo" "1" } { "bar" "2" } }
-] [
- { "1" "2" } \ foo quot>query
-] unit-test
-
-[
- "/responder/furnace.tests/foo?foo=3"
-] [
- [
- [ "3" foo ] quot-link
- ] with-scope
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs calendar debugger furnace.sessions
-furnace.validator hashtables heaps html.elements http
-http.server.responders http.server.templating io.files kernel
-math namespaces quotations sequences splitting words strings
-vectors webapps.callback continuations tuples classes vocabs
-html io ;
-IN: furnace
-
-: code>quotation ( word/quot -- quot )
- dup word? [ 1quotation ] when ;
-
-SYMBOL: default-action
-SYMBOL: template-path
-
-: render-template ( template -- )
- template-path get swap path+
- ".furnace" append resource-path
- run-template-file ;
-
-: define-action ( word hash -- )
- over t "action" set-word-prop
- "action-params" set-word-prop ;
-
-: define-form ( word1 word2 hash -- )
- dupd define-action
- swap code>quotation "form-failed" set-word-prop ;
-
-: default-values ( word hash -- )
- "default-values" set-word-prop ;
-
-SYMBOL: request-params
-SYMBOL: current-action
-SYMBOL: validators-errored
-SYMBOL: validation-errors
-
-: build-url ( str query-params -- newstr )
- [
- over %
- dup assoc-empty? [
- 2drop
- ] [
- CHAR: ? rot member? "&" "?" ? %
- assoc>query %
- ] if
- ] "" make ;
-
-: action-link ( query action -- url )
- [
- "/responder/" %
- dup word-vocabulary "webapps." ?head drop %
- "/" %
- word-name %
- ] "" make swap build-url ;
-
-: action-param ( hash paramsepc -- obj error/f )
- unclip rot at swap >quotation apply-validators ;
-
-: query>seq ( hash word -- seq )
- "action-params" word-prop [
- dup first -rot
- action-param [
- t validators-errored >session
- rot validation-errors session> set-at
- ] [
- nip
- ] if*
- ] with map ;
-
-: lookup-session ( hash -- session )
- "furnace-session-id" over at get-session
- [ ] [ new-session "furnace-session-id" roll set-at ] ?if ;
-
-: quot>query ( seq action -- hash )
- >r >array r> "action-params" word-prop
- [ first swap 2array ] 2map >hashtable ;
-
-PREDICATE: word action "action" word-prop ;
-
-: action-call? ( quot -- ? )
- >vector dup pop action? >r [ word? not ] all? r> and ;
-
-: unclip* dup 1 head* swap peek ;
-
-: quot-link ( quot -- url )
- dup action-call? [
- unclip* [ quot>query ] keep action-link
- ] [
- t register-html-callback
- ] if ;
-
-: replace-variables ( quot -- quot )
- [ dup string? [ request-params session> at ] when ] map ;
-
-: furnace-session-id ( -- hash )
- "furnace-session-id" request-params session> at
- "furnace-session-id" associate ;
-
-: redirect-to-action ( -- )
- current-action session>
- "form-failed" word-prop replace-variables
- quot-link furnace-session-id build-url permanent-redirect ;
-
-: if-form-page ( if then -- )
- current-action session> "form-failed" word-prop -rot if ;
-
-: do-action
- current-action session> [ query>seq ] keep add >quotation call ;
-
-: process-form ( -- )
- H{ } clone validation-errors >session
- request-params session> current-action session> query>seq
- validators-errored session> [
- drop redirect-to-action
- ] [
- current-action session> add >quotation call
- ] if ;
-
-: page-submitted ( -- )
- [ process-form ] [ request-params session> do-action ] if-form-page ;
-
-: action-first-time ( -- )
- request-params session> current-action session>
- [ "default-values" word-prop swap union request-params >session ] keep
- request-params session> do-action ;
-
-: page-not-submitted ( -- )
- [ redirect-to-action ] [ action-first-time ] if-form-page ;
-
-: setup-call-action ( hash word -- )
- over lookup-session session set
- current-action >session
- request-params session> swap union
- request-params >session
- f validators-errored >session ;
-
-: call-action ( hash word -- )
- setup-call-action
- "furnace-form-submitted" request-params session> at
- [ page-submitted ] [ page-not-submitted ] if ;
-
-: responder-vocab ( str -- newstr )
- "webapps." swap append ;
-
-: lookup-action ( str webapp -- word )
- responder-vocab lookup dup [
- dup "action" word-prop [ drop f ] unless
- ] when ;
-
-: truncate-url ( str -- newstr )
- CHAR: / over index [ head ] when* ;
-
-: parse-action ( str -- word/f )
- dup empty? [ drop default-action get ] when
- truncate-url "responder" get lookup-action ;
-
-: service-request ( hash str -- )
- parse-action [
- [ call-action ] [ <pre> print-error </pre> ] recover
- ] [
- "404 no such action: " "argument" get append httpd-error
- ] if* ;
-
-: service-get
- "query" get swap service-request ;
-
-: service-post
- "response" get swap service-request ;
-
-: web-app ( name defaul path -- )
- [
- template-path set
- default-action set
- "responder" set
- [ service-get ] "get" set
- [ service-post ] "post" set
- ] make-responder ;
-
-: explode-tuple ( tuple -- )
- dup tuple-slots swap class "slot-names" word-prop
- [ set ] 2each ;
-
-SYMBOL: model
-
-: with-slots ( model quot -- )
- [
- >r [ dup model set explode-tuple ] when* r> call
- ] with-scope ;
-
-: render-component ( model template -- )
- swap [ render-template ] with-slots ;
-
-: browse-webapp-source ( vocab -- )
- <a vocab browser-link-href =href a>
- "Browse source" write
- </a> ;
-
-: send-resource ( name -- )
- template-path get swap path+ resource-path <file-reader>
- stdio get stream-copy ;
-
-: render-link ( quot name -- )
- <a swap quot-link =href a> write </a> ;
-
-: session-var ( str -- newstr )
- request-params session> at ;
-
-: render ( str -- )
- request-params session> at [ write ] when* ;
-
-: render-error ( str error-str -- )
- swap validation-errors session> at validation-error? [
- write
- ] [
- drop
- ] if ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: assocs calendar init kernel math.parser
-namespaces random boxes alarms combinators.lib ;
-IN: furnace.sessions
-
-SYMBOL: sessions
-
-: timeout ( -- dt ) 20 minutes ;
-
-[
- H{ } clone sessions set-global
-] "furnace.sessions" add-init-hook
-
-: new-session-id ( -- str )
- [ 4 big-random >hex ]
- [ sessions get-global key? not ] generate ;
-
-TUPLE: session id namespace alarm user-agent ;
-
-: cancel-timeout ( session -- )
- session-alarm ?box [ cancel-alarm ] [ drop ] if ;
-
-: delete-session ( session -- )
- sessions get-global delete-at*
- [ cancel-timeout ] [ drop ] if ;
-
-: touch-session ( session -- )
- dup cancel-timeout
- dup [ session-id delete-session ] curry timeout later
- swap session-alarm >box ;
-
-: <session> ( id -- session )
- H{ } clone <box> f session construct-boa ;
-
-: new-session ( -- session id )
- new-session-id [
- dup <session> [
- [ sessions get-global set-at ] keep
- touch-session
- ] keep
- ] keep ;
-
-: get-session ( id -- session/f )
- sessions get-global at*
- [ dup touch-session ] when ;
-
-: session> ( str -- obj )
- session get session-namespace at ;
-
-: >session ( value key -- )
- session get session-namespace set-at ;
+++ /dev/null
-Action-based web framework
+++ /dev/null
-enterprise
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: furnace.validator.tests
-USING: kernel sequences tools.test furnace.validator furnace ;
-
-[
- 123 f
-] [
- H{ { "foo" "123" } } { "foo" v-number } action-param
-] unit-test
-
-: validation-fails
- [ action-param nip not ] append [ f ] swap unit-test ;
-
-[ H{ { "foo" "12X3" } } { "foo" v-number } ] validation-fails
-
-[ H{ { "foo" "" } } { "foo" 4 v-min-length } ] validation-fails
-
-[ "ABCD" f ]
-[ H{ { "foo" "ABCD" } } { "foo" 4 v-min-length } action-param ]
-unit-test
-
-[ H{ { "foo" "ABCD" } } { "foo" 2 v-max-length } ]
-validation-fails
-
-[ "AB" f ]
-[ H{ { "foo" "AB" } } { "foo" 2 v-max-length } action-param ]
-unit-test
-
-[ "AB" f ]
-[ H{ { "foo" f } } { "foo" "AB" v-default } action-param ]
-unit-test
+++ /dev/null
-! Copyright (C) 2006 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces math.parser ;
-IN: furnace.validator
-
-TUPLE: validation-error reason ;
-
-: apply-validators ( string quot -- obj error/f )
- [
- call f
- ] [
- dup validation-error? [ >r 2drop f r> ] [ rethrow ] if
- ] recover ;
-
-: validation-error ( msg -- * )
- \ validation-error construct-boa throw ;
-
-: v-default ( obj value -- obj )
- over empty? [ nip ] [ drop ] if ;
-
-: v-required ( str -- str )
- dup empty? [ "required" validation-error ] when ;
-
-: v-min-length ( str n -- str )
- over length over < [
- [ "must be at least " % # " characters" % ] "" make
- validation-error
- ] [
- drop
- ] if ;
-
-: v-max-length ( str n -- str )
- over length over > [
- [ "must be no more than " % # " characters" % ] "" make
- validation-error
- ] [
- drop
- ] if ;
-
-: v-number ( str -- n )
- string>number [
- "must be a number" validation-error
- ] unless* ;
USING: assocs html.parser kernel math sequences strings ascii
-arrays shuffle unicode.case namespaces splitting
-http.server.responders ;
+arrays shuffle unicode.case namespaces splitting http ;
IN: html.parser.analyzer
: remove-blank-text ( vector -- vector' )
: href-contains? ( str tag -- ? )
tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ;
-: query>hash* ( str -- hash )
- "?" split1 nip query>hash ;
+: query>assoc* ( str -- hash )
+ "?" split1 nip query>assoc ;
! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
! "a" over find-opening-tags-by-name
! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset
! first first 8 + over nth
-! tag-attributes "href" swap at query>hash*
+! tag-attributes "href" swap at query>assoc*
! "lat" over at "lon" rot at
IN: http.server.actions.tests
USING: http.server.actions tools.test math math.parser
multiline namespaces http io.streams.string http.server
-sequences ;
+sequences accessors ;
-[ + ]
-{ { "a" [ string>number ] } { "b" [ string>number ] } }
-"GET" <action> "action-1" set
+<action>
+ [ "a" get "b" get + ] >>get
+ { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
+"action-1" set
STRING: action-request-test-1
GET http://foo/bar?a=12&b=13 HTTP/1.1
"action-1" get call-responder
] unit-test
-[ "X" <repetition> concat append ]
-{ { +path+ [ ] } { "xxx" [ string>number ] } }
-"POST" <action> "action-2" set
+<action>
+ [ +path+ get "xxx" get "X" <repetition> concat append ] >>post
+ { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
+"action-2" set
STRING: action-request-test-2
POST http://foo/bar/baz HTTP/1.1
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors new-slots sequences kernel assocs combinators\r
-http.server http hashtables namespaces ;\r
+http.server http.server.validators http hashtables namespaces ;\r
IN: http.server.actions\r
\r
SYMBOL: +path+\r
\r
-TUPLE: action quot params method ;\r
+TUPLE: action get get-params post post-params revalidate ;\r
\r
-C: <action> action\r
+: <action>\r
+ action construct-empty\r
+ [ <400> ] >>get\r
+ [ <400> ] >>post\r
+ [ <400> ] >>revalidate ;\r
\r
: extract-params ( request path -- assoc )\r
>r dup method>> {\r
{ "POST" [ post-data>> query>assoc ] }\r
} case r> +path+ associate union ;\r
\r
-: push-params ( assoc action -- ... )\r
- params>> [ first2 >r swap at r> call ] with each ;\r
+: action-params ( request path param -- error? )\r
+ -rot extract-params validate-params ;\r
+\r
+: get-action ( request path -- response )\r
+ action get get-params>> action-params\r
+ [ <400> ] [ action get get>> call ] if ;\r
+\r
+: post-action ( request path -- response )\r
+ action get post-params>> action-params\r
+ [ action get revalidate>> ] [ action get post>> ] if call ;\r
\r
M: action call-responder ( request path action -- response )\r
- pick request set\r
- pick method>> over method>> = [\r
- >r extract-params r>\r
- [ push-params ] keep\r
- quot>> call\r
- ] [\r
- 3drop <400>\r
- ] if ;\r
+ action set\r
+ over request set\r
+ over method>>\r
+ {\r
+ { "GET" [ get-action ] }\r
+ { "POST" [ post-action ] }\r
+ } case ;\r
--- /dev/null
+! Copyright (c) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors new-slots quotations assocs kernel splitting\r
+base64 html.elements io combinators http.server\r
+http.server.auth.providers http.server.auth.providers.null\r
+http sequences ;\r
+IN: http.server.auth.basic\r
+\r
+TUPLE: basic-auth responder realm provider ;\r
+\r
+C: <basic-auth> basic-auth\r
+\r
+: authorization-ok? ( provider header -- ? )\r
+ #! Given the realm and the 'Authorization' header,\r
+ #! authenticate the user.\r
+ dup [\r
+ " " split1 swap "Basic" = [\r
+ base64> ":" split1 spin check-login\r
+ ] [\r
+ 2drop f\r
+ ] if\r
+ ] [\r
+ 2drop f\r
+ ] if ;\r
+\r
+: <401> ( realm -- response )\r
+ 401 "Unauthorized" <trivial-response>\r
+ "Basic realm=\"" rot "\"" 3append\r
+ "WWW-Authenticate" set-header\r
+ [\r
+ <html> <body>\r
+ "Username or Password is invalid" write\r
+ </body> </html>\r
+ ] >>body ;\r
+\r
+: logged-in? ( request responder -- ? )\r
+ provider>> swap "authorization" header authorization-ok? ;\r
+\r
+M: basic-auth call-responder ( request path responder -- response )\r
+ pick over logged-in?\r
+ [ responder>> call-responder ] [ 2nip realm>> <401> ] if ;\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors new-slots quotations assocs kernel splitting\r
+base64 html.elements io combinators http.server\r
+http.server.auth.providers http.server.actions\r
+http.server.sessions http.server.templating.fhtml http sequences\r
+io.files namespaces ;\r
+IN: http.server.auth.login\r
+\r
+TUPLE: login-auth responder provider ;\r
+\r
+C: (login-auth) login-auth\r
+\r
+SYMBOL: logged-in?\r
+SYMBOL: provider\r
+SYMBOL: post-login-url\r
+\r
+: login-page ( -- response )\r
+ "text/html" <content> [\r
+ "extra/http/server/auth/login/login.fhtml"\r
+ resource-path run-template-file\r
+ ] >>body ;\r
+\r
+: <login-action>\r
+ <action>\r
+ [ login-page ] >>get\r
+\r
+ {\r
+ { "name" [ ] }\r
+ { "password" [ ] }\r
+ } >>post-params\r
+ [\r
+ "password" get\r
+ "name" get\r
+ provider sget check-login [\r
+ t logged-in? sset\r
+ post-login-url sget <permanent-redirect>\r
+ ] [\r
+ login-page\r
+ ] if\r
+ ] >>post ;\r
+\r
+: <logout-action>\r
+ <action>\r
+ [\r
+ f logged-in? sset\r
+ request get "login" <permanent-redirect>\r
+ ] >>post ;\r
+\r
+M: login-auth call-responder ( request path responder -- response )\r
+ logged-in? sget\r
+ [ responder>> call-responder ] [\r
+ pick method>> "GET" = [\r
+ nip\r
+ provider>> provider sset\r
+ dup request-url post-login-url sset\r
+ "login" f session-link <permanent-redirect>\r
+ ] [\r
+ 3drop <400>\r
+ ] if\r
+ ] if ;\r
+\r
+: <login-auth> ( responder provider -- auth )\r
+ (login-auth)\r
+ <dispatcher>\r
+ swap >>default\r
+ <login-action> "login" add-responder\r
+ <logout-action> "logout" add-responder\r
+ <cookie-sessions> ;\r
--- /dev/null
+<html>\r
+<body>\r
+<h1>Login required</h1>\r
+\r
+<form method="POST" action="login">\r
+<table>\r
+\r
+<tr>\r
+<td>User name:</td>\r
+<td><input name="name" /></td>\r
+</tr>\r
+\r
+<tr>\r
+<td>Password:</td>\r
+<td><input type="password" name="password" /></td>\r
+</tr>\r
+\r
+</table>\r
+\r
+<input type="submit" value="Log in" />\r
+\r
+</form>\r
+\r
+</body>\r
+</html>\r
--- /dev/null
+IN: http.server.auth.providers.assoc.tests\r
+USING: http.server.auth.providers \r
+http.server.auth.providers.assoc tools.test\r
+namespaces ;\r
+\r
+<assoc-auth-provider> "provider" set\r
+\r
+"slava" "provider" get new-user\r
+\r
+[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with\r
+\r
+[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test\r
+\r
+[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with\r
+\r
+"fdasf" "slava" "provider" get set-password\r
+\r
+[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+IN: http.server.auth.providers.assoc\r
+USING: new-slots accessors assocs kernel\r
+http.server.auth.providers ;\r
+\r
+TUPLE: assoc-auth-provider assoc ;\r
+\r
+: <assoc-auth-provider> ( -- provider )\r
+ H{ } clone assoc-auth-provider construct-boa ;\r
+\r
+M: assoc-auth-provider check-login\r
+ assoc>> at = ;\r
+\r
+M: assoc-auth-provider new-user\r
+ assoc>>\r
+ 2dup key? [ drop user-exists ] when\r
+ t -rot set-at ;\r
+\r
+M: assoc-auth-provider set-password\r
+ assoc>>\r
+ 2dup key? [ drop no-such-user ] unless\r
+ set-at ;\r
--- /dev/null
+IN: http.server.auth.providers.db.tests\r
+USING: http.server.auth.providers\r
+http.server.auth.providers.db tools.test\r
+namespaces db db.sqlite db.tuples continuations\r
+io.files ;\r
+\r
+db-auth-provider "provider" set\r
+\r
+"auth-test.db" temp-file sqlite-db [\r
+ \r
+ [ user drop-table ] ignore-errors\r
+ [ user create-table ] ignore-errors\r
+\r
+ "slava" "provider" get new-user\r
+\r
+ [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with\r
+\r
+ [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test\r
+\r
+ [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with\r
+\r
+ "fdasf" "slava" "provider" get set-password\r
+\r
+ [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test\r
+] with-db\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: db db.tuples db.types new-slots accessors\r
+http.server.auth.providers kernel ;\r
+IN: http.server.auth.providers.db\r
+\r
+TUPLE: user name password ;\r
+\r
+: <user> user construct-empty ;\r
+\r
+user "USERS"\r
+{\r
+ { "name" "NAME" { VARCHAR 256 } +assigned-id+ }\r
+ { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }\r
+} define-persistent\r
+\r
+: init-users-table ( -- )\r
+ user create-table ;\r
+\r
+TUPLE: db-auth-provider ;\r
+\r
+: db-auth-provider T{ db-auth-provider } ;\r
+\r
+M: db-auth-provider check-login\r
+ drop\r
+ <user>\r
+ swap >>name\r
+ swap >>password\r
+ select-tuple >boolean ;\r
+\r
+M: db-auth-provider new-user\r
+ drop\r
+ [\r
+ <user>\r
+ swap >>name\r
+\r
+ dup select-tuple [ name>> user-exists ] when\r
+\r
+ "unassigned" >>password\r
+\r
+ insert-tuple\r
+ ] with-transaction ;\r
+\r
+M: db-auth-provider set-password\r
+ drop\r
+ [\r
+ <user>\r
+ swap >>name\r
+\r
+ dup select-tuple [ ] [ no-such-user ] ?if\r
+\r
+ swap >>password update-tuple\r
+ ] with-transaction ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: http.server.auth.providers kernel ;\r
+IN: http.server.auth.providers.null\r
+\r
+TUPLE: null-auth-provider ;\r
+\r
+: null-auth-provider T{ null-auth-provider } ;\r
+\r
+M: null-auth-provider check-login 3drop f ;\r
+\r
+M: null-auth-provider new-user 3drop f ;\r
+\r
+M: null-auth-provider set-password 3drop f ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel ;\r
+IN: http.server.auth.providers\r
+\r
+GENERIC: check-login ( password user provider -- ? )\r
+\r
+GENERIC: new-user ( user provider -- )\r
+\r
+GENERIC: set-password ( password user provider -- )\r
+\r
+TUPLE: user-exists name ;\r
+\r
+: user-exists ( name -- * ) \ user-exists construct-boa throw ;\r
+\r
+TUPLE: no-such-user name ;\r
+\r
+: no-such-user ( name -- * ) \ no-such-user construct-boa throw ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: new-slots html.elements http.server.validators
+accessors namespaces kernel io farkup math.parser assocs
+classes words tuples arrays sequences io.files
+http.server.templating.fhtml splitting ;
+IN: http.server.components
+
+SYMBOL: components
+
+TUPLE: component id ;
+
+: component ( name -- component )
+ dup components get at
+ [ ] [ "No such component: " swap append throw ] ?if ;
+
+GENERIC: validate* ( string component -- result )
+GENERIC: render-view* ( value component -- )
+GENERIC: render-edit* ( value component -- )
+GENERIC: render-error* ( reason value component -- )
+
+SYMBOL: values
+
+: value values get at ;
+
+: render-view ( component -- )
+ dup id>> value swap render-view* ;
+
+: render-error ( error -- )
+ <span "error" =class span> write </span> ;
+
+: render-edit ( component -- )
+ dup id>> value dup validation-error? [
+ dup reason>> swap value>> rot render-error*
+ ] [
+ swap render-edit*
+ ] if ;
+
+: <component> ( id string -- component )
+ >r \ component construct-boa r> construct-delegate ; inline
+
+TUPLE: string min max ;
+
+: <string> ( id -- component ) string <component> ;
+
+M: string validate*
+ [ min>> v-min-length ] keep max>> v-max-length ;
+
+M: string render-view*
+ drop write ;
+
+: render-input
+ <input "text" =type id>> dup =id =name =value input/> ;
+
+M: string render-edit*
+ render-input ;
+
+M: string render-error*
+ render-input render-error ;
+
+TUPLE: text ;
+
+: <text> ( id -- component ) <string> text construct-delegate ;
+
+: render-textarea
+ <textarea id>> dup =id =name textarea> write </textarea> ;
+
+M: text render-edit*
+ render-textarea ;
+
+M: text render-error*
+ render-textarea render-error ;
+
+TUPLE: farkup ;
+
+: <farkup> ( id -- component ) <text> farkup construct-delegate ;
+
+M: farkup render-view*
+ drop string-lines "\n" join convert-farkup write ;
+
+TUPLE: number min max ;
+
+: <number> ( id -- component ) number <component> ;
+
+M: number validate*
+ >r v-number r> [ min>> v-min-value ] keep max>> v-max-value ;
+
+M: number render-view*
+ drop number>string write ;
+
+M: number render-edit*
+ >r number>string r> render-input ;
+
+M: number render-error*
+ render-input render-error ;
+
+: tuple>slots ( tuple -- alist )
+ dup class "slot-names" word-prop swap tuple-slots
+ 2array flip ;
+
+: with-components ( tuple components quot -- )
+ [
+ >r components set
+ dup tuple>slots values set
+ tuple set
+ r> call
+ ] with-scope ; inline
+
+TUPLE: form view-template edit-template components ;
+
+: <form> ( id view-template edit-template -- form )
+ V{ } clone form construct-boa
+ swap \ component construct-boa
+ over set-delegate ;
+
+: add-field ( form component -- form )
+ dup id>> pick components>> set-at ;
+
+M: form render-view* ( value form -- )
+ dup components>>
+ swap view-template>>
+ [ resource-path run-template-file ] curry
+ with-components ;
+
+M: form render-edit* ( value form -- )
+ dup components>>
+ swap edit-template>>
+ [ resource-path run-template-file ] curry
+ with-components ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: http.server.crud
+USING: kernel namespaces db.tuples math.parser
+http.server.actions accessors ;
+
+: by-id ( class -- tuple )
+ construct-empty "id" get >>id ;
+
+: <delete-action> ( class -- action )
+ <action>
+ { { "id" [ string>number ] } } >>post-params
+ swap [ by-id delete-tuple f ] curry >>post ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: db http.server kernel new-slots accessors\r
-continuations namespaces ;\r
+continuations namespaces destructors ;\r
IN: http.server.db\r
\r
TUPLE: db-persistence responder db params ;\r
\r
C: <db-persistence> db-persistence\r
\r
+: connect-db ( db-persistence -- )\r
+ dup db>> swap params>> make-db\r
+ dup db set\r
+ dup db-open\r
+ add-always-destructor ;\r
+\r
M: db-persistence call-responder\r
- dup db>> over params>> make-db dup db-open [\r
- db set responder>> call-responder\r
- ] with-disposal ;\r
+ dup connect-db responder>> call-responder ;\r
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib
-vocabs.loader debugger html continuations random combinators ;
+vocabs.loader debugger html continuations random combinators
+destructors ;
IN: http.server
GENERIC: call-responder ( request path responder -- response )
swap method>> "HEAD" =
[ drop ] [ write-response-body ] if ;
-: do-request ( request -- request )
+: do-request ( request -- response )
[
dup dup path>> over host>>
find-virtual-host call-responder
: log-request ( request -- )
{ method>> host>> path>> } map-exec-with httpd-hit ;
-: handle-client ( -- )
- default-timeout
+: ?refresh-all ( -- )
development-mode get-global
- [ global [ refresh-all ] bind ] when
- read-request
- dup log-request
- do-request do-response ;
+ [ global [ refresh-all ] bind ] when ;
+
+: handle-client ( -- )
+ [
+ default-timeout
+ ?refresh-all
+ read-request
+ dup log-request
+ do-request do-response
+ ] with-destructors ;
: httpd ( port -- )
internet-server "http.server"
\r
: with-session \ session swap with-variable ; inline\r
\r
+TUPLE: foo ;\r
+\r
+C: <foo> foo\r
+\r
+M: foo init-session drop 0 "x" sset ;\r
+\r
"1234" f <session> [\r
[ ] [ 3 "x" sset ] unit-test\r
\r
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test\r
\r
[ ] [\r
- f <url-sessions>\r
- [ 0 "x" sset ] >>init\r
+ <foo> <url-sessions>\r
"manager" set\r
] unit-test\r
\r
GENERIC: init-session ( responder -- )
+M: dispatcher init-session drop ;
+
TUPLE: session-manager responder sessions ;
: <session-manager> ( responder class -- responder' )
+++ /dev/null
-Slava Pestov
-Matthew Willis
--- /dev/null
+Slava Pestov
+Matthew Willis
--- /dev/null
+USING: io io.files io.streams.string
+http.server.templating.fhtml kernel tools.test sequences ;
+IN: http.server.templating.fhtml.tests
+
+: test-template ( path -- ? )
+ "extra/http/server/templating/fhtml/test/" swap append
+ [
+ ".fhtml" append resource-path
+ [ run-template-file ] with-string-writer
+ ] keep
+ ".html" append resource-path file-contents = ;
+
+[ t ] [ "example" test-template ] unit-test
+[ t ] [ "bug" test-template ] unit-test
+[ t ] [ "stack" test-template ] unit-test
+
+[ ] [ "<%\n%>" parse-template drop ] unit-test
--- /dev/null
+! Copyright (C) 2005 Alex Chapman
+! Copyright (C) 2006, 2007 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations sequences kernel parser namespaces io
+io.files io.streams.lines io.streams.string html html.elements
+source-files debugger combinators math quotations generic
+strings splitting accessors http.server.static http.server
+assocs ;
+
+IN: http.server.templating.fhtml
+
+: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
+
+! See apps/http-server/test/ or libs/furnace/ for template usage
+! examples
+
+! We use a custom lexer so that %> ends a token even if not
+! followed by whitespace
+TUPLE: template-lexer ;
+
+: <template-lexer> ( lines -- lexer )
+ <lexer> template-lexer construct-delegate ;
+
+M: template-lexer skip-word
+ [
+ {
+ { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
+ { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
+ { [ t ] [ f skip ] }
+ } cond
+ ] change-column ;
+
+DEFER: <% delimiter
+
+: check-<% ( lexer -- col )
+ "<%" over lexer-line-text rot lexer-column start* ;
+
+: found-<% ( accum lexer col -- accum )
+ [
+ over lexer-line-text
+ >r >r lexer-column r> r> subseq parsed
+ \ write-html parsed
+ ] 2keep 2 + swap set-lexer-column ;
+
+: still-looking ( accum lexer -- accum )
+ [
+ dup lexer-line-text swap lexer-column tail
+ parsed \ print-html parsed
+ ] keep next-line ;
+
+: parse-%> ( accum lexer -- accum )
+ dup still-parsing? [
+ dup check-<%
+ [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
+ ] [
+ drop
+ ] if ;
+
+: %> lexer get parse-%> ; parsing
+
+: parse-template-lines ( lines -- quot )
+ <template-lexer> [
+ V{ } clone lexer get parse-%> f (parse-until)
+ ] with-parser ;
+
+: parse-template ( string -- quot )
+ [
+ use [ clone ] change
+ templating-vocab use+
+ string-lines parse-template-lines
+ ] with-scope ;
+
+: eval-template ( string -- ) parse-template call ;
+
+: html-error. ( error -- )
+ <pre> error. </pre> ;
+
+: run-template-file ( filename -- )
+ [
+ [
+ "quiet" on
+ parser-notes off
+ templating-vocab use+
+ ! so that reload works properly
+ dup source-file file set
+ ?resource-path file-contents
+ [ eval-template ] [ html-error. drop ] recover
+ ] with-file-vocabs
+ ] curry assert-depth ;
+
+: run-relative-template-file ( filename -- )
+ file get source-file-path parent-directory
+ swap path+ run-template-file ;
+
+: template-convert ( infile outfile -- )
+ [ run-template-file ] with-file-writer ;
+
+! file responder integration
+: serve-fhtml ( filename -- response )
+ "text/html" <content>
+ swap [ run-template-file ] curry >>body ;
+
+: enable-fhtml ( responder -- responder )
+ [ serve-fhtml ]
+ "application/x-factor-server-page"
+ pick special>> set-at ;
--- /dev/null
+<%
+ USING: prettyprint ;
+ ! Hello world
+ 5 pprint
+%>
--- /dev/null
+<% USING: math ; %>
+
+<html>
+ <head><title>Simple Embedded Factor Example</title></head>
+ <body>
+ <% 5 [ %><p>I like repetition</p><% ] times %>
+ </body>
+</html>
--- /dev/null
+
+
+<html>
+ <head><title>Simple Embedded Factor Example</title></head>
+ <body>
+ <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
+ </body>
+</html>
+
--- /dev/null
+The stack: <% USING: prettyprint ; .s %>
--- /dev/null
+The stack:
+
+++ /dev/null
-USING: io io.files io.streams.string http.server.templating kernel tools.test
- sequences ;
-IN: http.server.templating.tests
-
-: test-template ( path -- ? )
- "extra/http/server/templating/test/" swap append
- [
- ".fhtml" append resource-path
- [ run-template-file ] with-string-writer
- ] keep
- ".html" append resource-path file-contents = ;
-
-[ t ] [ "example" test-template ] unit-test
-[ t ] [ "bug" test-template ] unit-test
-[ t ] [ "stack" test-template ] unit-test
-
-[ ] [ "<%\n%>" parse-template drop ] unit-test
+++ /dev/null
-! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2007 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: continuations sequences kernel parser namespaces io
-io.files io.streams.lines io.streams.string html html.elements
-source-files debugger combinators math quotations generic
-strings splitting accessors http.server.static http.server
-assocs ;
-
-IN: http.server.templating
-
-: templating-vocab ( -- vocab-name ) "http.server.templating" ;
-
-! See apps/http-server/test/ or libs/furnace/ for template usage
-! examples
-
-! We use a custom lexer so that %> ends a token even if not
-! followed by whitespace
-TUPLE: template-lexer ;
-
-: <template-lexer> ( lines -- lexer )
- <lexer> template-lexer construct-delegate ;
-
-M: template-lexer skip-word
- [
- {
- { [ 2dup nth CHAR: " = ] [ drop 1+ ] }
- { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
- { [ t ] [ f skip ] }
- } cond
- ] change-column ;
-
-DEFER: <% delimiter
-
-: check-<% ( lexer -- col )
- "<%" over lexer-line-text rot lexer-column start* ;
-
-: found-<% ( accum lexer col -- accum )
- [
- over lexer-line-text
- >r >r lexer-column r> r> subseq parsed
- \ write-html parsed
- ] 2keep 2 + swap set-lexer-column ;
-
-: still-looking ( accum lexer -- accum )
- [
- dup lexer-line-text swap lexer-column tail
- parsed \ print-html parsed
- ] keep next-line ;
-
-: parse-%> ( accum lexer -- accum )
- dup still-parsing? [
- dup check-<%
- [ found-<% ] [ [ still-looking ] keep parse-%> ] if*
- ] [
- drop
- ] if ;
-
-: %> lexer get parse-%> ; parsing
-
-: parse-template-lines ( lines -- quot )
- <template-lexer> [
- V{ } clone lexer get parse-%> f (parse-until)
- ] with-parser ;
-
-: parse-template ( string -- quot )
- [
- use [ clone ] change
- templating-vocab use+
- string-lines parse-template-lines
- ] with-scope ;
-
-: eval-template ( string -- ) parse-template call ;
-
-: html-error. ( error -- )
- <pre> error. </pre> ;
-
-: run-template-file ( filename -- )
- [
- [
- "quiet" on
- parser-notes off
- templating-vocab use+
- ! so that reload works properly
- dup source-file file set
- ?resource-path file-contents
- [ eval-template ] [ html-error. drop ] recover
- ] with-file-vocabs
- ] curry assert-depth ;
-
-: run-relative-template-file ( filename -- )
- file get source-file-path parent-directory
- swap path+ run-template-file ;
-
-: template-convert ( infile outfile -- )
- [ run-template-file ] with-file-writer ;
-
-! file responder integration
-: serve-fhtml ( filename -- response )
- "text/html" <content>
- swap [ run-template-file ] curry >>body ;
-
-: enable-fhtml ( responder -- responder )
- [ serve-fhtml ]
- "application/x-factor-server-page"
- pick special>> set-at ;
+++ /dev/null
-<%
- USING: prettyprint ;
- ! Hello world
- 5 pprint
-%>
+++ /dev/null
-<% USING: math ; %>
-
-<html>
- <head><title>Simple Embedded Factor Example</title></head>
- <body>
- <% 5 [ %><p>I like repetition</p><% ] times %>
- </body>
-</html>
+++ /dev/null
-
-
-<html>
- <head><title>Simple Embedded Factor Example</title></head>
- <body>
- <p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
- </body>
-</html>
-
+++ /dev/null
-The stack: <% USING: prettyprint ; .s %>
+++ /dev/null
-The stack:
-
--- /dev/null
+IN: http.server.validators.tests
+USING: kernel sequences tools.test http.server.validators ;
+
+[ t t ] [ "foo" [ v-number ] with-validator >r validation-error? r> ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations sequences math namespaces
+math.parser assocs new-slots ;
+IN: http.server.validators
+
+TUPLE: validation-error value reason ;
+
+: validation-error ( value reason -- * )
+ \ validation-error construct-boa throw ;
+
+: with-validator ( string quot -- result error? )
+ [ f ] compose curry
+ [ dup validation-error? [ t ] [ rethrow ] if ] recover ; inline
+
+: validate-param ( name validator assoc -- error? )
+ swap pick
+ >r >r at r> with-validator swap r> set ;
+
+: validate-params ( validators assoc -- error? )
+ [ validate-param ] curry { } assoc>map [ ] contains? ;
+
+: v-default ( str def -- str )
+ over empty? spin ? ;
+
+: v-required ( str -- str )
+ dup empty? [ "required" validation-error ] when ;
+
+: v-min-length ( str n -- str )
+ over length over < [
+ [ "must be at least " % # " characters" % ] "" make
+ validation-error
+ ] [
+ drop
+ ] if ;
+
+: v-max-length ( str n -- str )
+ over length over > [
+ [ "must be no more than " % # " characters" % ] "" make
+ validation-error
+ ] [
+ drop
+ ] if ;
+
+: v-number ( str -- n )
+ dup string>number [ ] [
+ "must be a number" validation-error
+ ] ?if ;
+
+: v-min-value ( str n -- str )
+ 2dup < [
+ [ "must be at least " % # ] "" make
+ validation-error
+ ] [
+ drop
+ ] if ;
+
+: v-max-value ( str n -- str )
+ 2dup > [
+ [ "must be no more than " % # ] "" make
+ validation-error
+ ] [
+ drop
+ ] if ;
QUALIFIED: unix
IN: io.sniffer.bsd
-M: unix-io destruct-handle ( obj -- ) unix:close drop ;
+M: unix-io destruct-handle ( obj -- ) unix:close ;
C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ;
C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ;
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
} cleave
\ file-info construct-boa ;
+
+M: unix-io link-info ( path -- info )
+ lstat* {
+ [ stat>type ]
+ [ stat-st_size ]
+ [ stat-st_mode ]
+ [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
+ } cleave
+ \ file-info construct-boa ;
swap io-task-filter over set-kevent-filter ;
: register-kevent ( kevent mx -- )
- mx-fd swap 1 f 0 f kevent io-error ;
+ mx-fd swap 1 f 0 f kevent
+ 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
M: kqueue-mx register-io-task ( task mx -- )
over EV_ADD make-kevent over register-kevent
get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 <int> set-option
-[ B{ 0 0 0 3 } ] [
+[ 3 ] [
get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" <c-object> [ get-option ] keep
+ *int
] unit-test
+[
get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
get-ldp get-message next-message msgtype result-type
] with-bind
+] drop
IN: ldap.libldap
-"libldap" {
+<< "libldap" {
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
-} cond add-library
+} cond add-library >>
: LDAP_VERSION1 1 ; inline
: LDAP_VERSION2 2 ; inline
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib ;
+ assocs.lib math.parser math sequences.lib ;
IN: namespaces.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: set* ( val var -- ) namestack* set-assoc-stack ;
+
+SYMBOL: building-seq
+: get-building-seq ( n -- seq )
+ building-seq get nth ;
+
+: n, get-building-seq push ;
+: n% get-building-seq push-all ;
+: n# >r number>string r> n% ;
+
+: 0, 0 n, ;
+: 0% 0 n% ;
+: 0# 0 n# ;
+: 1, 1 n, ;
+: 1% 1 n% ;
+: 1# 1 n# ;
+: 2, 2 n, ;
+: 2% 2 n% ;
+: 2# 2 n# ;
+
+: nmake ( quot exemplars -- seqs )
+ dup length dup zero? [ 1+ ] when
+ [
+ [
+ [ drop 1024 swap new-resizable ] 2map
+ [ building-seq set call ] keep
+ ] 2keep >r [ like ] 2map r> firstn
+ ] with-scope ;
IN: openssl.libssl
-"libssl" {
+<< "libssl" {
{ [ win32? ] [ "ssleay32.dll" "stdcall" ] }
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
-} cond add-library
+} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline
: X509_FILETYPE_ASN1 2 ; inline
IN: pdf.libhpdf
-"libhpdf" {
+<< "libhpdf" {
{ [ win32? ] [ "libhpdf.dll" "stdcall" ] }
{ [ macosx? ] [ "libhpdf.dylib" "cdecl" ] }
{ [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] }
-} cond add-library
+} cond add-library >>
! compression mode
: HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed
] with-text
- "extra/pdf/test/font_test.pdf" resource-path save-to-file
+ "font_test.pdf" temp-file save-to-file
] with-pdf
+++ /dev/null
-%PDF-1.3
-%·¾Âª
-1 0 obj
-<<
-/Type /Catalog
-/Pages 2 0 R
->>
-endobj
-2 0 obj
-<<
-/Type /Pages
-/Kids [ 4 0 R ]
-/Count 1
->>
-endobj
-3 0 obj
-<<
-/Producer (Haru\040Free\040PDF\040Library\0402.0.8)
->>
-endobj
-4 0 obj
-<<
-/Type /Page
-/MediaBox [ 0 0 595 841 ]
-/Contents 5 0 R
-/Resources <<
-/ProcSet [ /PDF /Text /ImageB /ImageC /ImageI ]
-/Font <<
-/F1 7 0 R
-/F2 8 0 R
-/F3 9 0 R
-/F4 10 0 R
-/F5 11 0 R
-/F6 12 0 R
-/F7 13 0 R
-/F8 14 0 R
-/F9 15 0 R
-/F10 16 0 R
-/F11 17 0 R
-/F12 18 0 R
-/F13 19 0 R
-/F14 20 0 R
->>
->>
-/Parent 2 0 R
->>
-endobj
-5 0 obj
-<<
-/Length 6 0 R
->>
-stream\r
-1 w
-50 50 495 731 re
-S
-/F1 24 Tf
-BT
-238.148 791 Td
-(Font\040Demo) Tj
-ET
-BT
-/F1 16 Tf
-60 761 Td
-(\074Standard\040Type1\040font\040samples\076) Tj
-ET
-BT
-60 736 Td
-/F2 9 Tf
-(Courier) Tj
-0 -18 Td
-/F2 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F3 9 Tf
-(Courier-Bold) Tj
-0 -18 Td
-/F3 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F4 9 Tf
-(Courier-Oblique) Tj
-0 -18 Td
-/F4 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F5 9 Tf
-(Courier-BoldOblique) Tj
-0 -18 Td
-/F5 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F1 9 Tf
-(Helvetica) Tj
-0 -18 Td
-/F1 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F6 9 Tf
-(Helvetica-Bold) Tj
-0 -18 Td
-/F6 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F7 9 Tf
-(Helvetica-Oblique) Tj
-0 -18 Td
-/F7 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F8 9 Tf
-(Helvetica-BoldOblique) Tj
-0 -18 Td
-/F8 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F9 9 Tf
-(Times-Roman) Tj
-0 -18 Td
-/F9 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F10 9 Tf
-(Times-Bold) Tj
-0 -18 Td
-/F10 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F11 9 Tf
-(Times-Italic) Tj
-0 -18 Td
-/F11 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F12 9 Tf
-(Times-BoldItalic) Tj
-0 -18 Td
-/F12 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F13 9 Tf
-(Symbol) Tj
-0 -18 Td
-/F13 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-/F14 9 Tf
-(ZapfDingbats) Tj
-0 -18 Td
-/F14 20 Tf
-(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
-0 -20 Td
-ET
-
-endstream
-endobj
-6 0 obj
-1517
-endobj
-7 0 obj
-<<
-/Type /Font
-/BaseFont /Helvetica
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-8 0 obj
-<<
-/Type /Font
-/BaseFont /Courier
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-9 0 obj
-<<
-/Type /Font
-/BaseFont /Courier-Bold
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-10 0 obj
-<<
-/Type /Font
-/BaseFont /Courier-Oblique
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-11 0 obj
-<<
-/Type /Font
-/BaseFont /Courier-BoldOblique
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-12 0 obj
-<<
-/Type /Font
-/BaseFont /Helvetica-Bold
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-13 0 obj
-<<
-/Type /Font
-/BaseFont /Helvetica-Oblique
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-14 0 obj
-<<
-/Type /Font
-/BaseFont /Helvetica-BoldOblique
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-15 0 obj
-<<
-/Type /Font
-/BaseFont /Times-Roman
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-16 0 obj
-<<
-/Type /Font
-/BaseFont /Times-Bold
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-17 0 obj
-<<
-/Type /Font
-/BaseFont /Times-Italic
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-18 0 obj
-<<
-/Type /Font
-/BaseFont /Times-BoldItalic
-/Subtype /Type1
-/Encoding /StandardEncoding
->>
-endobj
-19 0 obj
-<<
-/Type /Font
-/BaseFont /Symbol
-/Subtype /Type1
->>
-endobj
-20 0 obj
-<<
-/Type /Font
-/BaseFont /ZapfDingbats
-/Subtype /Type1
->>
-endobj
-xref
-0 21
-0000000000 65535 f\r
-0000000015 00000 n\r
-0000000064 00000 n\r
-0000000123 00000 n\r
-0000000196 00000 n\r
-0000000518 00000 n\r
-0000002089 00000 n\r
-0000002109 00000 n\r
-0000002207 00000 n\r
-0000002303 00000 n\r
-0000002404 00000 n\r
-0000002509 00000 n\r
-0000002618 00000 n\r
-0000002722 00000 n\r
-0000002829 00000 n\r
-0000002940 00000 n\r
-0000003041 00000 n\r
-0000003141 00000 n\r
-0000003243 00000 n\r
-0000003349 00000 n\r
-0000003417 00000 n\r
-trailer
-<<
-/Root 1 0 R
-/Info 3 0 R
-/Size 21
->>
-startxref
-3491
-%%EOF
\r
HELP: delay\r
{ $values \r
+ { "quot" "a quotation" } \r
{ "parser" "a parser" } \r
}\r
{ $description \r
"Delays the construction of a parser until it is actually required to parse. This " \r
"allows for calling a parser that results in a recursive call to itself. The quotation "\r
- "should return the constructed parser." } ;
\ No newline at end of file
+ "should return the constructed parser." } ;\r
MEMO: hide ( parser -- parser )
[ drop ignore ] action ;
-MEMO: delay ( parser -- parser )
+MEMO: delay ( quot -- parser )
delay-parser construct-boa init-parser ;
: PEG:
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel math math.parser arrays tools.test peg peg.search ;
+USING: kernel math math.parser arrays tools.test peg peg.parsers
+peg.search ;
IN: peg.search.tests
{ V{ 123 456 } } [
: method-words
{
- method-def
forget-word
} ;
--- /dev/null
+USING: kernel peg regexp2 sequences tools.test ;
+IN: regexp2.tests
+
+[ T{ parse-result f T{ slice f 3 3 "056" } 46 } ]
+ [ "056" 'octal' parse ] unit-test
--- /dev/null
+USING: assocs combinators.lib kernel math math.parser
+namespaces peg unicode.case sequences unicode.categories
+memoize peg.parsers ;
+USE: io
+USE: tools.walker
+IN: regexp2
+
+<PRIVATE
+
+SYMBOL: ignore-case?
+
+: char=-quot ( ch -- quot )
+ ignore-case? get
+ [ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
+ curry ;
+
+: char-between?-quot ( ch1 ch2 -- quot )
+ ignore-case? get
+ [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
+ [ [ between? ] ]
+ if 2curry ;
+
+: or-predicates ( quots -- quot )
+ [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+
+: literal-action [ nip ] curry action ;
+
+: delay-action [ curry ] curry action ;
+
+PRIVATE>
+
+: ascii? ( n -- ? )
+ 0 HEX: 7f between? ;
+
+: octal-digit? ( n -- ? )
+ CHAR: 0 CHAR: 7 between? ;
+
+: hex-digit? ( n -- ? )
+ {
+ [ dup digit? ]
+ [ dup CHAR: a CHAR: f between? ]
+ [ dup CHAR: A CHAR: F between? ]
+ } || nip ;
+
+: control-char? ( n -- ? )
+ { [ dup 0 HEX: 1f between? ] [ dup HEX: 7f = ] } || nip ;
+
+: punct? ( n -- ? )
+ "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
+
+: c-identifier-char? ( ch -- ? )
+ { [ dup alpha? ] [ dup CHAR: _ = ] } || nip ;
+
+: java-blank? ( n -- ? )
+ {
+ CHAR: \s
+ CHAR: \t CHAR: \n CHAR: \r
+ HEX: c HEX: 7 HEX: 1b
+ } member? ;
+
+: java-printable? ( n -- ? )
+ { [ dup alpha? ] [ dup punct? ] } || nip ;
+
+MEMO: 'ordinary-char' ( -- parser )
+ [ "\\^*+?|(){}[$" member? not ] satisfy
+ [ char=-quot ] action ;
+
+MEMO: 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
+
+MEMO: 'octal' ( -- parser )
+ "0" token hide 'octal-digit' 1 3 from-m-to-n 2seq
+ [ first oct> ] action ;
+
+MEMO: 'hex-digit' ( -- parser ) [ hex-digit? ] satisfy ;
+
+MEMO: 'hex' ( -- parser )
+ "x" token hide 'hex-digit' 2 exactly-n 2seq
+ "u" token hide 'hex-digit' 6 exactly-n 2seq 2choice
+ [ first hex> ] action ;
+
+: satisfy-tokens ( assoc -- parser )
+ [ >r token r> literal-action ] { } assoc>map choice ;
+
+MEMO: 'simple-escape-char' ( -- parser )
+ {
+ { "\\" CHAR: \\ }
+ { "t" CHAR: \t }
+ { "n" CHAR: \n }
+ { "r" CHAR: \r }
+ { "f" HEX: c }
+ { "a" HEX: 7 }
+ { "e" HEX: 1b }
+ } [ char=-quot ] assoc-map satisfy-tokens ;
+
+MEMO: 'predefined-char-class' ( -- parser )
+ {
+ { "d" [ digit? ] }
+ { "D" [ digit? not ] }
+ { "s" [ java-blank? ] }
+ { "S" [ java-blank? not ] }
+ { "w" [ c-identifier-char? ] }
+ { "W" [ c-identifier-char? not ] }
+ } satisfy-tokens ;
+
+MEMO: 'posix-character-class' ( -- parser )
+ {
+ { "Lower" [ letter? ] }
+ { "Upper" [ LETTER? ] }
+ { "ASCII" [ ascii? ] }
+ { "Alpha" [ Letter? ] }
+ { "Digit" [ digit? ] }
+ { "Alnum" [ alpha? ] }
+ { "Punct" [ punct? ] }
+ { "Graph" [ java-printable? ] }
+ { "Print" [ java-printable? ] }
+ { "Blank" [ " \t" member? ] }
+ { "Cntrl" [ control-char? ] }
+ { "XDigit" [ hex-digit? ] }
+ { "Space" [ java-blank? ] }
+ } satisfy-tokens "p{" "}" surrounded-by ;
+
+MEMO: 'simple-escape' ( -- parser )
+ [
+ 'octal' ,
+ 'hex' ,
+ "c" token hide [ LETTER? ] satisfy 2seq ,
+ any-char ,
+ ] choice* [ char=-quot ] action ;
+
+MEMO: 'escape' ( -- parser )
+ "\\" token hide [
+ 'simple-escape-char' ,
+ 'predefined-char-class' ,
+ 'posix-character-class' ,
+ 'simple-escape' ,
+ ] choice* 2seq ;
+
+MEMO: 'any-char' ( -- parser )
+ "." token [ drop t ] literal-action ;
+
+MEMO: 'char' ( -- parser )
+ 'any-char' 'escape' 'ordinary-char' 3choice [ satisfy ] action ;
+
+DEFER: 'regexp'
+
+TUPLE: group-result str ;
+
+C: <group-result> group-result
+
+MEMO: 'non-capturing-group' ( -- parser )
+ "?:" token hide 'regexp' ;
+
+MEMO: 'positive-lookahead-group' ( -- parser )
+ "?=" token hide 'regexp' [ ensure ] action ;
+
+MEMO: 'negative-lookahead-group' ( -- parser )
+ "?!" token hide 'regexp' [ ensure-not ] action ;
+
+MEMO: 'simple-group' ( -- parser )
+ 'regexp' [ [ <group-result> ] action ] action ;
+
+MEMO: 'group' ( -- parser )
+ [
+ 'non-capturing-group' ,
+ 'positive-lookahead-group' ,
+ 'negative-lookahead-group' ,
+ 'simple-group' ,
+ ] choice* "(" ")" surrounded-by ;
+
+MEMO: 'range' ( -- parser )
+ any-char "-" token hide any-char 3seq
+ [ first2 char-between?-quot ] action ;
+
+MEMO: 'character-class-term' ( -- parser )
+ 'range'
+ 'escape'
+ [ "\\]" member? not ] satisfy [ char=-quot ] action
+ 3choice ;
+
+MEMO: 'positive-character-class' ( -- parser )
+ ! todo
+ "]" token [ CHAR: ] = ] literal-action 'character-class-term' repeat0 2seq
+ 'character-class-term' repeat1 2choice [ or-predicates ] action ;
+
+MEMO: 'negative-character-class' ( -- parser )
+ "^" token hide 'positive-character-class' 2seq
+ [ [ not ] append ] action ;
+
+MEMO: 'character-class' ( -- parser )
+ 'negative-character-class' 'positive-character-class' 2choice
+ "[" "]" surrounded-by [ satisfy ] action ;
+
+MEMO: 'escaped-seq' ( -- parser )
+ any-char repeat1
+ [ ignore-case? get token ] action "\\Q" "\\E" surrounded-by ;
+
+MEMO: 'break' ( quot -- parser )
+ satisfy ensure
+ epsilon just 2choice ;
+
+MEMO: 'break-escape' ( -- parser )
+ "$" token [ "\r\n" member? ] 'break' literal-action
+ "\\b" token [ blank? ] 'break' literal-action
+ "\\B" token [ blank? not ] 'break' literal-action
+ "\\z" token epsilon just literal-action 4choice ;
+
+MEMO: 'simple' ( -- parser )
+ [
+ 'escaped-seq' ,
+ 'break-escape' ,
+ 'group' ,
+ 'character-class' ,
+ 'char' ,
+ ] choice* ;
+
+MEMO: 'exactly-n' ( -- parser )
+ 'integer' [ exactly-n ] delay-action ;
+
+MEMO: 'at-least-n' ( -- parser )
+ 'integer' "," token hide 2seq [ at-least-n ] delay-action ;
+
+MEMO: 'at-most-n' ( -- parser )
+ "," token hide 'integer' 2seq [ at-most-n ] delay-action ;
+
+MEMO: 'from-m-to-n' ( -- parser )
+ 'integer' "," token hide 'integer' 3seq
+ [ first2 from-m-to-n ] delay-action ;
+
+MEMO: 'greedy-interval' ( -- parser )
+ 'exactly-n' 'at-least-n' 'at-most-n' 'from-m-to-n' 4choice ;
+
+MEMO: 'interval' ( -- parser )
+ 'greedy-interval'
+ 'greedy-interval' "?" token hide 2seq [ "reluctant {}" print ] action
+ 'greedy-interval' "+" token hide 2seq [ "possessive {}" print ] action
+ 3choice "{" "}" surrounded-by ;
+
+MEMO: 'repetition' ( -- parser )
+ [
+ ! Possessive
+ ! "*+" token [ <!*> ] literal-action ,
+ ! "++" token [ <!+> ] literal-action ,
+ ! "?+" token [ <!?> ] literal-action ,
+ ! Reluctant
+ ! "*?" token [ <(*)> ] literal-action ,
+ ! "+?" token [ <(+)> ] literal-action ,
+ ! "??" token [ <(?)> ] literal-action ,
+ ! Greedy
+ "*" token [ repeat0 ] literal-action ,
+ "+" token [ repeat1 ] literal-action ,
+ "?" token [ optional ] literal-action ,
+ ] choice* ;
+
+MEMO: 'dummy' ( -- parser )
+ epsilon [ ] literal-action ;
+
+! todo -- check the action
+! MEMO: 'term' ( -- parser )
+ ! 'simple'
+ ! 'repetition' 'interval' 'dummy' 3choice 2seq [ first2 call ] action
+ ! <!+> [ <and-parser> ] action ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax ;
+IN: singleton
+
+HELP: SINGLETON:
+{ $syntax "SINGLETON: class"
+} { $values
+ { "class" "a new tuple class to define" }
+} { $description
+ "Defines a new tuple class with membership predicate name? and a default empty constructor that is the class name itself."
+} { $examples
+ { $example "SINGLETON: foo\nfoo ." "T{ foo f }" }
+} { $see-also
+ POSTPONE: TUPLE:
+} ;
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel parser quotations prettyprint tuples words ;
+IN: singleton
+
+: SINGLETON:
+ CREATE-CLASS
+ dup { } define-tuple-class
+ dup unparse create-in reset-generic
+ dup construct-empty 1quotation define ; parsing
[ ] [
[
+ "localhost" smtp-host set
4321 smtp-port set
"Hi guys\nBye guys"
send-simple-message
] with-scope
-] unit-test
\ No newline at end of file
+] unit-test
"stat" <c-object> dup >r
stat check-status
r> ;
+
+: lstat* ( pathname -- stat )
+ "stat" <c-object> dup >r
+ lstat check-status
+ r> ;
: MAP_FAILED -1 <alien> ; inline
+: ESRCH 3 ; inline
: EEXIST 17 ; inline
! ! ! Unix functions
+++ /dev/null
-Chris Double
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: html http http.server.responders io kernel math
-namespaces prettyprint continuations random system sequences
-assocs ;
-IN: webapps.callback
-
-#! Name of the variable holding the continuation used to exit
-#! back to the httpd responder.
-SYMBOL: exit-continuation
-
-#! Tuple to hold global request data. This gets passed to
-#! the continuation when resumed so it can restore things
-#! like 'stdio' so it writes to the correct socket.
-TUPLE: request stream exitcc method url raw-query query header response ;
-
-: <request> ( -- request )
- stdio get
- exit-continuation get
- "method" get
- "request" get
- "raw-query" get
- "query" get
- "header" get
- "response" get
- request construct-boa ;
-
-: restore-request ( -- )
- request get
- dup request-stream stdio set
- dup request-method "method" set
- dup request-raw-query "raw-query" set
- dup request-query "query" set
- dup request-header "header" set
- dup request-response "response" set
- request-exitcc exit-continuation set ;
-
-: update-request ( request new-request -- )
- [ request-stream over set-request-stream ] keep
- [ request-method over set-request-method ] keep
- [ request-url over set-request-url ] keep
- [ request-raw-query over set-request-raw-query ] keep
- [ request-query over set-request-query ] keep
- [ request-header over set-request-header ] keep
- [ request-response over set-request-response ] keep
- request-exitcc swap set-request-exitcc ;
-
-: with-exit-continuation ( quot -- )
- #! Call the quotation with the variable exit-continuation bound
- #! such that when the exit continuation is called, computation
- #! will resume from the end of this 'with-exit-continuation' call.
- [
- exit-continuation set call exit-continuation get continue
- ] callcc0 drop ;
-
-: expiry-timeout ( -- ms ) 900 1000 * ;
-
-: get-random-id ( -- id )
- #! Generate a random id to use for continuation URL's
- 4 big-random unparse ;
-
-: callback-table ( -- <hashtable> )
- #! Return the global table of continuations
- \ callback-table get-global ;
-
-: reset-callback-table ( -- )
- #! Create the initial global table
- H{ } clone \ callback-table set-global ;
-
-reset-callback-table
-
-#! Tuple for holding data related to a callback.
-TUPLE: item quot expire? request id time-added ;
-
-: <item> ( quot expire? request id -- item )
- millis item construct-boa ;
-
-: expired? ( item -- ? )
- #! Return true if the callback item is expirable
- #! and has expired (ie. was added to the table more than
- #! timeout milliseconds ago).
- [ item-time-added expiry-timeout + millis < ] keep
- item-expire? and ;
-
-: expire-callbacks ( -- )
- #! Expire all continuations in the continuation table
- #! if they are 'timeout-seconds' old (ie. were added
- #! more than 'timeout-seconds' ago.
- callback-table clone [
- expired? [ callback-table delete-at ] [ drop ] if
- ] assoc-each ;
-
-: id>url ( id -- string )
- #! Convert the continuation id to an URL suitable for
- #! embedding in an HREF or other HTML.
- "/responder/callback/?id=" swap url-encode append ;
-
-: register-callback ( quot expire? -- url )
- #! Store a continuation in the table and associate it with
- #! a random id. That continuation will be expired after
- #! a certain period of time if 'expire?' is true.
- request get get-random-id [ <item> ] keep
- [ callback-table set-at ] keep
- id>url ;
-
-: register-html-callback ( quot expire? -- url )
- >r [ serving-html ] swap append r> register-callback ;
-
-: callback-responder ( -- )
- expire-callbacks
- "id" query-param callback-table at [
- [
- dup item-request [
- <request> update-request
- ] when*
- item-quot call
- exit-continuation get continue
- ] with-exit-continuation drop
- ] [
- "404 Callback not available" httpd-error
- ] if* ;
-
-global [
- "callback" [ callback-responder ] add-simple-responder
-] bind
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: http math namespaces io strings kernel html html.elements
-hashtables continuations quotations parser generic sequences
-webapps.callback http.server.responders ;
-IN: webapps.continuation
-
-#! Used inside the session state of responders to indicate whether the
-#! next request should use the post-refresh-get pattern. It is set to
-#! true after each request.
-SYMBOL: post-refresh-get?
-
-: >callable ( quot|interp|f -- interp )
- dup continuation? [
- [ continue ] curry
- ] when ;
-
-: forward-to-url ( url -- )
- #! When executed inside a 'show' call, this will force a
- #! HTTP 302 to occur to instruct the browser to forward to
- #! the request URL.
- [
- "HTTP/1.1 302 Document Moved\nLocation: " % %
- "\nContent-Length: 0\nContent-Type: text/plain\n\n" %
- ] "" make write exit-continuation get continue ;
-
-: forward-to-id ( id -- )
- #! When executed inside a 'show' call, this will force a
- #! HTTP 302 to occur to instruct the browser to forward to
- #! the request URL.
- >r "request" get r> id>url append forward-to-url ;
-
-SYMBOL: current-show
-
-: store-current-show ( -- )
- #! Store the current continuation in the variable 'current-show'
- #! so it can be returned to later by href callbacks. Note that it
- #! recalls itself when the continuation is called to ensure that
- #! it resets its value back to the most recent show call.
- [ ( 0 -- )
- [ ( 0 1 -- )
- current-show set ( 0 -- )
- continue
- ] callcc1
- nip
- restore-request
- call
- store-current-show
- ] callcc0 restore-request ;
-
-: redirect-to-here ( -- )
- #! Force a redirect to the client browser so that the browser
- #! goes to the current point in the code. This forces an URL
- #! change on the browser so that refreshing that URL will
- #! immediately run from this code point. This prevents the
- #! "this request will issue a POST" warning from the browser
- #! and prevents re-running the previous POST logic. This is
- #! known as the 'post-refresh-get' pattern.
- post-refresh-get? get [
- [
- >callable t register-callback forward-to-url
- ] callcc0 restore-request
- ] [
- t post-refresh-get? set
- ] if ;
-
-: (show) ( quot -- hashtable )
- #! See comments for show. The difference is the
- #! quotation MUST set the content-type using 'serving-html'
- #! or similar.
- store-current-show redirect-to-here
- [
- >callable t register-callback swap with-scope
- exit-continuation get continue
- ] callcc0 drop restore-request "response" get ;
-
-: show ( quot -- namespace )
- #! Call the quotation with the URL associated with the current
- #! continuation. All output from the quotation goes to the client
- #! browser. When the URL is later referenced then
- #! computation will resume from this 'show' call with a hashtable on
- #! the stack containing any query or post parameters.
- #! 'quot' has stack effect ( url -- )
- #! NOTE: On return from 'show' the stack is exactly the same as
- #! initial entry with 'quot' popped off and the hashtable pushed on. Even
- #! if the quotation consumes items on the stack.
- [ serving-html ] swap append (show) ;
-
-: (show-final) ( quot -- namespace )
- #! See comments for show-final. The difference is the
- #! quotation MUST set the content-type using 'serving-html'
- #! or similar.
- store-current-show redirect-to-here
- with-scope exit-continuation get continue ;
-
-: show-final ( quot -- namespace )
- #! Similar to 'show', except the quotation does not receive the URL
- #! to resume computation following 'show-final'. No continuation is
- #! stored for this resumption. As a result, 'show-final' is for use
- #! when a page is to be displayed with no further action to occur. Its
- #! use is an optimisation to save having to generate and save a continuation
- #! in that special case.
- #! 'quot' has stack effect ( -- ).
- [ serving-html ] swap compose (show-final) ;
-
-#! Name of variable for holding initial continuation id that starts
-#! the responder.
-SYMBOL: root-callback
-
-: cont-get/post-responder ( id-or-f -- )
- #! httpd responder that handles the root continuation request.
- #! The requests for actual continuation are processed by the
- #! 'callback-responder'.
- [
- [ f post-refresh-get? set <request> request set root-callback get call ] with-scope
- exit-continuation get continue
- ] with-exit-continuation drop ;
-
-: quot-url ( quot -- url )
- current-show get [ continue-with ] 2curry t register-callback ;
-
-: quot-href ( text quot -- )
- #! Write to standard output an HTML HREF where the href,
- #! when referenced, will call the quotation and then return
- #! back to the most recent 'show' call (via the callback-cc).
- #! The text of the link will be the 'text' argument on the
- #! stack.
- <a quot-url =href a> write </a> ;
-
-: install-cont-responder ( name quot -- )
- #! Install a cont-responder with the given name
- #! that will initially run the given quotation.
- #!
- #! Convert the quotation so it is run within a session namespace
- #! and that namespace is initialized first.
- [
- [ cont-get/post-responder ] "get" set
- [ cont-get/post-responder ] "post" set
- swap "responder" set
- root-callback set
- ] make-responder ;
-
-: show-message-page ( message -- )
- #! Display the message in an HTML page with an OK button.
- [
- "Press OK to Continue" [
- swap paragraph
- <a =href a> "OK" write </a>
- ] simple-page
- ] show 2drop ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! Simple test applications
-USING: hashtables html kernel io html html.elements strings math
-assocs quotations webapps.continuation namespaces prettyprint
-sequences ;
-
-IN: webapps.continuation.examples
-
-: display-page ( title -- )
- #! Display a page with some text to test the cont-responder.
- #! The page has a link to the 'next' continuation.
- [
- <h1> over write </h1>
- swap [
- <a =href a> "Next" write </a>
- ] simple-html-document
- ] show 2drop ;
-
-: display-get-name-page ( -- name )
- #! Display a page prompting for input of a name and return that name.
- [
- "Enter your name" [
- <h1> swap write </h1>
- <form "post" =method =action form>
- "Name: " write
- <input "text" =type "name" =name "20" =size input/>
- <input "submit" =type "Ok" =value input/>
- </form>
- ] simple-html-document
- ] show "name" swap at ;
-
-: test-cont-responder ( -- )
- #! Test the cont-responder responder by displaying a few pages in a row.
- "Page one" display-page
- "Hello " display-get-name-page append display-page
- "Page three" display-page ;
-
-: test-cont-responder2 ( -- )
- #! Test the cont-responder responder by displaying a few pages in a loop.
- [ "one" "two" "three" "four" ] [ display-page ] each
- "Done!" display-page ;
-
-: test-cont-responder3 ( -- )
- #! Test the quot-href word by displaying a menu of the current
- #! test words. Note that we use show-final as we don't link to a 'next' page.
- [
- "Menu" [
- <h1> "Menu" write </h1>
- <ol>
- <li> "Test responder1" [ test-cont-responder ] quot-href </li>
- <li> "Test responder2" [ test-cont-responder2 ] quot-href </li>
- </ol>
- ] simple-html-document
- ] show-final ;
-
-: counter-example ( count -- )
- #! Display a counter which can be incremented or decremented
- #! using anchors.
- #!
- #! Don't need the original alist
- [
- #! And we don't need the 'url' argument
- drop
- "Counter: " over unparse append [
- dup <h2> unparse write </h2>
- "++" over 1quotation [ f ] swap append [ 1 + counter-example ] append quot-href
- "--" over 1quotation [ f ] swap append [ 1 - counter-example ] append quot-href
- drop
- ] simple-html-document
- ] show drop ;
-
-: counter-example2 ( -- )
- #! Display a counter which can be incremented or decremented
- #! using anchors.
- #!
- 0 "counter" set
- [
- #! We don't need the 'url' argument
- drop
- "Counter: " "counter" get unparse append [
- <h2> "counter" get unparse write </h2>
- "++" [ "counter" get 1 + "counter" set ] quot-href
- "--" [ "counter" get 1 - "counter" set ] quot-href
- ] simple-html-document
- ] show
- drop ;
-
-! Install the examples
-"counter1" [ drop 0 counter-example ] install-cont-responder
-"counter2" [ drop counter-example2 ] install-cont-responder
-"test1" [ test-cont-responder ] install-cont-responder
-"test2" [ drop test-cont-responder2 ] install-cont-responder
-"test3" [ drop test-cont-responder3 ] install-cont-responder
projects / factor.git / commitdiff