test for send buffer overflow

streamtest.hs

module Main where

import Network
import Network.Socket hiding (listen, accept)

import System.IO
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString.Char8 as BS
import System.IO
import Foreign.Ptr
import Foreign.Storable
import Data.ByteString.Internal
import Foreign.ForeignPtr.Safe




main = do

   let port= PortNumber 2000
   
   forkIO $ listen' port
   h <- connectTo "localhost" port
   liftIO $  hSetBuffering h $  BlockBuffering Nothing
   loop $ hPutStrLn h "hello"
   getChar
   where
   loop x = x >>  loop x

   hPutStrLn' h str= do
       let bs@(PS ps s l) = BS.pack $ str  ++ "\n"
       n <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l
       when( n < l) $ do
          error "BUFFER FULLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL"
          hFlush h
          withForeignPtr ps $ \p -> hPutBuf  h ( p `plusPtr` (n * sizeOf  'x' ) )  (l - n)
          return ()

listen'  port = do
   sock <- withSocketsDo $ listenOn  port
   (h,host,port1) <- accept sock
   hSetBuffering h $ BlockBuffering Nothing
   repeatRead h
   where
   repeatRead h= do
       forkIO $ doit h
       return()
       where
       doit h= do
           rs <- loop1 $ hGetLine h
           print (rs :: String)

       loop1 x= x >>= print >> threadDelay 1000000 >> loop1 x