Demo for new thundering herd on epoll with non-blocking listening socket.

gistfile1.hs

{-
  Thundering herd on epoll with a non-blocking listening socket.
  Compile: ghc -O ThunderingHerd.hs -threaded
  Run this and do "telnet localhost 3000" to see new thundering herd.
-}

module Main where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Network
import Network.Socket
import Network.Socket.Internal
import System.Posix

main :: IO ()
main = handle handler $ do
    ignoreSigChild
    sock <- listenOn (PortNumber 3000)
    replicateM_ 4 $ void . forkProcess $ child sock
    sClose sock
    loop
    
child :: Socket -> IO ()
child (MkSocket s family _ _ _) = handle handler $ do
    putStrLn $ "waiting for a listen socket -- " ++ show s
    threadWaitRead (fromIntegral s)   
    let sz = sizeOfSockAddrByFamily family
    res <- allocaBytes sz $ \sockaddr ->
              with (fromIntegral sz) $ \ptr_len -> 
                  c_accept s sockaddr ptr_len
    if res /= -1 then
        putStrLn $ "accteped: " ++ show res
      else
        putStrLn $ "accteped failed (thundering herd!)"

handler :: SomeException -> IO ()
handler e = do
    pid <- getProcessID
    putStrLn $ show pid ++ ": " ++ show e

loop :: IO ()
loop = threadDelay 10000000 >> loop

ignoreSigChild :: IO ()
ignoreSigChild = void $ installHandler sigCHLD Ignore Nothing

foreign import ccall unsafe "accept"
  c_accept :: CInt -> Ptr SockAddr -> Ptr CInt{-CSockLen???-} -> IO CInt