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

db4
Doug Coleman 2008-09-22 20:05:37 -05:00
commit 35564e4377
13 changed files with 73 additions and 32 deletions

View File

@ -3,7 +3,7 @@
USING: accessors assocs namespaces kernel sequences sets USING: accessors assocs namespaces kernel sequences sets
destructors combinators fry logging destructors combinators fry logging
io.encodings.utf8 io.encodings.string io.binary random io.encodings.utf8 io.encodings.string io.binary random
checksums checksums.sha2 checksums checksums.sha2 urls
html.forms html.forms
http.server http.server
http.server.filters http.server.filters
@ -60,6 +60,10 @@ TUPLE: realm < dispatcher name users checksum secure ;
GENERIC: login-required* ( description capabilities realm -- response ) GENERIC: login-required* ( description capabilities realm -- response )
GENERIC: user-registered ( user realm -- response )
M: object user-registered 2drop URL" $realm" <redirect> ;
GENERIC: init-realm ( realm -- ) GENERIC: init-realm ( realm -- )
GENERIC: logged-in-username ( realm -- username ) GENERIC: logged-in-username ( realm -- username )

View File

@ -33,8 +33,7 @@ IN: furnace.auth.features.registration
users new-user [ user-exists ] unless* users new-user [ user-exists ] unless*
realm get init-user-profile realm get init-user-profile
realm get user-registered
URL" $realm" <redirect>
] >>submit ] >>submit
<auth-boilerplate> <auth-boilerplate>
<secure-realm-only> ; <secure-realm-only> ;

View File

@ -104,6 +104,9 @@ M: login-realm login-required* ( description capabilities login -- response )
URL" $realm/login" <continue-conversation> URL" $realm/login" <continue-conversation>
] if ; ] if ;
M: login-realm user-registered ( user realm -- )
drop successful-login ;
: <login-realm> ( responder name -- auth ) : <login-realm> ( responder name -- auth )
login-realm new-realm login-realm new-realm
<login-action> "login" add-responder <login-action> "login" add-responder

View File

@ -1,7 +1,7 @@
IN: furnace.tests IN: furnace.tests
USING: http.server.dispatchers http.server.responses USING: http http.server.dispatchers http.server.responses
http.server furnace tools.test kernel namespaces accessors http.server furnace tools.test kernel namespaces accessors
io.streams.string ; io.streams.string urls ;
TUPLE: funny-dispatcher < dispatcher ; TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ; : <funny-dispatcher> funny-dispatcher new-dispatcher ;
@ -33,3 +33,9 @@ M: base-path-check-responder call-responder*
[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;'/>" ] [ "<input type='hidden' name='foo' value='&amp;&amp;&amp;'/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] [ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test unit-test
[ f ] [ <request> request [ referrer ] with-variable ] unit-test
[ t ] [ URL" http://foo" dup url [ same-host? ] with-variable ] unit-test
[ f ] [ f URL" http://foo" url [ same-host? ] with-variable ] unit-test

View File

@ -4,7 +4,7 @@ USING: namespaces make assocs sequences kernel classes splitting
vocabs.loader accessors strings combinators arrays vocabs.loader accessors strings combinators arrays
continuations present fry continuations present fry
urls html.elements urls html.elements
http http.server http.server.redirection ; http http.server http.server.redirection http.server.remapping ;
IN: furnace IN: furnace
: nested-responders ( -- seq ) : nested-responders ( -- seq )
@ -89,16 +89,19 @@ M: object modify-form drop ;
] } ] }
} case ; } case ;
: referrer ( -- referrer ) : referrer ( -- referrer/f )
#! Typo is intentional, its in the HTTP spec! #! Typo is intentional, its in the HTTP spec!
"referer" request get header>> at >url ; "referer" request get header>> at
dup [ >url ensure-port [ remap-port ] change-port ] when ;
: user-agent ( -- user-agent ) : user-agent ( -- user-agent )
"user-agent" request get header>> at "" or ; "user-agent" request get header>> at "" or ;
: same-host? ( url -- ? ) : same-host? ( url -- ? )
url get dup [
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ; url get
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ =
] when ;
: cookie-client-state ( key request -- value/f ) : cookie-client-state ( key request -- value/f )
swap get-cookie dup [ value>> ] when ; swap get-cookie dup [ value>> ] when ;

