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

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

Conflicts:

	extra/db/sqlite/sqlite.factor
db4
Doug Coleman 2008-03-05 21:38:16 -06:00
parent 9f66ce692e b6b8ab32b5
commit 1ee943c2d5
64 changed files with 2213 additions and 1615 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 [ t ] [ \ c \ tuple class< ] unit-test
[ f ] [ \ tuple \ c class< ] unit-test [ f ] [ \ tuple \ c class< ] unit-test
DEFER: bah ! DEFER: bah
FORGET: bah ! FORGET: bah
UNION: bah fixnum alien ; UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test [ 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." } { $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* }" } } ; { $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 HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } } { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } { $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." } ;
{ method define-method POSTPONE: M: } related-words { method define-method POSTPONE: M: } related-words
HELP: <method> HELP: <method>
{ $values { "def" "a quotation" } { "method" "a new method definition" } } { $values { "def" "a quotation" } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ; { $description "Creates a new method." } ;
HELP: methods HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } { $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 ; PREDICATE: word generic "combination" word-prop >boolean ;
M: generic definer drop f f ;
M: generic definition drop f ; M: generic definition drop f ;
: make-generic ( word -- ) : make-generic ( word -- )
dup { "unannotated-def" } reset-props dup { "unannotated-def" } reset-props
dup dup "combination" word-prop perform-combination define ; dup dup "combination" word-prop perform-combination define ;
TUPLE: method word def specializer generic loc ;
: method ( class generic -- method/f ) : method ( class generic -- method/f )
"methods" word-prop at ; "methods" word-prop at ;
@ -47,7 +43,7 @@ PREDICATE: pair method-spec
: methods ( word -- assoc ) : methods ( word -- assoc )
"methods" word-prop "methods" word-prop
[ keys sort-classes ] keep [ keys sort-classes ] keep
[ dupd at method-word ] curry { } map>assoc ; [ dupd at ] curry { } map>assoc ;
TUPLE: check-method class generic ; TUPLE: check-method class generic ;
@ -63,29 +59,33 @@ TUPLE: check-method class generic ;
: method-word-name ( class word -- string ) : method-word-name ( class word -- string )
word-name "/" rot word-name 3append ; 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 ; "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 M: method-body stack-effect
"method" word-prop method-generic stack-effect ; "method-generic" word-prop stack-effect ;
: <method-word> ( quot class generic -- word ) : method-word-props ( quot class generic -- assoc )
[ make-method-def ] 2keep [
method-word-name f <word> "method-generic" set
dup rot define "method-class" set
dup xref ; "method-def" set
] H{ } make-assoc ;
: <method> ( quot class generic -- method ) : <method> ( quot class generic -- word )
check-method check-method
[ <method-word> ] 3keep f \ method construct-boa [ make-method-def ] 3keep
dup method-word over "method" set-word-prop ; [ method-word-props ] 2keep
method-word-name f <word>
tuck set-word-props
dup rot define ;
: redefine-method ( quot class generic -- ) : redefine-method ( quot class generic -- )
[ method set-method-def ] 3keep [ method swap "method-def" set-word-prop ] 3keep
[ make-method-def ] 2keep [ make-method-def ] 2keep
method method-word swap define ; method swap define ;
: define-method ( quot class generic -- ) : define-method ( quot class generic -- )
>r bootstrap-word r> >r bootstrap-word r>
@ -102,21 +102,22 @@ M: method-body stack-effect
! Definition protocol ! Definition protocol
M: method-spec where M: method-spec where
dup first2 method [ method-word ] [ second ] ?if where ; dup first2 method [ ] [ second ] ?if where ;
M: method-spec set-where M: method-spec set-where
first2 method method-word set-where ; first2 method set-where ;
M: method-spec definer M: method-spec definer
drop \ M: \ ; ; drop \ M: \ ; ;
M: method-spec definition M: method-spec definition
first2 method dup [ method-def ] when ; first2 method dup
[ "method-def" word-prop ] when ;
: forget-method ( class generic -- ) : forget-method ( class generic -- )
check-method check-method
[ delete-at* ] with-methods [ delete-at* ] with-methods
[ method-word forget-word ] [ drop ] if ; [ forget-word ] [ drop ] if ;
M: method-spec forget* M: method-spec forget*
first2 forget-method ; first2 forget-method ;
@ -125,11 +126,11 @@ M: method-body definer
drop \ M: \ ; ; drop \ M: \ ; ;
M: method-body definition M: method-body definition
"method" word-prop method-def ; "method-def" word-prop ;
M: method-body forget* M: method-body forget*
"method" word-prop dup "method-class" word-prop
{ method-specializer method-generic } get-slots swap "method-generic" word-prop
forget-method ; forget-method ;
: implementors* ( classes -- words ) : implementors* ( classes -- words )
@ -168,8 +169,7 @@ M: word subwords drop f ;
M: generic subwords M: generic subwords
dup "methods" word-prop values dup "methods" word-prop values
swap "default-method" word-prop add swap "default-method" word-prop add ;
[ method-word ] map ;
M: generic forget-word M: generic forget-word
dup subwords [ forget-word ] each (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 ) : applicable-method ( generic class -- quot )
over method over method
[ method-word word-def ] [ word-def ]
[ default-math-method ] ?if ; [ default-math-method ] ?if ;
: object-method ( generic -- quot ) : object-method ( generic -- quot )

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

@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
] if ; ] if ;
: default-method ( word -- pair ) : default-method ( word -- pair )
"default-method" word-prop method-word "default-method" word-prop
object bootstrap-word swap 2array ; object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot ) : 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 ; recursive-state get at ;
: inline? ( word -- ? ) : inline? ( word -- ? )
dup "method" word-prop dup "method-generic" word-prop swap or "inline" word-prop ;
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
: local-recursive-state ( -- assoc ) : local-recursive-state ( -- assoc )
recursive-state get dup keys recursive-state get dup keys

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

