httpd fixes and socket timeout

CHANGES.txt

@@ -34,6 +34,8 @@ Note that GENERIC: foo is the same as
 Sequence API refactoring, as described in
 http://www.jroller.com/page/slava/20050518.
 
+HTTP server now supports virtual hosting.
+
 Factor 0.74:
 ------------
 

TODO.FACTOR.txt

@@ -10,7 +10,6 @@
 - investigate if COPYING_GEN needs a fix
 - faster layout
 - add a socket timeout
-- virtual hosts
 - keep alive
 - sleep word
 - redo new compiler backend for PowerPC
@@ -24,7 +23,7 @@
 - index and index* are very slow with lists
 - code walker & exceptions
 - if two tasks write to a unix stream, the buffer can overflow
-- rename prettyprint to pprint
+- rename prettyprint* to pprint, prettyprint to pp
 - reader syntax for arrays, byte arrays, displaced aliens
 - dipping seq-2nmap, seq-2each
 - array sort
@@ -72,7 +71,6 @@
   - merge inc-d's across VOPs that don't touch the stack
 - [ EAX 0 ] --> [ EAX ]
 - intrinsic char-slot set-char-slot integer-slot set-integer-slot
-- optimize the generic word prologue
 - [ [ dup call ] dup call ] infer hangs
 - more accurate types for various words
 - declarations
@@ -80,7 +78,6 @@
   displaced, register and other predicates need to inherit from list
   not cons, and need stronger branch partial eval
 - optimize away arithmetic dispatch
-- dataflow optimizer needs eq not =
 - the invalid recursion form case needs to be fixed, for inlines too
 - #jump-f #jump-f-label
 - re-introduce #target-label => #target optimization

doc/handbook.tex

@@ -1855,7 +1855,7 @@ Class&Mutable&Growable&Lookup&at start&at end&Primary purpose\\
 %\texttt{array}&$\surd$&&$O(1)$&&&Low-level and unsafe\\
 \texttt{list}&&&$O(n)$&$O(1)$&$O(n)$&Functional manipulation\\
 \texttt{vector}&$\surd$&$\surd$&$O(1)$&$O(n)$&$O(1)$&Imperitive aggregation\\
-\texttt{sbuf}&$\surd$&$\surd$&$O(1)$&$O(n)$&$O(1)$&Character accumilation\\
+\texttt{sbuf}&$\surd$&$\surd$&$O(1)$&$O(n)$&$O(1)$&Character accumulation\\
 \texttt{string}&&&$O(1)$&&&Immutable text strings
 \end{tabular}
 

library/bootstrap/boot-stage3.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 USING: alien assembler command-line compiler compiler-backend
-io-internals kernel lists math namespaces parser sequences stdio
-unparser words ;
+compiler-frontend io-internals kernel lists math namespaces
+parser sequences stdio unparser words ;
 
 "Compiling base..." print
 
@@ -37,6 +37,7 @@ compile? [
     \ = compile
     \ unparse compile
     \ scan compile
+    \ optimize compile
     \ (generate) compile
 ] when
 

library/httpd/cont-responder.factor

@@ -307,12 +307,12 @@ SYMBOL: root-continuation
      over "responder" set
      reset-continuation-table 
      permanent register-continuation root-continuation set 
-   ] extend swap "httpd-responders" get set-hash ;
+   ] extend swap responders get set-hash ;
 
 : responder-items ( name -- items )
   #! Return the table of continuation items for a given responder. 
   #! Useful for debugging.
-  "httpd-responders" get hash [ continuation-table ] bind ;
+  responders get hash [ continuation-table ] bind ;
 
 
 : simple-page ( title quot -- )

library/httpd/default-responders.factor

@@ -8,7 +8,7 @@ test-responder ;
 #! Remove all existing responders, and create a blank
 #! responder table.
 global [
-    <namespace> "httpd-responders" set
+    <namespace> responders set
 
     ! Runs all unit tests and dumps result to the client. This uses
     ! a lot of server resources, so disable it on a busy server.
@@ -46,7 +46,5 @@ global [
     ! The root directory is served by...
     "file" set-default-responder
 
-    "httpd-vhosts" nest [
-        <namespace> "default" set
-    ] bind
+    vhosts nest [ <namespace> "default" set ] bind
 ] bind

library/httpd/httpd.factor

@@ -26,10 +26,13 @@ stdio streams strings threads http sequences ;
         [[ "HEAD" "head" ]]
     ] assoc [ "bad" ] unless* ;
 
+: host ( -- string )
+    #! The host the current responder was called from.
+    "Host" "header" get assoc ":" split1 drop ;
+
 : (handle-request) ( arg cmd -- method path host )
     request-method dup "method" set swap
