Fix io.servers -- if it doesn't start up, don't throw an error when it's stopped. IPV6 must be enabled on windows with the command: ipv6 install (the build machines need this before we get clean windows builds). Fix up winsock error handling.
							parent
							
								
									fd502e2c85
								
							
						
					
					
						commit
						8aa22487da
					
				| 
						 | 
					@ -44,7 +44,7 @@ ERROR: server-not-running threaded-server ;
 | 
				
			||||||
    running-servers get adjoin ;
 | 
					    running-servers get adjoin ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: remove-running-server ( threaded-server -- )
 | 
					: remove-running-server ( threaded-server -- )
 | 
				
			||||||
    must-be-running
 | 
					    ! must-be-running
 | 
				
			||||||
    running-servers get delete ;
 | 
					    running-servers get delete ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
PRIVATE>
 | 
					PRIVATE>
 | 
				
			||||||
| 
						 | 
					@ -72,6 +72,8 @@ GENERIC: handle-client* ( threaded-server -- )
 | 
				
			||||||
GENERIC: (>insecure) ( obj -- obj )
 | 
					GENERIC: (>insecure) ( obj -- obj )
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: inet (>insecure) ;
 | 
					M: inet (>insecure) ;
 | 
				
			||||||
 | 
					M: inet4 (>insecure) ;
 | 
				
			||||||
 | 
					M: inet6 (>insecure) ;
 | 
				
			||||||
M: local (>insecure) ;
 | 
					M: local (>insecure) ;
 | 
				
			||||||
M: integer (>insecure) internet-server ;
 | 
					M: integer (>insecure) internet-server ;
 | 
				
			||||||
M: string (>insecure) internet-server ;
 | 
					M: string (>insecure) internet-server ;
 | 
				
			||||||
| 
						 | 
					@ -224,6 +226,12 @@ PRIVATE>
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
 | 
					: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: secure-addr ( -- inet )
 | 
				
			||||||
 | 
					    threaded-server get servers>> [ addr>> secure? ] filter random ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: insecure-addr ( -- inet )
 | 
				
			||||||
 | 
					    threaded-server get servers>> [ addr>> secure? not ] filter random addr>> ;
 | 
				
			||||||
 | 
					    
 | 
				
			||||||
: server. ( threaded-server -- )
 | 
					: server. ( threaded-server -- )
 | 
				
			||||||
    [ [ "=== " write name>> ] [ ] bi write-object nl ]
 | 
					    [ [ "=== " write name>> ] [ ] bi write-object nl ]
 | 
				
			||||||
    [ servers>> [ addr>> present print ] each ] bi ;
 | 
					    [ servers>> [ addr>> present print ] each ] bi ;
 | 
				
			||||||
| 
						 | 
					@ -231,6 +239,9 @@ PRIVATE>
 | 
				
			||||||
: all-servers ( -- sequence )
 | 
					: all-servers ( -- sequence )
 | 
				
			||||||
    running-servers get-global members ;
 | 
					    running-servers get-global members ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: get-servers-named ( string -- sequence )
 | 
				
			||||||
 | 
					    [ all-servers ] dip '[ name>> _ = ] filter ;
 | 
				
			||||||
 | 
					    
 | 
				
			||||||
: servers. ( -- )
 | 
					: servers. ( -- )
 | 
				
			||||||
    all-servers [ server. ] each ;
 | 
					    all-servers [ server. ] each ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -100,7 +100,7 @@ M: winnt WSASocket-flags ( -- DWORD )
 | 
				
			||||||
        f
 | 
					        f
 | 
				
			||||||
        f
 | 
					        f
 | 
				
			||||||
        WSAIoctl SOCKET_ERROR = [
 | 
					        WSAIoctl SOCKET_ERROR = [
 | 
				
			||||||
            winsock-error-string throw
 | 
					            maybe-winsock-exception throw
 | 
				
			||||||
        ] when
 | 
					        ] when
 | 
				
			||||||
    ] with-out-parameters ;
 | 
					    ] with-out-parameters ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					@ -134,7 +134,7 @@ TUPLE: ConnectEx-args port
 | 
				
			||||||
    int
 | 
					    int
 | 
				
			||||||
    { SOCKET void* int PVOID DWORD LPDWORD void* }
 | 
					    { SOCKET void* int PVOID DWORD LPDWORD void* }
 | 
				
			||||||
    stdcall alien-indirect drop
 | 
					    stdcall alien-indirect drop
 | 
				
			||||||
    winsock-error-string [ throw ] when* ; inline
 | 
					    winsock-error ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: object establish-connection ( client-out remote -- )
 | 
					M: object establish-connection ( client-out remote -- )
 | 
				
			||||||
    make-sockaddr/size <ConnectEx-args>
 | 
					    make-sockaddr/size <ConnectEx-args>
 | 
				
			||||||
| 
						 | 
					@ -164,6 +164,7 @@ TUPLE: AcceptEx-args port
 | 
				
			||||||
        f >>lpdwBytesReceived
 | 
					        f >>lpdwBytesReceived
 | 
				
			||||||
        (make-overlapped) >>lpOverlapped ; inline
 | 
					        (make-overlapped) >>lpOverlapped ; inline
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					! AcceptEx return value is useless
 | 
				
			||||||
