module Network.C10kServer (C10kServer, C10kConfig(..),
runC10kServer) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import IO hiding (catch, try)
import Network hiding (accept)
import Network.Socket hiding (accept)
import Network.TCPInfo
import Prelude hiding (catch)
import System.Posix.Process
import System.Posix.Signals
import System.Posix.User
import System.Exit
type C10kServer = 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 = do
initHook cnf `catch` ignore
initServer srv 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 :: C10kServer -> C10kConfig -> IO ()
initServer srv cnf = do
let port = Service $ portName cnf
n = preforkProcessNumber cnf
pidf = pidFile cnf
s <- listenOn port
setGroupUser
preFork s n srv 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 :: Socket -> Int -> C10kServer -> C10kConfig -> IO ()
preFork s n srv cnf = do
ignoreSigChild
pid <- getProcessID
cids <- replicateM n $ forkProcess (runServer s srv 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 :: Socket -> C10kServer -> C10kConfig -> IO ()
runServer s srv cnf = do
startedHook cnf
mvar <- newMVar 0
dispatchOrSleep mvar s srv cnf
dispatchOrSleep :: MVar Int -> Socket -> C10kServer -> C10kConfig -> IO ()
dispatchOrSleep mvar s srv cnf = do
n <- howMany
if n > threadNumberPerProcess cnf
then sleep (sleepTimer cnf * microseconds)
else dispatch
dispatchOrSleep mvar s srv cnf
where
dispatch = do
(hdl,tcpi) <- accept s
increase
forkIO $ srv hdl tcpi `finally` (decrease >> hClose hdl)
return ()
howMany = readMVar mvar
increase = modifyMVar_ mvar (return . succ)
decrease = modifyMVar_ mvar (return . pred)
sleep = threadDelay
ignore :: SomeException -> IO ()
ignore _ = return ()
microseconds :: Int
microseconds = 1000000