-    prepare-url prepare-header
-    "Host" "header" get assoc ":" split1 drop ;
+    prepare-url prepare-header host ;
 
 : handle-request ( arg cmd -- )
     [ (handle-request) serve-responder ] with-scope ;
@@ -49,6 +52,7 @@ stdio streams strings threads http sequences ;
 : httpd-client ( socket -- )
     [
         dup log-client [
+            1 stdio get set-timeout
             read-line [ parse-request ] when*
         ] with-stream
     ] try ;

library/httpd/responder.factor

@@ -4,6 +4,10 @@ IN: httpd
 USING: hashtables http kernel lists namespaces parser sequences
 stdio streams strings ;
 
+! Variables
+SYMBOL: vhosts
+SYMBOL: responders
+
 : print-header ( alist -- )
     [ unswons write ": " write url-encode print ] each ;
 
@@ -112,15 +116,13 @@ stdio streams strings ;
     ] extend ;
 
 : vhost ( name -- responder )
-    "httpd-vhosts" get hash [ "default" vhost ] unless* ;
+    vhosts get hash [ "default" vhost ] unless* ;
 
 : responder ( name -- responder )
-    "httpd-responders" get hash [
-        "404" "httpd-responders" get hash
-    ] unless* ;
+    responders get hash [ "404" responder ] unless* ;
 
 : set-default-responder ( name -- )
-    responder "default" "httpd-responders" get set-hash ;
+    responder "default" responders get set-hash ;
 
 : responder-argument ( argument -- argument )
     dup empty? [ drop "default-argument" get ] when ;
@@ -163,4 +165,4 @@ stdio streams strings ;
 
 : add-responder ( responder -- )
     #! Add a responder object to the list.
-    "responder" over hash  "httpd-responders" get set-hash ;
+    "responder" over hash  responders get set-hash ;

library/io/c-streams.factor

@@ -52,6 +52,7 @@ TUPLE: client-stream host port ;
 : <client> c-stream-error ;
 : <server> c-stream-error ;
 : accept c-stream-error ;
