{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}

module Main where

import Network
import qualified Network.Socket as NS
import  qualified Network.BSD as BSD


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

import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals
import GHC.IO.Buffer
import GHC.IO.BufferedIO as Buffered
import GHC.IO.Device as RawIO
import GHC.IO.FD
import GHC.Word
import Data.IORef
import Data.Typeable
import System.IO.Unsafe
import Data.Monoid

main = do

   let port= PortNumber 2000

   forkIO $ listen' port
   h <- connectTo' "localhost" port
   liftIO $  hSetBuffering h $  BlockBuffering Nothing
   loop h 0
   getChar
   where
   loop h x = hPutStrLn' h (show x) >>  loop h (x +1)

   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
          print (n,l)
          print "BUFFER FULLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL"
          hFlush h
          print "AFTER BUFFER FLUSHHHH"
          withForeignPtr ps $ \p -> hPutBuf  h ( p `plusPtr` (n * sizeOf  'x' ) )  (l - n)
          print "AFTER HPUTBUF"
          return ()

connectTo' hostname (PortNumber port) = do
    proto <- BSD.getProtocolNumber "tcp"
    bracketOnError
        (NS.socket NS.AF_INET NS.Stream proto)
        (sClose)  -- only done if there's an error
        (\sock -> do
          NS.setSocketOption sock NS.SendBuffer 300
          he <- BSD.getHostByName hostname
          NS.connect sock (NS.SockAddrInet port (BSD.hostAddress he))

          NS.socketToHandle sock ReadWriteMode
        )

hPutBufNonBlocking handle ptr count
  | count == 0 = return 0
  | count <  0 = error "negative chunk size"
  | otherwise =
    wantWritableHandle "hPutBuf" handle $
      \ h_@Handle__{..} -> bufWriteNonBlocking h_ (castPtr ptr) count False



bufWriteNonBlocking :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
bufWriteNonBlocking h_@Handle__{..} ptr count can_block =
  seq count $ do  -- strictness hack
  old_buf@Buffer{  bufR=w, bufSize=size }  <- readIORef haByteBuffer
  -- print (size,w, count)
  old_buf'@Buffer{  bufR=w', bufSize = size' } <-
        if size - w <= count
          then   do
            (written,old_buf') <- Buffered.flushWriteBuffer0 haDevice old_buf
            writeIORef haByteBuffer old_buf'
            print (size , written,w, count)
            print (bufSize old_buf', bufR old_buf')
            return old_buf'
          else return old_buf

  let count'= if size' - w' > count then count else size' - w'
  writeChunkNonBlocking h_ (castPtr ptr) count'
  writeIORef haByteBuffer old_buf'{ bufR = w' + count' }

  return count'



writeChunkNonBlocking h_@Handle__{..} ptr bytes
  | Just fd <- cast haDevice  =  RawIO.writeNonBlocking (fd::FD) ptr bytes
  | otherwise = error "Todo: hPutBuf"




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
           s <- hGetLine h
           -- print s
           --threadDelay 10
           doit h