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

basis/furnace/auth/auth.factor

@@ -3,7 +3,7 @@
 USING: accessors assocs namespaces kernel sequences sets
 destructors combinators fry logging
 io.encodings.utf8 io.encodings.string io.binary random
-checksums checksums.sha2
+checksums checksums.sha2 urls
 html.forms
 http.server
 http.server.filters
@@ -60,6 +60,10 @@ TUPLE: realm < dispatcher name users checksum secure ;
 
 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: logged-in-username ( realm -- username )

basis/furnace/auth/features/registration/registration.factor

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

basis/furnace/auth/login/login.factor

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

basis/furnace/furnace-tests.factor

@@ -1,7 +1,7 @@
 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
-io.streams.string ;
+io.streams.string urls ;
 TUPLE: funny-dispatcher < 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;'/>" ]
 [ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
 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

basis/furnace/furnace.factor

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

basis/furnace/redirection/redirection.factor

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

basis/furnace/referrer/referrer.factor

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

basis/http/server/remapping/remapping.factor

@@ -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 ;

basis/http/server/server.factor

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

basis/io/servers/connection/connection.factor

@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations destructors kernel math math.parser
 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
 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
 combinators.short-circuit ;
 IN: io.servers.connection
@@ -56,11 +56,17 @@ GENERIC: handle-client* ( threaded-server -- )
     [ secure>> >secure ] [ insecure>> >insecure ] bi
     [ 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 -- )
+    [ accepted-connection ]
     [ [ remote-address set ] [ local-address set ] bi* ]
-    [ 2array accepted-connection ]
     2bi ;
 
 M: threaded-server handle-client* handler>> call ;

basis/io/sockets/secure/secure.factor

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

basis/io/sockets/sockets.factor

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

basis/urls/urls.factor

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