+: set-timeout c-stream-error ;
 
 : (stream-copy) ( in out -- )
     4096 pick stream-read [

library/tools/debugger.factor

@@ -20,13 +20,6 @@ vectors words ;
     "Object type: " write class word. terpri
     "Expected type: " write builtin-type word. terpri ;
 
-: range-error. ( list -- )
-    "Range check error" print
-    unswons [ "Object: " write . ] when*
-    unswons "Minimum index: " write .
-    unswons "Requested index: " write .
-    car "Maximum index: " write . ;
-
 : float-format-error. ( list -- )
     "Invalid floating point literal format: " write . ;
 
@@ -55,7 +48,6 @@ M: kernel-error error. ( error -- )
         io-error.
         undefined-word-error.
         type-check-error.
-        range-error.
         float-format-error.
         signal-error.
         negative-array-size-error.

library/unix/sockets.factor

@@ -38,7 +38,7 @@ USING: alien generic kernel math unix-internals ;
 : server-sockaddr ( port -- sockaddr )
     init-sockaddr  INADDR_ANY htonl over set-sockaddr-in-addr ;
 
-: sockopt ( fd level opt -- )
+: sockopt ( fd level opt value -- )
     1 <int> "int" c-size setsockopt io-error ;
 
 : server-socket ( port -- fd )
@@ -78,6 +78,9 @@ M: accept-task io-task-events ( task -- events )
 : <socket-stream> ( fd -- stream )
     dup f <fd-stream> ;
 
+: timeout-opt ( fd level opt value -- )
+    "timeval" c-size setsockopt io-error ;
+
 IN: streams
 
 C: client-stream ( fd host port -- stream )
@@ -100,3 +103,10 @@ C: client-stream ( fd host port -- stream )
 : accept ( server -- client )
     #! Wait for a client connection.
     dup wait-to-accept port-handle do-accept <client-stream> ;
+
+: set-timeout ( timeout client -- )
+    swap 0 make-timeval 2dup
+    >r duplex-stream-out port-handle SOL_SOCKET SO_SNDTIMEO r>
+    timeout-opt
+    >r duplex-stream-in port-handle SOL_SOCKET SO_RCVTIMEO r>
+    timeout-opt ;

library/unix/syscalls-freebsd.factor

@@ -17,6 +17,8 @@ IN: unix-internals
 : SOL_SOCKET HEX: ffff ;
 : SO_REUSEADDR HEX: 4 ;
 : SO_OOBINLINE HEX: 100 ;
+: SO_SNDTIMEO HEX: 1005 ;
+: SO_RCVTIMEO HEX: 1006 ;
 
 : INADDR_ANY 0 ;
 

library/unix/syscalls-linux.factor

@@ -15,8 +15,12 @@ IN: unix-internals
 : POLLOUT    HEX: 0004 ;
 
 : SOL_SOCKET 1 ;
+
 : SO_REUSEADDR 2 ;
 : SO_OOBINLINE 10 ;
+: SO_SNDTIMEO HEX: 15 ;
+: SO_RCVTIMEO HEX: 14 ;
+
 : INADDR_ANY 0 ;
 
 : F_SETFL 4 ;    ! set file status flags

library/unix/syscalls-macosx.factor

@@ -17,6 +17,8 @@ IN: unix-internals
 : SOL_SOCKET HEX: ffff ;
 : SO_REUSEADDR HEX: 4 ;
 : SO_OOBINLINE HEX: 100 ;
+: SO_SNDTIMEO HEX: 1005 ;
+: SO_RCVTIMEO HEX: 1006 ;
 
 : INADDR_ANY 0 ;
 

library/unix/syscalls.factor

@@ -97,3 +97,13 @@ END-STRUCT
 
 : ntohs ( n -- n )
     "ushort" "libc" "ntohs" [ "ushort" ] alien-invoke ;
+
+BEGIN-STRUCT: timeval
+    FIELD: long sec
+    FIELD: long usec
+END-STRUCT
+
+: make-timeval ( sec usec -- timeval )
+    <timeval>
+    [ set-timeval-usec ] keep
+    [ set-timeval-sec ] keep ;

native/bignum.c

@@ -2,30 +2,12 @@
 
 CELL to_cell(CELL x)
 {
-	F_FIXNUM fixnum;
-	F_ARRAY* bignum;
-
 	switch(type_of(x))
 	{
 	case FIXNUM_TYPE:
-		fixnum = untag_fixnum_fast(x);
-		if(fixnum < 0)
-		{
-			range_error(F,0,tag_fixnum(fixnum),FIXNUM_MAX);
-			return -1;
-		}
-		else
-			return (CELL)fixnum;
-		break;
+		return untag_fixnum_fast(x);
 	case BIGNUM_TYPE:
-		bignum = to_bignum(x);
-		if(BIGNUM_NEGATIVE_P(bignum))
-		{
-			range_error(F,0,tag_bignum(bignum),FIXNUM_MAX);
-			return -1;
-		}
-		else
-			return s48_bignum_to_long(untag_bignum_fast(x));
+		return s48_bignum_to_long(untag_bignum_fast(x));
 	default:
 		type_error(BIGNUM_TYPE,x);
 		return 0;

native/error.c

@@ -80,11 +80,3 @@ void type_error(CELL type, CELL tagged)
 	CELL c = cons(tag_fixnum(type),cons(tagged,F));
 	general_error(ERROR_TYPE,c);
 }
-
-/* index must be tagged */
-void range_error(CELL tagged, CELL min, CELL index, CELL max)
-{
-	CELL c = cons(tagged,cons(tag_cell(min),
-		cons(index,cons(tag_cell(max),F))));
-	general_error(ERROR_RANGE,c);
-}

native/error.h

@@ -2,13 +2,12 @@
 #define ERROR_IO (1<<3)
 #define ERROR_UNDEFINED_WORD (2<<3)
 #define ERROR_TYPE (3<<3)
-#define ERROR_RANGE (4<<3)
-#define ERROR_FLOAT_FORMAT (5<<3)
-#define ERROR_SIGNAL (6<<3)
-#define ERROR_NEGATIVE_ARRAY_SIZE (7<<3)
-#define ERROR_C_STRING (8<<3)
-#define ERROR_FFI (9<<3)
-#define ERROR_HEAP_SCAN (10<<3)
+#define ERROR_FLOAT_FORMAT (4<<3)
+#define ERROR_SIGNAL (5<<3)
+#define ERROR_NEGATIVE_ARRAY_SIZE (6<<3)
+#define ERROR_C_STRING (7<<3)
+#define ERROR_FFI (8<<3)
+#define ERROR_HEAP_SCAN (9<<3)
 
 /* When throw_error throws an error, it sets this global and
 longjmps back to the top-level. */
@@ -31,5 +30,3 @@ void signal_error(int signal);
 void type_error(CELL type, CELL tagged);
 void primitive_throw(void);
 void primitive_die(void);
-/* index must be tagged */
-void range_error(CELL tagged, CELL min, CELL index, CELL max);