Major overhaul of Windows I/O code: simpler, more readable, more efficient, more robust

core/libc/libc-tests.factor

@@ -0,0 +1,11 @@
+IN: libc.tests
+USING: libc libc.private tools.test namespaces assocs
+destructors kernel ;
+
+100 malloc "block" set
+
+[ t ] [ "block" get mallocs get key? ] unit-test
+
+[ ] [ [ "block" get &free drop ] with-destructors ] unit-test
+
+[ f ] [ "block" get mallocs get key? ] unit-test

core/libc/libc.factor

@@ -81,14 +81,14 @@ PRIVATE>
 <PRIVATE
 
 ! Memory allocations
-TUPLE: memory-destructor alien ;
+TUPLE: memory-destructor alien disposed ;
 
 M: memory-destructor dispose* alien>> free ;
 
 PRIVATE>
 
 : &free ( alien -- alien )
-    dup memory-destructor boa &dispose drop ; inline
+    dup f memory-destructor boa &dispose drop ; inline
 
 : |free ( alien -- alien )
-    dup memory-destructor boa |dispose drop ; inline
+    dup f memory-destructor boa |dispose drop ; inline

extra/io/mmap/mmap-docs.factor

@@ -16,6 +16,11 @@ HELP: <mapped-file>
 { $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
 { $errors "Throws an error if a memory mapping could not be established." } ;
 
+HELP: with-mapped-file
+{ $values { "path" "a pathname string" } { "length" integer } { "quot" "a quotation with stack effect " { $snippet "( mmap -- )" } } }
+{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $errors "Throws an error if a memory mapping could not be established." } ;
+
 HELP: close-mapped-file
 { $values { "mmap" mapped-file } }
 { $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }

extra/io/mmap/mmap-tests.factor

@@ -2,11 +2,14 @@ USING: io io.mmap io.files kernel tools.test continuations
 sequences io.encodings.ascii accessors ;
 IN: io.mmap.tests
 
-[ "resource:mmap-test-file.txt" delete-file ] ignore-errors
+[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
-[ ] [ "12345" "resource:mmap-test-file.txt" ascii set-file-contents ] unit-test
+[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
-[ ] [ "resource:mmap-test-file.txt" dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "resource:mmap-test-file.txt" dup file-info size>> [ length ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file dup file-info size>> [ length ] with-mapped-file ] unit-test
-[ "22345" ] [ "resource:mmap-test-file.txt" ascii file-contents ] unit-test
+[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
-[ "resource:mmap-test-file.txt" delete-file ] ignore-errors
+[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
-
 
+[ ] [ "a" "mmap-grow-test.txt" temp-file ascii set-file-contents ] unit-test
+[ 1 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test
+[ ] [ "mmap-grow-test.txt" temp-file 100 [ drop ] with-mapped-file ] unit-test
+[ 100 ] [ "mmap-grow-test.txt" temp-file file-info size>> ] unit-test

extra/io/sockets/sockets.factor

@@ -27,10 +27,10 @@ GENERIC: inet-ntop ( data addrspec -- str )
 GENERIC: inet-pton ( str addrspec -- data )
 
 : make-sockaddr/size ( addrspec -- sockaddr size )
-    dup make-sockaddr swap sockaddr-type heap-size ;
+    [ make-sockaddr ] [ sockaddr-type heap-size ] bi ;
 
-: empty-sockaddr/size ( addrspec -- sockaddr len )
+: empty-sockaddr/size ( addrspec -- sockaddr size )
-    sockaddr-type [ <c-object> ] [ heap-size <int> ] bi ;
+    sockaddr-type [ <c-object> ] [ heap-size ] bi ;
 
 GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
 

extra/io/unix/mmap/mmap.factor

@@ -6,7 +6,7 @@ IN: io.unix.mmap
 
 : open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
 
-:: mmap-open ( length prot flags path -- alien fd )
+:: mmap-open ( path length prot flags -- alien fd )
     [
         f length prot flags
         path open-r/w |dispose
@@ -14,10 +14,9 @@ IN: io.unix.mmap
     ] with-destructors ;
 
 M: unix (mapped-file)
-    swap >r
     { PROT_READ PROT_WRITE } flags
     { MAP_FILE MAP_SHARED } flags
-    r> mmap-open ;
+    mmap-open ;
 
 M: unix close-mapped-file ( mmap -- )
     [ [ address>> ] [ length>> ] bi munmap io-error ]

extra/io/unix/sockets/sockets.factor

@@ -23,7 +23,7 @@ M: unix addrinfo-error ( n -- )
 
 ! Client sockets - TCP and Unix domain
 M: object (get-local-address) ( handle remote -- sockaddr )
-    >r handle-fd r> empty-sockaddr/size
+    >r handle-fd r> empty-sockaddr/size <int>
     [ getsockname io-error ] 2keep drop ;
 
 : init-client-socket ( fd -- )
@@ -67,7 +67,7 @@ M: object (server) ( addrspec -- handle )
     ] with-destructors ;
 
 : do-accept ( server addrspec -- fd )
-    [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* accept ; inline
+    [ handle>> handle-fd ] [ empty-sockaddr/size <int> ] bi* accept ; inline
 
 M: object (accept) ( server addrspec -- fd )
     2dup do-accept
@@ -100,7 +100,7 @@ packet-size <byte-array> receive-buffer set-global
         packet-size ! nbytes
         0 ! flags
         sockaddr ! from
-        len ! fromlen
+        len <int> ! fromlen
         recvfrom dup 0 >= [
             receive-buffer get-global swap head sockaddr
         ] [

extra/io/windows/ce/privileges/privileges.factor

@@ -0,0 +1,4 @@
+IN: io.windows.ce.privileges
+USING: io.windows.privileges system ;
+
+M: wince set-privilege 2drop ;

extra/io/windows/files/files.factor

@@ -1,19 +1,17 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.backend io.files io.windows kernel math
+USING: alien.c-types io.binary io.backend io.files io.buffers
+io.windows kernel math splitting
 windows windows.kernel32 windows.time calendar combinators
 math.functions sequences namespaces words symbols system
-combinators.lib io.ports destructors math.bitfields.lib ;
+combinators.lib io.ports destructors accessors
+math.bitfields 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
+        CreateFile-flags f CreateFile opened-file
-        dup invalid-handle?
-        <win32-file>
-        |dispose
-        dup add-completion
     ] with-destructors ;
 
 : open-pipe-r/w ( path -- win32-file )
@@ -213,7 +211,7 @@ M: winnt link-info ( path -- info )
 
 : file-times ( path -- timestamp timestamp timestamp )
     [
-        normalize-path open-existing &close-handle
+        normalize-path open-existing &dispose handle>>
         "FILETIME" <c-object>
         "FILETIME" <c-object>
         "FILETIME" <c-object>
@@ -229,7 +227,7 @@ M: winnt link-info ( path -- info )
     #! timestamp order: creation access write
     [
         >r >r >r
-            normalize-path open-existing &close-handle
+            normalize-path open-existing &dispose handle>>
         r> r> r> (set-file-times)
     ] with-destructors ;
 
@@ -246,5 +244,5 @@ M: winnt touch-file ( path -- )
     [
         normalize-path
         maybe-create-file >r &dispose r>
-        [ drop ] [ f now dup (set-file-times) ] if
+        [ drop ] [ handle>> f now dup (set-file-times) ] if
     ] with-destructors ;

extra/io/windows/files/unique/unique.factor

@@ -1,10 +1,10 @@
 USING: kernel system io.files.unique.backend
-windows.kernel32 io.windows io.ports windows ;
+windows.kernel32 io.windows io.windows.files io.ports windows
+destructors ;
 IN: io.windows.files.unique
 
 M: windows (make-unique-file) ( path -- )
-    GENERIC_WRITE CREATE_NEW 0 open-file
+    GENERIC_WRITE CREATE_NEW 0 open-file dispose ;
-    CloseHandle win32-error=0/f ;
 
 M: windows temporary-path ( -- path )
     "TEMP" os-env ;

extra/io/windows/launcher/launcher.factor

@@ -6,7 +6,7 @@ windows.types math windows.kernel32
 namespaces io.launcher kernel sequences windows.errors
 splitting system threads init strings combinators
 io.backend accessors concurrency.flags io.files assocs
-io.files.private windows destructors ;
+io.files.private windows destructors classes.tuple.lib ;
 IN: io.windows.launcher
 
 TUPLE: CreateProcess-args

extra/io/windows/mmap/mmap.factor

@@ -1,86 +1,44 @@
-USING: alien alien.c-types alien.syntax arrays continuations
+USING: alien alien.c-types arrays destructors generic io.mmap
-destructors generic io.mmap io.ports io.windows
+io.ports io.windows io.windows.files io.windows.privileges
-kernel libc math namespaces quotations sequences windows
+kernel libc math math.bitfields namespaces quotations sequences
-windows.advapi32 windows.kernel32 io.backend system ;
+windows windows.advapi32 windows.kernel32 io.backend system
+accessors locals ;
 IN: io.windows.mmap
 
-TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
+: create-file-mapping
+    CreateFileMapping [ win32-error=0/f ] keep <win32-handle> ;
 
-! Security tokens
+: map-view-of-file
-!  http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
+    MapViewOfFile [ win32-error=0/f ] keep ;
 
-: (open-process-token) ( handle -- handle )
+:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
-    { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>
+    [let | lo [ length HEX: ffffffff bitand ]
-    [ OpenProcessToken win32-error=0/f ] keep *void* ;
+           hi [ length -32 shift HEX: ffffffff bitand ] |
-
-: open-process-token ( -- handle )
-    #! remember to handle-close this
-    GetCurrentProcess (open-process-token) ;
-
-: with-process-token ( quot -- )
-    #! quot: ( token-handle -- token-handle )
-    >r open-process-token r>
-    [ keep ] curry
-    [ CloseHandle drop ] [ ] cleanup ; inline
-
-: lookup-privilege ( string -- luid )
-    >r f r> "LUID" <c-object>
-    [ LookupPrivilegeValue win32-error=0/f ] keep ;
-
-: make-token-privileges ( name ? -- obj )
-    "TOKEN_PRIVILEGES" <c-object>
-    1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
-    "LUID_AND_ATTRIBUTES" malloc-array &free
-    over set-TOKEN_PRIVILEGES-Privileges
-
-    swap [
-        SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
-        set-LUID_AND_ATTRIBUTES-Attributes
-    ] when
-
-    >r lookup-privilege r>
-    [
-        TOKEN_PRIVILEGES-Privileges
-        >r 0 r> LUID_AND_ATTRIBUTES-nth
-        set-LUID_AND_ATTRIBUTES-Luid
-    ] keep ;
-
-: set-privilege ( name ? -- )
-    [
-        -rot 0 -rot make-token-privileges
-        dup length f f AdjustTokenPrivileges win32-error=0/f
-    ] with-process-token ;
-
-HOOK: with-privileges io-backend ( seq quot -- ) inline
-
-M: winnt with-privileges
-    over [ [ t set-privilege ] each ] curry compose
-    swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
-
-M: wince with-privileges
-    nip call ;
-
-: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
         { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
-        >r >r 0 open-file dup f r> 0 0 f
+            path access-mode create-mode 0 open-file |dispose
-        CreateFileMapping [ win32-error=0/f ] keep |close-handle
+            dup handle>> f protect hi lo f create-file-mapping |dispose
-        dup
+            dup handle>> access 0 0 0 map-view-of-file
-        r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep |close-handle
+        ] with-privileges
-    ] with-privileges ;
+    ] ;
+
+TUPLE: win32-mapped-file file mapping ;
+
+M: win32-mapped-file dispose
+    [ file>> dispose ] [ mapping>> dispose ] bi ;
+
+C: <win32-mapped-file> win32-mapped-file
 
 M: windows (mapped-file)
     [
-        swap
+        { GENERIC_WRITE GENERIC_READ } flags
-        GENERIC_WRITE GENERIC_READ bitor
         OPEN_ALWAYS
-        PAGE_READWRITE SEC_COMMIT bitor
+        { PAGE_READWRITE SEC_COMMIT } flags
         FILE_MAP_ALL_ACCESS mmap-open
-        -rot 2array
+        -rot <win32-mapped-file>
     ] with-destructors ;
 
 M: windows close-mapped-file ( mapped-file -- )
     [
-        [ handle>> [ &close-handle drop ] each ]
+        [ handle>> &dispose drop ]
-        [ address>> UnmapViewOfFile win32-error=0/f ]
+        [ address>> UnmapViewOfFile win32-error=0/f ] bi
-        bi
     ] with-destructors ;

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

@@ -1,9 +1,10 @@
 USING: alien alien.c-types arrays assocs combinators
-continuations destructors io io.backend io.ports
+continuations destructors io io.backend io.ports io.timeouts
-io.windows libc kernel math namespaces sequences
+io.windows io.windows.files libc kernel math namespaces
-threads classes.tuple.lib windows windows.errors
+sequences threads classes.tuple.lib windows windows.errors
-windows.kernel32 strings splitting io.files qualified ascii
+windows.kernel32 strings splitting io.files
-combinators.lib system accessors ;
+io.buffers qualified ascii combinators.lib system
+accessors locals ;
 QUALIFIED: windows.winsock
 IN: io.windows.nt.backend
 
@@ -28,8 +29,8 @@ SYMBOL: master-completion-port
 : <master-completion-port> ( -- handle )
     INVALID_HANDLE_VALUE f <completion-port> ;
 
-M: winnt add-completion ( handle -- )
+M: winnt add-completion ( win32-handle -- )
-    master-completion-port get-global <completion-port> drop ;
+    handle>> master-completion-port get-global <completion-port> drop ;
 
 : eof? ( error -- ? )
     dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
@@ -64,7 +65,6 @@ M: winnt add-completion ( handle -- )
 
 :: wait-for-overlapped ( ms -- overlapped ? )
     master-completion-port get-global
-    r> INFINITE or ! timeout
     0 <int> ! bytes
     f <void*> ! key
     f <void*> ! overlapped
@@ -82,9 +82,9 @@ M: winnt add-completion ( handle -- )
         GetLastError dup expected-io-error? [ 2drop f ] [
             >r lookup-callback [ thread>> ] [ port>> ] bi r>
             dup eof?
-            [ drop t >>eof drop ]
+            [ drop t >>eof ]
-            [ (win32-error-string) >>error drop ] if
+            [ (win32-error-string) >>error ] if drop
-            thread>> resume t
+            resume t
         ] if
     ] [
         lookup-callback
@@ -102,6 +102,9 @@ M: winnt init-io ( -- )
     H{ } clone io-hash set-global
     windows.winsock:init-winsock ;
 
+: update-file-ptr ( n port -- )
+    handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
+
 : finish-flush ( n port -- )
     [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
 
@@ -124,7 +127,7 @@ M: winnt (wait-to-write)
     over zero? [
         t >>eof 2drop
     ] [
-        [ buffer>> n>buffer ] [ update-file-ptr ] bi
+        [ buffer>> n>buffer ] [ update-file-ptr ] 2bi
     ] if ;
 
 : ((wait-to-read)) ( port -- )

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

@@ -1,6 +1,7 @@
 USING: continuations destructors io.buffers io.files io.backend
-io.timeouts io.ports io.windows io.windows.nt.backend
+io.timeouts io.ports io.windows io.windows.files
-kernel libc math threads windows windows.kernel32 system
+io.windows.nt.backend windows windows.kernel32
+kernel libc math threads system
 alien.c-types alien.arrays alien.strings sequences combinators
 combinators.lib sequences.lib ascii splitting alien strings
 assocs namespaces io.files.private accessors ;
@@ -55,7 +56,4 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
 
 M: winnt open-append
     [ dup file-info size>> ] [ drop 0 ] recover
-    >r (open-append) r> ;
+    >r (open-append) r> >>ptr ;
-
-: update-file-ptr ( n port -- )
-    handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;

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

@@ -4,8 +4,9 @@ USING: alien alien.c-types arrays continuations destructors io
 io.windows libc io.ports io.pipes windows.types
 math windows.kernel32 windows namespaces io.launcher kernel
 sequences windows.errors assocs splitting system strings
-io.windows.launcher io.windows.nt.pipes io.backend io.files
+io.windows.launcher io.windows.files
-io.files.private combinators shuffle accessors locals ;
+io.backend io.files io.files.private combinators shuffle
+accessors locals ;
 IN: io.windows.nt.launcher
 
 : duplicate-handle ( handle -- handle' )
@@ -35,13 +36,13 @@ IN: io.windows.nt.launcher
 ! The below code is based on the example given in
 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
 
-: redirect-default ( default obj access-mode create-mode -- handle )
+: redirect-default ( obj access-mode create-mode -- handle )
-    3drop ;
+    3drop f ;
 
-: redirect-closed ( default obj access-mode create-mode -- handle )
+: redirect-closed ( obj access-mode create-mode -- handle )
-    drop 2nip null-pipe ;
+    drop nip null-pipe ;
 
-:: redirect-file ( default path access-mode create-mode -- handle )
+:: redirect-file ( path access-mode create-mode -- handle )
     path normalize-path
     access-mode
     share-mode
@@ -49,9 +50,9 @@ IN: io.windows.nt.launcher
     create-mode
     FILE_ATTRIBUTE_NORMAL ! flags and attributes
     f ! template file
-    CreateFile dup invalid-handle? <win32-file> &dispose ;
+    CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
 
-: redirect-append ( default path access-mode create-mode -- handle )
+: redirect-append ( path access-mode create-mode -- handle )
     >r >r path>> r> r>
     drop OPEN_ALWAYS
     redirect-file
@@ -60,14 +61,13 @@ IN: io.windows.nt.launcher
 : set-inherit ( handle ? -- )
     >r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
 
-: redirect-handle ( default handle access-mode create-mode -- handle )
+: redirect-handle ( handle access-mode create-mode -- handle )
-    2drop nip
+    2drop handle>> duplicate-handle dup t set-inherit ;
-    handle>> duplicate-handle dup t set-inherit ;
 
-: redirect-stream ( default stream access-mode create-mode -- handle )
+: redirect-stream ( stream access-mode create-mode -- handle )
-    >r >r underlying-handle r> r> redirect-handle ;
+    >r >r underlying-handle handle>> r> r> redirect-handle ;
 
-: redirect ( default obj access-mode create-mode -- handle )
+: redirect ( obj access-mode create-mode -- handle )
     {
         { [ pick not ] [ redirect-default ] }
         { [ pick +closed+ eq? ] [ redirect-closed ] }
@@ -78,21 +78,20 @@ IN: io.windows.nt.launcher
     } cond ;
 
 : redirect-stdout ( process args -- handle )
+    drop
     stdout>>
     GENERIC_WRITE
     CREATE_ALWAYS
     redirect
-    STD_OUTPUT_HANDLE GetStdHandle ;
+    STD_OUTPUT_HANDLE GetStdHandle or ;
 
 : redirect-stderr ( process args -- handle )
     over stderr>> +stdout+ eq? [
-        lpStartupInfo>>
-        STARTUPINFO-hStdOutput
         nip
+        lpStartupInfo>> STARTUPINFO-hStdOutput
     ] [
         drop
-        f
+        stderr>>
-        swap stderr>>
         GENERIC_WRITE
         CREATE_ALWAYS
         redirect
@@ -100,11 +99,12 @@ IN: io.windows.nt.launcher
     ] if ;
 
 : redirect-stdin ( process args -- handle )
+    drop
     stdin>>
     GENERIC_READ
     OPEN_EXISTING
     redirect
-    STD_INPUT_HANDLE GetStdHandle ;
+    STD_INPUT_HANDLE GetStdHandle or ;
 
 M: winnt fill-redirection ( process args -- )
     [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput

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

@@ -17,11 +17,7 @@ IN: io.windows.nt.monitors
     OPEN_EXISTING
     { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
     f
-    CreateFile
+    CreateFile opened-file ;
-    dup invalid-handle?
-    <win32-file>
-    |close-handle
-    dup add-completion ;
 
 TUPLE: win32-monitor-port < input-port recursive ;
 
@@ -93,7 +89,7 @@ TUPLE: win32-monitor < monitor port ;
 
 : fill-queue-thread ( monitor -- )
     [ dup fill-queue (fill-queue-thread) ]
-    [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ;
+    [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ;
 
 M:: winnt (monitor) ( path recursive? mailbox -- monitor )
     [

extra/io/windows/nt/nt.factor

@@ -7,6 +7,7 @@ USE: io.windows.nt.backend
 USE: io.windows.nt.files
 USE: io.windows.nt.launcher
 USE: io.windows.nt.monitors
+USE: io.windows.nt.privileges
 USE: io.windows.nt.sockets
 USE: io.windows.mmap
 USE: io.windows.files

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

@@ -17,10 +17,7 @@ IN: io.windows.nt.pipes
     4096
     0
     security-attributes-inherit
-    CreateNamedPipe
+    CreateNamedPipe opened-file ;
-    dup win32-error=0/f
-    <win32-file> |dispose
-    dup add-completion ;
 
 : open-other-end ( name -- handle )
     GENERIC_WRITE
@@ -29,10 +26,7 @@ IN: io.windows.nt.pipes
     OPEN_EXISTING
     FILE_FLAG_OVERLAPPED
     f
-    CreateFile
+    CreateFile opened-file ;
-    dup win32-error=0/f
-    <win32-file> |dispose
-    dup add-completion ;
 
 : unique-pipe-name ( -- string )
     [

extra/io/windows/nt/privileges/privileges.factor

@@ -0,0 +1,53 @@
+USING: alien alien.c-types alien.syntax arrays continuations
+destructors generic io.mmap io.ports io.windows io.windows.files
+kernel libc math math.bitfields namespaces quotations sequences windows
+windows.advapi32 windows.kernel32 io.backend system accessors
+io.windows.privileges ;
+IN: io.windows.nt.privileges
+
+TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
+
+! Security tokens
+!  http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
+
+: (open-process-token) ( handle -- handle )
+    { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags "PHANDLE" <c-object>
+    [ OpenProcessToken win32-error=0/f ] keep *void* ;
+
+: open-process-token ( -- handle )
+    #! remember to CloseHandle
+    GetCurrentProcess (open-process-token) ;
+
+: with-process-token ( quot -- )
+    #! quot: ( token-handle -- token-handle )
+    >r open-process-token r>
+    [ keep ] curry
+    [ CloseHandle drop ] [ ] cleanup ; inline
+
+: lookup-privilege ( string -- luid )
+    >r f r> "LUID" <c-object>
+    [ LookupPrivilegeValue win32-error=0/f ] keep ;
+
+: make-token-privileges ( name ? -- obj )
+    "TOKEN_PRIVILEGES" <c-object>
+    1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
+    "LUID_AND_ATTRIBUTES" malloc-array &free
+    over set-TOKEN_PRIVILEGES-Privileges
+
+    swap [
+        SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
+        set-LUID_AND_ATTRIBUTES-Attributes
+    ] when
+
+    >r lookup-privilege r>
+    [
+        TOKEN_PRIVILEGES-Privileges
+        >r 0 r> LUID_AND_ATTRIBUTES-nth
+        set-LUID_AND_ATTRIBUTES-Luid
+    ] keep ;
+
+M: winnt set-privilege ( name ? -- )
+    [
+        -rot 0 -rot make-token-privileges
+        dup length f f AdjustTokenPrivileges win32-error=0/f
+    ] with-process-token ;

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

@@ -1,8 +1,9 @@
 USING: alien alien.accessors alien.c-types byte-arrays
 continuations destructors io.ports io.timeouts io.sockets
 io.sockets io namespaces io.streams.duplex io.windows
+io.windows.sockets
 io.windows.nt.backend windows.winsock kernel libc math sequences
-threads classes.tuple.lib system accessors ;
+threads classes.tuple.lib system combinators accessors ;
 IN: io.windows.nt.sockets
 
 : malloc-int ( object -- object )
@@ -11,9 +12,6 @@ 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
@@ -33,7 +31,10 @@ TUPLE: ConnectEx-args port
     s* name* namelen* lpSendBuffer* dwSendDataLength*
     lpdwBytesSent* lpOverlapped* ptr* ;
 
-: <ConnectEx-args> ( sockaddr size -- )
+: wait-for-socket ( args -- n )
+    [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
+
+: <ConnectEx-args> ( sockaddr size -- ConnectEx )
     ConnectEx-args new
         swap >>namelen*
         swap >>name*
@@ -61,18 +62,18 @@ TUPLE: AcceptEx-args port
     sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
     dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
 
-: init-accept-buffer ( server-port AcceptEx -- )
+: init-accept-buffer ( addr AcceptEx -- )
-    swap addr>> sockaddr-type heap-size 16 +
+    swap sockaddr-type heap-size 16 +
         [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
         dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
         drop ;
 
-: <AcceptEx-args> ( server-port -- AcceptEx )
+: <AcceptEx-args> ( server addr -- AcceptEx )
     AcceptEx-args new
         2dup init-accept-buffer
+        swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket*
+        over handle>> handle>> >>sListenSocket*
         swap >>port
-        dup port>> handle>> handle>> >>sListenSocket*
-        dup port>> addr>> tcp-socket >>sAcceptSocket*
         0 >>dwReceiveDataLength*
         f >>lpdwBytesReceived*
         (make-overlapped) >>lpOverlapped* ;
@@ -81,20 +82,17 @@ TUPLE: AcceptEx-args port
     AcceptEx-args >tuple*< AcceptEx drop
     winsock-error-string [ throw ] when* ;
 
-: finish-accept ( AcceptEx -- client )
+M: object (accept) ( server addr -- handle )
-    sAcceptSocket*>> [ <win32-socket> |dispose ] [ add-completion ] bi ;
-
-M: winnt (accept) ( server -- handle )
     [
         [
             <AcceptEx-args>
             {
                 [ call-AcceptEx ]
                 [ wait-for-socket drop ]
-                [ finish-accept ]
+                [ sAcceptSocket*>> opened-socket ]
                 [ port>> pending-error ]
             } cleave
-        ] with-timeout
+        ] curry with-timeout
     ] with-destructors ;
 
 TUPLE: WSARecvFrom-args port
@@ -107,7 +105,7 @@ TUPLE: WSARecvFrom-args port
     default-buffer-size get malloc &free over set-WSABUF-buf ;
 
 : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
-    WSARecvFrom new
+    WSARecvFrom-args new
         swap >>port
         dup port>> handle>> handle>> >>s*
         dup port>> addr>> sockaddr-type heap-size
@@ -125,7 +123,7 @@ TUPLE: WSARecvFrom-args port
 : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
     [ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
 
-M: winnt receive ( datagram -- packet addrspec )
+M: winnt (receive) ( datagram -- packet addrspec )
     [
         <WSARecvFrom-args>
         {
@@ -163,7 +161,7 @@ TUPLE: WSASendTo-args port
 : call-WSASendTo ( WSASendTo -- )
     WSASendTo-args >tuple*< WSASendTo socket-error* ;
 
-M: winnt send ( packet addrspec datagram -- )
+M: winnt (send) ( packet addrspec datagram -- )
     [
         <WSASendTo-args>
         [ call-WSASendTo ]

extra/io/windows/privileges/privileges.factor

@@ -0,0 +1,8 @@
+USING: io.backend kernel continuations sequences ;
+IN: io.windows.privileges
+
+HOOK: set-privilege io-backend ( name ? -- ) inline
+
+: with-privileges ( seq quot -- )
+    over [ [ t set-privilege ] each ] curry compose
+    swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline

extra/io/windows/sockets/sockets.factor

@@ -1,5 +1,5 @@
-USING: kernel accessors io.sockets io.windows
+USING: kernel accessors io.sockets io.windows io.backend
-windows.winsock system ;
+windows.winsock system destructors alien.c-types ;
 IN: io.windows.sockets
 
 HOOK: WSASocket-flags io-backend ( -- DWORD )
@@ -17,24 +17,29 @@ M: win32-socket dispose ( stream -- )
     [ empty-sockaddr/size ] [ protocol-family ] bi
     pick set-sockaddr-in-family ;
 
-: open-socket ( addrspec type -- win3-socket )
+: opened-socket ( handle -- win32-socket )
+    <win32-socket> |dispose dup add-completion ;
+
+: open-socket ( addrspec type -- win32-socket )
     >r protocol-family r>
     0 f 0 WSASocket-flags WSASocket
     dup socket-error
-    <win32-socket> |dispose
+    opened-socket ;
-    dup add-completion ;
 
-M: object get-local-address ( socket addrspec -- sockaddr )
+M: object (get-local-address) ( socket addrspec -- sockaddr )
-    >r handle>> r> empty-sockaddr/size
+    >r handle>> r> empty-sockaddr/size <int>
     [ getsockname socket-error ] 2keep drop ;
 
+: bind-socket ( win32-socket sockaddr len -- )
+    >r >r handle>> r> r> bind socket-error ;
+
 M: object ((client)) ( addrspec -- handle )
-    [ open-socket ] [ drop ] 2bi
+    [ SOCK_STREAM open-socket ] keep
-    [ unspecific-sockaddr/size bind socket-error ] [ drop ] 2bi ;
+    [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;
 
 : server-socket ( addrspec type -- fd )
     [ open-socket ] [ drop ] 2bi
-    [ make-sockaddr/size bind socket-error ] [ drop ] 2bi ;
+    [ make-sockaddr/size bind-socket ] [ drop ] 2bi ;
 
 ! http://support.microsoft.com/kb/127144
 ! NOTE: Possibly tweak this because of SYN flood attacks

extra/io/windows/windows.factor

@@ -19,7 +19,7 @@ TUPLE: win32-handle handle disposed ;
 M: win32-handle dispose* ( handle -- )
     handle>> CloseHandle drop ;
 
-TUPLE: win32-file handle ptr disposed ;
+TUPLE: win32-file < win32-handle ptr ;
 
 : <win32-file> ( handle -- win32-file )
     win32-file new-win32-handle ;
@@ -31,6 +31,11 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
 HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
 HOOK: add-completion io-backend ( port -- )
 
+: opened-file ( handle -- win32-file )
+    dup invalid-handle?
+    <win32-file> |dispose
+    dup add-completion ;
+
 : share-mode ( -- fixnum )
     {
         FILE_SHARE_READ

extra/windows/winsock/winsock.factor

@@ -167,6 +167,8 @@ FUNCTION: int shutdown ( SOCKET s, int how ) ;
 FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
 FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
 
+FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ;
+
 TYPEDEF: uint SERVICETYPE
 TYPEDEF: OVERLAPPED WSAOVERLAPPED
 TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED