steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor into semantic-db

db4
Alex Chapman 2008-03-06 23:54:46 +11:00
parent 6bb2a46acb 626334303c
commit 60ac79e5ab
114 changed files with 3449 additions and 2577 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/classes/classes-tests.factor
View File

@ -56,8 +56,8 @@ UNION: c a b ;
[ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test
DEFER: bah
FORGET: bah
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test

10
core/generic/generic-docs.factor
View File

@ -116,16 +116,18 @@ HELP: method-spec
{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
HELP: method-body
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
{ $description "Looks up a method definition." }
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } ;
{ method define-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ;
{ $description "Creates a new method." } ;
HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }

54
core/generic/generic.factor
View File

@ -25,16 +25,12 @@ GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
M: generic definer drop f f ;
M: generic definition drop f ;
: make-generic ( word -- )
dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ;
TUPLE: method word def specializer generic loc ;
: method ( class generic -- method/f )
"methods" word-prop at ;
@ -47,7 +43,7 @@ PREDICATE: pair method-spec
: methods ( word -- assoc )
"methods" word-prop
[ keys sort-classes ] keep
[ dupd at method-word ] curry { } map>assoc ;
[ dupd at ] curry { } map>assoc ;
TUPLE: check-method class generic ;
@ -63,29 +59,33 @@ TUPLE: check-method class generic ;
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
: make-method-def ( quot word combination -- quot )
: make-method-def ( quot class generic -- quot )
"combination" word-prop method-prologue swap append ;
PREDICATE: word method-body "method" word-prop >boolean ;
PREDICATE: word method-body "method-def" word-prop >boolean ;
M: method-body stack-effect
"method" word-prop method-generic stack-effect ;
"method-generic" word-prop stack-effect ;
: <method-word> ( quot class generic -- word )
[ make-method-def ] 2keep
method-word-name f <word>
dup rot define
dup xref ;
: method-word-props ( quot class generic -- assoc )
[
"method-generic" set
"method-class" set
"method-def" set
] H{ } make-assoc ;
: <method> ( quot class generic -- method )
: <method> ( quot class generic -- word )
check-method
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ;
[ make-method-def ] 3keep
[ method-word-props ] 2keep
method-word-name f <word>
tuck set-word-props
dup rot define ;
: redefine-method ( quot class generic -- )
[ method set-method-def ] 3keep
[ method swap "method-def" set-word-prop ] 3keep
[ make-method-def ] 2keep
method method-word swap define ;
method swap define ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
@ -102,21 +102,22 @@ M: method-body stack-effect
! Definition protocol
M: method-spec where
dup first2 method [ method-word ] [ second ] ?if where ;
dup first2 method [ ] [ second ] ?if where ;
M: method-spec set-where
first2 method method-word set-where ;
first2 method set-where ;
M: method-spec definer
drop \ M: \ ; ;
M: method-spec definition
first2 method dup [ method-def ] when ;
first2 method dup
[ "method-def" word-prop ] when ;
: forget-method ( class generic -- )
check-method
[ delete-at* ] with-methods
[ method-word forget-word ] [ drop ] if ;
[ forget-word ] [ drop ] if ;
M: method-spec forget*
first2 forget-method ;
@ -125,11 +126,11 @@ M: method-body definer
drop \ M: \ ; ;
M: method-body definition
"method" word-prop method-def ;
"method-def" word-prop ;
M: method-body forget*
"method" word-prop
{ method-specializer method-generic } get-slots
dup "method-class" word-prop
swap "method-generic" word-prop
forget-method ;
: implementors* ( classes -- words )
@ -168,8 +169,7 @@ M: word subwords drop f ;
M: generic subwords
dup "methods" word-prop values
swap "default-method" word-prop add
[ method-word ] map ;
swap "default-method" word-prop add ;
M: generic forget-word
dup subwords [ forget-word ] each (forget-word) ;

2
core/generic/math/math.factor
View File

@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
: applicable-method ( generic class -- quot )
over method
[ method-word word-def ]
[ word-def ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )

2
core/generic/standard/standard.factor
View File

@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
] if ;
: default-method ( word -- pair )
"default-method" word-prop method-word
"default-method" word-prop
object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot )

3
core/inference/backend/backend.factor
View File

@ -10,8 +10,7 @@ IN: inference.backend
recursive-state get at ;
: inline? ( word -- ? )
dup "method" word-prop
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
dup "method-generic" word-prop swap or "inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys

2
core/optimizer/inlining/inlining.factor
View File

@ -64,7 +64,7 @@ DEFER: (flat-length)
: inline-standard-method ( node word -- node )
2dup dispatching-class dup [
over +inlined+ depends-on
swap method method-word 1quotation f splice-quot
swap method 1quotation f splice-quot
] [
3drop t
] if ;

2
core/optimizer/optimizer-tests.factor
View File

@ -293,7 +293,7 @@ TUPLE: silly-tuple a b ;
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics
: should-inline? method method-word flat-length 10 <= ;
: should-inline? method flat-length 10 <= ;
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test

14
core/prettyprint/prettyprint.factor
View File

@ -175,10 +175,10 @@ M: method-spec synopsis*
dup definer. [ pprint-word ] each ;
M: method-body synopsis*
dup definer.
"method" word-prop dup
method-specializer pprint*
method-generic pprint* ;
dup dup
definer.
"method-class" word-prop pprint*
"method-generic" word-prop pprint* ;
M: mixin-instance synopsis*
dup definer.
@ -269,7 +269,7 @@ M: builtin-class see-class*
: see-implementors ( class -- seq )
dup implementors
[ method method-word ] with map
[ method ] with map
natural-sort ;
: see-class ( class -- )
@ -280,9 +280,7 @@ M: builtin-class see-class*
] when drop ;
: see-methods ( generic -- seq )
"methods" word-prop
[ nip method-word ] { } assoc>map
natural-sort ;
"methods" word-prop values natural-sort ;
M: word see
dup see-class

2
core/vocabs/vocabs.factor
View File

@ -55,6 +55,8 @@ M: f vocab-docs-loaded? ;
M: f set-vocab-docs-loaded? 2drop ;
M: f vocab-help ;
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;

2
core/words/words-tests.factor
View File

@ -141,7 +141,7 @@ SYMBOL: quot-uses-b
[ { + } ] [ \ quot-uses-b uses ] unit-test
[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ]
[ [ undefined? ] is? ] must-fail-with
[ ] [

2
core/words/words.factor
View File

@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
: crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
{ [ dup "method" word-prop ] [ t ] }
{ [ dup "method-def" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;

9
extra/assocs/lib/lib.factor
View File

@ -16,13 +16,16 @@ IN: assocs.lib
: at-default ( key assoc -- value/key )
dupd at [ nip ] when* ;
: replace-at ( assoc value key -- assoc )
>r >r dup r> 1vector r> rot set-at ;
: insert-at ( value key assoc -- )
[ ?push ] change-at ;
: peek-at* ( key assoc -- obj ? )
at* dup [ >r peek r> ] when ;
: peek-at* ( assoc key -- obj ? )
swap at* dup [ >r peek r> ] when ;
: peek-at ( key assoc -- obj )
: peek-at ( assoc key -- obj )
peek-at* drop ;
: >multi-assoc ( assoc -- new-assoc )

2
extra/benchmark/benchmark.factor
View File

@ -21,7 +21,7 @@ IN: benchmark
] with-row
[
[
swap [ ($vocab-link) ] with-cell
swap [ dup ($vocab-link) ] with-cell
first2 pprint-cell pprint-cell
] with-row
] assoc-each

9
extra/benchmark/sockets/sockets.factor
View File

@ -53,13 +53,6 @@ SYMBOL: counter
yield yield
] time ;
: socket-benchmarks
10 clients
20 clients
40 clients ;
! 80 clients
! 160 clients
! 320 clients
! 640 clients ;
: socket-benchmarks ;
MAIN: socket-benchmarks

2
extra/bootstrap/image/upload/upload.factor
View File

@ -8,7 +8,7 @@ SYMBOL: upload-images-destination
: destination ( -- dest )
upload-images-destination get
"slava@/var/www/factorcode.org/newsite/images/latest/"
"slava@factorcode.org:/var/www/factorcode.org/newsite/images/latest/"
or ;
: checksums "checksums.txt" temp-file ;

68
extra/calendar/format/format.factor
View File

@ -36,8 +36,12 @@ M: timestamp year. ( timestamp -- )
: pad-00 number>string 2 CHAR: 0 pad-left ;
: pad-0000 number>string 4 CHAR: 0 pad-left ;
: write-00 pad-00 write ;
: write-0000 pad-0000 write ;
: (timestamp>string) ( timestamp -- )
dup day-of-week day-abbreviations3 nth write ", " write
dup day>> number>string write bl
@ -107,24 +111,68 @@ M: timestamp year. ( timestamp -- )
60 / + *
] if ;
: read-ymd ( -- y m d )
read-0000 "-" expect read-00 "-" expect read-00 ;
: read-hms ( -- h m s )
read-00 ":" expect read-00 ":" expect read-00 ;
: (rfc3339>timestamp) ( -- timestamp )
read-0000 ! year
"-" expect
read-00 ! month
"-" expect
read-00 ! day
read-ymd
"Tt" expect
read-00 ! hour
":" expect
read-00 ! minute
":" expect
read-00 ! second
read-hms
read-rfc3339-gmt-offset ! timezone
<timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] with-string-reader ;
: (ymdhms>timestamp) ( -- timestamp )
read-ymd " " expect read-hms 0 <timestamp> ;
: ymdhms>timestamp ( str -- timestamp )
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
f f f read-hms f <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
read-ymd f f f f <timestamp> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;
: (timestamp>ymd) ( timestamp -- )
dup timestamp-year write-0000
"-" write
dup timestamp-month write-00
"-" write
timestamp-day write-00 ;
: timestamp>ymd ( timestamp -- str )
[ (timestamp>ymd) ] with-string-writer ;
: (timestamp>hms)
dup timestamp-hour write-00
":" write
dup timestamp-minute write-00
":" write
timestamp-second >integer write-00 ;
: timestamp>hms ( timestamp -- str )
[ (timestamp>hms) ] with-string-writer ;
: timestamp>ymdhms ( timestamp -- str )
>gmt
[
dup (timestamp>ymd)
" " write
(timestamp>hms)
] with-string-writer ;
: file-time-string ( timestamp -- string )
[
[ month>> month-abbreviations nth write ] keep bl

10
extra/db/db.factor
View File

@ -34,7 +34,7 @@ HOOK: db-close db ( handle -- )
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 ;
@ -47,6 +47,7 @@ GENERIC: query-results ( query -- result-set )
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 -- ? )
@ -67,13 +68,16 @@ 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

259
extra/db/postgresql/postgresql-tests.factor
View File

