Further cleanups

extra/io/windows/files/files.factor

@@ -6,6 +6,118 @@ math.functions sequences namespaces words symbols system
 combinators.lib io.ports destructors math.bitfields.lib ;
 IN: io.windows.files
 
+: open-file ( path access-mode create-mode flags -- handle )
+    [
+        >r >r share-mode security-attributes-inherit r> r>
+        CreateFile-flags f CreateFile
+        dup invalid-handle?
+        <win32-file>
+        |dispose
+        dup add-completion
+    ] with-destructors ;
+
+: open-pipe-r/w ( path -- win32-file )
+    { GENERIC_READ GENERIC_WRITE } flags
+    OPEN_EXISTING 0 open-file ;
+
+: open-read ( path -- win32-file )
+    GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
+
+: open-write ( path -- win32-file )
+    GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
+
+: (open-append) ( path -- win32-file )
+    GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
+
+: open-existing ( path -- win32-file )
+    { GENERIC_READ GENERIC_WRITE } flags
+    share-mode
+    f
+    OPEN_EXISTING
+    FILE_FLAG_BACKUP_SEMANTICS
+    f CreateFileW dup win32-error=0/f <win32-file> ;
+
+: maybe-create-file ( path -- win32-file ? )
+    #! return true if file was just created
+    { GENERIC_READ GENERIC_WRITE } flags
+    share-mode
+    f
+    OPEN_ALWAYS
+    0 CreateFile-flags
+    f CreateFileW dup win32-error=0/f <win32-file>
+    GetLastError ERROR_ALREADY_EXISTS = not ;
+
+: set-file-pointer ( handle length method -- )
+    >r dupd d>w/w <uint> r> SetFilePointer
+    INVALID_SET_FILE_POINTER = [
+        CloseHandle "SetFilePointer failed" throw
+    ] when drop ;
+
+HOOK: open-append os ( path -- win32-file )
+
+TUPLE: FileArgs
+    hFile lpBuffer nNumberOfBytesToRead
+    lpNumberOfBytesRet lpOverlapped ;
+
+C: <FileArgs> FileArgs
+
+: make-FileArgs ( port -- <FileArgs> )
+    {
+        [ handle>> handle>> ]
+        [ buffer>> ]
+        [ buffer>> buffer-length ]
+        [ drop "DWORD" <c-object> ]
+        [ FileArgs-overlapped ]
+    } cleave <FileArgs> ;
+
+: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
+    {
+        [ hFile>> ]
+        [ lpBuffer>> buffer-end ]
+        [ lpBuffer>> buffer-capacity ]
+        [ lpNumberOfBytesRet>> ]
+        [ lpOverlapped>> ]
+    } cleave ;
+
+: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
+    {
+        [ hFile>> ]
+        [ lpBuffer>> buffer@ ]
+        [ lpBuffer>> buffer-length ]
+        [ lpNumberOfBytesRet>> ]
+        [ lpOverlapped>> ]
+    } cleave ;
+
+M: windows (file-reader) ( path -- stream )
+    open-read <input-port> ;
+
+M: windows (file-writer) ( path -- stream )
+    open-write <output-port> ;
+
+M: windows (file-appender) ( path -- stream )
+    open-append <output-port> ;
+
+M: windows move-file ( from to -- )
+    [ normalize-path ] bi@ MoveFile win32-error=0/f ;
+
+M: windows delete-file ( path -- )
+    normalize-path DeleteFile win32-error=0/f ;
+
+M: windows copy-file ( from to -- )
+    dup parent-directory make-directories
+    [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
+
+M: windows make-directory ( path -- )
+    normalize-path
+    f CreateDirectory win32-error=0/f ;
+
+M: windows delete-directory ( path -- )
+    normalize-path
+    RemoveDirectory win32-error=0/f ;
+
+M: windows normalize-directory ( string -- string )
+    normalize-path "\\" ?tail drop "\\*" append ;
+
 SYMBOLS: +read-only+ +hidden+ +system+
 +archive+ +device+ +normal+ +temporary+
 +sparse-file+ +reparse-point+ +compressed+ +offline+
@@ -133,6 +245,6 @@ M: winnt link-info ( path -- info )
 M: winnt touch-file ( path -- )
     [
         normalize-path
-        maybe-create-file >r &close-handle r>
+        maybe-create-file >r &dispose r>
         [ drop ] [ f now dup (set-file-times) ] if
     ] with-destructors ;

extra/io/windows/launcher/launcher.factor

@@ -19,8 +19,7 @@ TUPLE: CreateProcess-args
        lpEnvironment
        lpCurrentDirectory
        lpStartupInfo
-       lpProcessInformation
-       stdout-pipe stdin-pipe ;
+       lpProcessInformation ;
 
 : default-CreateProcess-args ( -- obj )
     CreateProcess-args new
@@ -31,18 +30,7 @@ TUPLE: CreateProcess-args
     0 >>dwCreateFlags ;
 
 : call-CreateProcess ( CreateProcess-args -- )
-    {
-        lpApplicationName>>
-        lpCommandLine>>
-        lpProcessAttributes>>
-        lpThreadAttributes>>
-        bInheritHandles>>
-        dwCreateFlags>>
-        lpEnvironment>>
-        lpCurrentDirectory>>
-        lpStartupInfo>>
-        lpProcessInformation>>
-    } get-slots CreateProcess win32-error=0/f ;
+    CreateProcess-args >tuple< CreateProcess win32-error=0/f ;
 
 : count-trailing-backslashes ( str n -- str n )
     >r "\\" ?tail [

extra/io/windows/mmap/mmap.factor

@@ -10,7 +10,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
 !  http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
 
 : (open-process-token) ( handle -- handle )
-    TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY bitor "PHANDLE" <c-object>
+    { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>
     [ OpenProcessToken win32-error=0/f ] keep *void* ;
 
 : open-process-token ( -- handle )

extra/io/windows/nt/backend/backend.factor

@@ -101,3 +101,39 @@ M: winnt init-io ( -- )
     <master-completion-port> master-completion-port set-global
     H{ } clone io-hash set-global
     windows.winsock:init-winsock ;
+
+: finish-flush ( n port -- )
+    [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
+
+: ((wait-to-write)) ( port -- )
+    dup make-FileArgs
+    tuck setup-write WriteFile
+    dupd overlapped-error? [
+        >r lpOverlapped>> r>
+        [ twiddle-thumbs ] keep
+        [ finish-flush ] keep
+        dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
+    ] [
+        2drop
+    ] if ;
+
+M: winnt (wait-to-write)
+    [ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
+
+: finish-read ( n port -- )
+    over zero? [
+        t >>eof 2drop
+    ] [
+        [ buffer>> n>buffer ] [ update-file-ptr ] bi
+    ] if ;
+
+: ((wait-to-read)) ( port -- )
+    dup make-FileArgs
+    tuck setup-read ReadFile
+    dupd overlapped-error? [
+        >r lpOverlapped>> r>
+        [ twiddle-thumbs ] [ finish-read ] bi
+    ] [ 2drop ] if ;
+
+M: winnt (wait-to-read) ( port -- )
+    [ [ ((wait-to-read)) ] with-timeout ] with-destructors ;

extra/io/windows/nt/files/files.factor

@@ -29,6 +29,7 @@ M: winnt root-directory? ( path -- ? )
     } cond nip ;
 
 ERROR: not-absolute-path ;
+
 : root-directory ( string -- string' )
     {
         [ dup length 2 >= ]
@@ -58,39 +59,3 @@ M: winnt open-append
 
 : update-file-ptr ( n port -- )
     handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
-
-: finish-flush ( n port -- )
-    [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
-
-: ((wait-to-write)) ( port -- )
-    dup make-FileArgs
-    tuck setup-write WriteFile
-    dupd overlapped-error? [
-        >r lpOverlapped>> r>
-        [ twiddle-thumbs ] keep
-        [ finish-flush ] keep
-        dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
-    ] [
-        2drop
-    ] if ;
-
-M: winnt (wait-to-write)
-    [ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
-
-: finish-read ( n port -- )
-    over zero? [
-        t >>eof 2drop
-    ] [
-        [ buffer>> n>buffer ] [ update-file-ptr ] bi
-    ] if ;
-
-: ((wait-to-read)) ( port -- )
-    dup make-FileArgs
-    tuck setup-read ReadFile
-    dupd overlapped-error? [
-        >r lpOverlapped>> r>
-        [ twiddle-thumbs ] [ finish-read ] bi
-    ] [ 2drop ] if ;
-
-M: winnt (wait-to-read) ( port -- )
-    [ [ ((wait-to-read)) ] with-timeout ] with-destructors ;

extra/io/windows/nt/launcher/launcher.factor

@@ -21,10 +21,10 @@ IN: io.windows.nt.launcher
 
 ! /dev/null simulation
 : null-input ( -- pipe )
-    (pipe) [ in>> handle>> ] [ out>> close-handle ] bi ;
+    (pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
 
 : null-output ( -- pipe )
-    (pipe) [ in>> close-handle ] [ out>> handle>> ] bi ;
+    (pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
 
 : null-pipe ( mode -- pipe )
     {
@@ -49,7 +49,7 @@ IN: io.windows.nt.launcher
     create-mode
     FILE_ATTRIBUTE_NORMAL ! flags and attributes
     f ! template file
-    CreateFile dup invalid-handle? &close-handle ;
+    CreateFile dup invalid-handle? <win32-file> &dispose ;
 
 : redirect-append ( default path access-mode create-mode -- handle )
     >r >r path>> r> r>
@@ -77,16 +77,12 @@ IN: io.windows.nt.launcher
         [ redirect-stream ]
     } cond ;
 
-: default-stdout ( args -- handle )
-    stdout-pipe>> dup [ out>> ] when ;
-
 : redirect-stdout ( process args -- handle )
-    default-stdout
-    swap stdout>>
+    stdout>>
     GENERIC_WRITE
     CREATE_ALWAYS
     redirect
-    STD_OUTPUT_HANDLE GetStdHandle or ;
+    STD_OUTPUT_HANDLE GetStdHandle ;
 
 : redirect-stderr ( process args -- handle )
     over stderr>> +stdout+ eq? [
@@ -103,16 +99,12 @@ IN: io.windows.nt.launcher
         STD_ERROR_HANDLE GetStdHandle or
     ] if ;
 
-: default-stdin ( args -- handle )
-    stdin-pipe>> dup [ in>> ] when ;
-
 : redirect-stdin ( process args -- handle )
-    default-stdin
-    swap stdin>>
+    stdin>>
     GENERIC_READ
     OPEN_EXISTING
     redirect
-    STD_INPUT_HANDLE GetStdHandle or ;
+    STD_INPUT_HANDLE GetStdHandle ;
 
 M: winnt fill-redirection ( process args -- )
     [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput

extra/io/windows/nt/monitors/monitors.factor

@@ -19,9 +19,9 @@ IN: io.windows.nt.monitors
     f
     CreateFile
     dup invalid-handle?
+    <win32-file>
     |close-handle
-    dup add-completion
-    f <win32-file> ;
+    dup add-completion ;
 
 TUPLE: win32-monitor-port < input-port recursive ;
 
@@ -83,7 +83,7 @@ TUPLE: win32-monitor < monitor port ;
     ] each ;
 
 : fill-queue ( monitor -- )
-    dup port>> check-closed
+    dup port>> dup check-disposed
     [ buffer>> ptr>> ] [ read-changes zero? ] bi
     [ 2dup parse-notify-records ] unless
     2drop ;

extra/io/windows/nt/pipes/pipes.factor

@@ -19,8 +19,8 @@ IN: io.windows.nt.pipes
     security-attributes-inherit
     CreateNamedPipe
     dup win32-error=0/f
-    dup add-completion
-    f <win32-file> ;
+    <win32-file> |dispose
+    dup add-completion ;
 
 : open-other-end ( name -- handle )
     GENERIC_WRITE
@@ -31,8 +31,8 @@ IN: io.windows.nt.pipes
     f
     CreateFile
     dup win32-error=0/f
-    dup add-completion
-    f <win32-file> ;
+    <win32-file> |dispose
+    dup add-completion ;
 
 : unique-pipe-name ( -- string )
     [
@@ -47,7 +47,6 @@ IN: io.windows.nt.pipes
 M: winnt (pipe) ( -- pipe )
     [
         unique-pipe-name
-        [ create-named-pipe |close-handle ]
-        [ open-other-end |close-handle ]
-        bi pipe boa
+        [ create-named-pipe ] [ open-other-end ] bi
+        pipe boa
     ] with-destructors ;

extra/io/windows/nt/sockets/sockets.factor

@@ -11,6 +11,9 @@ IN: io.windows.nt.sockets
 M: winnt WSASocket-flags ( -- DWORD )
     WSA_FLAG_OVERLAPPED ;
 
+: wait-for-socket ( args -- n )
+    [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
+
 : get-ConnectEx-ptr ( socket -- void* )
     SIO_GET_EXTENSION_FUNCTION_POINTER
     WSAID_CONNECTEX
@@ -46,28 +49,13 @@ TUPLE: ConnectEx-args port
     "stdcall" alien-indirect drop
     winsock-error-string [ throw ] when* ;
 
-: (wait-to-connect) ( client-out handle -- )
-    overlapped>> swap twiddle-thumbs drop ;
-
-: get-socket-name ( socket addrspec -- sockaddr )
-    >r handle>> r> empty-sockaddr/size
-    [ getsockname socket-error ] 2keep drop ;
-
-M: win32-socket wait-to-connect ( client-out handle remote -- sockaddr )
-    [
-        [ drop (wait-to-connect) ]
-        [ get-socket-name nip ]
-        3bi
-    ] keep parse-sockaddr ;
-
-M: object ((client)) ( addrspec -- handle )
-    dup make-sockaddr/size <ConnectEx-args>
-    over tcp-socket >>s*
-    dup s*>> add-completion
-    dup s*>> get-ConnectEx-ptr >>ptr*
-    dup s*>> INADDR_ANY roll bind-socket
-    dup call-ConnectEx
-    dup [ s*>> ] [ lpOverlapped*>> ] bi <win32-socket> ;
+M: object establish-connection ( client-out remote -- )
+    make-sockaddr/size <ConnectEx-args>
+        swap >>port
+        dup port>> handle>> handle>> >>s*
+        dup s*>> get-ConnectEx-ptr >>ptr*
+        dup call-ConnectEx
+        wait-for-socket drop ;
 
 TUPLE: AcceptEx-args port
     sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
@@ -82,75 +70,33 @@ TUPLE: AcceptEx-args port
 : <AcceptEx-args> ( server-port -- AcceptEx )
     AcceptEx-args new
         2dup init-accept-buffer
-        over >>port
-        over handle>> handle>> >>sListenSocket*
-        over addr>> tcp-socket >>sAcceptSocket*
+        swap >>port
+        dup port>> handle>> handle>> >>sListenSocket*
+        dup port>> addr>> tcp-socket >>sAcceptSocket*
         0 >>dwReceiveDataLength*
         f >>lpdwBytesReceived*
-        (make-overlapped) >>lpOverlapped*
-        nip ;
+        (make-overlapped) >>lpOverlapped* ;
 
 : call-AcceptEx ( AcceptEx -- )
-    AcceptEx-args >tuple*<
-    AcceptEx drop
+    AcceptEx-args >tuple*< AcceptEx drop
     winsock-error-string [ throw ] when* ;
 
-: extract-remote-host ( AcceptEx -- addrspec )
-    {
-        [ lpOutputBuffer*>> ]
-        [ dwReceiveDataLength*>> ]
-        [ dwLocalAddressLength*>> ]
-        [ dwRemoteAddressLength*>> ]
-    } cleave
-    f <void*>
-    0 <int>
-    f <void*> [
-        0 <int> GetAcceptExSockaddrs
-    ] keep *void* ;
+: finish-accept ( AcceptEx -- client )
+    sAcceptSocket*>> [ <win32-socket> |dispose ] [ add-completion ] bi ;
 
-: finish-accept ( AcceptEx -- client sockaddr )
-    [ sAcceptSocket*>> add-completion ]
-    [ [ sAcceptSocket*>> ] [ lpOverlapped*>> ] bi <win32-socket> ]
-    [ extract-remote-host ]
-    tri ;
-
-: wait-to-accept ( AcceptEx -- )
-    [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ;
-
-M: winnt (accept) ( server -- handle sockaddr )
+M: winnt (accept) ( server -- handle )
     [
         [
             <AcceptEx-args>
             {
                 [ call-AcceptEx ]
-                [ wait-to-accept ]
+                [ wait-for-socket drop ]
                 [ finish-accept ]
                 [ port>> pending-error ]
             } cleave
         ] with-timeout
     ] with-destructors ;
 
-M: winnt (server) ( addrspec -- handle sockaddr )
-    [
-        [ SOCK_STREAM server-fd ] keep
-        [
-            drop
-            [ listen-on-socket ]
-            [ add-completion ]
-            [ f <win32-socket> ]
-            tri
-        ]
-        [ get-socket-name ]
-        2bi
-    ] with-destructors ;
-
-M: winnt (datagram) ( addrspec -- handle )
-    [
-        SOCK_DGRAM server-fd
-        dup add-completion
-        f <win32-socket>
-    ] with-destructors ;
-
 TUPLE: WSARecvFrom-args port
        s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd*
        lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
@@ -162,9 +108,9 @@ TUPLE: WSARecvFrom-args port
 
 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
     WSARecvFrom new
-        over >>port
-        over handle>> handle>> >>s*
-        swap addr>> sockaddr-type heap-size
+        swap >>port
+        dup port>> handle>> handle>> >>s*
+        dup port>> addr>> sockaddr-type heap-size
             [ malloc &free >>lpFrom* ]
             [ malloc-int &free >>lpFromLen* ] bi
         make-receive-buffer >>lpBuffers*
@@ -173,23 +119,18 @@ TUPLE: WSARecvFrom-args port
         0 malloc-int &free >>lpNumberOfBytesRecvd*
         (make-overlapped) >>lpOverlapped* ;
 
-: wait-to-receive ( WSARecvFrom -- n )
-    [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
-
 : call-WSARecvFrom ( WSARecvFrom -- )
     WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
 
 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
-    [ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
-    [ lpFrom*>> ]
-    bi ;
+    [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
 
 M: winnt receive ( datagram -- packet addrspec )
     [
         <WSARecvFrom-args>
         {
             [ call-WSARecvFrom ]
-            [ wait-to-receive ]
+            [ wait-for-socket ]
             [ port>> pending-error ]
             [ parse-WSARecvFrom ]
         } cleave
@@ -208,8 +149,8 @@ TUPLE: WSASendTo-args port
 
 : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
     WSASendTo-args new
-        over >>port
-        over handle>> handle>> >>s*
+        swap >>port
+        dup port>> handle>> handle>> >>s*
         swap make-sockaddr/size
             >r malloc-byte-array &free
             r> [ >>lpTo* ] [ >>iToLen* ] bi*
@@ -219,19 +160,14 @@ TUPLE: WSASendTo-args port
         0 <uint> >>lpNumberOfBytesSent*
         (make-overlapped) >>lpOverlapped* ;
 
-: wait-to-send ( WSASendTo -- )
-    [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs drop ;
-
 : call-WSASendTo ( WSASendTo -- )
     WSASendTo-args >tuple*< WSASendTo socket-error* ;
 
-USE: io.sockets
-
 M: winnt send ( packet addrspec datagram -- )
     [
         <WSASendTo-args>
         [ call-WSASendTo ]
-        [ wait-to-send ]
+        [ wait-for-socket drop ]
         [ port>> pending-error ]
         tri
     ] with-destructors ;

extra/io/windows/sockets/sockets.factor

@@ -0,0 +1,53 @@
+USING: kernel accessors io.sockets io.windows
+windows.winsock system ;
+IN: io.windows.sockets
+
+HOOK: WSASocket-flags io-backend ( -- DWORD )
+
+TUPLE: win32-socket < win32-file ;
+
+: <win32-socket> ( handle -- win32-socket )
+    win32-socket new
+        swap >>handle ;
+
+M: win32-socket dispose ( stream -- )
+    handle>> closesocket drop ;
+
+: unspecific-sockaddr/size ( addrspec -- sockaddr len )
+    [ empty-sockaddr/size ] [ protocol-family ] bi
+    pick set-sockaddr-in-family ;
+
+: open-socket ( addrspec type -- win3-socket )
+    >r protocol-family r>
+    0 f 0 WSASocket-flags WSASocket
+    dup socket-error
+    <win32-socket> |dispose
+    dup add-completion ;
+
+M: object get-local-address ( socket addrspec -- sockaddr )
+    >r handle>> r> empty-sockaddr/size
+    [ getsockname socket-error ] 2keep drop ;
+
+M: object ((client)) ( addrspec -- handle )
+    [ open-socket ] [ drop ] 2bi
+    [ unspecific-sockaddr/size bind socket-error ] [ drop ] 2bi ;
+
+: server-socket ( addrspec type -- fd )
+    [ open-socket ] [ drop ] 2bi
+    [ make-sockaddr/size bind socket-error ] [ drop ] 2bi ;
+
+! http://support.microsoft.com/kb/127144
+! NOTE: Possibly tweak this because of SYN flood attacks
+: listen-backlog ( -- n ) HEX: 7fffffff ; inline
+
+M: object (server) ( addrspec -- handle )
+    [
+        SOCK_STREAM server-socket
+        dup handle>> listen-backlog listen winsock-return-check
+    ] with-destructors ;
+
+M: windows (datagram) ( addrspec -- handle )
+    [ SOCK_DGRAM server-socket ] with-destructors ;
+
+M: windows addrinfo-error ( n -- )
+    winsock-return-check ;