Check port number

extra/http/http-tests.factor

@@ -7,7 +7,7 @@ IN: http.tests
 : lf>crlf "\n" split "\r\n" join ;
 
 STRING: read-request-test-1
-POST http://foo/bar HTTP/1.1
+POST /bar HTTP/1.1
 Some-Header: 1
 Some-Header: 2
 Content-Length: 4
@@ -18,7 +18,7 @@ blah
 
 [
     TUPLE{ request
-        url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
+        url: TUPLE{ url path: "/bar" }
         method: "POST"
         version: "1.1"
         header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
@@ -49,14 +49,14 @@ read-request-test-1' 1array [
 ] unit-test
 
 STRING: read-request-test-2
-HEAD  http://foo/bar   HTTP/1.1
+HEAD  /bar   HTTP/1.1
 Host: www.sex.com
 
 ;
 
 [
     TUPLE{ request
-        url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
+        url: TUPLE{ url host: "www.sex.com" path: "/bar" }
         method: "HEAD"
         version: "1.1"
         header: H{ { "host" "www.sex.com" } }

extra/http/http.factor

@@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger
 strings vectors hashtables quotations arrays byte-arrays
 math.parser calendar calendar.format present
 
-io io.server io.sockets.secure
+io io.encodings.iana io.encodings.binary io.encodings.8-bit
-io.encodings.iana io.encodings.binary io.encodings.8-bit
 
 unicode.case unicode.categories qualified
 
@@ -142,7 +141,6 @@ cookies ;
     request new
         "1.1" >>version
         <url>
-            "http" >>protocol
             H{ } clone >>query
         >>url
         H{ } clone >>header
@@ -202,7 +200,6 @@ TUPLE: post-data raw content content-type ;
 : extract-host ( request -- request )
     [ ] [ url>> ] [ "host" header parse-host ] tri
     [ >>host ] [ >>port ] bi*
-    ensure-port
     drop ;
 
 : extract-cookies ( request -- request )
@@ -214,9 +211,6 @@ TUPLE: post-data raw content content-type ;
 : parse-content-type ( content-type -- type encoding )
     ";" split1 parse-content-type-attributes "charset" swap at ;
 
-: detect-protocol ( request -- request )
-    dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
-
 : read-request ( -- request )
     <request>
     read-method
@@ -224,7 +218,6 @@ TUPLE: post-data raw content content-type ;
     read-request-version
     read-request-header
     read-post-data
-    detect-protocol
     extract-host
     extract-cookies ;
 

extra/http/server/server.factor

@@ -2,16 +2,18 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences arrays namespaces splitting
 vocabs.loader destructors assocs debugger continuations
-tools.vocabs math
+combinators tools.vocabs math
 io
 io.server
+io.sockets
+io.sockets.secure
 io.encodings
 io.encodings.utf8
 io.encodings.ascii
 io.encodings.binary
 io.streams.limited
 io.timeouts
-fry logging calendar
+fry logging calendar urls
 http
 http.server.responses
 html.elements
@@ -88,12 +90,26 @@ LOG: httpd-hit NOTICE
 : dispatch-request ( request -- response )
     url>> path>> split-path main-responder get call-responder ;
 
+: prepare-request ( request -- request )
+    [
+        local-address get
+        [ secure? "https" "http" ? >>protocol ]
+        [ port>> '[ , or ] change-port ]
+        bi
+    ] change-url ;
+
+: valid-request? ( request -- ? )
+    url>> port>> local-address get port>> = ;
+
 : do-request ( request -- response )
     '[
         ,
+        {
             [ init-request ]
+            [ prepare-request ]
             [ log-request ]
-        [ dispatch-request ] tri
+            [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
+        } cleave
     ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
 
 : ?refresh-all ( -- )

extra/io/server/server.factor

@@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files
 io.streams.duplex logging continuations destructors kernel math
 math.parser namespaces parser sequences strings prettyprint
 debugger quotations calendar threads concurrency.combinators
-assocs fry ;
+assocs fry accessors ;
 IN: io.server
 
 SYMBOL: servers
@@ -15,9 +15,10 @@ SYMBOL: remote-address
 
 LOG: accepted-connection NOTICE
 
-: with-connection ( client remote quot -- )
+: with-connection ( client remote local quot -- )
     '[
         , [ remote-address set ] [ accepted-connection ] bi
+        , local-address set
         @
     ] with-stream ; inline
 
@@ -25,7 +26,8 @@ LOG: accepted-connection NOTICE
 
 : accept-loop ( server quot -- )
     [
-        >r accept r> '[ , , , with-connection ] "Client" spawn drop
+        [ [ accept ] [ addr>> ] bi ] dip
+        '[ , , , , with-connection ] "Client" spawn drop
     ] 2keep accept-loop ; inline
 
 : server-loop ( addrspec encoding quot -- )
@@ -59,7 +61,7 @@ LOG: received-datagram NOTICE
 
 : datagram-loop ( quot datagram -- )
     [
-        [ receive dup received-datagram >r swap call r> ] keep
+        [ receive dup received-datagram [ swap call ] dip ] keep
         pick [ send ] [ 3drop ] if
     ] 2keep datagram-loop ; inline