module System.Restricted.Worker
(
module System.Restricted.Worker.Types
, module System.Restricted.Worker.Pool
, module System.Restricted.Worker.Protocol
, mkDefaultWorker
, startWorker
, startIOWorker
, killWorker
, workerAlive
, connectToWorker
) where
import Prelude hiding (mapM_)
import Control.Monad (forever)
import Control.Monad.Base (MonadBase (..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Foldable (mapM_)
import Data.Typeable ()
import Network (Socket, accept)
import System.IO (Handle)
import System.Posix.User (getEffectiveUserID,
setEffectiveUserID)
import System.Restricted.Limits
import System.Restricted.Types
import System.Restricted.Worker.Internal
import System.Restricted.Worker.Pool
import System.Restricted.Worker.Protocol
import System.Restricted.Worker.Types
mkDefaultWorker :: String -> FilePath -> LimitSettings -> Worker a
mkDefaultWorker name sock set = Worker
{ workerName = name
, workerSocket = sock
, workerLimits = set
, workerPid = Nothing
}
startWorker :: (WorkerData w, MonadIO (WMonad w),
MonadBase (WMonad w) m)
=> String
-> FilePath
-> Maybe (IO Handle)
-> LimitSettings
-> WMonad w (WData w)
-> (WData w -> Socket -> IO ())
-> WMonad w (Worker w, RestartWorker m w)
startWorker name sock out set pre cb = do
let defW = mkDefaultWorker name sock set
let restarter !w = do
w' <- liftIO $ killWorker w
oldId <- liftIO $ getEffectiveUserID
liftIO $ mapM_ setEffectiveUserID (processUid set)
dat <- pre
pid <- liftIO $ forkWorker w' out (cb dat)
liftIO $ setEffectiveUserID oldId
liftIO $ setCGroup set pid
let w'' = w' { workerPid = Just pid }
w'' `seq` return w''
w' <- restarter defW
return (w', liftBase . restarter)
startIOWorker :: String
-> LimitSettings
-> FilePath
-> (Handle -> IO ())
-> IO (Worker IOWorker, RestartWorker IO IOWorker)
startIOWorker name set sock callb = startWorker name sock out set preFork handle
where handle () soc = forever $ do
(hndl, _, _) <- accept soc
callb hndl
out = Nothing
preFork = putStrLn ("Starting worker " ++ show name)
>> return ()