Merge branch 'master' of git://factorcode.org/git/factor
commit
35564e4377
|
@ -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 )
|
||||||
|
|
|
@ -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> ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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='&&&'/>" ]
|
[ "<input type='hidden' name='foo' value='&&&'/>" ]
|
||||||
[ [ "&&&" "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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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> ;
|
||||||
|
|
|
@ -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> ;
|
||||||
|
|
|
@ -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 ;
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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' )
|
||||||
|
|
Loading…
Reference in New Issue