Paste: broken write on large byte-arrays

! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays destructors io io.binary
io.encodings.binary io.sockets kernel math namespaces random
sequences strings ;
IN: socket-test

: <test-server> ( -- server )
    "127.0.0.1" 0 <inet4> binary <server> ;

: server-port ( server -- n ) addr>> port>> ;

: <test-client> ( server -- client )
    [ "127.0.0.1" ] dip server-port <inet4> binary <client> drop ;

SYMBOL: server
SYMBOL: client
SYMBOL: n

: write-flush ( seq stream -- ) [ stream-write ] [ stream-flush ] bi ;

: write-client ( string -- ) client get write-flush ;
: read-client ( n -- string ) client get stream-read ;

: write-server ( string -- ) server get write-flush ;
: read-server ( n -- string ) server get stream-read ;

ERROR: bad-length seq n ;
: ensure-length ( seq n -- seq )
    2dup [ length ] dip = [ drop ] [ bad-length ] if ;

ERROR: bad-ensure-all seq quot ;
: ensure-all ( seq quot -- seq )
    2dup all? [ drop ] [ bad-ensure-all ] if ; inline

: test-pair ( -- )
    [
        <test-server> &dispose
        [ <test-client> &dispose client set ]
        [ accept drop server set ] bi

        1 [
             10,000,000 random n set

            [ n get [ CHAR: a <array> >byte-array ] [ 8 >be write-client ] bi write-client ] in-thread

            8 read-server be> read-server n get ensure-length [ CHAR: a = ] ensure-all
            '[ _ [ length 8 >be write-client ] [ write-client ] bi ] in-thread

            8 read-client be> read-client n get ensure-length [ CHAR: a = ] ensure-all drop
        ] times
        
    ] with-destructors ;