module Network.C10kServer (
C10kConfig(..)
, C10kServer, runC10kServer
, C10kServerH, runC10kServerH
) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import IO hiding (catch, try)
import Network hiding (accept)
import Network.Socket
import Prelude hiding (catch)
import Network.TCPInfo hiding (accept)
import qualified Network.TCPInfo as T (accept)
import System.Posix.Process
import System.Posix.Signals
import System.Posix.User
import System.Exit
type C10kServer = Socket -> IO ()
type C10kServerH = Handle -> TCPInfo -> IO ()
data C10kConfig = C10kConfig {
initHook :: IO ()
, exitHook :: String -> IO ()
, parentStartedHook :: IO ()
, startedHook :: IO ()
, sleepTimer :: Int
, preforkProcessNumber :: Int
, threadNumberPerProcess :: Int
, portName :: ServiceName
, pidFile :: FilePath
, user :: String
, group :: String
}
runC10kServer :: C10kServer -> C10kConfig -> IO ()
runC10kServer srv cnf = runC10kServer' (dispatchS srv) cnf
runC10kServerH :: C10kServerH -> C10kConfig -> IO ()
runC10kServerH srv cnf = runC10kServer' (dispatchH srv) cnf
runC10kServer' :: (Socket -> Dispatch) -> C10kConfig -> IO ()
runC10kServer' sDispatch cnf = do
initHook cnf `catch` ignore
initServer sDispatch cnf `catch` errorHandle
parentStartedHook cnf `catch` ignore
doNothing
where
errorHandle :: SomeException -> IO ()
errorHandle e = do
exitHook cnf (show e)
exitFailure
doNothing = do
threadDelay $ 5 * microseconds
doNothing
initServer :: (Socket -> Dispatch) -> C10kConfig -> IO ()
initServer sDispatch cnf = do
let port = Service $ portName cnf
n = preforkProcessNumber cnf
pidf = pidFile cnf
s <- listenOn port
setGroupUser
preFork n (sDispatch s) cnf
sClose s
writePidFile pidf
where
writePidFile pidf = do
pid <- getProcessID
writeFile pidf $ show pid ++ "\n"
setGroupUser = do
uid <- getRealUserID
when (uid == 0) $ do
getGroupEntryForName (group cnf) >>= setGroupID . groupID
getUserEntryForName (user cnf) >>= setUserID . userID
preFork :: Int -> Dispatch -> C10kConfig -> IO ()
preFork n dispatch cnf = do
ignoreSigChild
pid <- getProcessID
cids <- replicateM n $ forkProcess (runServer dispatch cnf)
mapM_ (terminator pid cids) [sigTERM,sigINT]
where
ignoreSigChild = installHandler sigCHLD Ignore Nothing
terminator pid cids sig = installHandler sig (Catch (terminate pid cids)) Nothing
terminate pid cids = do
mapM_ terminateChild cids
signalProcess killProcess pid
terminateChild cid = signalProcess sigTERM cid `catch` ignore
runServer :: Dispatch -> C10kConfig -> IO ()
runServer dispatch cnf = do
startedHook cnf
mvar <- newMVar 0
dispatchOrSleep mvar dispatch cnf
dispatchOrSleep :: MVar Int -> Dispatch -> C10kConfig -> IO ()
dispatchOrSleep mvar dispatch cnf = do
n <- howMany
if n > threadNumberPerProcess cnf
then sleep (sleepTimer cnf * microseconds)
else dispatch increase decrease
dispatchOrSleep mvar dispatch cnf
where
howMany = readMVar mvar
increase = modifyMVar_ mvar (return . succ)
decrease = modifyMVar_ mvar (return . pred)
sleep = threadDelay
type Dispatch = IO () -> IO () -> IO ()
dispatchS :: C10kServer -> Socket -> Dispatch
dispatchS srv sock inc dec = do
(connsock,_) <- accept sock
inc
forkIO $ srv connsock `finally` (dec >> sClose connsock)
return ()
dispatchH :: C10kServerH -> Socket -> Dispatch
dispatchH srv sock inc dec = do
(hdl,tcpi) <- T.accept sock
inc
forkIO $ srv hdl tcpi `finally` (dec >> hClose hdl)
return ()
ignore :: SomeException -> IO ()
ignore _ = return ()
microseconds :: Int
microseconds = 1000000