More referrer fixes

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

@@ -89,17 +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 ensure-port [ remap-port ] change-port ;
+    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/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/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' )