: call-AcceptEx ( AcceptEx -- )
 | 
					: call-AcceptEx ( AcceptEx -- )
 | 
				
			||||||
    {
 | 
					    {
 | 
				
			||||||
        [ sListenSocket>> ]
 | 
					        [ sListenSocket>> ]
 | 
				
			||||||
| 
						 | 
					@ -174,8 +175,7 @@ TUPLE: AcceptEx-args port
 | 
				
			||||||
        [ dwRemoteAddressLength>> ]
 | 
					        [ dwRemoteAddressLength>> ]
 | 
				
			||||||
        [ lpdwBytesReceived>> ]
 | 
					        [ lpdwBytesReceived>> ]
 | 
				
			||||||
        [ lpOverlapped>> ]
 | 
					        [ lpOverlapped>> ]
 | 
				
			||||||
    } cleave AcceptEx drop
 | 
					    } cleave AcceptEx drop winsock-error ; inline
 | 
				
			||||||
    winsock-error-string [ throw ] when* ; inline
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
 | 
					: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
 | 
				
			||||||
    f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
 | 
					    f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -7,7 +7,7 @@ classes.struct windows.com.syntax init ;
 | 
				
			||||||
FROM: alien.c-types => short ;
 | 
					FROM: alien.c-types => short ;
 | 
				
			||||||
IN: windows.winsock
 | 
					IN: windows.winsock
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TYPEDEF: void* SOCKET
 | 
					TYPEDEF: int* SOCKET
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: <wsadata> ( -- byte-array )
 | 
					: <wsadata> ( -- byte-array )
 | 
				
			||||||
    HEX: 190 <byte-array> ;
 | 
					    HEX: 190 <byte-array> ;
 | 
				
			||||||
| 
						 | 
					@ -394,35 +394,40 @@ CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
 | 
				
			||||||
 | 
					
 | 
				
			||||||
CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
 | 
					CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					ERROR: winsock-exception n string ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: winsock-expected-error? ( n -- ? )
 | 
					: winsock-expected-error? ( n -- ? )
 | 
				
			||||||
    ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
 | 
					    ${ ERROR_IO_PENDING ERROR_SUCCESS WSA_IO_PENDING } member? ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: (winsock-error-string) ( n -- str )
 | 
					: (maybe-winsock-exception) ( n -- winsock-exception/f )
 | 
				
			||||||
    ! #! WSAStartup returns the error code 'n' directly
 | 
					    ! #! WSAStartup returns the error code 'n' directly
 | 
				
			||||||
    dup winsock-expected-error?
 | 
					    dup winsock-expected-error?
 | 
				
			||||||
    [ drop f ] [ n>win32-error-string ] if ;
 | 
					    [ drop f ] [ [ ] [ n>win32-error-string ] bi \ winsock-exception boa ] if ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: winsock-error-string ( -- string/f )
 | 
					: maybe-winsock-exception ( -- winsock-exception/f )
 | 
				
			||||||
    WSAGetLastError (winsock-error-string) ;
 | 
					    WSAGetLastError (maybe-winsock-exception) ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: winsock-error ( -- )
 | 
					: winsock-error ( -- )
 | 
				
			||||||
    winsock-error-string [ throw ] when* ;
 | 
					    maybe-winsock-exception [ throw ] when* ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: (throw-winsock-error) ( n -- * )
 | 
				
			||||||
 | 
					    [ ] [ n>win32-error-string ] bi winsock-exception ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					: throw-winsock-error ( -- * )
 | 
				
			||||||
 | 
					    WSAGetLastError (throw-winsock-error) ;
 | 
				
			||||||
 | 
					    
 | 
				
			||||||
: winsock-error=0/f ( n/f -- )
 | 
					: winsock-error=0/f ( n/f -- )
 | 
				
			||||||
    { 0 f } member? [
 | 
					    { 0 f } member? [ throw-winsock-error ] when ;
 | 
				
			||||||
        winsock-error-string throw
 | 
					 | 
				
			||||||
    ] when ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
: winsock-error!=0/f ( n/f -- )
 | 
					: winsock-error!=0/f ( n/f -- )
 | 
				
			||||||
    { 0 f } member? [
 | 
					    { 0 f } member? [ throw-winsock-error ] unless ;
 | 
				
			||||||
        winsock-error-string throw
 | 
					 | 
				
			||||||
    ] unless ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					! WSAStartup and WSACleanup return the error code directly
 | 
				
			||||||
: winsock-return-check ( n/f -- )
 | 
					: winsock-return-check ( n/f -- )
 | 
				
			||||||
    dup { 0 f } member? [
 | 
					    dup { 0 f } member? [
 | 
				
			||||||
        drop
 | 
					        drop
 | 
				
			||||||
    ] [
 | 
					    ] [
 | 
				
			||||||
        (winsock-error-string) throw
 | 
					        [ ] [ n>win32-error-string ] bi winsock-exception
 | 
				
			||||||
    ] if ;
 | 
					    ] if ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: socket-error* ( n -- )
 | 
					: socket-error* ( n -- )
 | 
				
			||||||
| 
						 | 
					@ -431,7 +436,7 @@ CONSTANT: WSAID_CONNECTEX GUID: {25a207b9-ddf3-4660-8ee9-76e58c74063e}
 | 
				
			||||||
        dup WSA_IO_PENDING = [
 | 
					        dup WSA_IO_PENDING = [
 | 
				
			||||||
            drop
 | 
					            drop
 | 
				
			||||||
        ] [
 | 
					        ] [
 | 
				
			||||||
            (winsock-error-string) throw
 | 
					            (maybe-winsock-exception) throw
 | 
				
			||||||
        ] if
 | 
					        ] if
 | 
				
			||||||
    ] when ;
 | 
					    ] when ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue