# LANGUAGE CPP #

#include "HsNetDef.h"

module Network.Socket.Shutdown (
    ShutdownCmd(..)
  , shutdown
  , gracefulClose
  ) where

import qualified Control.Exception as E
import Foreign.Marshal.Alloc (mallocBytes, free)

import Control.Concurrent (threadDelay)

import Network.Socket.Buffer
import Network.Socket.Imports
import Network.Socket.Internal
import Network.Socket.Types

data ShutdownCmd = ShutdownReceive
                 | ShutdownSend
                 | ShutdownBoth

sdownCmdToInt :: ShutdownCmd -> CInt
sdownCmdToInt ShutdownReceive = 0
sdownCmdToInt ShutdownSend    = 1
sdownCmdToInt ShutdownBoth    = 2

  | Shut down one or both halves of the connection , depending on the
  second argument to the function .   If the second argument is
-- 'ShutdownReceive', further receives are disallowed.  If it is
  ' ShutdownSend ' , further sends are disallowed .   If it is
  ' ShutdownBoth ' , further sends and receives are disallowed .
shutdown :: Socket -> ShutdownCmd -> IO ()
shutdown s stype = void $ withFdSocket s $ \fd ->
  throwSocketErrorIfMinus1Retry_ "Network.Socket.shutdown" $
    c_shutdown fd $ sdownCmdToInt stype

foreign import CALLCONV unsafe "shutdown"
  c_shutdown :: CInt -> CInt -> IO CInt

-- | Closing a socket gracefully.
--   This sends TCP FIN and check if TCP FIN is received from the peer.
    The second argument is time out to receive TCP FIN in millisecond .
--   In both normal cases and error cases, socket is deallocated finally.
--
    Since : 3.1.1.0
gracefulClose :: Socket -> Int -> IO ()
gracefulClose s tmout = sendRecvFIN `E.finally` close s
  where
    sendRecvFIN = do
        -- Sending TCP FIN.
        ex <- E.try $ shutdown s ShutdownSend
        case ex of
          Left (E.SomeException _) -> return ()
          Right () -> do
              -- Waiting TCP FIN.
              E.bracket (mallocBytes bufSize) free $ \buf -> do
                  {-# SCC "" #-} recvEOFloop buf
  milliseconds . Taken from BSD fast clock value .
    clock = 200
    recvEOFloop buf = loop 0
      where
        loop delay = do
            -- We don't check the (positive) length.
            -- In normal case, it's 0. That is, only FIN is received.
            -- In error cases, data is available. But there is no
            -- application which can read it. So, let's stop receiving
            -- to prevent attacks.
            r <- recvBufNoWait s buf bufSize
            let delay' = delay + clock
            when (r == -1 && delay' < tmout) $ do
                threadDelay (clock * 1000)
                loop delay'
  Do n't use 4092 here . The GHC runtime takes the global lock
  if the length is over 3276 bytes in 32bit or 3272 bytes in 64bit .
    bufSize = 1024

 'ShutdownReceive', further receives are disallowed.  If it is
 | Closing a socket gracefully.
   This sends TCP FIN and check if TCP FIN is received from the peer.
   In both normal cases and error cases, socket is deallocated finally.

 Sending TCP FIN.
 Waiting TCP FIN.
# SCC "" #
 We don't check the (positive) length.
 In normal case, it's 0. That is, only FIN is received.
 In error cases, data is available. But there is no
 application which can read it. So, let's stop receiving
 to prevent attacks.
# LANGUAGE CPP #

#include "HsNetDef.h"

module Network.Socket.Shutdown (
    ShutdownCmd(..)
  , shutdown
  , gracefulClose
  ) where

import qualified Control.Exception as E
import Foreign.Marshal.Alloc (mallocBytes, free)

import Control.Concurrent (threadDelay)

import Network.Socket.Buffer
import Network.Socket.Imports
import Network.Socket.Internal
import Network.Socket.Types

data ShutdownCmd = ShutdownReceive
                 | ShutdownSend
                 | ShutdownBoth

sdownCmdToInt :: ShutdownCmd -> CInt
sdownCmdToInt ShutdownReceive = 0
sdownCmdToInt ShutdownSend    = 1
sdownCmdToInt ShutdownBoth    = 2

  | Shut down one or both halves of the connection , depending on the
  second argument to the function .   If the second argument is
  ' ShutdownSend ' , further sends are disallowed .   If it is
  ' ShutdownBoth ' , further sends and receives are disallowed .
shutdown :: Socket -> ShutdownCmd -> IO ()
shutdown s stype = void $ withFdSocket s $ \fd ->
  throwSocketErrorIfMinus1Retry_ "Network.Socket.shutdown" $
    c_shutdown fd $ sdownCmdToInt stype

foreign import CALLCONV unsafe "shutdown"
  c_shutdown :: CInt -> CInt -> IO CInt

    The second argument is time out to receive TCP FIN in millisecond .
    Since : 3.1.1.0
gracefulClose :: Socket -> Int -> IO ()
gracefulClose s tmout = sendRecvFIN `E.finally` close s
  where
    sendRecvFIN = do
        ex <- E.try $ shutdown s ShutdownSend
        case ex of
          Left (E.SomeException _) -> return ()
          Right () -> do
              E.bracket (mallocBytes bufSize) free $ \buf -> do
  milliseconds . Taken from BSD fast clock value .
    clock = 200
    recvEOFloop buf = loop 0
      where
        loop delay = do
            r <- recvBufNoWait s buf bufSize
            let delay' = delay + clock
            when (r == -1 && delay' < tmout) $ do
                threadDelay (clock * 1000)
                loop delay'
  Do n't use 4092 here . The GHC runtime takes the global lock
  if the length is over 3276 bytes in 32bit or 3272 bytes in 64bit .
    bufSize = 1024