View File

@ -1,9 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators namespaces fry USING: kernel accessors combinators namespaces fry urls http
io.servers.connection urls http http.server http.server http.server.redirection http.server.responses
http.server.redirection http.server.responses http.server.remapping http.server.filters furnace ;
http.server.filters furnace ;
IN: furnace.redirection IN: furnace.redirection
: <redirect> ( url -- response ) : <redirect> ( url -- response )
@ -16,7 +15,7 @@ IN: furnace.redirection
: >secure-url ( url -- url' ) : >secure-url ( url -- url' )
clone clone
"https" >>protocol "https" >>protocol
secure-port >>port ; secure-http-port >>port ;
: <secure-redirect> ( url -- response ) : <secure-redirect> ( url -- response )
>secure-url <redirect> ; >secure-url <redirect> ;

View File

@ -14,4 +14,4 @@ M: referrer-check call-responder*
[ 2drop 403 "Bad referrer" <trivial-response> ] if ; [ 2drop 403 "Bad referrer" <trivial-response> ] if ;
: <check-form-submissions> ( responder -- responder' ) : <check-form-submissions> ( responder -- responder' )
[ same-host? post-request? not or ] <referrer-check> ; [ post-request? [ same-host? ] [ drop f ] if ] <referrer-check> ;

View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel io.servers.connection ;
IN: http.server.remapping
SYMBOL: port-remapping
: remap-port ( n -- n' )
[ port-remapping get at ] keep or ;
: secure-http-port ( -- n )
secure-port remap-port ;

View File

@ -18,6 +18,7 @@ fry logging logging.insomniac calendar urls
http http
http.parsers http.parsers
http.server.responses http.server.responses
http.server.remapping
html.templates html.templates
html.elements html.elements
html.streams ; html.streams ;
@ -198,19 +199,20 @@ LOG: httpd-header NOTICE
[ [
local-address get local-address get
[ secure? "https" "http" ? >>protocol ] [ secure? "https" "http" ? >>protocol ]
[ port>> '[ _ or ] change-port ] [ port>> remap-port '[ _ or ] change-port ]
bi bi
] change-url drop ; ] change-url drop ;
: valid-request? ( request -- ? ) : valid-request? ( request -- ? )
url>> port>> local-address get port>> = ; url>> port>> remap-port
local-address get port>> remap-port = ;
: do-request ( request -- response ) : do-request ( request -- response )
'[ '[
_ _
{ {
[ init-request ]
[ prepare-request ] [ prepare-request ]
[ init-request ]
[ log-request ] [ log-request ]
[ dup valid-request? [ dispatch-request ] [ drop <400> ] if ] [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
} cleave } cleave

View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint debugger namespaces parser sequences strings prettyprint debugger
quotations combinators logging calendar assocs quotations combinators logging calendar assocs present
fry accessors arrays io io.sockets io.encodings.ascii fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads concurrency.combinators io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags concurrency.semaphores concurrency.flags
combinators.short-circuit ; combinators.short-circuit ;
IN: io.servers.connection IN: io.servers.connection
@ -56,11 +56,17 @@ GENERIC: handle-client* ( threaded-server -- )
[ secure>> >secure ] [ insecure>> >insecure ] bi [ secure>> >secure ] [ insecure>> >insecure ] bi
[ resolve-host ] bi@ append ; [ resolve-host ] bi@ append ;
LOG: accepted-connection NOTICE : accepted-connection ( remote local -- )
[
[ "remote: " % present % ", " % ]
[ "local: " % present % ]
bi*
] "" make
\ accepted-connection NOTICE log-message ;
: log-connection ( remote local -- ) : log-connection ( remote local -- )
[ accepted-connection ]
[ [ remote-address set ] [ local-address set ] bi* ] [ [ remote-address set ] [ local-address set ] bi* ]
[ 2array accepted-connection ]
2bi ; 2bi ;
M: threaded-server handle-client* handler>> call ; M: threaded-server handle-client* handler>> call ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel symbols namespaces continuations USING: accessors kernel symbols namespaces continuations
destructors io.sockets sequences summary calendar delegate destructors io.sockets sequences summary calendar delegate
system vocabs.loader combinators ; system vocabs.loader combinators present ;
IN: io.sockets.secure IN: io.sockets.secure
SYMBOL: secure-socket-timeout SYMBOL: secure-socket-timeout
@ -43,6 +43,8 @@ TUPLE: secure addrspec ;
C: <secure> secure C: <secure> secure
M: secure present addrspec>> present " (secure)" append ;
CONSULT: inet secure addrspec>> ; CONSULT: inet secure addrspec>> ;
M: secure resolve-host ( secure -- seq ) M: secure resolve-host ( secure -- seq )

View File

@ -5,8 +5,8 @@ USING: generic kernel io.backend namespaces continuations
sequences arrays io.encodings io.ports io.streams.duplex sequences arrays io.encodings io.ports io.streams.duplex
io.encodings.ascii alien.strings io.binary accessors destructors io.encodings.ascii alien.strings io.binary accessors destructors
classes debugger byte-arrays system combinators parser classes debugger byte-arrays system combinators parser
alien.c-types math.parser splitting grouping alien.c-types math.parser splitting grouping math assocs summary
math assocs summary system vocabs.loader combinators ; system vocabs.loader combinators present ;
IN: io.sockets IN: io.sockets
<< { << {
@ -40,7 +40,14 @@ TUPLE: local path ;
: <local> ( path -- addrspec ) : <local> ( path -- addrspec )
normalize-path local boa ; normalize-path local boa ;
TUPLE: inet4 host port ; M: local present path>> "Unix domain socket: " prepend ;
TUPLE: abstract-inet host port ;
M: abstract-inet present
[ host>> ":" ] [ port>> number>string ] bi 3append ;
TUPLE: inet4 < abstract-inet ;
C: <inet4> inet4 C: <inet4> inet4
@ -81,7 +88,7 @@ M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop >r dup sockaddr-in-addr <uint> r> inet-ntop
swap sockaddr-in-port ntohs <inet4> ; swap sockaddr-in-port ntohs <inet4> ;
TUPLE: inet6 host port ; TUPLE: inet6 < abstract-inet ;
C: <inet6> inet6 C: <inet6> inet6
@ -255,7 +262,7 @@ HOOK: addrinfo-error io-backend ( n -- )
GENERIC: resolve-host ( addrspec -- seq ) GENERIC: resolve-host ( addrspec -- seq )
TUPLE: inet host port ; TUPLE: inet < abstract-inet ;
C: <inet> inet C: <inet> inet

View File

@ -212,15 +212,13 @@ PRIVATE>
[ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
secure-protocol? [ <secure> ] when ; secure-protocol? [ <secure> ] when ;
ERROR: no-protocol-found protocol ;
: protocol-port ( protocol -- port ) : protocol-port ( protocol -- port )
{ {
{ "http" [ 80 ] } { "http" [ 80 ] }
{ "https" [ 443 ] } { "https" [ 443 ] }
{ "feed" [ 80 ] } { "feed" [ 80 ] }
{ "ftp" [ 21 ] } { "ftp" [ 21 ] }
[ no-protocol-found ] [ drop f ]
} case ; } case ;
: ensure-port ( url -- url' ) : ensure-port ( url -- url' )