@ -33,24 +33,6 @@ IN: db.postgresql.tests
] with-db
] unit-test
[
{ { "John" "America" } }
] [
test-db [
"select * from person where name = $1 and country = $2"
f f <simple-statement> [
{ { "Jane" TEXT } { "New Zealand" TEXT } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ { "John" TEXT } { "America" TEXT } }
swap do-bound-query
] with-disposal
] with-db
] unit-test
[
{
{ "John" "America" }
@ -111,244 +93,3 @@ IN: db.postgresql.tests
: with-dummy-db ( quot -- )
>r T{ postgresql-db } db r> with-variable ;
! TEST TUPLE DB
TUPLE: puppy id name age ;
: <puppy> ( name age -- puppy )
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
{ "id" "ID" +native-id+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: kitty id name age ;
: <kitty> ( name age -- kitty )
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
{ "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id serial primary key not null, name varchar 256, age integer);"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
[
"create table basket(id serial primary key not null, location text);"
] [
T{ postgresql-db } db [
basket dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
! Create function
[
"create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table create-function-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ postgresql-db } db [
puppy db-table drop-table-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ postgresql-db } db [
kitty db-table drop-table-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ postgresql-db } db [
basket db-table drop-table-sql >lower
] with-variable
] unit-test
! Drop function
[
"drop function add_puppy(varchar, integer);"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table drop-function-sql >lower
] with-variable
] unit-test
! Insert
[
] [
T{ postgresql-db } db [
puppy <insert-native-statement>
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values($1, $2, $3);"
{
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
T{ sql-spec f "name" "NAME" TEXT { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
{ }
] [
T{ postgresql-db } db [
kitty <insert-assigned-statement>
] with-variable
] unit-test
! Update
[
"update puppy set name = $1, age = $2 where id = $3"
{
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
}
{ }
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
[
"update kitty set name = $1, age = $2 where id = $3"
{
T{ sql-spec f "name" "NAME" TEXT { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
}
{ }
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = $1"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
}
{ }
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table <delete-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
[
"delete from KITTY where ID = $1"
{
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
}
{ }
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table <delete-tuple-statement>
] with-variable
] unit-test
! Select
[
"select from PUPPY ID, NAME, AGE where NAME = $1;"
{ T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } }
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ postgresql-db } db [
T{ puppy f f "Mr. Clunkers" }
<select-by-slots-statement>
] with-variable
] unit-test

2
extra/db/sqlite/ffi/ffi.factor
View File

@ -112,7 +112,7 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;

51
extra/db/sqlite/lib/lib.factor
View File

@ -2,7 +2,9 @@
! 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 -- * )
@ -55,6 +57,10 @@ IN: db.sqlite.lib
: 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 ;
@ -67,20 +73,32 @@ IN: db.sqlite.lib
: 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 ;
@ -93,21 +111,38 @@ IN: db.sqlite.lib
: 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 ;

194
extra/db/sqlite/sqlite-tests.factor
View File

@ -3,49 +3,34 @@ prettyprint tools.test db.sqlite db sequences
continuations db.types db.tuples unicode.case ;
IN: db.sqlite.tests
: test.db "extra/db/sqlite/test.db" resource-path ;
: db-path "test.db" temp-file ;
: test.db db-path sqlite-db ;
[ ] [ [ test.db delete-file ] ignore-errors ] unit-test
[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
[ ] [
test.db [
"create table person (name varchar(30), country varchar(30))" sql-command
"insert into person values('John', 'America')" sql-command
"insert into person values('Jane', 'New Zealand')" sql-command
] with-sqlite
] with-db
] unit-test
[ { { "John" "America" } { "Jane" "New Zealand" } } ] [
test.db [
"select * from person" sql-query
] with-sqlite
] unit-test
[ { { "John" "America" } } ] [
test.db [
"select * from person where name = :name and country = :country"
<simple-statement> [
{ { ":name" "Jane" TEXT } { ":country" "New Zealand" TEXT } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ { ":name" "John" TEXT } { ":country" "America" TEXT } }
swap do-bound-query
] with-disposal
] with-sqlite
] with-db
] unit-test
[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ]
[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
[ ] [
test.db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-sqlite
] with-db
] unit-test
[
@ -54,7 +39,7 @@ IN: db.sqlite.tests
{ "2" "Jane" "New Zealand" }
{ "3" "Jimmy" "Canada" }
}
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
] [ test.db [ "select rowid, * from person" sql-query ] with-db ] unit-test
[
test.db [
@ -63,13 +48,13 @@ IN: db.sqlite.tests
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
] with-sqlite
] with-db
] must-fail
[ 3 ] [
test.db [
"select * from person" sql-query length
] with-sqlite
] with-db
] unit-test
[
@ -81,166 +66,11 @@ IN: db.sqlite.tests
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
] with-transaction
] with-sqlite
] with-db
] unit-test
[ 5 ] [
test.db [
"select * from person" sql-query length
] with-sqlite
] unit-test
! TEST TUPLE DB
TUPLE: puppy id name age ;
: <puppy> ( name age -- puppy )
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
{ "id" "ID" +native-id+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: kitty id name age ;
: <kitty> ( name age -- kitty )
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
{ "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id integer primary key not null, name varchar, age integer);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table basket(id integer primary key not null, location text);"
] [
T{ sqlite-db } db [
basket dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ sqlite-db } db [
puppy db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ sqlite-db } db [
kitty db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ sqlite-db } db [
basket db-table drop-sql >lower
] with-variable
] unit-test
! Insert
[
"insert into puppy(name, age) values(:name, :age);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values(:id, :name, :age);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
! Update
[
"update puppy set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
[
"update kitty set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
[
"delete from kitty where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
! Select
[
"select from puppy id, name, age where name = :name;"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ sqlite-db } db [
T{ puppy f f "Mr. Clunkers" }
select-sql >r >lower r>
] with-variable
] with-db
] unit-test

23
extra/db/sqlite/sqlite.factor
View File

@ -88,8 +88,9 @@ M: sqlite-result-set #columns ( result-set -- n )
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
@ -149,6 +150,10 @@ M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
" 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%
@ -181,14 +186,7 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
" 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
";" 0%
] if
dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ;
M: sqlite-db modifier-table ( -- hashtable )
@ -217,8 +215,13 @@ M: sqlite-db type-table ( -- assoc )
{ 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

120
extra/db/tuples/tuples-tests.factor
View File

@ -2,39 +2,46 @@
! 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 ;
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 }
@ -48,9 +55,33 @@ SYMBOL: the-person2
}
] [ 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 ( -- )
@ -67,9 +98,14 @@ SYMBOL: the-person2
{ "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"
@ -78,10 +114,14 @@ SYMBOL: the-person2
{ "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 ;
@ -118,9 +158,8 @@ 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 ;
@ -128,4 +167,45 @@ TUPLE: annotation n paste-id summary author mode contents ;
[ 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

13
extra/db/tuples/tuples.factor
View File

@ -37,27 +37,24 @@ HOOK: <delete-tuples-statement> db ( class -- obj )
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 )
@ -104,7 +101,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
db get db-delete-statements [ <delete-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: select-tuples ( tuple -- tuple )
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> [
[ bind-tuple ] keep query-tuples
] with-disposal ;

33
extra/db/types/types.factor
View File

@ -3,7 +3,8 @@
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 )
@ -60,14 +61,19 @@ SYMBOL: +has-many+
: 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*
@ -80,15 +86,6 @@ SYMBOL: DATE
} 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 ;
@ -210,15 +207,3 @@ TUPLE: no-slot-named ;
>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 ;

3
extra/delegate/delegate.factor
View File

@ -39,7 +39,8 @@ M: tuple-class group-words
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
pick "methods" word-prop at dup
[ method-def spin define-method ] [ 3drop ] if
[ "method-def" word-prop spin define-method ]
[ 3drop ] if
] 2curry each ;
: MIMIC:

4
extra/destructors/destructors-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax libc kernel ;
USING: help.markup help.syntax libc kernel continuations ;
IN: destructors
HELP: free-always
@ -23,7 +23,7 @@ HELP: close-later
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" }

2
extra/destructors/destructors-tests.factor
View File

@ -9,7 +9,7 @@ TUPLE: dummy-destructor obj ;
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

16
extra/destructors/destructors.factor
View File

@ -4,18 +4,16 @@ USING: continuations io.backend libc kernel namespaces
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 ;
@ -29,10 +27,10 @@ M: destructor destruct
<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 -- )
[
@ -47,7 +45,7 @@ TUPLE: memory-destructor alien ;
C: <memory-destructor> memory-destructor
M: memory-destructor destruct ( obj -- )
M: memory-destructor dispose ( obj -- )
memory-destructor-alien free ;
: free-always ( alien -- )
@ -63,7 +61,7 @@ C: <handle-destructor> handle-destructor
HOOK: destruct-handle io-backend ( obj -- )
M: handle-destructor destruct ( obj -- )
M: handle-destructor dispose ( obj -- )
handle-destructor-alien destruct-handle ;
: close-always ( handle -- )
@ -79,7 +77,7 @@ C: <socket-destructor> socket-destructor
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 -- )

4
extra/farkup/farkup-tests.factor
View File

@ -42,3 +42,7 @@ IN: farkup.tests
[ "<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

2
extra/furnace/authors.txt
View File

@ -1,2 +0,0 @@
Slava Pestov
Doug Coleman

47
extra/furnace/furnace-tests.factor
View File

@ -1,47 +0,0 @@
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

206
extra/furnace/furnace.factor
View File

@ -1,206 +0,0 @@
! 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
: 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 ;

50
extra/furnace/sessions/sessions.factor
View File

@ -1,50 +0,0 @@
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 ;

1
extra/furnace/summary.txt
View File

@ -1 +0,0 @@
Action-based web framework

1
extra/furnace/tags.txt
View File

@ -1 +0,0 @@
enterprise

30
extra/furnace/validator/validator-tests.factor
View File

@ -1,30 +0,0 @@
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

43
extra/furnace/validator/validator.factor
View File

@ -1,43 +0,0 @@
! 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* ;

28
extra/help/markup/markup.factor Normal file → Executable file
View File

@ -144,24 +144,36 @@ M: f print-element drop ;
: $link ( element -- )
first ($link) ;
: ($subsection) ( object -- )
[ article-title ] keep >link write-object ;
: ($long-link) ( object -- )
dup article-title swap >link write-link ;
: $subsection ( element -- )
: ($subsection) ( element quot -- )
[
subsection-style get [
bullet get write bl
first ($subsection)
call
] with-style
] ($block) ;
] ($block) ; inline
: ($vocab-link) ( vocab -- ) dup f >vocab-link write-link ;
: $subsection ( element -- )
[ first ($long-link) ] ($subsection) ;
: $vocab-link ( element -- ) first ($vocab-link) ;
: ($vocab-link) ( text vocab -- ) f >vocab-link write-link ;
: $vocab-subsection ( element -- )
[
first2 dup vocab-help dup [
2nip ($long-link)
] [
drop ($vocab-link)
] if
] ($subsection) ;
: $vocab-link ( element -- ) first dup ($vocab-link) ;
: $vocabulary ( element -- )
first word-vocabulary [
"Vocabulary" $heading nl ($vocab-link)
"Vocabulary" $heading nl dup ($vocab-link)
] when* ;
: textual-list ( seq quot -- )

1
extra/http/basic-authentication/authors.txt
View File

@ -1 +0,0 @@
Chris Double

69
extra/http/basic-authentication/basic-authentication-docs.factor
View File