@ -1,208 +1,208 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs inference inference.class USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables math namespaces sequences vectors words quotations hashtables
combinators classes generic.math continuations optimizer.def-use combinators classes generic.math continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ; optimizer.control kernel.private ;
IN: optimizer.inlining IN: optimizer.inlining
: remember-inlining ( node history -- ) : remember-inlining ( node history -- )
[ swap set-node-history ] curry each-node ; [ swap set-node-history ] curry each-node ;
: inlining-quot ( node quot -- node ) : inlining-quot ( node quot -- node )
over node-in-d dataflow-with over node-in-d dataflow-with
dup rot infer-classes/node ; dup rot infer-classes/node ;
: splice-quot ( #call quot history -- node ) : splice-quot ( #call quot history -- node )
#! Must add history *before* splicing in, otherwise #! Must add history *before* splicing in, otherwise
#! the rest of the IR will also remember the history #! the rest of the IR will also remember the history
pick node-history append pick node-history append
>r dupd inlining-quot dup r> remember-inlining >r dupd inlining-quot dup r> remember-inlining
tuck splice-node ; tuck splice-node ;
! A heuristic to avoid excessive inlining ! A heuristic to avoid excessive inlining
DEFER: (flat-length) DEFER: (flat-length)
: word-flat-length ( word -- n ) : word-flat-length ( word -- n )
{ {
! heuristic: { ... } declare comes up in method bodies ! heuristic: { ... } declare comes up in method bodies
! and we don't care about it ! and we don't care about it
{ [ dup \ declare eq? ] [ drop -2 ] } { [ dup \ declare eq? ] [ drop -2 ] }
! recursive ! recursive
{ [ dup get ] [ drop 1 ] } { [ dup get ] [ drop 1 ] }
! not inline ! not inline
{ [ dup inline? not ] [ drop 1 ] } { [ dup inline? not ] [ drop 1 ] }
! inline ! inline
{ [ t ] [ dup dup set word-def (flat-length) ] } { [ t ] [ dup dup set word-def (flat-length) ] }
} cond ; } cond ;
: (flat-length) ( seq -- n ) : (flat-length) ( seq -- n )
[ [
{ {
{ [ dup quotation? ] [ (flat-length) 1+ ] } { [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] } { [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] } { [ dup word? ] [ word-flat-length ] }
{ [ t ] [ drop 1 ] } { [ t ] [ drop 1 ] }
} cond } cond
] map sum ; ] map sum ;
: flat-length ( seq -- n ) : flat-length ( seq -- n )
[ word-def (flat-length) ] with-scope ; [ word-def (flat-length) ] with-scope ;
! Single dispatch method inlining optimization ! Single dispatch method inlining optimization
: specific-method ( class word -- class ) order min-class ; : specific-method ( class word -- class ) order min-class ;
: node-class# ( node n -- class ) : node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ; over node-in-d <reversed> ?nth node-class ;
: dispatching-class ( node word -- class ) : dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ; [ dispatch# node-class# ] keep specific-method ;
: inline-standard-method ( node word -- node ) : inline-standard-method ( node word -- node )
2dup dispatching-class dup [ 2dup dispatching-class dup [
over +inlined+ depends-on over +inlined+ depends-on
swap method method-word 1quotation f splice-quot swap method 1quotation f splice-quot
] [ ] [
3drop t 3drop t
] if ; ] if ;
! Partial dispatch of math-generic words ! Partial dispatch of math-generic words
: math-both-known? ( word left right -- ? ) : math-both-known? ( word left right -- ? )
math-class-max swap specific-method ; math-class-max swap specific-method ;
: inline-math-method ( #call word -- node ) : inline-math-method ( #call word -- node )
over node-input-classes first2 3dup math-both-known? over node-input-classes first2 3dup math-both-known?
[ math-method f splice-quot ] [ 2drop 2drop t ] if ; [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
: inline-method ( #call -- node ) : inline-method ( #call -- node )
dup node-param { dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] } { [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] } { [ dup math-generic? ] [ inline-math-method ] }
{ [ t ] [ 2drop t ] } { [ t ] [ 2drop t ] }
} cond ; } cond ;
! Resolve type checks at compile time where possible ! Resolve type checks at compile time where possible
: comparable? ( actual testing -- ? ) : comparable? ( actual testing -- ? )
#! If actual is a subset of testing or if the two classes #! If actual is a subset of testing or if the two classes
#! are disjoint, return t. #! are disjoint, return t.
2dup class< >r classes-intersect? not r> or ; 2dup class< >r classes-intersect? not r> or ;
: optimize-predicate? ( #call -- ? ) : optimize-predicate? ( #call -- ? )
dup node-param "predicating" word-prop dup [ dup node-param "predicating" word-prop dup [
>r node-class-first r> comparable? >r node-class-first r> comparable?
] [ ] [
2drop f 2drop f
] if ; ] if ;
: literal-quot ( node literals -- quot ) : literal-quot ( node literals -- quot )
#! Outputs a quotation which drops the node's inputs, and #! Outputs a quotation which drops the node's inputs, and
#! pushes some literals. #! pushes some literals.
>r node-in-d length \ drop <repetition> >r node-in-d length \ drop <repetition>
r> [ literalize ] map append >quotation ; r> [ literalize ] map append >quotation ;
: inline-literals ( node literals -- node ) : inline-literals ( node literals -- node )
#! Make #shuffle -> #push -> #return -> successor #! Make #shuffle -> #push -> #return -> successor
dupd literal-quot f splice-quot ; dupd literal-quot f splice-quot ;
: evaluate-predicate ( #call -- ? ) : evaluate-predicate ( #call -- ? )
dup node-param "predicating" word-prop >r dup node-param "predicating" word-prop >r
node-class-first r> class< ; node-class-first r> class< ;
: optimize-predicate ( #call -- node ) : optimize-predicate ( #call -- node )
#! If the predicate is followed by a branch we fold it #! If the predicate is followed by a branch we fold it
#! immediately #! immediately
dup evaluate-predicate swap dup evaluate-predicate swap
dup node-successor #if? [ dup node-successor #if? [
dup drop-inputs >r dup drop-inputs >r
node-successor swap 0 1 ? fold-branch node-successor swap 0 1 ? fold-branch
r> [ set-node-successor ] keep r> [ set-node-successor ] keep
] [ ] [
swap 1array inline-literals swap 1array inline-literals
] if ; ] if ;
: optimizer-hooks ( node -- conditions ) : optimizer-hooks ( node -- conditions )
node-param "optimizer-hooks" word-prop ; node-param "optimizer-hooks" word-prop ;
: optimizer-hook ( node -- pair/f ) : optimizer-hook ( node -- pair/f )
dup optimizer-hooks [ first call ] find 2nip ; dup optimizer-hooks [ first call ] find 2nip ;
: optimize-hook ( node -- ) : optimize-hook ( node -- )
dup optimizer-hook second call ; dup optimizer-hook second call ;
: define-optimizers ( word optimizers -- ) : define-optimizers ( word optimizers -- )
"optimizer-hooks" set-word-prop ; "optimizer-hooks" set-word-prop ;
: flush-eval? ( #call -- ? ) : flush-eval? ( #call -- ? )
dup node-param "flushable" word-prop [ dup node-param "flushable" word-prop [
node-out-d [ unused? ] all? node-out-d [ unused? ] all?
] [ ] [
drop f drop f
] if ; ] if ;
: flush-eval ( #call -- node ) : flush-eval ( #call -- node )
dup node-param +inlined+ depends-on dup node-param +inlined+ depends-on
dup node-out-d length f <repetition> inline-literals ; dup node-out-d length f <repetition> inline-literals ;
: partial-eval? ( #call -- ? ) : partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [ dup node-param "foldable" word-prop [
dup node-in-d [ node-literal? ] with all? dup node-in-d [ node-literal? ] with all?
] [ ] [
drop f drop f
] if ; ] if ;
: literal-in-d ( #call -- inputs ) : literal-in-d ( #call -- inputs )
dup node-in-d [ node-literal ] with map ; dup node-in-d [ node-literal ] with map ;
: partial-eval ( #call -- node ) : partial-eval ( #call -- node )
dup node-param +inlined+ depends-on dup node-param +inlined+ depends-on
dup literal-in-d over node-param 1quotation dup literal-in-d over node-param 1quotation
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ; [ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
: define-identities ( words identities -- ) : define-identities ( words identities -- )
[ "identities" set-word-prop ] curry each ; [ "identities" set-word-prop ] curry each ;
: find-identity ( node -- quot ) : find-identity ( node -- quot )
[ node-param "identities" word-prop ] keep [ node-param "identities" word-prop ] keep
[ swap first in-d-match? ] curry find [ swap first in-d-match? ] curry find
nip dup [ second ] when ; nip dup [ second ] when ;
: apply-identities ( node -- node/f ) : apply-identities ( node -- node/f )
dup find-identity dup [ f splice-quot ] [ 2drop f ] if ; dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
: optimistic-inline? ( #call -- ? ) : optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [ dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail* >r node-input-classes r> specialized-length tail*
[ types length 1 = ] all? [ types length 1 = ] all?
] [ ] [
2drop f 2drop f
] if ; ] if ;
: splice-word-def ( #call word -- node ) : splice-word-def ( #call word -- node )
dup +inlined+ depends-on dup +inlined+ depends-on
dup word-def swap 1array splice-quot ; dup word-def swap 1array splice-quot ;
: optimistic-inline ( #call -- node ) : optimistic-inline ( #call -- node )
dup node-param over node-history memq? [ dup node-param over node-history memq? [
drop t drop t
] [ ] [
dup node-param splice-word-def dup node-param splice-word-def
] if ; ] if ;
: method-body-inline? ( #call -- ? ) : method-body-inline? ( #call -- ? )
node-param dup method-body? node-param dup method-body?
[ flat-length 10 <= ] [ drop f ] if ; [ flat-length 10 <= ] [ drop f ] if ;
M: #call optimize-node* M: #call optimize-node*
{ {
{ [ dup flush-eval? ] [ flush-eval ] } { [ dup flush-eval? ] [ flush-eval ] }
{ [ dup partial-eval? ] [ partial-eval ] } { [ dup partial-eval? ] [ partial-eval ] }
{ [ dup find-identity ] [ apply-identities ] } { [ dup find-identity ] [ apply-identities ] }
{ [ dup optimizer-hook ] [ optimize-hook ] } { [ dup optimizer-hook ] [ optimize-hook ] }
{ [ dup optimize-predicate? ] [ optimize-predicate ] } { [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] } { [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] } { [ dup method-body-inline? ] [ optimistic-inline ] }
{ [ t ] [ inline-method ] } { [ t ] [ inline-method ] }
} cond dup not ; } cond dup not ;

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

@ -1,378 +1,378 @@
USING: arrays compiler.units generic hashtables inference kernel USING: arrays compiler.units generic hashtables inference kernel
kernel.private math optimizer prettyprint sequences sbufs kernel.private math optimizer prettyprint sequences sbufs
strings tools.test vectors words sequences.private quotations strings tools.test vectors words sequences.private quotations
optimizer.backend classes inference.dataflow tuples.private optimizer.backend classes inference.dataflow tuples.private
continuations growable optimizer.inlining namespaces hints ; continuations growable optimizer.inlining namespaces hints ;
IN: optimizer.tests IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
] unit-test ] unit-test
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ [ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
] unit-test ] unit-test
! Test method inlining ! Test method inlining
[ f ] [ fixnum { } min-class ] unit-test [ f ] [ fixnum { } min-class ] unit-test
[ string ] [ [ string ] [
\ string \ string
[ integer string array reversed sbuf [ integer string array reversed sbuf
slice vector quotation ] slice vector quotation ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ fixnum ] [ [ fixnum ] [
\ fixnum \ fixnum
[ fixnum integer object ] [ fixnum integer object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ integer ] [ [ integer ] [
\ fixnum \ fixnum
[ integer float object ] [ integer float object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ object ] [ [ object ] [
\ word \ word
[ integer float object ] [ integer float object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ reversed ] [ [ reversed ] [
\ reversed \ reversed
[ integer reversed slice ] [ integer reversed slice ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
M: array xyz xyz ; M: array xyz xyz ;
[ t ] [ \ xyz compiled? ] unit-test [ t ] [ \ xyz compiled? ] unit-test
! Test predicate inlining ! Test predicate inlining
: pred-test-1 : pred-test-1
dup fixnum? [ dup fixnum? [
dup integer? [ "integer" ] [ "nope" ] if dup integer? [ "integer" ] [ "nope" ] if
] [ ] [
"not a fixnum" "not a fixnum"
] if ; ] if ;
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test [ 1 "integer" ] [ 1 pred-test-1 ] unit-test
TUPLE: pred-test ; TUPLE: pred-test ;
: pred-test-2 : pred-test-2
dup tuple? [ dup tuple? [
dup pred-test? [ "pred-test" ] [ "nope" ] if dup pred-test? [ "pred-test" ] [ "nope" ] if
] [ ] [
"not a tuple" "not a tuple"
] if ; ] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
: pred-test-3 : pred-test-3
dup pred-test? [ dup pred-test? [
dup tuple? [ "pred-test" ] [ "nope" ] if dup tuple? [ "pred-test" ] [ "nope" ] if
] [ ] [
"not a tuple" "not a tuple"
] if ; ] if ;
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test [ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
: inline-test : inline-test
"nom" = ; "nom" = ;
[ t ] [ "nom" inline-test ] unit-test [ t ] [ "nom" inline-test ] unit-test
[ f ] [ "shayin" inline-test ] unit-test [ f ] [ "shayin" inline-test ] unit-test
[ f ] [ 3 inline-test ] unit-test [ f ] [ 3 inline-test ] unit-test
: fixnum-declarations >fixnum 24 shift 1234 bitxor ; : fixnum-declarations >fixnum 24 shift 1234 bitxor ;
[ ] [ 1000000 fixnum-declarations . ] unit-test [ ] [ 1000000 fixnum-declarations . ] unit-test
! regression ! regression
: literal-not-branch 0 not [ ] [ ] if ; : literal-not-branch 0 not [ ] [ ] if ;
[ ] [ literal-not-branch ] unit-test [ ] [ literal-not-branch ] unit-test
! regression ! regression
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline : bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
: bad-kill-2 bad-kill-1 drop ; : bad-kill-2 bad-kill-1 drop ;
[ 3 ] [ t bad-kill-2 ] unit-test [ 3 ] [ t bad-kill-2 ] unit-test
! regression ! regression
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline : (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
: the-test ( -- x y ) 2 dup (the-test) ; : the-test ( -- x y ) 2 dup (the-test) ;
[ 2 0 ] [ the-test ] unit-test [ 2 0 ] [ the-test ] unit-test
! regression ! regression
: (double-recursion) ( start end -- ) : (double-recursion) ( start end -- )
< [ < [
6 1 (double-recursion) 6 1 (double-recursion)
3 2 (double-recursion) 3 2 (double-recursion)
] when ; inline ] when ; inline
: double-recursion 0 2 (double-recursion) ; : double-recursion 0 2 (double-recursion) ;
[ ] [ double-recursion ] unit-test [ ] [ double-recursion ] unit-test
! regression ! regression
: double-label-1 ( a b c -- d ) : double-label-1 ( a b c -- d )
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
: double-label-2 ( a -- b ) : double-label-2 ( a -- b )
dup array? [ ] [ ] if 0 t double-label-1 ; dup array? [ ] [ ] if 0 t double-label-1 ;
[ 0 ] [ 10 double-label-2 ] unit-test [ 0 ] [ 10 double-label-2 ] unit-test
! regression ! regression
GENERIC: void-generic ( obj -- * ) GENERIC: void-generic ( obj -- * )
: breakage "hi" void-generic ; : breakage "hi" void-generic ;
[ t ] [ \ breakage compiled? ] unit-test [ t ] [ \ breakage compiled? ] unit-test
[ breakage ] must-fail [ breakage ] must-fail
! regression ! regression
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline : test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline : test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
: test-2 ( -- ) 5 test-1 ; : test-2 ( -- ) 5 test-1 ;
[ f ] [ f test-2 ] unit-test [ f ] [ f test-2 ] unit-test
: branch-fold-regression-0 ( m -- n ) : branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
: branch-fold-regression-1 ( -- m ) : branch-fold-regression-1 ( -- m )
10 branch-fold-regression-0 ; 10 branch-fold-regression-0 ;
[ 10 ] [ branch-fold-regression-1 ] unit-test [ 10 ] [ branch-fold-regression-1 ] unit-test
! another regression ! another regression
: constant-branch-fold-0 "hey" ; foldable : constant-branch-fold-0 "hey" ; foldable
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline : constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test [ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
! another regression ! another regression
: foo f ; : foo f ;
: bar foo 4 4 = and ; : bar foo 4 4 = and ;
[ f ] [ bar ] unit-test [ f ] [ bar ] unit-test
! ensure identities are working in some form ! ensure identities are working in some form
[ t ] [ [ t ] [
[ { number } declare 0 + ] dataflow optimize [ { number } declare 0 + ] dataflow optimize
[ #push? ] node-exists? not [ #push? ] node-exists? not
] unit-test ] unit-test
! compiling <tuple> with a non-literal class failed ! compiling <tuple> with a non-literal class failed
: <tuple>-regression <tuple> ; : <tuple>-regression <tuple> ;
[ t ] [ \ <tuple>-regression compiled? ] unit-test [ t ] [ \ <tuple>-regression compiled? ] unit-test
GENERIC: foozul ( a -- b ) GENERIC: foozul ( a -- b )
M: reversed foozul ; M: reversed foozul ;
M: integer foozul ; M: integer foozul ;
M: slice foozul ; M: slice foozul ;
[ reversed ] [ reversed \ foozul specific-method ] unit-test [ reversed ] [ reversed \ foozul specific-method ] unit-test
! regression ! regression
: constant-fold-2 f ; foldable : constant-fold-2 f ; foldable
: constant-fold-3 4 ; foldable : constant-fold-3 4 ; foldable
[ f t ] [ [ f t ] [
[ constant-fold-2 constant-fold-3 4 = ] compile-call [ constant-fold-2 constant-fold-3 4 = ] compile-call
] unit-test ] unit-test
: constant-fold-4 f ; foldable : constant-fold-4 f ; foldable
: constant-fold-5 f ; foldable : constant-fold-5 f ; foldable
[ f ] [ [ f ] [
[ constant-fold-4 constant-fold-5 or ] compile-call [ constant-fold-4 constant-fold-5 or ] compile-call
] unit-test ] unit-test
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test [ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test [ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test [ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test [ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test [ 0 ] [ 5 [ dup - ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test [ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test [ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test [ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test [ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test [ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test [ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test [ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test [ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test [ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test [ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test [ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test [ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test [ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test [ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test [ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test [ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test [ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test [ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test [ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test [ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test [ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test [ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test [ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test [ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test [ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
[ f ] [ 5 [ dup < ] compile-call ] unit-test [ f ] [ 5 [ dup < ] compile-call ] unit-test
[ t ] [ 5 [ dup <= ] compile-call ] unit-test [ t ] [ 5 [ dup <= ] compile-call ] unit-test
[ f ] [ 5 [ dup > ] compile-call ] unit-test [ f ] [ 5 [ dup > ] compile-call ] unit-test
[ t ] [ 5 [ dup >= ] compile-call ] unit-test [ t ] [ 5 [ dup >= ] compile-call ] unit-test
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test [ t ] [ 5 [ dup eq? ] compile-call ] unit-test
[ t ] [ 5 [ dup = ] compile-call ] unit-test [ t ] [ 5 [ dup = ] compile-call ] unit-test
[ t ] [ 5 [ dup number= ] compile-call ] unit-test [ t ] [ 5 [ dup number= ] compile-call ] unit-test
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test [ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
GENERIC: detect-number ( obj -- obj ) GENERIC: detect-number ( obj -- obj )
M: number detect-number ; M: number detect-number ;
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail [ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
! Regression ! Regression
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
! Regression ! Regression
USE: sorting USE: sorting
USE: sorting.private USE: sorting.private
: old-binsearch ( elt quot seq -- elt quot i ) : old-binsearch ( elt quot seq -- elt quot i )
dup length 1 <= [ dup length 1 <= [
slice-from slice-from
] [ ] [
[ midpoint swap call ] 3keep roll dup zero? [ midpoint swap call ] 3keep roll dup zero?
[ drop dup slice-from swap midpoint@ + ] [ drop dup slice-from swap midpoint@ + ]
[ partition old-binsearch ] if [ partition old-binsearch ] if
] if ; inline ] if ; inline
[ 10 ] [ [ 10 ] [
10 20 >vector <flat-slice> 10 20 >vector <flat-slice>
[ [ - ] swap old-binsearch ] compile-call 2nip [ [ - ] swap old-binsearch ] compile-call 2nip
] unit-test ] unit-test
! Regression ! Regression
TUPLE: silly-tuple a b ; TUPLE: silly-tuple a b ;
[ 1 2 { silly-tuple-a silly-tuple-b } ] [ [ 1 2 { silly-tuple-a silly-tuple-b } ] [
T{ silly-tuple f 1 2 } T{ silly-tuple f 1 2 }
[ [
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep { silly-tuple-a silly-tuple-b } [ get-slots ] keep
] compile-call ] compile-call
] unit-test ] unit-test
! Regression ! Regression
: empty-compound ; : empty-compound ;
: node-successor-f-bug ( x -- * ) : node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled? ] unit-test [ t ] [ \ node-successor-f-bug compiled? ] unit-test
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test [ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
! Make sure we have sane heuristics ! 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 [ t ] [ \ fixnum \ shift should-inline? ] unit-test
[ f ] [ \ array \ equal? should-inline? ] unit-test [ f ] [ \ array \ equal? should-inline? ] unit-test
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test [ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test [ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test [ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test [ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
! Regression ! Regression
: lift-throw-tail-regression : lift-throw-tail-regression
dup integer? [ "an integer" ] [ dup integer? [ "an integer" ] [
dup string? [ "a string" ] [ dup string? [ "a string" ] [
"error" throw "error" throw
] if ] if
] if ; ] if ;
[ t ] [ \ lift-throw-tail-regression compiled? ] unit-test [ t ] [ \ lift-throw-tail-regression compiled? ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: lift-loop-tail-test-1 ( a quot -- ) : lift-loop-tail-test-1 ( a quot -- )
over even? [ over even? [
[ >r 3 - r> call ] keep lift-loop-tail-test-1 [ >r 3 - r> call ] keep lift-loop-tail-test-1
] [ ] [
over 0 < [ over 0 < [
2drop 2drop
] [ ] [
[ >r 2 - r> call ] keep lift-loop-tail-test-1 [ >r 2 - r> call ] keep lift-loop-tail-test-1
] if ] if
] if ; inline ] if ; inline
: lift-loop-tail-test-2 : lift-loop-tail-test-2
10 [ ] lift-loop-tail-test-1 1 2 3 ; 10 [ ] lift-loop-tail-test-1 1 2 3 ;
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
! Make sure we don't lose ! Make sure we don't lose
GENERIC: generic-inline-test ( x -- y ) GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ; M: integer generic-inline-test ;
: generic-inline-test-1 : generic-inline-test-1
1 1
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test generic-inline-test
generic-inline-test ; generic-inline-test ;
[ { t f } ] [ [ { t f } ] [
\ generic-inline-test-1 word-def dataflow \ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make [ optimize-1 , optimize-1 , drop ] { } make
] unit-test ] unit-test
! Forgot a recursive inline check ! Forgot a recursive inline check
: recursive-inline-hang ( a -- a ) : recursive-inline-hang ( a -- a )
dup array? [ recursive-inline-hang ] when ; dup array? [ recursive-inline-hang ] when ;
HINTS: recursive-inline-hang array ; HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 : recursive-inline-hang-1
{ } recursive-inline-hang ; { } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test [ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
DEFER: recursive-inline-hang-3 DEFER: recursive-inline-hang-3
: recursive-inline-hang-2 ( a -- a ) : recursive-inline-hang-2 ( a -- a )
dup array? [ recursive-inline-hang-3 ] when ; dup array? [ recursive-inline-hang-3 ] when ;
HINTS: recursive-inline-hang-2 array ; HINTS: recursive-inline-hang-2 array ;
: recursive-inline-hang-3 ( a -- a ) : recursive-inline-hang-3 ( a -- a )
dup array? [ recursive-inline-hang-2 ] when ; dup array? [ recursive-inline-hang-2 ] when ;
HINTS: recursive-inline-hang-3 array ; HINTS: recursive-inline-hang-3 array ;

14
core/prettyprint/prettyprint.factor
View File

@ -175,10 +175,10 @@ M: method-spec synopsis*
dup definer. [ pprint-word ] each ; dup definer. [ pprint-word ] each ;
M: method-body synopsis* M: method-body synopsis*
dup definer. dup dup
"method" word-prop dup definer.
method-specializer pprint* "method-class" word-prop pprint*
method-generic pprint* ; "method-generic" word-prop pprint* ;
M: mixin-instance synopsis* M: mixin-instance synopsis*
dup definer. dup definer.
@ -269,7 +269,7 @@ M: builtin-class see-class*
: see-implementors ( class -- seq ) : see-implementors ( class -- seq )
dup implementors dup implementors
[ method method-word ] with map [ method ] with map
natural-sort ; natural-sort ;
: see-class ( class -- ) : see-class ( class -- )
@ -280,9 +280,7 @@ M: builtin-class see-class*
] when drop ; ] when drop ;
: see-methods ( generic -- seq ) : see-methods ( generic -- seq )
"methods" word-prop "methods" word-prop values natural-sort ;
[ nip method-word ] { } assoc>map
natural-sort ;
M: word see M: word see
dup see-class 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 set-vocab-docs-loaded? 2drop ;
M: f vocab-help ;
: create-vocab ( name -- vocab ) : create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ; 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 [ { + } ] [ \ 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 [ [ undefined? ] is? ] must-fail-with
[ ] [ [ ] [

2
core/words/words.factor
View File

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

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

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

2
extra/benchmark/benchmark.factor
View File

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

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

@ -1,65 +1,58 @@
USING: io.sockets io kernel math threads USING: io.sockets io kernel math threads
debugger tools.time prettyprint concurrency.count-downs debugger tools.time prettyprint concurrency.count-downs
namespaces arrays continuations ; namespaces arrays continuations ;
IN: benchmark.sockets IN: benchmark.sockets
SYMBOL: counter SYMBOL: counter
: number-of-requests 1 ; : number-of-requests 1 ;
: server-addr "127.0.0.1" 7777 <inet4> ; : server-addr "127.0.0.1" 7777 <inet4> ;
: server-loop ( server -- ) : server-loop ( server -- )
dup accept [ dup accept [
[ [
read1 CHAR: x = [ read1 CHAR: x = [
"server" get dispose "server" get dispose
] [ ] [
number-of-requests number-of-requests
[ read1 write1 flush ] times [ read1 write1 flush ] times
counter get count-down counter get count-down
] if ] if
] with-stream ] with-stream
] curry "Client handler" spawn drop server-loop ; ] curry "Client handler" spawn drop server-loop ;
: simple-server ( -- ) : simple-server ( -- )
[ [
server-addr <server> dup "server" set [ server-addr <server> dup "server" set [
server-loop server-loop
] with-disposal ] with-disposal
] ignore-errors ; ] ignore-errors ;
: simple-client ( -- ) : simple-client ( -- )
server-addr <client> [ server-addr <client> [
CHAR: b write1 flush CHAR: b write1 flush
number-of-requests number-of-requests
[ CHAR: a dup write1 flush read1 assert= ] times [ CHAR: a dup write1 flush read1 assert= ] times
counter get count-down counter get count-down
] with-stream ; ] with-stream ;
: stop-server ( -- ) : stop-server ( -- )
server-addr <client> [ server-addr <client> [
CHAR: x write1 CHAR: x write1
] with-stream ; ] with-stream ;
: clients ( n -- ) : clients ( n -- )
dup pprint " clients: " write [ dup pprint " clients: " write [
dup 2 * <count-down> counter set dup 2 * <count-down> counter set
[ simple-server ] "Simple server" spawn drop [ simple-server ] "Simple server" spawn drop
yield yield yield yield
[ [ simple-client ] "Simple client" spawn drop ] times [ [ simple-client ] "Simple client" spawn drop ] times
counter get await counter get await
stop-server stop-server
yield yield yield yield
] time ; ] time ;
: socket-benchmarks : socket-benchmarks ;
10 clients
20 clients MAIN: socket-benchmarks
40 clients ;
! 80 clients
! 160 clients
! 320 clients
! 640 clients ;
MAIN: socket-benchmarks

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

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

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_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( 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_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_double ( sqlite3_stmt* pStmt, int index, double x ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;

BIN
extra/db/sqlite/test.db Normal file
View File

Binary file not shown.

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

@ -100,7 +100,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
db get db-delete-statements [ <delete-tuple-statement> ] cache db get db-delete-statements [ <delete-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ; [ bind-tuple ] keep execute-statement ;
: select-tuples ( tuple -- tuple ) : select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> [ dup dup class <select-by-slots-statement> [
[ bind-tuple ] keep query-tuples [ bind-tuple ] keep query-tuples
] with-disposal ; ] with-disposal ;

3
extra/delegate/delegate.factor
View File

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

11
extra/furnace/furnace.factor
View File

@ -35,6 +35,17 @@ SYMBOL: current-action
SYMBOL: validators-errored SYMBOL: validators-errored
SYMBOL: validation-errors SYMBOL: validation-errors
: build-url ( str query-params -- newstr )
[
over %
dup assoc-empty? [
2drop
] [
CHAR: ? rot member? "&" "?" ? %
assoc>query %
] if
] "" make ;
: action-link ( query action -- url ) : action-link ( query action -- url )
[ [
"/responder/" % "/responder/" %

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

@ -144,24 +144,36 @@ M: f print-element drop ;
: $link ( element -- ) : $link ( element -- )
first ($link) ; first ($link) ;
: ($subsection) ( object -- ) : ($long-link) ( object -- )
[ article-title ] keep >link write-object ; dup article-title swap >link write-link ;
: $subsection ( element -- ) : ($subsection) ( element quot -- )
[ [
subsection-style get [ subsection-style get [
bullet get write bl bullet get write bl
first ($subsection) call
] with-style ] 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 -- ) : $vocabulary ( element -- )
first word-vocabulary [ first word-vocabulary [
"Vocabulary" $heading nl ($vocab-link) "Vocabulary" $heading nl dup ($vocab-link)
] when* ; ] when* ;
: textual-list ( seq quot -- ) : 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" 80 ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test [ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
[ "localhost:8888" "/" ] [ "http://localhost:8888" 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.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] 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?xxx" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" 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 [ "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. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings 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 IN: http.client
: parse-host ( url -- host port ) : parse-url ( url -- resource host port )
#! Extract the host name and port number from an HTTP URL. "http://" ?head [ "Only http:// supported" throw ] unless
":" 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
"/" split1 [ "/" swap append ] [ "/" ] if* "/" split1 [ "/" swap append ] [ "/" ] if*
>r dup empty? [ drop domain get ] [ dup domain set ] if r> ; swap parse-host ;
: parse-response ( line -- code ) <PRIVATE
"HTTP/" ?head [ " " split1 nip ] when
" " split1 drop string>number [
"Premature end of stream" throw
] unless* ;
: read-response ( -- code header ) : store-path ( request path -- request )
#! After sending a GET or POST we read a response line and "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
#! header.
flush readln parse-response read-header ;
: 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 -- ) DEFER: (http-request)
write bl write " HTTP/1.0" write crlf
"Host: " write write crlf ;
: get-request ( host resource -- ) : absolute-redirect ( url -- request )
"GET" http-request crlf ; "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 ) : do-redirect ( response -- response stream )
#! Should this support Location: headers that are dup response-code 300 399 between? [
#! relative URLs? header>> "location" swap at
pick 100 /i 3 = [ dup "http://" head? [
dispose "location" swap peek-at nip http-get-stream absolute-redirect
] when ; ] [
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 ) PRIVATE>
#! Opens a stream for reading from an HTTP URL.
parse-url over parse-host <inet> <client> [ : http-request ( url request -- response stream )
[ [ get-request read-response ] with-stream* ] keep [
default-timeout request-with-url
] [ ] [ dispose ] cleanup do-redirect ; [
(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 = ; : success? ( code -- ? ) 200 = ;
: check-response ( code headers stream -- stream ) : check-response ( response stream -- stream )
nip swap success? swap code>> success?
[ dispose "HTTP download failed" throw ] unless ; [ dispose "HTTP download failed" throw ] unless ;
: http-get ( url -- string ) : http-get ( url -- string )
@ -70,23 +78,18 @@ DEFER: http-get-stream
: download-to ( url file -- ) : download-to ( url file -- )
#! Downloads the contents of a URL to a file. #! Downloads the contents of a URL to a file.
>r http-get-stream check-response swap http-get-stream check-response
r> <file-writer> stream-copy ; [ swap <file-writer> stream-copy ] with-disposal ;
: download ( url -- ) : download ( url -- )
dup download-name download-to ; dup download-name download-to ;
: post-request ( content-type content host resource -- ) : <post-request> ( content-type content -- request )
#! Note: It is up to the caller to url encode the content if <request>
#! it is required according to the content-type. "POST" >>method
"POST" http-request [ swap >>post-data
"Content-Length: " write length number>string write crlf swap >>post-data-type ;
"Content-Type: " write url-encode write crlf
crlf
] keep write ;
: http-post ( content-type content url -- code headers string ) : http-post ( content-type content url -- response string )
#! Make a POST request. The content is URL encoded for you. #! The content is URL encoded for you.
parse-url over parse-host <inet> <client> [ -rot url-encode <post-request> http-request contents ;
post-request flush read-response stdio get contents
] with-stream ;

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 IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@ -16,3 +17,113 @@ IN: http.tests
[ "%20%21%20" ] [ " ! " url-encode ] unit-test [ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] 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. ! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs USING: hashtables io io.streams.string kernel math namespaces
sequences strings splitting ascii io.encodings.utf8 assocs.lib math.parser assocs sequences strings splitting ascii
namespaces unicode.case ; io.encodings.utf8 namespaces unicode.case combinators
vectors sorting new-slots accessors calendar calendar.format
quotations arrays ;
IN: http IN: http
: header-line ( line -- ) : http-port 80 ; inline
": " 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 ;
: url-quotable? ( ch -- ? ) : url-quotable? ( ch -- ? )
#! In a URL, can this character be used without #! In a URL, can this character be used without
@ -23,7 +17,7 @@ IN: http
over digit? or over digit? or
swap "/_-." member? or ; foldable swap "/_-." member? or ; foldable
: push-utf8 ( string -- ) : push-utf8 ( ch -- )
1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str ) : url-encode ( str -- str )
@ -58,17 +52,375 @@ IN: http
: url-decode ( str -- str ) : url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make decode-utf8 ; [ 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 [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
"&" join ; "&" 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 % f swap
dup assoc-empty? [
2drop ";" split [
] [ [ blank? ] trim "=" split1 swap >lower {
CHAR: ? rot member? "&" "?" ? % { "expires" [ >>expires ] }
hash>query % { "domain" [ >>domain ] }
] if { "path" [ >>path ] }
] "" make ; { "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" } { "pdf" "application/pdf" }
{ "factor" "text/plain" } { "factor" "text/plain" }
{ "cgi" "application/x-cgi-script" }
{ "fhtml" "application/x-factor-server-page" } { "fhtml" "application/x-factor-server-page" }
} "mime-types" set-global } "mime-types" set-global

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

@ -0,0 +1,37 @@
IN: http.server.actions.tests
USING: http.server.actions tools.test math math.parser
multiline namespaces http io.streams.string http.server
sequences ;
[ + ]
{ { "a" [ string>number ] } { "b" [ string>number ] } }
"GET" <action> "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
[ "X" <repetition> concat append ]
{ { +path+ [ ] } { "xxx" [ string>number ] } }
"POST" <action> "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

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

@ -0,0 +1,30 @@
! 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 hashtables namespaces ;
IN: http.server.actions
SYMBOL: +path+
TUPLE: action quot params method ;
C: <action> action
: extract-params ( request path -- assoc )
>r dup method>> {
{ "GET" [ query>> ] }
{ "POST" [ post-data>> query>assoc ] }
} case r> +path+ associate union ;
: push-params ( assoc action -- ... )
params>> [ first2 >r swap at r> call ] with each ;
M: action call-responder ( request path action -- response )
pick request set
pick method>> over method>> = [
>r extract-params r>
[ push-params ] keep
quot>> call
] [
3drop <400>
] if ;

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 ;

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

@ -0,0 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: db http.server kernel new-slots accessors
continuations namespaces ;
IN: http.server.db
TUPLE: db-persistence responder db params ;
C: <db-persistence> db-persistence
M: db-persistence call-responder
dup db>> over params>> make-db dup db-open [
db set responder>> call-responder
] with-disposal ;

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 USING: http.server tools.test kernel namespaces accessors
http.server namespaces io tools.test strings io.server new-slots io http math sequences assocs ;
logging ;
IN: http.server.tests 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" ] M: mock-responder call-responder
[ "http://www.jedit.org/index.html" url>path ] unit-test 2nip
path>> on
"text/plain" <content> ;
[ "foo/bar" ] : check-dispatch ( tag path -- ? )
[ "http://www.jedit.org/foo/bar" url>path ] unit-test 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
[ "" ] [ "foo" ] [
[ "http://www.jedit.org" url>path ] unit-test "foo" default-host get find-responder path>> nip
] unit-test
[ "foobar" ] [ "bar" ] [
[ "foobar" secure-path ] unit-test "bar" default-host get find-responder path>> nip
] unit-test
[ f ] [ t ] [ "foo" "foo" check-dispatch ] unit-test
[ "foobar/../baz" secure-path ] 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 [ t ] [
[ ] [ f [ "POO" parse-request ] with-logging ] unit-test <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" } } ] [ "/default" ] [ "/default" default-host get find-responder drop ] unit-test
[ "Foo=Bar&Baz=Quux" query>hash ] unit-test ] with-scope
[ H{ { "Baz" " " } } ]
[ "Baz=%20" query>hash ] unit-test
[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test

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

@ -1,65 +1,170 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting USING: assocs kernel namespaces io io.timeouts strings splitting
threads http http.server.responders sequences prettyprint threads http sequences prettyprint io.server logging calendar
io.server logging calendar ; new-slots html.elements accessors math.parser combinators.lib
vocabs.loader debugger html continuations random combinators ;
IN: http.server IN: http.server
: (url>path) ( uri -- path ) GENERIC: call-responder ( request path responder -- response )
url-decode "http://" ?head [
"/" split1 dup "" ? nip
] when ;
: url>path ( uri -- path ) TUPLE: trivial-responder response ;
"?" split1 dup [
>r (url>path) "?" r> 3append
] [
drop (url>path)
] if ;
: secure-path ( path -- path ) C: <trivial-responder> trivial-responder
".." over subseq? [ drop f ] when ;
: request-method ( cmd -- method ) M: trivial-responder call-responder nip response>> call ;
H{
{ "GET" "get" }
{ "POST" "post" }
{ "HEAD" "head" }
} at "bad" or ;
: (handle-request) ( arg cmd -- method path host ) : trivial-response-body ( code message -- )
request-method dup "method" set swap <html>
prepare-url prepare-header host ; <body>
<h1> swap number>string write bl write </h1>
</body>
</html> ;
: handle-request ( arg cmd -- ) : <trivial-response> ( code message -- response )
[ (handle-request) serve-responder ] with-scope ; <response>
2over [ trivial-response-body ] 2curry >>body
"text/html" set-content-type
swap >>message
swap >>code ;
: parse-request ( request -- ) : <400> ( -- response )
" " split1 dup [ 400 "Bad request" <trivial-response> ;
" HTTP" split1 drop url>path secure-path dup [
swap handle-request : <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 default>> [
] if call-responder
] [
3drop f
] if*
] if*
] [ ] [
2drop bad-request 2drop redirect-with-/
] if ; ] 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 -- request )
[
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 ;
: handle-client ( -- )
default-timeout
development-mode get-global
[ global [ refresh-all ] bind ] when
read-request
dup log-request
do-request do-response ;
: httpd ( port -- ) : httpd ( port -- )
internet-server "http.server" [ internet-server "http.server"
1 minutes stdio get set-timeout [ handle-client ] with-server ;
readln [ parse-request ] when*
] with-server ;
: httpd-main ( -- ) 8888 httpd ; : httpd-main ( -- ) 8888 httpd ;
MAIN: httpd-main MAIN: httpd-main
! Load default webapps : generate-key ( assoc -- str )
USE: webapps.file 4 big-random >hex dup pick key?
USE: webapps.callback [ drop generate-key ] [ nip ] if ;
USE: webapps.continuation
USE: webapps.cgi

1
extra/http/server/sessions/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

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

@ -0,0 +1,34 @@
IN: http.server.sessions.tests
USING: tools.test http.server.sessions math namespaces
kernel accessors ;
: with-session \ session swap with-variable ; inline
"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
[ ] [
f <url-sessions>
[ 0 "x" sset ] >>init
"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

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

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

13
extra/http/server/templating/templating.factor
View File

@ -4,7 +4,8 @@
USING: continuations sequences kernel parser namespaces io USING: continuations sequences kernel parser namespaces io
io.files io.streams.lines io.streams.string html html.elements io.files io.streams.lines io.streams.string html html.elements
source-files debugger combinators math quotations generic 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
@ -93,3 +94,13 @@ DEFER: <% delimiter
: template-convert ( infile outfile -- ) : template-convert ( infile outfile -- )
[ run-template-file ] with-file-writer ; [ 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 ;

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

@ -35,33 +35,43 @@ HELP: +environment-mode+
HELP: +stdin+ HELP: +stdin+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $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" } { { $link +closed+ } " - standard input is closed" }
{ "a path name - standard input is read from the given file, which must exist" } { "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+ HELP: +stdout+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $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" } { { $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 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+ HELP: +stderr+
{ $description "Launch descriptor key. Must equal one of the following:" { $description "Launch descriptor key. Must equal one of the following:"
{ $list { $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" } { { $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 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+ HELP: +closed+
{ $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; { $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+ 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." { $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 $nl

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. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend io.windows.launcher io.windows.nt.pipes io.backend
combinators ; combinators shuffle ;
IN: io.windows.nt.launcher 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 ! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: (redirect) ( path access-mode create-mode -- handle ) : redirect-default ( default obj access-mode create-mode -- handle )
>r >r 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 normalize-pathname
r> ! access-mode r> ! access-mode
share-mode share-mode
@ -22,47 +42,59 @@ IN: io.windows.nt.launcher
f ! template file f ! template file
CreateFile dup invalid-handle? dup close-later ; 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 ? -- ) : set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ; >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 -- ) : add-pipe-dtors ( pipe -- )
dup dup
pipe-in close-later 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 ) : open-file ( path access-mode create-mode flags -- handle )
[ [
>r >r >r normalize-pathname r> >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 invalid-handle? dup close-later
dup add-completion dup add-completion
] with-destructors ; ] with-destructors ;

14
extra/locals/locals.factor
View File

@ -279,7 +279,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
! are unified ! are unified
: create-method ( class generic -- method ) : create-method ( class generic -- method )
2dup method dup 2dup method dup
[ 2nip method-word ] [ 2nip ]
[ drop 2dup [ ] -rot define-method create-method ] if ; [ drop 2dup [ ] -rot define-method create-method ] if ;
: CREATE-METHOD ( -- class generic body ) : CREATE-METHOD ( -- class generic body )
@ -367,16 +367,16 @@ M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition M: lambda-method definition
"lambda" word-prop lambda-body ; "lambda" word-prop lambda-body ;
: method-stack-effect : method-stack-effect ( method -- effect )
dup "lambda" word-prop lambda-vars 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> ; <effect> ;
M: lambda-method synopsis* M: lambda-method synopsis*
dup definer. dup dup dup definer.
dup "method" word-prop dup "method-specializer" word-prop pprint*
method-specializer pprint* "method-generic" word-prop pprint*
method-generic pprint*
method-stack-effect effect>string comment. ; method-stack-effect effect>string comment. ;
PRIVATE> 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 }" } } } { $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." } ; { $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." "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 $nl
"Required configuration parameters:" "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.levels" }
{ $subsection "logging.messages" } { $subsection "logging.messages" }
{ $subsection "logging.rotation" } { $subsection "logging.rotation" }
{ $subsection "logging.parser" } { $vocab-subsection "Log file parser" "logging.parser" }
{ $subsection "logging.analysis" } { $vocab-subsection "Log analysis" "logging.analysis" }
{ $subsection "logging.insomniac" } { $vocab-subsection "Automated log analysis" "logging.insomniac" }
{ $subsection "logging.server" } ; { $subsection "logging.server" } ;
ABOUT: "logging" ABOUT: "logging"

2
extra/tools/crossref/crossref-tests.factor
View File

@ -8,5 +8,5 @@ M: integer foo + ;
"resource:extra/tools/crossref/test/foo.factor" run-file "resource:extra/tools/crossref/test/foo.factor" run-file
[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test [ t ] [ integer \ foo method \ + usage member? ] unit-test
[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test [ t ] [ \ foo usage [ pathname? ] contains? ] unit-test

3
extra/tools/deploy/shaker/strip-cocoa.factor
View File

@ -1,5 +1,6 @@
USING: cocoa cocoa.messages cocoa.application cocoa.nibs USING: cocoa cocoa.messages cocoa.application cocoa.nibs
assocs namespaces kernel words compiler sequences ui.cocoa ; assocs namespaces kernel words compiler.units sequences
ui.cocoa ;
"stop-after-last-window?" get "stop-after-last-window?" get
global [ global [

5
extra/tools/profiler/profiler.factor
View File

@ -29,9 +29,8 @@ M: string (profile.)
dup <vocab-profile> write-object ; dup <vocab-profile> write-object ;
M: method-body (profile.) M: method-body (profile.)
"method" word-prop dup synopsis swap "method-generic" word-prop
dup method-specializer over method-generic 2array synopsis <usage-profile> write-object ;
swap method-generic <usage-profile> write-object ;
: counter. ( obj n -- ) : counter. ( obj n -- )
[ [

1
extra/webapps/cgi/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

75
extra/webapps/cgi/cgi.factor
View File

@ -1,75 +0,0 @@
! 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.responders webapps.file
sequences strings math.parser unicode.case ;
IN: webapps.cgi
SYMBOL: cgi-root
: post? "method" get "post" = ;
: cgi-variables ( script-path -- assoc )
#! This needs some work.
[
"CGI/1.0" "GATEWAY_INTERFACE" set
"HTTP/1.0" "SERVER_PROTOCOL" set
"Factor" "SERVER_SOFTWARE" set
dup "PATH_TRANSLATED" set
"SCRIPT_FILENAME" set
"request" get "SCRIPT_NAME" set
host "SERVER_NAME" set
"" "SERVER_PORT" set
"" "PATH_INFO" set
"" "REMOTE_HOST" set
"" "REMOTE_ADDR" set
"" "AUTH_TYPE" set
"" "REMOTE_USER" set
"" "REMOTE_IDENT" set
"method" get >upper "REQUEST_METHOD" set
"raw-query" get "QUERY_STRING" set
"cookie" header-param "HTTP_COOKIE" set
"user-agent" header-param "HTTP_USER_AGENT" set
"accept" header-param "HTTP_ACCEPT" set
post? [
"content-type" header-param "CONTENT_TYPE" set
"raw-response" get length number>string "CONTENT_LENGTH" set
] when
] H{ } make-assoc ;
: cgi-descriptor ( name -- desc )
[
cgi-root get swap path+ dup 1array +arguments+ set
cgi-variables +environment+ set
] H{ } make-assoc ;
: (do-cgi) ( name -- )
"200 CGI output follows" response
stdio get swap cgi-descriptor <process-stream> [
post? [
"raw-response" get write flush
] when
stdio get swap (stream-copy)
] with-stream ;
: serve-regular-file ( -- )
cgi-root get doc-root [ file-responder ] with-variable ;
: do-cgi ( name -- )
{
{ [ dup ".cgi" tail? not ] [ drop serve-regular-file ] }
{ [ dup empty? ] [ "403 forbidden" httpd-error ] }
{ [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] }
{ [ ".." over subseq? ] [ "403 forbidden" httpd-error ] }
{ [ t ] [ (do-cgi) ] }
} cond ;
global [
"cgi" [ "argument" get do-cgi ] add-simple-responder
] bind

1
extra/webapps/file/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

136
extra/webapps/file/file.factor
View File

@ -1,136 +0,0 @@
! 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.server.responders http.server.templating namespaces parser
sequences strings assocs hashtables debugger http.mime sorting
html.elements logging calendar.format ;
IN: webapps.file
SYMBOL: doc-root
: serving-path ( filename -- filename )
"" or doc-root get swap path+ ;
: unix-time>timestamp ( n -- timestamp )
>r unix-1970 r> seconds time+ ;
: file-http-date ( filename -- string )
file-modified unix-time>timestamp timestamp>http-string ;
: file-response ( filename mime-type -- )
"200 OK" response
[
"Content-Type" set
dup file-length number>string "Content-Length" set
file-http-date "Last-Modified" set
now timestamp>http-string "Date" set
] H{ } make-assoc print-header ;
: last-modified-matches? ( filename -- bool )
file-http-date dup [
"if-modified-since" header-param =
] when ;
: not-modified-response ( -- )
"304 Not Modified" response
now timestamp>http-string "Date" associate print-header ;
! You can override how files are served in a custom responder
SYMBOL: serve-file-hook
[
dupd
file-response
<file-reader> stdio get stream-copy
] serve-file-hook set-global
: serve-static ( filename mime-type -- )
over last-modified-matches? [
2drop not-modified-response
] [
"method" get "head" = [
file-response
] [
serve-file-hook get call
] if
] if ;
SYMBOL: page
: run-page ( filename -- )
dup
[ [ dup page set run-template-file ] with-scope ] try
drop ;
\ run-page DEBUG add-input-logging
: include-page ( filename -- )
serving-path run-page ;
: serve-fhtml ( filename -- )
serving-html
"method" get "head" = [ drop ] [ run-page ] if ;
: serve-file ( filename -- )
dup mime-type dup "application/x-factor-server-page" =
[ drop serve-fhtml ] [ serve-static ] if ;
\ serve-file NOTICE add-input-logging
: file. ( name dirp -- )
[ "/" append ] when
dup <a =href a> write </a> ;
: directory. ( path request -- )
dup [
<h1> write </h1>
<ul>
directory sort-keys
[ <li> file. </li> ] assoc-each
</ul>
] simple-html-document ;
: list-directory ( directory -- )
serving-html
"method" get "head" = [
drop
] [
"request" get directory.
] if ;
: find-index ( filename -- path )
{ "index.html" "index.fhtml" }
[ dupd path+ exists? ] find nip
dup [ path+ ] [ nip ] if ;
: serve-directory ( filename -- )
dup "/" tail? [
dup find-index
[ serve-file ] [ list-directory ] ?if
] [
drop directory-no/
] if ;
: serve-object ( filename -- )
serving-path dup exists? [
dup directory? [ serve-directory ] [ serve-file ] if
] [
drop "404 not found" httpd-error
] if ;
: file-responder ( -- )
doc-root get [
"argument" get serve-object
] [
"404 doc-root not set" httpd-error
] if ;
global [
! Serves files from a directory stored in the doc-root
! variable. You can set the variable in the global
! namespace, or inside the responder.
"file" [ file-responder ] add-simple-responder
! The root directory is served by...
"file" set-default-responder
] bind

1
extra/webapps/source/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

35
extra/webapps/source/source.factor
View File

@ -1,35 +0,0 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files namespaces webapps.file http.server.responders
xmode.code2html kernel html sequences ;
IN: webapps.source
! This responder is a potential security problem. Make sure you
! don't have sensitive files stored under vm/, core/, extra/
! or misc/.
: check-source-path ( path -- ? )
{ "vm/" "core/" "extra/" "misc/" }
[ head? ] with contains? ;
: source-responder ( path mime-type -- )
drop
serving-html
[
dup file-name swap <file-reader> htmlize-stream
] with-html-stream ;
global [
! Serve up our own source code
"source" [
"argument" get check-source-path [
[
"" resource-path doc-root set
[ source-responder ] serve-file-hook set
file-responder
] with-scope
] [
"403 forbidden" httpd-error
] if
] add-simple-responder
] bind

15
extra/xmode/code2html/responder/responder.factor Executable file
View File

@ -0,0 +1,15 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files namespaces http.server http.server.static http
xmode.code2html kernel html sequences accessors ;
IN: xmode.code2html.responder
: <sources> ( root -- responder )
[
drop
"text/html" <content>
over file-http-date "last-modified" set-header
swap [
dup file-name swap <file-reader> htmlize-stream
] curry >>body
] <file-responder> ;