@ -1,69 +0,0 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax crypto.sha2 ;
IN: http.basic-authentication
HELP: realms
{ $description
"A hashtable mapping a basic authentication realm (a string) "
"to either a quotation or a hashtable. The quotation has "
"stack effect ( username sha-256-string -- bool ). It "
"is expected to perform the user authentication when called." $nl
"If the realm maps to a hashtable then the hashtable should be a "
"mapping of usernames to sha-256 hashed passwords." $nl
"If the 'realms' variable does not exist in the current scope then "
"authentication will always fail." }
{ $see-also add-realm with-basic-authentication } ;
HELP: add-realm
{ $values
{ "data" "a quotation or a hashtable" } { "name" "a string" } }
{ $description
"Adds the authentication data to the " { $link realms } ". 'data' can be "
"a quotation with stack effect ( username sha-256-string -- bool ) or "
"a hashtable mapping username strings to sha-256-string passwords." }
{ $examples
{ $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" }
{ $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" }
}
{ $see-also with-basic-authentication realms } ;
HELP: with-basic-authentication
{ $values
{ "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } }
{ $description
"Checks if the HTTP request has the correct authorisation headers "
"for basic authentication within the named realm. If the headers "
"are not present then a '401' HTTP response results from the "
"request, otherwise the quotation is called." }
{ $examples
{ $code "\"my-realm\" [\n serving-html \"<html><body>Success!</body></html>\" write\n] with-basic-authentication" } }
{ $see-also add-realm realms }
;
ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication"
"The Basic Authentication system provides a simple browser based "
"authentication method to web applications. When the browser requests "
"a resource protected with basic authentication the server responds with "
"a '401' response code which means the user is unauthorized."
$nl
"When the browser receives this it prompts the user for a username and "
"password. This is sent back to the server in a special HTTP header. The "
"server then checks this against its authentication information and either "
"accepts or rejects the users request."
$nl
"Authentication is split up into " { $link realms } ". Each realm can have "
"a different database of username and password information. A responder can "
"require basic authentication by using the " { $link with-basic-authentication } " word."
$nl
"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "."
$nl
"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word."
$nl
"Note that Basic Authentication itself is insecure in that it "
"sends the username and password as clear text (although it is "
"base64 encoded this is not much help). To prevent eavesdropping "
"it is best to use Basic Authentication with SSL." ;
IN: http.basic-authentication
ABOUT: { "http-authentication" "basic-authentication" }

66
extra/http/basic-authentication/basic-authentication-tests.factor
View File

@ -1,66 +0,0 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel crypto.sha2 http.basic-authentication tools.test
namespaces base64 sequences ;
{ t } [
[
H{ } clone realms set
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
] with-scope
] unit-test
{ f } [
[
H{ } clone realms set
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
"test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok?
] with-scope
] unit-test
{ f } [
[
H{ } clone realms set
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
"test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
] with-scope
] unit-test
{ t } [
[
H{ } clone realms set
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
] with-scope
] unit-test
{ f } [
[
H{ } clone realms set
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
"test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
] with-scope
] unit-test
{ f } [
[
H{ } clone realms set
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
"test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok?
] with-scope
] unit-test
{ f } [
[
f realms set
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
] with-scope
] unit-test
{ f } [
[
H{ } clone realms set
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
] with-scope
] unit-test

65
extra/http/basic-authentication/basic-authentication.factor
View File

@ -1,65 +0,0 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel base64 http.server crypto.sha2 namespaces assocs
quotations hashtables combinators splitting sequences
http.server.responders io html.elements ;
IN: http.basic-authentication
! 'realms' is a hashtable mapping a realm (a string) to
! either a quotation or a hashtable. The quotation
! has stack effect ( username sha-256-string -- bool ).
! It should perform the user authentication. 'sha-256-string'
! is the plain text password provided by the user passed through
! 'string>sha-256-string'. If 'realms' maps to a hashtable then
! it is a mapping of usernames to sha-256 hashed passwords.
!
! 'realms' can be set on a per vhost basis in the vhosts
! table.
!
! If there are no realms then authentication fails.
SYMBOL: realms
: add-realm ( data name -- )
#! Add the named realm to the realms table.
#! 'data' should be a hashtable or a quotation.
realms get [ H{ } clone dup realms set ] unless*
set-at ;
: user-authorized? ( username password realm -- bool )
realms get dup [
at {
{ [ dup quotation? ] [ call ] }
{ [ dup hashtable? ] [ swapd at = ] }
{ [ t ] [ 3drop f ] }
} cond
] [
3drop drop f
] if ;
: authorization-ok? ( realm header -- bool )
#! Given the realm and the 'Authorization' header,
#! authenticate the user.
dup [
" " split dup first "Basic" = [
second base64> ":" split first2 string>sha-256-string rot
user-authorized?
] [
2drop f
] if
] [
2drop f
] if ;
: authentication-error ( realm -- )
"401 Unauthorized" response
"Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header
<html> <body>
"Username or Password is invalid" write
</body> </html> ;
: with-basic-authentication ( realm quot -- )
#! Check if the user is authenticated in the given realm
#! to run the specified quotation. If not, use Basic
#! Authentication to ask for authorization details.
over "authorization" header-param authorization-ok?
[ nip call ] [ drop authentication-error ] if ;

1
extra/http/basic-authentication/summary.txt
View File

@ -1 +0,0 @@
HTTP Basic Authentication implementation

1
extra/http/basic-authentication/tags.txt
View File

@ -1 +0,0 @@
web

28
extra/http/client/client-tests.factor
View File

@ -1,14 +1,28 @@
USING: http.client tools.test ;
USING: http.client http.client.private http tools.test
tuple-syntax namespaces ;
[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test
[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test
[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test
[ 404 ] [ "404 File not found" parse-response ] unit-test
[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
[ "/" "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.arcsucks.com/foo.txt/" download-name ] unit-test
[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
[
TUPLE{ request
method: "GET"
host: "www.apple.com"
path: "/index.html"
port: 80
version: "1.1"
cookies: V{ }
}
] [
[
"http://www.apple.com/index.html"
<get-request>
request-with-url
] with-scope
] unit-test

119
extra/http/client/client.factor
View File

@ -2,64 +2,72 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting continuations assocs.lib calendar ;
splitting continuations calendar vectors hashtables
accessors ;
IN: http.client
: parse-host ( url -- host port )
#! Extract the host name and port number from an HTTP URL.
":" split1 [ string>number ] [ 80 ] if* ;
SYMBOL: domain
: parse-url ( url -- host resource )
dup "https://" head? [
"ssl not yet supported: " swap append throw
] when "http://" ?head drop
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
"/" split1 [ "/" swap append ] [ "/" ] if*
>r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
swap parse-host ;
: parse-response ( line -- code )
"HTTP/" ?head [ " " split1 nip ] when
" " split1 drop string>number [
"Premature end of stream" throw
] unless* ;
<PRIVATE
: read-response ( -- code header )
#! After sending a GET or POST we read a response line and
#! header.
flush readln parse-response read-header ;
: store-path ( request path -- request )
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
: crlf "\r\n" write ;
! This is all pretty complex because it needs to handle
! HTTP redirects, which might be absolute or relative
: request-with-url ( url request -- request )
clone dup "request" set
swap parse-url >r >r store-path r> >>host r> >>port ;
: http-request ( host resource method -- )
write bl write " HTTP/1.0" write crlf
"Host: " write write crlf ;
DEFER: (http-request)
: get-request ( host resource -- )
"GET" http-request crlf ;
: absolute-redirect ( url -- request )
"request" get request-with-url ;
DEFER: http-get-stream
: relative-redirect ( path -- request )
"request" get swap store-path ;
: do-redirect ( code headers stream -- code headers stream )
#! Should this support Location: headers that are
#! relative URLs?
pick 100 /i 3 = [
dispose "location" swap peek-at nip http-get-stream
] when ;
: do-redirect ( response -- response stream )
dup response-code 300 399 between? [
header>> "location" swap at
dup "http://" head? [
absolute-redirect
] [
relative-redirect
] if "GET" >>method (http-request)
] [
stdio get
] if ;
: default-timeout 1 minutes over set-timeout ;
: (http-request) ( request -- response stream )
dup host>> over port>> <inet> <client> stdio set
dup "r" set-global write-request flush read-response
do-redirect ;
: http-get-stream ( url -- code headers stream )
#! Opens a stream for reading from an HTTP URL.
parse-url over parse-host <inet> <client> [
[ [ get-request read-response ] with-stream* ] keep
default-timeout
] [ ] [ dispose ] cleanup do-redirect ;
PRIVATE>
: http-request ( url request -- response stream )
[
request-with-url
[
(http-request)
1 minutes over set-timeout
] [ ] [ stdio get dispose ] cleanup
] with-scope ;
: <get-request> ( -- request )
<request> "GET" >>method ;
: http-get-stream ( url -- response stream )
<get-request> http-request ;
: success? ( code -- ? ) 200 = ;
: check-response ( code headers stream -- stream )
nip swap success?
: check-response ( response stream -- stream )
swap code>> success?
[ dispose "HTTP download failed" throw ] unless ;
: http-get ( url -- string )
@ -70,23 +78,18 @@ DEFER: http-get-stream
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
>r http-get-stream check-response
r> <file-writer> stream-copy ;
swap http-get-stream check-response
[ swap <file-writer> stream-copy ] with-disposal ;
: download ( url -- )
dup download-name download-to ;
: post-request ( content-type content host resource -- )
#! Note: It is up to the caller to url encode the content if
#! it is required according to the content-type.
"POST" http-request [
"Content-Length: " write length number>string write crlf
"Content-Type: " write url-encode write crlf
crlf
] keep write ;
: <post-request> ( content-type content -- request )
<request>
"POST" >>method
swap >>post-data
swap >>post-data-type ;
: http-post ( content-type content url -- code headers string )
#! Make a POST request. The content is URL encoded for you.
parse-url over parse-host <inet> <client> [
post-request flush read-response stdio get contents
] with-stream ;
: http-post ( content-type content url -- response string )
#! The content is URL encoded for you.
-rot url-encode <post-request> http-request contents ;

113
extra/http/http-tests.factor Normal file → Executable file
View File

@ -1,4 +1,5 @@
USING: http tools.test ;
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
@ -16,3 +17,113 @@ IN: http.tests
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
[ "/" ] [ "http://foo.com" url>path ] unit-test
[ "/" ] [ "http://foo.com/" url>path ] unit-test
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
STRING: read-request-test-1
GET http://foo/bar HTTP/1.1
Some-Header: 1
Some-Header: 2
Content-Length: 4
blah
;
[
TUPLE{ request
port: 80
method: "GET"
path: "/bar"
query: H{ }
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
post-data: "blah"
cookies: V{ }
}
] [
read-request-test-1 [
read-request
] with-string-reader
] unit-test
STRING: read-request-test-1'
GET /bar HTTP/1.1
content-length: 4
some-header: 1; 2
blah
;
read-request-test-1' 1array [
read-request-test-1
[ read-request ] with-string-reader
[ write-request ] with-string-writer
! normalize crlf
string-lines "\n" join
] unit-test
STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1
Host: www.sex.com
;
[
TUPLE{ request
port: 80
method: "HEAD"
path: "/bar"
query: H{ }
version: "1.1"
header: H{ { "host" "www.sex.com" } }
host: "www.sex.com"
cookies: V{ }
}
] [
read-request-test-2 [
read-request
] with-string-reader
] unit-test
STRING: read-response-test-1
HTTP/1.1 404 not found
Content-Type: text/html
blah
;
[
TUPLE{ response
version: "1.1"
code: 404
message: "not found"
header: H{ { "content-type" "text/html" } }
cookies: V{ }
}
] [
read-response-test-1
[ read-response ] with-string-reader
] unit-test
STRING: read-response-test-1'
HTTP/1.1 404 not found
content-type: text/html
;
read-response-test-1' 1array [
read-response-test-1
[ read-response ] with-string-reader
[ write-response ] with-string-writer
! normalize crlf
string-lines "\n" join
] unit-test
[ t ] [
"rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
dup parse-cookies unparse-cookies =
] unit-test

400
extra/http/http.factor
View File

@ -1,19 +1,13 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs
sequences strings splitting ascii io.encodings.utf8 assocs.lib
namespaces unicode.case ;
USING: hashtables io io.streams.string kernel math namespaces
math.parser assocs sequences strings splitting ascii
io.encodings.utf8 namespaces unicode.case combinators
vectors sorting new-slots accessors calendar calendar.format
quotations arrays ;
IN: http
: header-line ( line -- )
": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
: (read-header) ( -- )
readln dup
empty? [ drop ] [ header-line (read-header) ] if ;
: read-header ( -- hash )
[ (read-header) ] H{ } make-assoc ;
: http-port 80 ; inline
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
@ -23,7 +17,7 @@ IN: http
over digit? or
swap "/_-." member? or ; foldable
: push-utf8 ( string -- )
: push-utf8 ( ch -- )
1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
@ -58,17 +52,375 @@ IN: http
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
: hash>query ( hash -- str )
: crlf "\r\n" write ;
: add-header ( value key assoc -- )
[ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
: header-line ( line -- )
dup first blank? [
[ blank? ] left-trim
"last-header" get
"header" get
add-header
] [
": " split1 dup [
swap >lower dup "last-header" set
"header" get add-header
] [
2drop
] if
] if ;
: read-header-line ( -- )
readln dup
empty? [ drop ] [ header-line read-header-line ] if ;
: read-header ( -- assoc )
H{ } clone [
"header" [ read-header-line ] with-variable
] keep ;
: header-value>string ( value -- string )
{
{ [ dup number? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>http-string ] }
{ [ dup string? ] [ ] }
{ [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
} cond ;
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
dup [ "\r\n" member? ] contains?
[ "Header injection attack" throw ] when ;
: write-header ( assoc -- )
>alist sort-keys [
swap url-encode write ": " write
header-value>string check-header-string write crlf
] assoc-each crlf ;
: query>assoc ( query -- assoc )
dup [
"&" split [
"=" split1 [ dup [ url-decode ] when ] 2apply
] H{ } map>assoc
] when ;
: assoc>query ( hash -- str )
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
"&" join ;
: build-url ( str query-params -- newstr )
TUPLE: cookie name value path domain expires http-only ;
: <cookie> ( value name -- cookie )
cookie construct-empty
swap >>name swap >>value ;
: parse-cookies ( string -- seq )
[
over %
dup assoc-empty? [
2drop
] [
CHAR: ? rot member? "&" "?" ? %
hash>query %
] if
] "" make ;
f swap
";" split [
[ blank? ] trim "=" split1 swap >lower {
{ "expires" [ >>expires ] }
{ "domain" [ >>domain ] }
{ "path" [ >>path ] }
{ "httponly" [ drop t >>http-only ] }
{ "" [ drop ] }
[ <cookie> dup , nip ]
} case
] each
drop
] { } make ;
: (unparse-cookie) ( key value -- )
{
{ [ dup f eq? ] [ 2drop ] }
{ [ dup t eq? ] [ drop , ] }
{ [ t ] [ "=" swap 3append , ] }
} cond ;
: unparse-cookie ( cookie -- strings )
[
dup name>> >lower over value>> (unparse-cookie)
"path" over path>> (unparse-cookie)
"domain" over domain>> (unparse-cookie)
"expires" over expires>> (unparse-cookie)
"httponly" over http-only>> (unparse-cookie)
drop
] { } make ;
: unparse-cookies ( cookies -- string )
[ unparse-cookie ] map concat "; " join ;
TUPLE: request
host
port
method
path
query
version
header
post-data
post-data-type
cookies ;
: <request>
request construct-empty
"1.1" >>version
http-port >>port
H{ } clone >>query
V{ } clone >>cookies ;
: query-param ( request key -- value )
swap query>> at ;
: set-query-param ( request value key -- request )
pick query>> set-at ;
: chop-hostname ( str -- str' )
CHAR: / over index over length or tail
dup empty? [ drop "/" ] when ;
: url>path ( url -- path )
#! Technically, only proxies are meant to support hostnames
#! in HTTP requests, but IE sends these sometimes so we
#! just chop the hostname part.
url-decode "http://" ?head [ chop-hostname ] when ;
: read-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless
>>method ;
: read-query ( request -- request )
" " read-until
[ "Bad request: query params" throw ] unless
query>assoc >>query ;
: read-url ( request -- request )
" ?" read-until {
{ CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
{ CHAR: ? [ url>path >>path read-query ] }
[ "Bad request: URL" throw ]
} case ;
: parse-version ( string -- version )
"HTTP/" ?head [ "Bad version" throw ] unless
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
: read-request-version ( request -- request )
readln [ CHAR: \s = ] left-trim
parse-version
>>version ;
: read-request-header ( request -- request )
read-header >>header ;
: header ( request/response key -- value )
swap header>> at ;
SYMBOL: max-post-request
1024 256 * max-post-request set-global
: content-length ( header -- n )
"content-length" swap at string>number dup [
dup max-post-request get > [
"content-length > max-post-request" throw
] when
] when ;
: read-post-data ( request -- request )
dup header>> content-length [ read >>post-data ] when* ;
: parse-host ( string -- host port )
"." ?tail drop ":" split1
[ string>number ] [ http-port ] if* ;
: extract-host ( request -- request )
dup "host" header parse-host >r >>host r> >>port ;
: extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ;
: extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ;
: read-request ( -- request )
<request>
read-method
read-url
read-request-version
read-request-header
read-post-data
extract-host
extract-post-data-type
extract-cookies ;
: write-method ( request -- request )
dup method>> write bl ;
: write-url ( request -- request )
dup path>> url-encode write
dup query>> dup assoc-empty? [ drop ] [
"?" write
assoc>query write
] if ;
: write-request-url ( request -- request )
write-url bl ;
: write-version ( request -- request )
"HTTP/" write dup request-version write crlf ;
: write-request-header ( request -- request )
dup header>> >hashtable
over 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*
write-header ;
: write-post-data ( request -- request )
dup post-data>> [ write ] when* ;
: write-request ( request -- )
write-method
write-request-url
write-version
write-request-header
write-post-data
flush
drop ;
: request-url ( request -- url )
[
dup host>> [
"http://" write
dup host>> url-encode write
":" write
dup port>> number>string write
] when
dup path>> "/" head? [ "/" write ] unless
write-url
drop
] 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 -- )
TUPLE: response
version
code
message
header
cookies
body ;
: <response>
response construct-empty
"1.1" >>version
H{ } clone >>header
"close" "connection" set-header
now timestamp>http-string "date" set-header
V{ } clone >>cookies ;
: read-response-version
" \t" read-until
[ "Bad response: version" throw ] unless
parse-version
>>version ;
: read-response-code
" \t" read-until [ "Bad response: code" throw ] unless
string>number [ "Bad response: code" throw ] unless*
>>code ;
: read-response-message
readln >>message ;
: read-response-header
read-header >>header
dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
: read-response ( -- response )
<response>
read-response-version
read-response-code
read-response-message
read-response-header ;
: write-response-version ( response -- response )
"HTTP/" write
dup version>> write bl ;
: write-response-code ( response -- response )
dup code>> number>string write bl ;
: write-response-message ( response -- response )
dup message>> write crlf ;
: write-response-header ( response -- response )
dup header>> clone
over cookies>> f like
[ unparse-cookies "set-cookie" pick set-at ] when*
write-header ;
: write-response-body ( response -- response )
dup body>> {
{ [ dup not ] [ drop ] }
{ [ dup string? ] [ write ] }
{ [ dup callable? ] [ call ] }
{ [ t ] [ stdio get stream-copy ] }
} cond ;
M: response write-response ( respose -- )
write-response-version
write-response-code
write-response-message
write-response-header
flush
drop ;
M: response write-full-response ( request response -- )
dup write-response
swap method>> "HEAD" = [ write-response-body ] unless ;
: set-content-type ( request/response content-type -- request/response )
"content-type" set-header ;
: get-cookie ( request/response name -- cookie/f )
>r cookies>> r> [ swap name>> = ] curry find nip ;
: delete-cookie ( request/response name -- )
over cookies>> >r get-cookie r> delete ;
: put-cookie ( request/response cookie -- request/response )
[ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep
over cookies>> push ;
TUPLE: raw-response
version
code
message
body ;
: <raw-response> ( -- response )
raw-response construct-empty
"1.1" >>version ;
M: raw-response write-response ( respose -- )
write-response-version
write-response-code
write-response-message
write-response-body
drop ;
M: raw-response write-full-response ( response -- )
write-response nip ;

1
extra/http/mime/mime.factor Normal file → Executable file
View File

@ -30,5 +30,6 @@ H{
{ "pdf" "application/pdf" }
{ "factor" "text/plain" }
{ "cgi" "application/x-cgi-script" }
{ "fhtml" "application/x-factor-server-page" }
} "mime-types" set-global

39
extra/http/server/actions/actions-tests.factor Normal file
View File

@ -0,0 +1,39 @@
IN: http.server.actions.tests
USING: http.server.actions tools.test math math.parser
multiline namespaces http io.streams.string http.server
sequences accessors ;
<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
blah
;
[ 25 ] [
action-request-test-1 [ read-request ] with-string-reader
"/blah"
"action-1" get call-responder
] unit-test
<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
content-length: 5
xxx=4
;
[ "/blahXXXX" ] [
action-request-test-2 [ read-request ] with-string-reader
"/blah"
"action-2" get call-responder
] unit-test

41
extra/http/server/actions/actions.factor Executable file
View File

@ -0,0 +1,41 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots sequences kernel assocs combinators
http.server http.server.validators http hashtables namespaces ;
IN: http.server.actions
SYMBOL: +path+
TUPLE: action get get-params post post-params revalidate ;
: <action>
action construct-empty
[ <400> ] >>get
[ <400> ] >>post
[ <400> ] >>revalidate ;
: extract-params ( request path -- assoc )
>r dup method>> {
{ "GET" [ query>> ] }
{ "POST" [ post-data>> query>assoc ] }
} case r> +path+ associate union ;
: action-params ( request path param -- error? )
-rot extract-params validate-params ;
: get-action ( request path -- response )
action get get-params>> action-params
[ <400> ] [ action get get>> call ] if ;
: post-action ( request path -- response )
action get post-params>> action-params
[ action get revalidate>> ] [ action get post>> ] if call ;
M: action call-responder ( request path action -- response )
action set
over request set
over method>>
{
{ "GET" [ get-action ] }
{ "POST" [ post-action ] }
} case ;

41
extra/http/server/auth/basic/basic.factor Executable file
View File

@ -0,0 +1,41 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.providers.null
http sequences ;
IN: http.server.auth.basic
TUPLE: basic-auth responder realm provider ;
C: <basic-auth> basic-auth
: authorization-ok? ( provider header -- ? )
#! Given the realm and the 'Authorization' header,
#! authenticate the user.
dup [
" " split1 swap "Basic" = [
base64> ":" split1 spin check-login
] [
2drop f
] if
] [
2drop f
] if ;
: <401> ( realm -- response )
401 "Unauthorized" <trivial-response>
"Basic realm=\"" rot "\"" 3append
"WWW-Authenticate" set-header
[
<html> <body>
"Username or Password is invalid" write
</body> </html>
] >>body ;
: logged-in? ( request responder -- ? )
provider>> swap "authorization" header authorization-ok? ;
M: basic-auth call-responder ( request path responder -- response )
pick over logged-in?
[ responder>> call-responder ] [ 2nip realm>> <401> ] if ;

69
extra/http/server/auth/login/login.factor Executable file
View File

@ -0,0 +1,69 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors new-slots quotations assocs kernel splitting
base64 html.elements io combinators http.server
http.server.auth.providers http.server.actions
http.server.sessions http.server.templating.fhtml http sequences
io.files namespaces ;
IN: http.server.auth.login
TUPLE: login-auth responder provider ;
C: (login-auth) login-auth
SYMBOL: logged-in?
SYMBOL: provider
SYMBOL: post-login-url
: login-page ( -- response )
"text/html" <content> [
"extra/http/server/auth/login/login.fhtml"
resource-path run-template-file
] >>body ;
: <login-action>
<action>
[ login-page ] >>get
{
{ "name" [ ] }
{ "password" [ ] }
} >>post-params
[
"password" get
"name" get
provider sget check-login [
t logged-in? sset
post-login-url sget <permanent-redirect>
] [
login-page
] if
] >>post ;
: <logout-action>
<action>
[
f logged-in? sset
request get "login" <permanent-redirect>
] >>post ;
M: login-auth call-responder ( request path responder -- response )
logged-in? sget
[ responder>> call-responder ] [
pick method>> "GET" = [
nip
provider>> provider sset
dup request-url post-login-url sset
"login" f session-link <permanent-redirect>
] [
3drop <400>
] if
] if ;
: <login-auth> ( responder provider -- auth )
(login-auth)
<dispatcher>
swap >>default
<login-action> "login" add-responder
<logout-action> "logout" add-responder
<cookie-sessions> ;

25
extra/http/server/auth/login/login.fhtml Executable file
View File

@ -0,0 +1,25 @@
<html>
<body>
<h1>Login required</h1>
<form method="POST" action="login">
<table>
<tr>
<td>User name:</td>
<td><input name="name" /></td>
</tr>
<tr>
<td>Password:</td>
<td><input type="password" name="password" /></td>
</tr>
</table>
<input type="submit" value="Log in" />
</form>
</body>
</html>

18
extra/http/server/auth/providers/assoc/assoc-tests.factor Executable file
View File

@ -0,0 +1,18 @@
IN: http.server.auth.providers.assoc.tests
USING: http.server.auth.providers
http.server.auth.providers.assoc tools.test
namespaces ;
<assoc-auth-provider> "provider" set
"slava" "provider" get new-user
[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with
[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test
[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with
"fdasf" "slava" "provider" get set-password
[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test

23
extra/http/server/auth/providers/assoc/assoc.factor Executable file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.auth.providers.assoc
USING: new-slots accessors assocs kernel
http.server.auth.providers ;
TUPLE: assoc-auth-provider assoc ;
: <assoc-auth-provider> ( -- provider )
H{ } clone assoc-auth-provider construct-boa ;
M: assoc-auth-provider check-login
assoc>> at = ;
M: assoc-auth-provider new-user
assoc>>
2dup key? [ drop user-exists ] when
t -rot set-at ;
M: assoc-auth-provider set-password
assoc>>
2dup key? [ drop no-such-user ] unless
set-at ;

25
extra/http/server/auth/providers/db/db-tests.factor Executable file
View File

@ -0,0 +1,25 @@
IN: http.server.auth.providers.db.tests
USING: http.server.auth.providers
http.server.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
io.files ;
db-auth-provider "provider" set
"auth-test.db" temp-file sqlite-db [
[ user drop-table ] ignore-errors
[ user create-table ] ignore-errors
"slava" "provider" get new-user
[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with
[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test
[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with
"fdasf" "slava" "provider" get set-password
[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test
] with-db

53
extra/http/server/auth/providers/db/db.factor Executable file
View File

@ -0,0 +1,53 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db db.tuples db.types new-slots accessors
http.server.auth.providers kernel ;
IN: http.server.auth.providers.db
TUPLE: user name password ;
: <user> user construct-empty ;
user "USERS"
{
{ "name" "NAME" { VARCHAR 256 } +assigned-id+ }
{ "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
} define-persistent
: init-users-table ( -- )
user create-table ;
TUPLE: db-auth-provider ;
: db-auth-provider T{ db-auth-provider } ;
M: db-auth-provider check-login
drop
<user>
swap >>name
swap >>password
select-tuple >boolean ;
M: db-auth-provider new-user
drop
[
<user>
swap >>name
dup select-tuple [ name>> user-exists ] when
"unassigned" >>password
insert-tuple
] with-transaction ;
M: db-auth-provider set-password
drop
[
<user>
swap >>name
dup select-tuple [ ] [ no-such-user ] ?if
swap >>password update-tuple
] with-transaction ;

14
extra/http/server/auth/providers/null/null.factor Executable file
View File

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.server.auth.providers kernel ;
IN: http.server.auth.providers.null
TUPLE: null-auth-provider ;
: null-auth-provider T{ null-auth-provider } ;
M: null-auth-provider check-login 3drop f ;
M: null-auth-provider new-user 3drop f ;
M: null-auth-provider set-password 3drop f ;

18
extra/http/server/auth/providers/providers.factor Executable file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel ;
IN: http.server.auth.providers
GENERIC: check-login ( password user provider -- ? )
GENERIC: new-user ( user provider -- )
GENERIC: set-password ( password user provider -- )
TUPLE: user-exists name ;
: user-exists ( name -- * ) \ user-exists construct-boa throw ;
TUPLE: no-such-user name ;
: no-such-user ( name -- * ) \ no-such-user construct-boa throw ;

50
extra/http/server/authentication/basic/basic.factor Executable file
View File

@ -0,0 +1,50 @@
! Copyright (c) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
IN: http.server.authentication.basic
USING: accessors new-slots quotations assocs kernel splitting
base64 crypto.sha2 html.elements io combinators http.server
http sequences ;
! 'users' is a quotation or an assoc. The quotation
! has stack effect ( sha-256-string username -- ? ).
! It should perform the user authentication. 'sha-256-string'
! is the plain text password provided by the user passed through
! 'string>sha-256-string'. If 'users' is an assoc then
! it is a mapping of usernames to sha-256 hashed passwords.
TUPLE: realm responder name users ;
C: <realm> realm
: user-authorized? ( password username realm -- ? )
users>> {
{ [ dup callable? ] [ call ] }
{ [ dup assoc? ] [ at = ] }
} cond ;
: authorization-ok? ( realm header -- bool )
#! Given the realm and the 'Authorization' header,
#! authenticate the user.
dup [
" " split1 swap "Basic" = [
base64> ":" split1 string>sha-256-string
spin user-authorized?
] [
2drop f
] if
] [
2drop f
] if ;
: <401> ( realm -- response )
401 "Unauthorized" <trivial-response>
"Basic realm=\"" rot name>> "\"" 3append
"WWW-Authenticate" set-header
[
<html> <body>
"Username or Password is invalid" write
</body> </html>
] >>body ;
M: realm call-responder ( request path realm -- response )
pick "authorization" header dupd authorization-ok?
[ responder>> call-responder ] [ 2nip <401> ] if ;

135
extra/http/server/callbacks/callbacks.factor Executable file
View File

@ -0,0 +1,135 @@
! Copyright (C) 2004 Chris Double.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: html http http.server io kernel math namespaces
continuations calendar sequences assocs new-slots hashtables
accessors arrays alarms quotations combinators ;
IN: http.server.callbacks
SYMBOL: responder
TUPLE: callback-responder responder callbacks ;
: <callback-responder> ( responder -- responder' )
#! A continuation responder is a special type of session
#! manager. However it works entirely differently from
#! the URL and cookie session managers.
H{ } clone callback-responder construct-boa ;
TUPLE: callback cont quot expires alarm responder ;
: timeout 20 minutes ;
: timeout-callback ( callback -- )
dup alarm>> cancel-alarm
dup responder>> callbacks>> delete-at ;
: touch-callback ( callback -- )
dup expires>> [
dup alarm>> [ cancel-alarm ] when*
dup [ timeout-callback ] curry timeout later >>alarm
] when drop ;
: <callback> ( cont quot expires? -- callback )
[ f responder get callback construct-boa ] keep
[ dup touch-callback ] when ;
: invoke-callback ( request exit-cont callback -- response )
[ quot>> 3array ] keep cont>> continue-with ;
: register-callback ( cont quot expires? -- id )
<callback>
responder get callbacks>> generate-key
[ responder get callbacks>> set-at ] keep ;
SYMBOL: exit-continuation
: exit-with exit-continuation get continue-with ;
: 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.
request get swap <temporary-redirect> exit-with ;
: cont-id "factorcontid" ;
: id>url ( id -- url )
request get
swap cont-id associate >>query
request-url ;
: 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.
id>url forward-to-url ;
: restore-request ( pair -- )
first3 >r exit-continuation set request set r> call ;
: resume-page ( request page responder callback -- * )
dup touch-callback
>r 2drop exit-continuation get
r> invoke-callback ;
SYMBOL: post-refresh-get?
: 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 [
[
[ ] t register-callback forward-to-id
] callcc1 restore-request
] [
post-refresh-get? on
] if ;
SYMBOL: current-show
: store-current-show ( -- )
#! Store the current continuation in the variable 'current-show'
#! so it can be returned to later by 'quot-id'. Note that it
#! recalls itself when the continuation is called to ensure that
#! it resets its value back to the most recent show call.
[ current-show set f ] callcc1
[ restore-request store-current-show ] when* ;
: show-final ( quot -- * )
>r redirect-to-here store-current-show
r> call exit-with ; inline
M: callback-responder call-responder
[
[
exit-continuation set
dup responder set
pick request set
pick cont-id query-param over callbacks>> at [
resume-page
] [
responder>> call-responder
"Continuation responder pages must use show-final" throw
] if*
] with-scope
] callcc1 >r 3drop r> ;
: show-page ( quot -- )
>r redirect-to-here store-current-show r>
[
[ ] register-callback
with-scope
exit-with
] callcc1 restore-request ; inline
: quot-id ( quot -- id )
current-show get swap t register-callback ;
: quot-url ( quot -- url )
quot-id id>url ;

65
extra/http/server/cgi/cgi.factor Executable file
View File

@ -0,0 +1,65 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server.static http.server
http accessors sequences strings math.parser ;
IN: http.server.cgi
: post? request get method>> "POST" = ;
: cgi-variables ( script-path -- assoc )
#! This needs some work.
[
"CGI/1.0" "GATEWAY_INTERFACE" set
"HTTP/" request get version>> append "SERVER_PROTOCOL" set
"Factor" "SERVER_SOFTWARE" set
dup "PATH_TRANSLATED" set
"SCRIPT_FILENAME" set
request get path>> "SCRIPT_NAME" set
request get host>> "SERVER_NAME" set
request get port>> number>string "SERVER_PORT" set
"" "PATH_INFO" set
"" "REMOTE_HOST" set
"" "REMOTE_ADDR" set
"" "AUTH_TYPE" set
"" "REMOTE_USER" set
"" "REMOTE_IDENT" set
request get method>> "REQUEST_METHOD" set
request get query>> assoc>query "QUERY_STRING" set
request get "cookie" header "HTTP_COOKIE" set
request get "user-agent" header "HTTP_USER_AGENT" set
request get "accept" header "HTTP_ACCEPT" set
post? [
request get post-data-type>> "CONTENT_TYPE" set
request get post-data>> length number>string "CONTENT_LENGTH" set
] when
] H{ } make-assoc ;
: cgi-descriptor ( name -- desc )
[
dup 1array +arguments+ set
cgi-variables +environment+ set
] H{ } make-assoc ;
: serve-cgi ( name -- response )
<raw-response>
200 >>code
"CGI output follows" >>message
swap [
stdio get swap cgi-descriptor <process-stream> [
post? [
request get post-data>> write flush
] when
stdio get swap (stream-copy)
] with-stream
] curry >>body ;
: enable-cgi ( responder -- responder )
[ serve-cgi ] "application/x-cgi-script"
pick special>> set-at ;

129
extra/http/server/components/components.factor Normal file
View File

@ -0,0 +1,129 @@
! 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 ;

13
extra/http/server/crud/crud.factor Normal file
View File

@ -0,0 +1,13 @@
! 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 ;

18
extra/http/server/db/db.factor Executable file
View File

@ -0,0 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db http.server kernel new-slots accessors
continuations namespaces destructors ;
IN: http.server.db
TUPLE: db-persistence responder db params ;
C: <db-persistence> db-persistence
: connect-db ( db-persistence -- )
dup db>> swap params>> make-db
dup db set
dup db-open
add-always-destructor ;
M: db-persistence call-responder
dup connect-db responder>> call-responder ;

1
extra/http/server/responders/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

225
extra/http/server/responders/responders.factor
View File

@ -1,225 +0,0 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs hashtables html html.elements splitting
http io kernel math math.parser namespaces parser sequences
strings io.server vectors assocs.lib logging ;
IN: http.server.responders
! Variables
SYMBOL: vhosts
SYMBOL: responders
: >header ( value key -- multi-hash )
H{ } clone [ insert-at ] keep ;
: print-header ( alist -- )
[ swap write ": " write print ] multi-assoc-each nl ;
: response ( msg -- ) "HTTP/1.0 " write print ;
: error-body ( error -- )
<html> <body> <h1> write </h1> </body> </html> ;
: error-head ( error -- )
response
H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
: httpd-error ( error -- )
#! This must be run from handle-request
dup error-head
"head" "method" get = [ drop ] [ error-body ] if ;
\ httpd-error ERROR add-error-logging
: bad-request ( -- )
[
! Make httpd-error print a body
"get" "method" set
"400 Bad request" httpd-error
] with-scope ;
: serving-content ( mime -- )
"200 Document follows" response
"Content-Type" >header print-header ;
: serving-html "text/html" serving-content ;
: serve-html ( quot -- )
serving-html with-html-stream ;
: serving-text "text/plain" serving-content ;
: redirect ( to response -- )
response "Location" >header print-header ;
: permanent-redirect ( to -- )
"301 Moved Permanently" redirect ;
: temporary-redirect ( to -- )
"307 Temporary Redirect" redirect ;
: directory-no/ ( -- )
[
"request" get % CHAR: / ,
"raw-query" get [ CHAR: ? , % ] when*
] "" make permanent-redirect ;
: query>hash ( query -- hash )
dup [
"&" split [
"=" split1 [ dup [ url-decode ] when ] 2apply 2array
] map
] when >hashtable ;
SYMBOL: max-post-request
1024 256 * max-post-request set-global
: content-length ( header -- n )
"content-length" swap peek-at string>number dup [
dup max-post-request get > [
"Content-Length > max-post-request" throw
] when
] when ;
: read-post-request ( header -- str hash )
content-length [ read dup query>hash ] [ f f ] if* ;
LOG: log-headers DEBUG
: interesting-headers ( assoc -- string )
[
[
drop {
"user-agent"
"referer"
"x-forwarded-for"
"host"
} member?
] assoc-subset [
": " swap 3append % "\n" %
] multi-assoc-each
] "" make ;
: prepare-url ( url -- url )
#! This is executed in the with-request namespace.
"?" split1
dup "raw-query" set query>hash "query" set
dup "request" set ;
: prepare-header ( -- )
read-header
dup "header" set
dup interesting-headers log-headers
read-post-request "response" set "raw-response" set ;
! Responders are called in a new namespace with these
! variables:
! - method -- one of get, post, or head.
! - request -- the entire URL requested, including responder
! name
! - responder-url -- the component of the URL for the responder
! - raw-query -- raw query string
! - query -- a hashtable of query parameters, eg
! foo.bar?a=b&c=d becomes
! H{ { "a" "b" } { "c" "d" } }
! - header -- a hashtable of headers from the user's client
! - response -- a hashtable of the POST request response
! - raw-response -- raw POST request response
: query-param ( key -- value ) "query" get at ;
: header-param ( key -- value )
"header" get peek-at ;
: host ( -- string )
#! The host the current responder was called from.
"host" header-param ":" split1 drop ;
: add-responder ( responder -- )
#! Add a responder object to the list.
"responder" over at responders get set-at ;
: make-responder ( quot -- )
#! quot has stack effect ( url -- )
[
[
drop "GET method not implemented" httpd-error
] "get" set
[
drop "POST method not implemented" httpd-error
] "post" set
[
drop "HEAD method not implemented" httpd-error
] "head" set
[
drop bad-request
] "bad" set
call
] H{ } make-assoc add-responder ;
: add-simple-responder ( name quot -- )
[
[ drop ] swap append dup "get" set "post" set
"responder" set
] make-responder ;
: vhost ( name -- vhost )
vhosts get at [ "default" vhost ] unless* ;
: responder ( name -- responder )
responders get at [ "404" responder ] unless* ;
: set-default-responder ( name -- )
responder "default" responders get set-at ;
: call-responder ( method argument responder -- )
over "argument" set [ swap get with-scope ] bind ;
: serve-default-responder ( method url -- )
"/" "responder-url" set
"default" responder call-responder ;
: trim-/ ( url -- url )
#! Trim a leading /, if there is one.
"/" ?head drop ;
: serve-explicit-responder ( method url -- )
"/" split1
"/responder/" pick "/" 3append "responder-url" set
dup [
swap responder call-responder
] [
! Just a responder name by itself
drop "request" get "/" append permanent-redirect 2drop
] if ;
: serve-responder ( method path host -- )
#! Responder paths come in two forms:
#! /foo/bar... - default responder used
#! /responder/foo/bar - responder foo, argument bar
vhost [
trim-/ "responder/" ?head [
serve-explicit-responder
] [
serve-default-responder
] if
] bind ;
\ serve-responder DEBUG add-input-logging
: no-such-responder ( -- )
"404 No such responder" httpd-error ;
! create a responders hash if it doesn't already exist
global [
responders [ H{ } assoc-like ] change
! 404 error message pages are served by this guy
"404" [ no-such-responder ] add-simple-responder
H{ } clone "default" associate vhosts set
] bind

76
extra/http/server/server-tests.factor
View File

@ -1,39 +1,61 @@
USING: webapps.file http.server.responders http
http.server namespaces io tools.test strings io.server
logging ;
USING: http.server tools.test kernel namespaces accessors
new-slots io http math sequences assocs ;
IN: http.server.tests
[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test
TUPLE: mock-responder path ;
[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
C: <mock-responder> mock-responder
[ "index.html" ]
[ "http://www.jedit.org/index.html" url>path ] unit-test
M: mock-responder call-responder
2nip
path>> on
"text/plain" <content> ;
[ "foo/bar" ]
[ "http://www.jedit.org/foo/bar" url>path ] unit-test
: check-dispatch ( tag path -- ? )
over off
<request> swap default-host get call-responder
write-response get ;
[ "" ]
[ "http://www.jedit.org/" url>path ] unit-test
[
<dispatcher>
"foo" <mock-responder> "foo" add-responder
"bar" <mock-responder> "bar" add-responder
<dispatcher>
"123" <mock-responder> "123" add-responder
"default" <mock-responder> >>default
"baz" add-responder
default-host set
[ "" ]
[ "http://www.jedit.org" url>path ] unit-test
[ "foo" ] [
"foo" default-host get find-responder path>> nip
] unit-test
[ "foobar" ]
[ "foobar" secure-path ] unit-test
[ "bar" ] [
"bar" default-host get find-responder path>> nip
] unit-test
[ f ]
[ "foobar/../baz" secure-path ] unit-test
[ t ] [ "foo" "foo" check-dispatch ] unit-test
[ f ] [ "foo" "bar" check-dispatch ] unit-test
[ t ] [ "bar" "bar" check-dispatch ] unit-test
[ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
[ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
[ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
[ t ] [ "123" "baz/123" check-dispatch ] unit-test
[ t ] [ "123" "baz///123" check-dispatch ] unit-test
[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test
[ ] [ f [ "POO" parse-request ] with-logging ] unit-test
[ t ] [
<request>
"baz" >>path
"baz" default-host get call-responder
dup code>> 300 399 between? >r
header>> "location" swap at "baz/" tail? r> and
] unit-test
] with-scope
[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test
[
<dispatcher>
"default" <mock-responder> >>default
default-host set
[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ]
[ "Foo=Bar&Baz=Quux" query>hash ] unit-test
[ H{ { "Baz" " " } } ]
[ "Baz=%20" query>hash ] unit-test
[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test
[ "/default" ] [ "/default" default-host get find-responder drop ] unit-test
] with-scope

197
extra/http/server/server.factor
View File

@ -1,65 +1,176 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http http.server.responders sequences prettyprint
io.server logging calendar ;
threads http sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib
vocabs.loader debugger html continuations random combinators
destructors ;
IN: http.server
: (url>path) ( uri -- path )
url-decode "http://" ?head [
"/" split1 dup "" ? nip
] when ;
GENERIC: call-responder ( request path responder -- response )
: url>path ( uri -- path )
"?" split1 dup [
>r (url>path) "?" r> 3append
] [
drop (url>path)
] if ;
TUPLE: trivial-responder response ;
: secure-path ( path -- path )
".." over subseq? [ drop f ] when ;
C: <trivial-responder> trivial-responder
: request-method ( cmd -- method )
H{
{ "GET" "get" }
{ "POST" "post" }
{ "HEAD" "head" }
} at "bad" or ;
M: trivial-responder call-responder nip response>> call ;
: (handle-request) ( arg cmd -- method path host )
request-method dup "method" set swap
prepare-url prepare-header host ;
: trivial-response-body ( code message -- )
<html>
<body>
<h1> swap number>string write bl write </h1>
</body>
</html> ;
: handle-request ( arg cmd -- )
[ (handle-request) serve-responder ] with-scope ;
: <trivial-response> ( code message -- response )
<response>
2over [ trivial-response-body ] 2curry >>body
"text/html" set-content-type
swap >>message
swap >>code ;
: parse-request ( request -- )
" " split1 dup [
" HTTP" split1 drop url>path secure-path dup [
swap handle-request
: <400> ( -- response )
400 "Bad request" <trivial-response> ;
: <404> ( -- response )
404 "Not Found" <trivial-response> ;
SYMBOL: 404-responder
[ drop <404> ] <trivial-responder> 404-responder set-global
: modify-for-redirect ( request to -- url )
{
{ [ dup "http://" head? ] [ nip ] }
{ [ dup "/" head? ] [ >>path request-url ] }
{ [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] }
} cond ;
: <redirect> ( request to code message -- response )
<trivial-response>
-rot modify-for-redirect
"location" set-header ;
\ <redirect> DEBUG add-input-logging
: <permanent-redirect> ( request to -- response )
301 "Moved Permanently" <redirect> ;
: <temporary-redirect> ( request to -- response )
307 "Temporary Redirect" <redirect> ;
: <content> ( content-type -- response )
<response>
200 >>code
swap set-content-type ;
TUPLE: dispatcher default responders ;
: <dispatcher> ( -- dispatcher )
404-responder H{ } clone dispatcher construct-boa ;
: set-main ( dispatcher name -- dispatcher )
[ <permanent-redirect> ] curry
<trivial-responder> >>default ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
: find-responder ( path dispatcher -- path responder )
over split-path pick responders>> at*
[ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
: redirect-with-/ ( request -- response )
dup path>> "/" append <permanent-redirect> ;
M: dispatcher call-responder
over [
3dup find-responder call-responder [
>r 3drop r>
] [
2drop bad-request
] if
default>> [
call-responder
] [
3drop f
] if*
] if*
] [
2drop bad-request
2drop redirect-with-/
] if ;
\ parse-request NOTICE add-input-logging
: add-responder ( dispatcher responder path -- dispatcher )
pick responders>> set-at ;
: add-main-responder ( dispatcher responder path -- dispatcher )
[ add-responder ] keep set-main ;
: <webapp> ( class -- dispatcher )
<dispatcher> swap construct-delegate ; inline
SYMBOL: virtual-hosts
SYMBOL: default-host
virtual-hosts global [ drop H{ } clone ] cache drop
default-host global [ drop 404-responder get-global ] cache drop
: find-virtual-host ( host -- responder )
virtual-hosts get at [ default-host get ] unless* ;
SYMBOL: development-mode
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
swap [
"Internal server error" [
development-mode get [
[ print-error nl :c ] with-html-stream
] [
500 "Internal server error"
trivial-response-body
] if
] simple-page
] curry >>body ;
: do-response ( request response -- )
dup write-response
swap method>> "HEAD" =
[ drop ] [ write-response-body ] if ;
: do-request ( request -- response )
[
dup dup path>> over host>>
find-virtual-host call-responder
[ <404> ] unless*
] [ dup \ do-request log-error <500> ] recover ;
: default-timeout 1 minutes stdio get set-timeout ;
LOG: httpd-hit NOTICE
: log-request ( request -- )
{ method>> host>> path>> } map-exec-with httpd-hit ;
: ?refresh-all ( -- )
development-mode get-global
[ 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" [
1 minutes stdio get set-timeout
readln [ parse-request ] when*
] with-server ;
internet-server "http.server"
[ handle-client ] with-server ;
: httpd-main ( -- ) 8888 httpd ;
MAIN: httpd-main
! Load default webapps
USE: webapps.file
USE: webapps.callback
USE: webapps.continuation
USE: webapps.cgi
: generate-key ( assoc -- str )
4 big-random >hex dup pick key?
[ drop generate-key ] [ nip ] if ;

0
extra/furnace/sessions/authors.txt → extra/http/server/sessions/authors.txt
View File

39
extra/http/server/sessions/sessions-tests.factor Executable file
View File

@ -0,0 +1,39 @@
IN: http.server.sessions.tests
USING: tools.test http.server.sessions math namespaces
kernel accessors ;
: with-session \ session swap with-variable ; inline
TUPLE: foo ;
C: <foo> foo
M: foo init-session drop 0 "x" sset ;
"1234" f <session> [
[ ] [ 3 "x" sset ] unit-test
[ 9 ] [ "x" sget sq ] unit-test
[ ] [ "x" [ 1- ] schange ] unit-test
[ 4 ] [ "x" sget sq ] unit-test
] with-session
[ t ] [ f <url-sessions> url-sessions? ] unit-test
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
[ ] [
<foo> <url-sessions>
"manager" set
] unit-test
[ { 5 0 } ] [
[
"manager" get new-session
dup "manager" get get-session [ 5 "a" sset ] with-session
dup "manager" get get-session [ "a" sget , ] with-session
dup "manager" get get-session [ "x" sget , ] with-session
"manager" get get-session delete-session
] { } make
] unit-test

114
extra/http/server/sessions/sessions.factor Executable file
View File

@ -0,0 +1,114 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
boxes alarms new-slots accessors http http.server
quotations hashtables sequences ;
IN: http.server.sessions
! ! ! ! ! !
! WARNING: this session manager is vulnerable to XSRF attacks
! ! ! ! ! !
GENERIC: init-session ( responder -- )
M: dispatcher init-session drop ;
TUPLE: session-manager responder sessions ;
: <session-manager> ( responder class -- responder' )
>r H{ } clone session-manager construct-boa r>
construct-delegate ; inline
TUPLE: session id manager namespace alarm ;
: <session> ( id manager -- session )
H{ } clone <box> \ session construct-boa ;
: timeout ( -- dt ) 20 minutes ;
: cancel-timeout ( session -- )
alarm>> [ cancel-alarm ] if-box? ;
: delete-session ( session -- )
dup cancel-timeout
dup manager>> sessions>> delete-at ;
: touch-session ( session -- )
dup cancel-timeout
dup [ delete-session ] curry timeout later
swap session-alarm >box ;
: session ( -- assoc ) \ session get namespace>> ;
: sget ( key -- value ) session at ;
: sset ( value key -- ) session set-at ;
: schange ( key quot -- ) session swap change-at ; inline
: new-session ( responder -- id )
[ sessions>> generate-key dup ] keep
[ <session> dup touch-session ] keep
[ swap \ session [ responder>> init-session ] with-variable ] 2keep
>r over r> sessions>> set-at ;
: get-session ( id responder -- session )
sessions>> tuck at* [
nip dup touch-session
] [
2drop f
] if ;
: call-responder/session ( request path responder session -- response )
\ session set responder>> call-responder ;
: sessions ( -- manager/f )
\ session get dup [ manager>> ] when ;
GENERIC: session-link* ( url query sessions -- string )
M: object session-link* 2drop url-encode ;
: session-link ( url query -- string ) sessions session-link* ;
TUPLE: url-sessions ;
: <url-sessions> ( responder -- responder' )
url-sessions <session-manager> ;
: sess-id "factorsessid" ;
M: url-sessions call-responder ( request path responder -- response )
pick sess-id query-param over get-session [
call-responder/session
] [
new-session nip sess-id set-query-param
dup request-url <temporary-redirect>
] if* ;
M: url-sessions session-link*
drop
\ session get id>> sess-id associate union assoc>query
>r url-encode r>
dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
TUPLE: cookie-sessions ;
: <cookie-sessions> ( responder -- responder' )
cookie-sessions <session-manager> ;
: get-session-cookie ( request responder -- cookie )
>r sess-id get-cookie dup
[ value>> r> get-session ] [ r> 2drop f ] if ;
: <session-cookie> ( id -- cookie )
sess-id <cookie> ;
M: cookie-sessions call-responder ( request path responder -- response )
3dup nip get-session-cookie [
call-responder/session
] [
dup new-session
[ over get-session call-responder/session ] keep
<session-cookie> put-cookie
] if* ;

101
extra/http/server/static/static.factor Executable file
View File

@ -0,0 +1,101 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar html io io.files kernel math math.parser http
http.server namespaces parser sequences strings assocs
hashtables debugger http.mime sorting html.elements logging
calendar.format new-slots accessors ;
IN: http.server.static
SYMBOL: responder
! special maps mime types to quots with effect ( path -- )
TUPLE: file-responder root hook special ;
: unix-time>timestamp ( n -- timestamp )
>r unix-1970 r> seconds time+ ;
: file-http-date ( filename -- string )
file-modified unix-time>timestamp timestamp>http-string ;
: last-modified-matches? ( filename -- ? )
file-http-date dup [
request get "if-modified-since" header =
] when ;
: <304> ( -- response )
304 "Not modified" <trivial-response> ;
: <file-responder> ( root hook -- responder )
H{ } clone file-responder construct-boa ;
: <static> ( root -- responder )
[
<content>
over file-length "content-length" set-header
over file-http-date "last-modified" set-header
swap [ <file-reader> stdio get stream-copy ] curry >>body
] <file-responder> ;
: serve-static ( filename mime-type -- response )
over last-modified-matches?
[ 2drop <304> ] [ responder get hook>> call ] if ;
: serving-path ( filename -- filename )
"" or responder get root>> swap path+ ;
: serve-file ( filename -- response )
dup mime-type
dup responder get special>> at
[ call ] [ serve-static ] ?if ;
\ serve-file NOTICE add-input-logging
: file. ( name dirp -- )
[ "/" append ] when
dup <a =href a> write </a> ;
: directory. ( path -- )
dup file-name [
<h1> dup file-name write </h1>
<ul>
directory sort-keys
[ <li> file. </li> ] assoc-each
</ul>
] simple-html-document ;
: list-directory ( directory -- response )
"text/html" <content>
swap [ directory. ] curry >>body ;
: find-index ( filename -- path )
{ "index.html" "index.fhtml" }
[ dupd path+ exists? ] find nip
dup [ path+ ] [ nip ] if ;
: serve-directory ( filename -- response )
dup "/" tail? [
dup find-index
[ serve-file ] [ list-directory ] ?if
] [
drop request get redirect-with-/
] if ;
: serve-object ( filename -- response )
serving-path dup exists? [
dup directory? [ serve-directory ] [ serve-file ] if
] [
drop <404>
] if ;
M: file-responder call-responder ( request path responder -- response )
over [
".." pick subseq? [
3drop <400>
] [
responder set
swap request set
serve-object
] if
] [
2drop redirect-with-/
] if ;

0
extra/http/server/templating/authors.txt → extra/http/server/templating/fhtml/authors.txt
View File

8
extra/http/server/templating/templating-tests.factor → extra/http/server/templating/fhtml/fhtml-tests.factor
View File

@ -1,9 +1,9 @@
USING: io io.files io.streams.string http.server.templating kernel tools.test
sequences ;
IN: http.server.templating.tests
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/test/" swap append
"extra/http/server/templating/fhtml/test/" swap append
[
".fhtml" append resource-path
[ run-template-file ] with-string-writer

17
extra/http/server/templating/templating.factor → extra/http/server/templating/fhtml/fhtml.factor
View File

@ -4,11 +4,12 @@
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 ;
strings splitting accessors http.server.static http.server
assocs ;
IN: http.server.templating
IN: http.server.templating.fhtml
: templating-vocab ( -- vocab-name ) "http.server.templating" ;
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
! See apps/http-server/test/ or libs/furnace/ for template usage
! examples
@ -93,3 +94,13 @@ DEFER: <% delimiter
: 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 ;

0
extra/http/server/templating/test/bug.fhtml → extra/http/server/templating/fhtml/test/bug.fhtml
View File

0
extra/http/server/templating/test/bug.html → extra/http/server/templating/fhtml/test/bug.html
View File

0
extra/http/server/templating/test/example.fhtml → extra/http/server/templating/fhtml/test/example.fhtml
View File

0
extra/http/server/templating/test/example.html → extra/http/server/templating/fhtml/test/example.html
View File

0
extra/http/server/templating/test/stack.fhtml → extra/http/server/templating/fhtml/test/stack.fhtml
View File

0
extra/http/server/templating/test/stack.html → extra/http/server/templating/fhtml/test/stack.html
View File

4
extra/http/server/validators/validators-tests.factor Normal file
View File

@ -0,0 +1,4 @@
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

64
extra/http/server/validators/validators.factor Normal file
View File

@ -0,0 +1,64 @@
! 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 ;

16
extra/io/launcher/launcher-docs.factor
View File

@ -35,33 +35,43 @@ HELP: +environment-mode+
HELP: +stdin+
{ $description "Launch descriptor key. Must equal one of the following:"
{ $list
{ { $link f } " - standard input is inherited" }
{ { $link f } " - standard input is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
{ { $link +inherit+ } " - standard input is inherited from the current process" }
{ { $link +closed+ } " - standard input is closed" }
{ "a path name - standard input is read from the given file, which must exist" }
{ "a file stream or a socket - standard input is read from the given stream, which must be closed after the process has been started" }
}
} ;
HELP: +stdout+
{ $description "Launch descriptor key. Must equal one of the following:"
{ $list
{ { $link f } " - standard output is inherited" }
{ { $link f } " - standard output is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
{ { $link +inherit+ } " - standard output is inherited from the current process" }
{ { $link +closed+ } " - standard output is closed" }
{ "a path name - standard output is written to the given file, which is overwritten if it already exists" }
{ "a file stream or a socket - standard output is written to the given stream, which must be closed after the process has been started" }
}
} ;
HELP: +stderr+
{ $description "Launch descriptor key. Must equal one of the following:"
{ $list
{ { $link f } " - standard error is inherited" }
{ { $link f } " - standard error is inherited from the current process" }
{ { $link +inherit+ } " - same as above" }
{ { $link +stdout+ } " - standard error is merged with standard output" }
{ { $link +closed+ } " - standard error is closed" }
{ "a path name - standard error is written to the given file, which is overwritten if it already exists" }
{ "a file stream or a socket - standard error is written to the given stream, which must be closed after the process has been started" }
}
} ;
HELP: +closed+
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
HELP: +inherit+
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ;
HELP: +prepend-environment+
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
$nl

108
extra/io/windows/files/files.factor Normal file
View File

@ -0,0 +1,108 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.files io.windows kernel
math windows windows.kernel32 combinators.cleave
windows.time calendar combinators math.functions
sequences combinators.lib namespaces words ;
IN: io.windows.files
SYMBOL: +read-only+
SYMBOL: +hidden+
SYMBOL: +system+
SYMBOL: +directory+
SYMBOL: +archive+
SYMBOL: +device+
SYMBOL: +normal+
SYMBOL: +temporary+
SYMBOL: +sparse-file+
SYMBOL: +reparse-point+
SYMBOL: +compressed+
SYMBOL: +offline+
SYMBOL: +not-content-indexed+
SYMBOL: +encrypted+
: expand-constants ( word/obj -- obj'/obj )
dup word? [ execute ] when ;
: get-flags ( n seq -- seq' )
[
[
first2 expand-constants
[ swapd mask? [ , ] [ drop ] if ] 2curry
] map call-with
] { } make ;
: win32-file-attributes ( n -- seq )
{
{ +read-only+ FILE_ATTRIBUTE_READONLY }
{ +hidden+ FILE_ATTRIBUTE_HIDDEN }
{ +system+ FILE_ATTRIBUTE_SYSTEM }
{ +directory+ FILE_ATTRIBUTE_DIRECTORY }
{ +archive+ FILE_ATTRIBUTE_ARCHIVE }
{ +device+ FILE_ATTRIBUTE_DEVICE }
{ +normal+ FILE_ATTRIBUTE_NORMAL }
{ +temporary+ FILE_ATTRIBUTE_TEMPORARY }
{ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE }
{ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT }
{ +compressed+ FILE_ATTRIBUTE_COMPRESSED }
{ +offline+ FILE_ATTRIBUTE_OFFLINE }
{ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED }
{ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED }
} get-flags ;
: WIN32_FIND_DATA>file-info
{
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
[
[ WIN32_FIND_DATA-nFileSizeLow ]
[ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
]
[ WIN32_FIND_DATA-dwFileAttributes ]
[
WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp
]
} cleave
\ file-info construct-boa ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
FindFirstFile
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
FindClose win32-error=0/f
] keep ;
: BY_HANDLE_FILE_INFORMATION>file-info
{
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
]
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
[
BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
FILETIME>timestamp
]
} cleave
\ file-info construct-boa ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
"BY_HANDLE_FILE_INFORMATION" <c-object>
[ GetFileInformationByHandle win32-error=0/f ] keep
] keep CloseHandle win32-error=0/f ;
: get-file-information-stat ( path -- BY_HANDLE_FILE_INFORMATION )
dup
GENERIC_READ FILE_SHARE_READ f
OPEN_EXISTING FILE_FLAG_BACKUP_SEMANTICS f
CreateFileW dup INVALID_HANDLE_VALUE = [
drop find-first-file-stat WIN32_FIND_DATA>file-info
] [
nip
get-file-information BY_HANDLE_FILE_INFORMATION>file-info
] if ;
M: windows-nt-io file-info ( path -- info )
get-file-information-stat ;

116
extra/io/windows/nt/launcher/launcher.factor
View File

@ -1,18 +1,38 @@
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend
combinators ;
combinators shuffle ;
IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' )
GetCurrentProcess ! source process
swap ! handle
GetCurrentProcess ! target process
f <void*> [ ! target handle
DUPLICATE_SAME_ACCESS ! desired access
TRUE ! inherit handle
DUPLICATE_CLOSE_SOURCE ! options
DuplicateHandle win32-error=0/f
] keep *void* ;
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: (redirect) ( path access-mode create-mode -- handle )
>r >r
: redirect-default ( default obj access-mode create-mode -- handle )
3drop ;
: redirect-inherit ( default obj access-mode create-mode -- handle )
4drop f ;
: redirect-closed ( default obj access-mode create-mode -- handle )
drop 2nip null-pipe ;
: redirect-file ( default path access-mode create-mode -- handle )
>r >r >r drop r>
normalize-pathname
r> ! access-mode
share-mode
@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
f ! template file
CreateFile dup invalid-handle? dup close-later ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ 3drop f ] }
{ [ pick +closed+ eq? ] [ drop nip null-pipe ] }
{ [ pick string? ] [ (redirect) ] }
} cond ;
: ?closed or dup t eq? [ drop f ] when ;
: inherited-stdout ( args -- handle )
CreateProcess-args-stdout-pipe
[ pipe-out ] [ STD_OUTPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdout ( args -- handle )
+stdout+ get GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stdout ?closed ;
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
] if ;
: inherited-stdin ( args -- handle )
CreateProcess-args-stdin-pipe
[ pipe-in ] [ STD_INPUT_HANDLE GetStdHandle ] if* ;
: redirect-stdin ( args -- handle )
+stdin+ get GENERIC_READ OPEN_EXISTING redirect
swap inherited-stdin ?closed ;
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
: redirect-stream ( default stream access-mode create-mode -- handle )
2drop nip
underlying-handle win32-file-handle
duplicate-handle dup t set-inherit ;
: redirect ( default obj access-mode create-mode -- handle )
{
{ [ pick not ] [ redirect-default ] }
{ [ pick +inherit+ eq? ] [ redirect-inherit ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick string? ] [ redirect-file ] }
{ [ t ] [ redirect-stream ] }
} cond ;
: default-stdout ( args -- handle )
CreateProcess-args-stdout-pipe dup [ pipe-out ] when ;
: redirect-stdout ( args -- handle )
default-stdout
+stdout+ get
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_OUTPUT_HANDLE GetStdHandle or ;
: redirect-stderr ( args -- handle )
+stderr+ get +stdout+ eq? [
CreateProcess-args-lpStartupInfo
STARTUPINFO-hStdOutput
] [
drop
f
+stderr+ get
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_ERROR_HANDLE GetStdHandle or
] if ;
: default-stdin ( args -- handle )
CreateProcess-args-stdin-pipe dup [ pipe-in ] when ;
: redirect-stdin ( args -- handle )
default-stdin
+stdin+ get
GENERIC_READ
OPEN_EXISTING
redirect
STD_INPUT_HANDLE GetStdHandle or ;
: add-pipe-dtors ( pipe -- )
dup
pipe-in close-later

2
extra/io/windows/windows.factor
View File

@ -55,7 +55,7 @@ M: win32-file close-handle ( handle -- )
: open-file ( path access-mode create-mode flags -- handle )
[
>r >r >r normalize-pathname r>
share-mode f r> r> CreateFile-flags f CreateFile
share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;

14
extra/locals/locals.factor
View File

@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
! are unified
: create-method ( class generic -- method )
2dup method dup
[ 2nip method-word ]
[ 2nip ]
[ drop 2dup [ ] -rot define-method create-method ] if ;
: CREATE-METHOD ( -- class generic body )
@ -367,16 +367,16 @@ M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop lambda-body ;
: method-stack-effect
: method-stack-effect ( method -- effect )
dup "lambda" word-prop lambda-vars
swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
swap "method-generic" word-prop stack-effect
dup [ effect-out ] when
<effect> ;
M: lambda-method synopsis*
dup definer.
dup "method" word-prop dup
method-specializer pprint*
method-generic pprint*
dup dup dup definer.
"method-specializer" word-prop pprint*
"method-generic" word-prop pprint*
method-stack-effect effect>string comment. ;
PRIVATE>

2
extra/logging/insomniac/insomniac-docs.factor Normal file → Executable file
View File

@ -27,7 +27,7 @@ HELP: schedule-insomniac
{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } }
{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ;
ARTICLE: "logging.insomniac" "Automating log analysis and rotation"
ARTICLE: "logging.insomniac" "Automated log analysis"
"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary."
$nl
"Required configuration parameters:"

6
extra/logging/logging-docs.factor Normal file → Executable file
View File

@ -115,9 +115,9 @@ ARTICLE: "logging" "Logging framework"
{ $subsection "logging.levels" }
{ $subsection "logging.messages" }
{ $subsection "logging.rotation" }
{ $subsection "logging.parser" }
{ $subsection "logging.analysis" }
{ $subsection "logging.insomniac" }
{ $vocab-subsection "Log file parser" "logging.parser" }
{ $vocab-subsection "Log analysis" "logging.analysis" }
{ $vocab-subsection "Automated log analysis" "logging.insomniac" }
{ $subsection "logging.server" } ;
ABOUT: "logging"

4
extra/math/functions/functions.factor
View File

@ -34,6 +34,10 @@ M: real sqrt
: set-bit ( x n -- y ) 2^ bitor ; foldable
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
: bit-set? ( x n -- ? ) bit-clear? not ; foldable
: unmask ( x n -- ? ) bitnot bitand ; foldable
: unmask? ( x n -- ? ) unmask 0 > ; foldable
: mask ( x n -- ? ) bitand ; foldable
: mask? ( x n -- ? ) mask 0 > ; foldable
GENERIC: (^) ( x y -- z ) foldable

1
extra/peg/peg-docs.factor
View File

@ -135,6 +135,7 @@ HELP: hide
HELP: delay
{ $values
{ "quot" "a quotation" }
{ "parser" "a parser" }
}
{ $description

2
extra/peg/peg.factor
View File

@ -358,7 +358,7 @@ MEMO: sp ( parser -- parser )
MEMO: hide ( parser -- parser )
[ drop ignore ] action ;
MEMO: delay ( parser -- parser )
MEMO: delay ( quot -- parser )
delay-parser construct-boa init-parser ;
: PEG:

5
extra/regexp2/regexp2-tests.factor Normal file
View File

@ -0,0 +1,5 @@
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

262
extra/regexp2/regexp2.factor Normal file
View File

@ -0,0 +1,262 @@
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 ;

0
extra/furnace/validator/authors.txt → extra/singleton/authors.txt Executable file → Normal file
View File

Some files were not shown because too many files have changed in this diff Show More