diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Dan Frumin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dan Frumin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,73 @@ +# Restricted Workers Library + +This library provides an abstract interface for running various kinds +of workers under resource restrictions. It was originally developed as +part of the +interactive-diagrams () +project. You can read more about security restrictions in the wiki: + +The library provides a convenient way of running worker processes, +saving data obtained by the workers at start-up, a simple pool +abstraction and a configurable security and resource limitations. + +Right now there are several kinds of security restrictions that could +be applied to the worker process: + +- RLimits +- chroot jail +- custom process euid +- cgroups +- process niceness +- SELinux security context + +# Documentation + +The easiest way to get a grip of the restricted-workers library is to +look at the examples below showing off the basic concepts of the +library. Another good idea would be to read haddock documentations +which feature comments for each exported function and type in the +library. Do not hesitate to bug me if you think that the documentation +in some places can be improved. + +## Examples + +The following examples will walk you through creating basic kinds of +workers (IOWorker), handling a pool of workers, communicating with +workers using 'System.Restricted.Workers.Protocol' and creating your +own types of workers. + +- [EchoWorker.lhs](examples/EchoWorker.lhs) - basic usage of + `IOWorker` +- [EchoPool.lhs](examples/EchoPool.lhs) - basic usage of + `Workers.Pool` +- [CommandEvalProtocol.lhs](examples/CommandEvalProtocol.lhs) - + rewriting our Echo worker to use the provided Protocol module +- [NewWorkerType.lhs](examples/NewWorkerTypes.lhs) - rolling out your + own worker types + +## Wiki page + + + +# External configurations + +Some restrictions require external configuration, below we provide +some example files for them that we use in interactive-diagrams: + +- SELinux configuration: + https://github.com/co-dan/interactive-diagrams/tree/master/selinux + + Run `build.sh` to build the policy module, then `load.sh` to load + it. Read the + [blog post](http://parenz.wordpress.com/2013/07/15/interactive-diagrams-gsoc-progress-report/) + which explains the policy. + +- CGroups: + https://github.com/co-dan/interactive-diagrams/blob/master/cgconfig.conf + + CGroups configuration is pretty straightforward. You can load the + configuration with + + ``` + cgconfigparser -l cgconfig.conf + ``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/CommandEvalProtocol.lhs b/examples/CommandEvalProtocol.lhs new file mode 100644 --- /dev/null +++ b/examples/CommandEvalProtocol.lhs @@ -0,0 +1,104 @@ +> {-# LANGUAGE DeriveGeneric #-} +> module Main where + +We already know how to define simple workers that communicate with the +client using text. But sometimes it's necessary to transfer more +complex data to the worker. We provide a simple way of tackling this +problem using the 'System.Restricted.Worker.Protocol' module. + +> import Control.Monad (forM_) +> import Control.Concurrent (threadDelay) +> import Data.Default (def) +> import Data.Serialize (Serialize) +> import GHC.Generics (Generic) +> import System.IO (BufferMode (..), Handle, hClose, +> hSetBuffering, stdin) +> +> import System.Restricted.Worker +> import System.Restricted.Worker.Protocol + +Imaging we want our worker to receive commands in the form of the +following data structure: + +> data CommandW = AddNumbers Int Int +> | Dance +> | Echo String +> | Bye +> deriving (Generic) +> +> instance Serialize CommandW where +> +> evalCommand :: CommandW -> IO () +> evalCommand (AddNumbers a b) = print $ a + b +> evalCommand Dance = putStrLn "♪ *dum* *dum* ♫" +> evalCommand (Echo s) = putStrLn s +> evalCommand Bye = return () + +If we want to be able to use 'Worker.Protocol' with our data-types we +must define 'Serialize' instances for them. 'Serialize' is a typeclass +from the 'cereal' package and usually you can use the default +implementation (as you have seen above) as long as you can derive +'Generic' for your data-types. + +After we are done with our type we can go on defining our handler. +'System.Restricted.Worker.Protocol' provides us with useful functions +for sending and receiving data: + +```haskell +-- | Send some serialiazable data over a handle. +-- Returns 'ByteString' representing the encoded data. May throw +-- 'ProtocolException' +sendData :: Serialize a => Handle -> a -> IO ByteString + +-- | Read the data from a handle and deserialize it. +-- May throw 'ProtocolException' +getData :: Serialize a => Handle -> IO a +``` + +Let's try to implement our handler in terms of those functions. + +> cmdHandler :: Handle -> IO () +> cmdHandler hndl = loop =<< getData hndl +> where +> loop Bye = hClose hndl +> loop cmd = evalCommand cmd >> getData hndl >>= loop + +Our worker evaluates incoming commands until it hits 'Bye'. + +Now let's implement the part of our program that would send commands to the worker: + +> sendCommands :: Worker IOWorker -> [CommandW] -> IO () +> sendCommands worker cmds = do +> hndl <- connectToWorker worker +> forM_ cmds (sendData hndl) +> sendData hndl Bye +> return () + +In the code above we are using 'connectToWorker' function from +'Worker.Internal', which simply connects to the active worker and +returns a handle for communication. + +In the main function we delay for 80000 before killing the worker (or exiting) to make sure that the worker process has time to print its output. + +> main :: IO () +> main = do +> hSetBuffering stdin NoBuffering +> (worker,_) <- startIOWorker "Command Evaluator" def +> "/tmp/commandme.sock" cmdHandler +> sendCommands worker [Dance, Dance, AddNumbers 1 2, Echo "Hi", Dance] +> threadDelay 80000 +> killWorker worker +> return () + +Sample output: + +``` +$ runhaskell CommandEvalProtocol.lhs +Starting worker "Command Evaluator" + +♪ *dum* *dum* ♫ +♪ *dum* *dum* ♫ +3 +Hi +♪ *dum* *dum* ♫ +``` diff --git a/examples/EchoPool.lhs b/examples/EchoPool.lhs new file mode 100644 --- /dev/null +++ b/examples/EchoPool.lhs @@ -0,0 +1,119 @@ +> {-# LANGUAGE OverloadedStrings #-} +> module Main where + +In this example we'll take a look how to use 'System.Restricted.Worker.Pool' to create a +pool of EchoWokers. See also: 'EchoWorker.lhs'. + +> import Control.Concurrent (forkIO, threadDelay) +> import Control.Monad (forever, void) +> import qualified Data.ByteString as BS +> import Data.Default (def) +> import Data.Monoid ((<>)) +> import System.IO (Handle, stdin, hClose, +> hSetBuffering, BufferMode(..)) +> +> import System.Restricted.Worker +> import System.Restricted.Worker.Pool + +This is just the 'echoHandler' function from 'EchoWorker.lhs': + +> echoHandler :: Handle -> IO () +> echoHandler h = do +> hSetBuffering h LineBuffering +> s <- BS.hGetLine h +> BS.putStrLn $ "Got: " <> s +> BS.hPutStrLn h s +> hClose h + +Let's examine the type of 'System.Restricted.Worker.Pool.mkPool': + +```haskell +mkPool :: (Int -> IO (Worker IOWorker, RestartWorker IO IOWorker)) + -- ^ An action that creates a new worker. Takes a unique number as an argument + -> Int + -- ^ Maximum number of workers in the pool + -> Int + -- ^ Restart rate (in seconds) + -> IO (WorkersPool a) +``` + +Let's implement those parameters. + +We allow a maximum of two workers being active concurrently + +> maxWorkers :: Int +> maxWorkers = 2 + +Restart rate is how frequently we restart inactive workers. In this +case we restart inactive workers (workers not being currently used) +every 5 seconds. Normally you would specify a bigger number. + +> restartRate :: Int +> restartRate = 5 + +Now we come to the more interesting part. Implementing an action that +creats a new worker. This is callback that gets called with a unique +worker id. No two live workers share the same id. + +> newWorkerAct :: Int -> IO (Worker IOWorker, RestartWorker IO IOWorker) +> newWorkerAct uid = startIOWorker wname def wsock echoHandler +> where wname = "Worker" ++ show uid +> wsock = "/tmp/" ++ show uid ++ ".sock" + +We are ready to write code for initializing our pool: + +> main :: IO () +> main = do +> hSetBuffering stdin NoBuffering +> pool <- mkPool newWorkerAct maxWorkers restartRate +> loop pool + +Then we can write a simple control loop for out program. + +When we recieve the "new" command from stdin, we take a worker from +the pool, wait for 8 seconds so the user can interact with it from +another shell and put the worker back. + +> loop :: WorkersPool IOWorker -> IO () +> loop pool = forever $ do +> ln <- getLine +> case ln of +> "new" -> void $ forkIO $ do +> withWorker pool $ \(w,_) -> do +> putStrLn $ "Got worker " ++ +> show (workerName w) +> threadDelay 8000000 +> putStrLn $ "Putting back worker " ++ +> show (workerName w) +> _ -> putStrLn "Dunno" + + +By running the program we can see that we can have up to two +simultaneously active workers: + +``` +$ ./EchoPool +new +Starting worker "Worker1" +Got worker "Worker1" + +Putting back worker "Worker1" +Starting worker "Worker1" + +Starting worker "Worker1" + +Starting worker "Worker1" + +Starting worker "Worker1" + +new +Got worker "Worker1" +new +Starting worker "Worker2" +Got worker "Worker2" + +new +Putting back worker "Worker1" +<....> +``` + diff --git a/examples/EchoWorker.lhs b/examples/EchoWorker.lhs new file mode 100644 --- /dev/null +++ b/examples/EchoWorker.lhs @@ -0,0 +1,100 @@ +> {-# LANGUAGE OverloadedStrings #-} +> module Main where + +In this example we will take a look at 'IOWorker' and how to use it in +your programs. We will create a simple worker that would echo back to +us whatever we sent it. + +Let's start by importing some libraries + +> import qualified Data.ByteString as BS +> import Data.Default (def) +> import Data.Monoid ((<>)) +> import System.IO (BufferMode (..), Handle, hClose, +> hSetBuffering, stdin) +> +> import System.Restricted.Worker + +Let's take a look at 'startIOWorker' function: + +```haskell +startIOWorker :: String -- ^ Name + -> LimitSettings -- ^ Restrictions + -> FilePath -- ^ UNIX socket + -> (Handle -> IO ()) -- ^ Callback + -> IO (Worker IOWorker, RestartWorker IO IOWorker) +``` + +it takes a worker name, a UNIX socket filepath, callback. It returns +the worker itself together with the restarting function. + +Firstly, let's implement our callback: + +> echoHandler :: Handle -> IO () +> echoHandler h = do +> hSetBuffering h LineBuffering +> s <- BS.hGetLine h +> BS.putStr $ "Got: " <> s <> "\n" +> BS.hPutStrLn h s +> hClose h + +we are not doing anything fancy here, just getting one line of text, +printing it to stdout and sending it back. + +Now we are going to write the main loop function that would take care +of restarting the worker: + +> loop :: (Worker IOWorker, RestartWorker IO IOWorker) -> IO () +> loop (w, restart) = do +> putStrLn "Press to restart the worker" +> _ <- getChar +> w' <- restart w +> loop (w', restart) + + +and a main function: + +> main :: IO () +> main = do +> hSetBuffering stdin NoBuffering +> loop =<< startIOWorker "Testworker" def "/tmp/1.sock" echoHandler +> return () + +We can test it: + +``` +(In one shell) +$ ./EchoWorker +tarting worker "Testworker" +Press to restart the worker + +(In another shell) +$ echo -n whatsup | nc -U /tmp/1.sock +whatsup +$ echo -n test | nc -U /tmp/1.sock +test +``` + +Now in the first window we can see the following: + +``` +Starting worker "Testworker" +Press to restart the worker + +Got: whatsup +Got: test +``` + +We can press enter to restart the worker: + +``` +Starting worker "Testworker" +Press to restart the worker + +Got: whatsup +Got: test + +Starting worker "Testworker" +Press to restart the worker + +``` diff --git a/examples/NewWorkerType.lhs b/examples/NewWorkerType.lhs new file mode 100644 --- /dev/null +++ b/examples/NewWorkerType.lhs @@ -0,0 +1,183 @@ +> {-# LANGUAGE OverloadedStrings, TypeFamilies #-} +> module Main where + +In this walkthrough we will learn how to make our worker types. Let's +consider the following motivational situation. + +We want to have our worker perform some database operations based on +the commands it receives. The worker needs to connect to the database +on startup, based on some run-time information, store the connection +in memory and re-use this connection for every client that connects to +it. + +We will use the 'sqlite-simple' library for the database access. + +> import Control.Applicative ((<$>), (<*>)) +> import Control.Monad (forever) +> import Database.SQLite.Simple +> import Data.Default +> import Network (accept, Socket) +> import System.IO (hGetLine, hClose) +> +> import System.Restricted.Types (LimitSettings) +> import System.Restricted.Worker +> import System.Restricted.Worker.Types + +First of all, let's deal with abstractions for the underlying database. + +Our database would have a table called 'accounts' with columns 'id', +'name' and 'age'. We can create such a database from a shell: + +``` +$ sqlite3 one.db "CREATE TABLE accounts (id INTEGER PRIMARY KEY, \ +name text, age INTEGER);" +``` + +Some sqlite-simple boilerplate for representing our table in Haskell + +> data Account = Account Int String Int +> deriving (Show) +> +> instance FromRow Account where +> fromRow = Account <$> field <*> field <*> field +> +> type Accounts = [Account] + + +Now we are going to roll out or worker type and corresponding +WorkerData instance. + + +> data DBWorker = DBWorker +> +> instance WorkerData DBWorker where +> type WData DBWorker = Connection +> type WMonad DBWorker = IO + + +Our worker would run in the IO monad and it would store 'Connection' +between sessions. This information is provided via type families in +the 'WorkerData' typeclass. + +The next thing we should provide is the runner +function for our worker. Let's examine (a simplified) 'startWorker' +function: + +```haskell +{-| + Start a general type of worker. + + The pre-forking action is a monadic action that will be run prior to + calling 'forkWorker'. It might be some initialization code, running the + DB query, anything you want. The resulting 'WData' will be passed to + the callback. +-} +startWorker :: (WorkerData w, MonadIO (WMonad w)) + => String -- ^ Name + -> FilePath -- ^ Socket + -> Maybe (IO Handle) -- ^ Where to redirect stdout, stderr + -> LimitSettings -- ^ Restrictions + -> WMonad w (WData w) -- ^ Pre-forking action + -> (WData w -> Socket -> IO ()) -- ^ Socket callback + -> WMonad w (Worker w, RestartWorker (WMonad w) w) +``` + +Specified to 'DBWorker' the signature will be + +```haskell +startWorker :: String -- ^ Name + -> FilePath -- ^ Socket + -> Maybe (IO Handle) -- ^ Where to redirect stdout, stderr + -> LimitSettings -- ^ Restrictions + -> IO Connection -- ^ Pre-forking action + -> (Connection -> Socket -> IO ()) -- ^ Socket callback + -> IO (Worker DBWorker, RestartWorker IO DBWorker) +``` + +First of all, let's provide a callback for our type of worker: + +> dbWorkerCallb :: (String -> Query) -> (Connection -> Socket -> IO ()) +> dbWorkerCallb mkQuery conn sock = forever $ do +> (hndl, _, _) <- accept sock +> ln <- hGetLine hndl +> r <- query_ conn (mkQuery ln) :: IO Accounts +> mapM_ print r +> putStrLn "--------------------------------------------------" +> hClose hndl + +Our callback (more of a callback generator) takes a function which +converts String of incoming data to a query and performs it. The +socket that we receive is a server socket which accepts connections, +that's why we need a 'forever' above. + +All is left is to write a general runDbWorker function. + +> runDbWorker :: String -- ^ Name +> -> LimitSettings -- ^ Restrictions +> -> IO Connection -- ^ Action that gets the connection +> -> (String -> Query) -- ^ Query convertion function +> -> IO (Worker DBWorker, RestartWorker IO DBWorker) +> runDbWorker name settings initConn mkQuery = +> startWorker name path Nothing settings initConn callback +> where +> path = "/tmp/" ++ name ++ ".sock" +> callback = dbWorkerCallb mkQuery + + +To test our newly crafted worker type let's make some dummy values. + +> dummyInit :: IO Connection +> dummyInit = msg >> conn -- usually here we might want to consult a +> -- configuration file or whatnot to get the information during the +> -- run-time +> where conn = open "one.db" +> msg = putStrLn "Welcome to dummybot 2000" + +> dummyCb :: String -> Query +> dummyCb "all" = "SELECT * FROM accounts;" +> dummyCb "adults" = "SELECT * FROM accounts WHERE (age >= 18);" + + +At once we can go ahead and run our worker + +> main :: IO () +> main = do +> (dummyWorker, _) <- runDbWorker "dummy" def dummyInit dummyCb +> _ <- getLine +> killWorker dummyWorker +> return () + +Sample output: + +``` +$ sqlite3 one.db "INSERT INTO accounts (name, age) VALUES ('Bob Dole', 14)" +$ sqlite3 one.db "INSERT INTO accounts (name, age) VALUES ('Dob Bole', 15)" +$ sqlite3 one.db "INSERT INTO accounts (name, age) VALUES ('Stephen Colbert', 18)" +$ sqlite3 one.db "INSERT INTO accounts (name, age) VALUES ('Jon Steward', 24)" +$ ./NewWorkerType +Welcome to dummybot 2000 + +``` + +In another terminal window: + +``` +$ echo all | nc -U /tmp/dummy.sock +$ echo adults | nc -U /tmp/dummy.sock +``` + +Back to the first window: + +``` +<...> +Welcome to dummybot 2000 + +Account 1 "Bob Dole" 14 +Account 2 "Dob Bole" 15 +Account 3 "Stephen Colbert" 18 +Account 4 "Jon Steward" 24 +-------------------------------------------------- +Account 3 "Stephen Colbert" 18 +Account 4 "Jon Steward" 24 +-------------------------------------------------- +``` diff --git a/restricted-workers.cabal b/restricted-workers.cabal new file mode 100644 --- /dev/null +++ b/restricted-workers.cabal @@ -0,0 +1,83 @@ +name: restricted-workers +synopsis: Running worker processes under system resource restrictions +version: 0.1.0 + +description: This library provides an abstract interface for + running various kinds of workers under resource + restrictions. It was originally developed as part + of the interactive-diagrams + () + project. To read more about the idia behind the + library check out my GSoC report: + . + + . + + The library provides a convenient way of running worker processes, + saving data obtained by the workers at start-up, a simple pool + abstraction and a configurable security and resource limitations. + + Please consult + + and + + for more details. + + . + + /Warning/: this library requires SELinux to + function + +homepage: https://github.com/co-dan/interactive-diagrams/wiki/Restricted-Workers + + +author: Dan Frumin +maintainer: difrumin@gmail.com +license: BSD3 +license-file: LICENSE +copyright: (c) 2013 + +build-type: Simple +cabal-version: >=1.10 +category: System, Concurrency, Data + +extra-source-files: examples/EchoWorker.lhs, + examples/EchoPool.lhs, + examples/CommandEvalProtocol.lhs, + examples/NewWorkerType.lhs, + README.md + +library + exposed-modules: System.Restricted.Limits, + System.Restricted.Types, + System.Restricted.Worker, + System.Restricted.Worker.Internal, + System.Restricted.Worker.Pool, + System.Restricted.Worker.Protocol, + System.Restricted.Worker.Types + other-modules: SignalHandlers + ghc-options: -Wall -fno-warn-orphans + build-depends: base >=4.5 && <4.8, + async >=2.0 && <2.1, + bytestring >= 0.10 && < 0.13, + cereal >=0.3 && <0.4, + data-default >= 0.5, + directory >=1.2 && <1.3, + either >= 3.4, + filepath >= 1, + monad-control >=0.3 && <0.4, + mtl >=2.1 && <2.2, + network >=2.4 && <2.5, + selinux -any, + stm >=2.4 && <2.5, + text >= 0.10, + transformers >=0.3 && <0.4, + transformers-base >= 0.4 && <0.5, + unix >=2.6 && <2.8 + hs-source-dirs: src + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/co-dan/interactive-diagrams + diff --git a/src/SignalHandlers.hs b/src/SignalHandlers.hs new file mode 100644 --- /dev/null +++ b/src/SignalHandlers.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} + +module SignalHandlers where + +#if !defined(mingw32_HOST_OS) + +import System.Posix.Signals + +restoreHandlers :: IO () +restoreHandlers = do + mapM_ restore [sigQUIT, sigINT, sigHUP, sigTERM] + putStrLn "" -- for some reason, restoring handlers often fails without this + where + restore s = installHandler s Default Nothing + +#else + +restoreHandlers :: IO () +restoreHandlers = return () + +#endif diff --git a/src/System/Restricted/Limits.hs b/src/System/Restricted/Limits.hs new file mode 100644 --- /dev/null +++ b/src/System/Restricted/Limits.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE RecordWildCards #-} +-- | The implementation of security restrictions +module System.Restricted.Limits + ( + -- * Apply restrictions + setLimits + -- * Individual limits + , setRLimits + , chroot + , changeUserID + , setCGroup + , setupSELinuxCntx + , processTimeout + ) where + +import Prelude hiding (mapM_) + +import Control.Applicative ((<$>)) +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Data.Foldable (mapM_) +import Data.List (intersperse) +import Data.Monoid (mconcat) +import Foreign.C +import Foreign.C.Types +import System.FilePath.Posix (()) +import System.Linux.SELinux (SecurityContext, getCon, setCon) +import System.Posix.Directory (changeWorkingDirectory) +import System.Posix.Process (nice) +import System.Posix.Resource (setResourceLimit) +import System.Posix.Resource (Resource (..)) +import System.Posix.Signals (killProcess, signalProcess) +import System.Posix.Types (CUid (..), ProcessID, UserID) +import System.Posix.User (getEffectiveUserID, setEffectiveUserID, + setUserID) + +import SignalHandlers +import System.Restricted.Types + + +-- | Waits for a certain period of time +-- and then kills the process +processTimeout :: ProcessID -- ^ ID of a process to be killed + -> Int -- ^ Time limit (in seconds) + -> IO () +processTimeout pid lim = do + threadDelay (lim * 1000000) + signalProcess killProcess pid + return () + + +foreign import ccall unsafe "unistd.h chroot" + c_chroot :: CString -> IO CInt + +-- | Set the chroot jail +chroot :: FilePath -> IO () +chroot fp = do + eid <- getEffectiveUserID + setUserID (CUid 0) + withCString fp $ \c_fp -> do + _ <- throwErrnoIfMinus1 "chroot" (c_chroot c_fp) + changeWorkingDirectory "/" + return () + setEffectiveUserID eid + +-- | Change the uid of the current process +changeUserID :: UserID -> IO () +changeUserID uid = do + setUserID (CUid 0) -- need to be root in order to setuid() + setUserID uid + +-- | Add a process to a cgroup +setCGroup :: LimitSettings + -> ProcessID -- ^ The ID of a process to be added to the group + -> IO () +setCGroup LimitSettings{..} pid = + mapM_ (\fp -> writeFile (fp "tasks") $ show pid) cgroupPath + + +-- | Set rlimits using setrlimit syscall +setRLimits :: RLimits -> IO () +setRLimits RLimits{..} = mapM_ (uncurry setResourceLimit) lims + where lims = [ (ResourceCoreFileSize, coreFileSizeLimit) + , (ResourceCPUTime, cpuTimeLimit) + , (ResourceDataSize, dataSizeLimit) + , (ResourceFileSize, fileSizeLimit) + , (ResourceOpenFiles, openFilesLimit) + -- , (ResourceStackSize, stackSizeLimit) + , (ResourceTotalMemory, totalMemoryLimit) ] + +-- | Set the security context. +-- To be more precise, it only sets up the type. +-- Example usage: +-- +-- > setupSELinuxCntx "my_restricted_t" + +-- SELinx context has the following format +-- user:role:type:level +-- we only modify the type part +setupSELinuxCntx :: SecurityContext -> IO () +setupSELinuxCntx ty = do + con <- splitBy (==':') <$> getCon + when (length con < 4) $ error ("Bad context: " ++ mconcat (intersperse ":" con)) + setCon $ mconcat $ intersperse ":" [con !! 0, con !! 1, ty, con !! 3] + +-- | @splitBy (==x)@ is an inverse of @'intersperse' [x]@ +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy _ [] = [] +splitBy f (x:xs) + | f x = splitBy f xs + | otherwise = s : splitBy f s' + where (s, s') = break f (x:xs) + +-- | Apply the 'LimitSettings' +setLimits :: LimitSettings -> IO () +setLimits LimitSettings{..} = do + mapM_ setRLimits rlimits + mapM_ setupSELinuxCntx secontext + nice niceness + mapM_ chroot chrootPath + mapM_ changeUserID processUid + restoreHandlers diff --git a/src/System/Restricted/Types.hs b/src/System/Restricted/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Restricted/Types.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +module System.Restricted.Types + ( + -- * Limit settings + LimitSettings(..) + , RLimits(..) + , defaultLimits + ) where + + +import Data.Default +import Data.Serialize (Serialize) +import GHC.Generics +import System.Linux.SELinux (SecurityContext) +import System.Posix.Resource (Resource (..), ResourceLimit (..), + ResourceLimits (..)) +import System.Posix.Types (CUid (..), UserID) + + +-- | Resource limits +data RLimits = RLimits + { coreFileSizeLimit :: ResourceLimits + , cpuTimeLimit :: ResourceLimits + , dataSizeLimit :: ResourceLimits + , fileSizeLimit :: ResourceLimits + , openFilesLimit :: ResourceLimits + , stackSizeLimit :: ResourceLimits + , totalMemoryLimit :: ResourceLimits + } deriving (Eq, Show, Generic) + +deriving instance Show ResourceLimits +deriving instance Show ResourceLimit +deriving instance Show Resource +deriving instance Generic ResourceLimit +deriving instance Generic ResourceLimits +instance Serialize ResourceLimit +instance Serialize ResourceLimits +instance Serialize RLimits + +-- | Datastructure that holds the information about restrictions and +-- limitations for the worker process +data LimitSettings = LimitSettings + { -- | Maximum time for which the code is allowed to run + -- (in seconds) + timeout :: Int + -- | Process priority for the 'nice' syscall. + -- -20 is the highest, 20 is the lowest + , niceness :: Int + -- | Resource limits for the 'setrlimit' syscall + , rlimits :: Maybe RLimits + -- | The directory that the evaluator process will be 'chroot'ed + -- into. Please note that if chroot is applied, all the pathes + -- in 'EvalSettings' will be calculated relatively to this + -- value. + , chrootPath :: Maybe FilePath + -- | The UID that will be set after the call to chroot. + , processUid :: Maybe UserID + -- | SELinux security context under which the worker + -- process will be running. + , secontext :: Maybe SecurityContext + -- | A filepath to the 'tasks' file for the desired cgroup. + -- + -- For example, if I have mounted the @cpu@ controller at + -- @/cgroups/cpu/@ and I want the evaluator to be running in the + -- cgroup 'idiaworkers' then the 'cgroupPath' would be + -- @/cgroups/cpu/idiaworkers@ + , cgroupPath :: Maybe FilePath + } deriving (Eq, Show, Generic) + +deriving instance Generic CUid +instance Serialize CUid +instance Serialize LimitSettings + +-- | Default 'LimitSettings' +defaultLimits :: LimitSettings +defaultLimits = LimitSettings + { timeout = 3 + , niceness = 10 + , rlimits = Nothing + , chrootPath = Nothing + , processUid = Nothing + , secontext = Nothing -- Just "idia_restricted_t" + , cgroupPath = Nothing + } + +instance Default LimitSettings where + def = defaultLimits + +instance Default RLimits where + def = RLimits + { coreFileSizeLimit = mkLimits (coreSizeLimitSoft, coreSizeLimitHard) + , cpuTimeLimit = mkLimits (cpuTimeLimitSoft, cpuTimeLimitHard) + , dataSizeLimit = mkLimits (dataSizeLimitSoft, dataSizeLimitHard) + , fileSizeLimit = mkLimits (fileSizeLimitSoft, fileSizeLimitHard) + , openFilesLimit = mkLimits (openFilesLimitSoft, openFilesLimitHard) + , stackSizeLimit = mkLimits (stackSizeLimitSoft, stackSizeLimitHard) + , totalMemoryLimit = mkLimits (totalMemoryLimitSoft, totalMemoryLimitHard) + } + + +mkLimits :: (ResourceLimit, ResourceLimit) -> ResourceLimits +mkLimits = uncurry ResourceLimits + +--- This snippet is taken from the mueval package +-- (c) Gwern Branwen + + +-- | Set all the available rlimits. +-- These values have been determined through trial-and-error +stackSizeLimitSoft, stackSizeLimitHard, totalMemoryLimitSoft, totalMemoryLimitHard, + dataSizeLimitSoft, openFilesLimitSoft, openFilesLimitHard, fileSizeLimitSoft, fileSizeLimitHard, + dataSizeLimitHard, cpuTimeLimitSoft, cpuTimeLimitHard, coreSizeLimitSoft, coreSizeLimitHard, zero :: ResourceLimit +totalMemoryLimitSoft = dataSizeLimitSoft +totalMemoryLimitHard = dataSizeLimitHard +-- These limits seem to be useless? +stackSizeLimitSoft = ResourceLimitUnknown +stackSizeLimitHard = ResourceLimitUnknown +-- We allow a few files to be opened, such as package.conf, because they are necessary. This +-- doesn't seem to be security problem because it'll be opened at the module +-- stage, before code ever evaluates. I hope. +openFilesLimitSoft = ResourceLimit 20 +openFilesLimitHard = ResourceLimit 50 +-- TODO: It would be nice to set these to zero, but right now Hint gets around the +-- insecurity of the GHC API by writing stuff out to a file in /tmp, so we need +-- to allow our compiled binary to do file I/O... :( But at least we can still limit +-- how much we write out! +fileSizeLimitSoft = fileSizeLimitHard +fileSizeLimitHard = ResourceLimitUnknown +dataSizeLimitSoft = dataSizeLimitHard +dataSizeLimitHard = ResourceLimit $ 104857600 * 5 -- 100 * 5 mb +-- These should not be identical, to give the XCPU handler time to trigger +cpuTimeLimitSoft = ResourceLimit 4 +cpuTimeLimitHard = ResourceLimit 5 +coreSizeLimitSoft = coreSizeLimitHard +coreSizeLimitHard = zero + +-- convenience +zero = ResourceLimit 0 + + diff --git a/src/System/Restricted/Worker.hs b/src/System/Restricted/Worker.hs new file mode 100644 --- /dev/null +++ b/src/System/Restricted/Worker.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | Main entry point of the library +module System.Restricted.Worker + ( + -- * Exposed modules + module System.Restricted.Worker.Types + , module System.Restricted.Worker.Pool + , module System.Restricted.Worker.Protocol + -- * Creating workers + , mkDefaultWorker + , startWorker + , startIOWorker + -- * Quering and killing workers + , 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 + +-- | Create an uninitialized worker +mkDefaultWorker :: String -> FilePath -> LimitSettings -> Worker a +mkDefaultWorker name sock set = Worker + { workerName = name + , workerSocket = sock + , workerLimits = set + , workerPid = Nothing + } + + +{-| + Start a general type of worker. + + The pre-forking action is a monadic action that will be run prior to + calling 'forkWorker'. It might be some initialization code, running the + DB query, anything you want. The resulting 'WData' will be passed to + the callback. + + The socket that is passed to the callback is a server socket. +-} +startWorker :: (WorkerData w, MonadIO (WMonad w), + MonadBase (WMonad w) m) + => String -- ^ Name + -> FilePath -- ^ Socket + -> Maybe (IO Handle) -- ^ Where to redirect stdout, stderr + -> LimitSettings -- ^ Restrictions + -> WMonad w (WData w) -- ^ Pre-forking action + -> (WData w -> Socket -> IO ()) -- ^ Socket callback + -> 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) + -- this is necessary so that the control socket is accessible by + -- non-root processes, probably a hack + 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) + + +-- | Start a worker of type 'IOWorker' +-- The callback function is called every time a connectino is established +-- +-- >>> startIOWorker "test" "/tmp/test.sock" $ \h -> hPutStrLn h "hello, world" +-- +startIOWorker :: String -- ^ Name + -> LimitSettings -- ^ Restrictions + -> FilePath -- ^ UNIX socket + -> (Handle -> IO ()) -- ^ Callback + -> 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 () + diff --git a/src/System/Restricted/Worker/Internal.hs b/src/System/Restricted/Worker/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Restricted/Worker/Internal.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Library exposing internal functions uses by 'Eval.Worker' +-- useful work writing your own workers +module System.Restricted.Worker.Internal + ( + -- * Worker related + killWorker + , workerAlive + , workerTimeout + , forkWorker + -- * Connection related + , connectToWorker + , mkSock + -- * Useful util functions + , removeFileIfExists + , processAlive + ) where + +import Control.Concurrent (threadDelay) +import Control.Exception (IOException, catch, handle, throwIO) +import Control.Monad (void, when) +import Data.Maybe (fromJust) +import Network (PortID (..), Socket, connectTo, listenOn) +import Network.Socket (close) +import System.Directory (removeFile) +import System.IO (Handle) +import System.IO.Error (isDoesNotExistError, isPermissionError) +import System.Mem.Weak (addFinalizer) +import System.Posix.IO (dupTo, handleToFd) +import System.Posix.Process (forkProcess, getProcessStatus) +import System.Posix.Signals (Handler (..), installHandler, + killProcess, processStatusChanged, + setStoppedChildFlag, signalProcess) +import System.Posix.Types (Fd (..), ProcessID) + +import System.Restricted.Limits +import System.Restricted.Worker.Types + +-- | Connect to the worker's socket and return a handle +connectToWorker :: Worker a -> IO Handle +connectToWorker Worker{..} = connectTo "localhost" (UnixSocket workerSocket) + +-- | Remove a file if it exists. Should be thread-safe. +removeFileIfExists :: FilePath -> IO () +removeFileIfExists f = removeFile f `catch` handleE + where handleE e + | isDoesNotExistError e = return () + | isPermissionError e = return () + | otherwise = putStrLn ("removeFileIfExists " ++ show e) + >> throwIO e + +-- | Create a new unix socket +mkSock :: FilePath -> IO Socket +mkSock sf = do + removeFileIfExists sf + listenOn (UnixSocket sf) + +-- | Fork a worker process +forkWorker :: Worker a + -> Maybe (IO Handle) -- ^ Where to redirect stdout + -> (Socket -> IO ()) -- ^ Callback funcion + -> IO ProcessID +forkWorker (w@Worker{..}) out cb = do + _ <- setStoppedChildFlag True + _ <- installHandler processStatusChanged Ignore Nothing + soc <- mkSock workerSocket + addFinalizer w (close soc) + forkProcess $ do + _ <- setStoppedChildFlag False + _ <- installHandler processStatusChanged Default Nothing + setLimits workerLimits + case out of + Nothing -> return () + Just x -> do + fd <- handleToFd =<< x + void $ dupTo fd (Fd 1) + cb soc + + + +-- | Kill a worker. Takes an initialized worker, +-- returns non-initialized one. +killWorker :: Worker a -> IO (Worker a) +killWorker w@Worker{..} = do + when (initialized w) $ do + alive <- processAlive (fromJust workerPid) + when alive $ do + signalProcess killProcess (fromJust workerPid) + tc <- getProcessStatus False False (fromJust workerPid) + case tc of + Just _ -> return () + Nothing -> signalProcess killProcess (fromJust workerPid) + return (w { workerPid = Nothing }) + +-- | Waits for a certain period of time +-- and then kills the worker +workerTimeout :: Worker a -- ^ ID of a process to be killed + -> Int -- ^ Time limit (in seconds) + -> IO (Worker a) +workerTimeout w lim = do + threadDelay (lim * 1000000) + killWorker w + + +----------------------- + +-- | Checks whether the process is alive +-- /hacky/ +processAlive :: ProcessID -> IO Bool +processAlive pid = handle (\(_ :: IOException) -> return False) $ do + _ <- getProcessStatus False False pid + return True + +-- | Checks whether the worker is alive +workerAlive :: Worker a -> IO Bool +workerAlive w = do + case (workerPid w) of + Nothing -> return False + Just pid -> processAlive pid + diff --git a/src/System/Restricted/Worker/Pool.hs b/src/System/Restricted/Worker/Pool.hs new file mode 100644 --- /dev/null +++ b/src/System/Restricted/Worker/Pool.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} + +-- | A non-stripped pooling abstraction that restarts workers +-- Some got has been taken from 'Data.Pool' by bos +module System.Restricted.Worker.Pool + ( + -- * Workers Pool + WorkersPool + , mkPool + -- * High-level operations on the pool + , withWorker + -- * Low-level operations on the pool + , takeWorker + , putWorker + , destroyWorker + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Concurrent.STM +import Control.Exception (mask, onException) +import Control.Monad (forM, forever, join, when) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Trans.Control (MonadBaseControl, control) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.Mem.Weak (addFinalizer) + +import System.Restricted.Worker.Internal +import System.Restricted.Worker.Types + +-- | A simple pool for workers. Workers are restarted from time to time +data WorkersPool w = Pool + { newWorker :: Int -> WMonad w (Worker w, RestartWorker IO w) + -- ^ Action for creating a new worker + , maxWorkers :: Int + -- ^ Maximum number of initialized workers + , activeWorkers :: TVar Int + -- ^ Current number of active workers + , workers :: TVar [(Worker w, RestartWorker IO w)] + -- ^ A list of Workers + , restartRate :: Int + -- ^ How long we should wait before restarting the workers (in seconds) + } + + +-- | Create a new workers pool +mkPool :: (MonadIO (WMonad a)) + => (Int -> WMonad a (Worker a, RestartWorker IO a)) + -- ^ An action that creates a new worker. Takes a unique number as an argument + -> Int + -- ^ Maximum number of workers in the pool + -> Int + -- ^ Restart rate (in seconds) + -> WMonad a (WorkersPool a) +mkPool newW maxW restartRate = do + res <- liftIO $ atomically $ newTVar [] + num <- liftIO $ atomically $ newTVar (0 :: Int) + reaperT <- liftIO $ forkIO $ reaper res restartRate + let p = Pool newW maxW num res restartRate + liftIO $ addFinalizer p (killThread reaperT) + return p + + +reaper :: TVar [(Worker a, RestartWorker IO a)] -> Int -> IO () +reaper wrkrs t' = forever $ do + let t = t' * 1000000 + threadDelay t + workers <- readTVarIO wrkrs + workers' <- forM workers $ \(w, rw) -> (,) <$> rw w <*> return rw + atomically $ writeTVar wrkrs workers' + + +-- | Take worker from the pool. +-- The caller is responsible for putting the worker back into the pool +-- or destroying it with 'destroyWorker' +takeWorker :: (MonadIO (WMonad a), MonadBaseControl IO (WMonad a)) + => WorkersPool a -> WMonad a (Worker a, RestartWorker IO a) +takeWorker Pool{..} = do + res <- liftIO $ readTVarIO workers + case res of + ((w@Worker{..}, restartW):xs) -> liftIO $ do + atomically $ writeTVar workers xs + workerDead <- not <$> workerAlive w + wrk <- if workerDead + then do + restartW w + else return w + return (wrk, restartW) + [] -> join $ liftIO . atomically $ do + activeRes <- readTVar activeWorkers + when (activeRes >= maxWorkers) retry + modifyTVar' activeWorkers (+1) + return $ control $ \runIO -> + runIO (newWorker (activeRes+1)) + `onException` + atomically (modifyTVar' activeWorkers (subtract 1)) + +-- | Put the worker back in pool +putWorker :: WorkersPool a -> (Worker a, RestartWorker IO a) -> IO () +putWorker Pool{..} w = atomically $ + modifyTVar' workers (w:) + +-- | Destroy a worker. Frees up space in the pool +destroyWorker :: WorkersPool a -> Worker a -> IO () +destroyWorker Pool{..} w = do + _ <- killWorker w + atomically $ modifyTVar' activeWorkers (subtract 1) + + +-- | Like 'takeWorker' + 'putWorker' but takes care of the exception handling for you +withWorker :: (MonadBaseControl IO m, MonadBase (WMonad a) m, + MonadBaseControl IO (WMonad a), MonadIO (WMonad a)) + => WorkersPool a + -> ((Worker a, RestartWorker IO a) -> m b) + -> m b +withWorker pool cb = do + res <- liftBase $ takeWorker pool + control $ \runIO -> mask $ \restore -> do + ret <- restore (runIO (cb res)) + `onException` destroyWorker pool (fst res) + putWorker pool res + return ret + diff --git a/src/System/Restricted/Worker/Protocol.hs b/src/System/Restricted/Worker/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/System/Restricted/Worker/Protocol.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | A simple protocol for sending serializable data over handles +-- +-- Please note that this is a very simple implementation that works +-- fine for most of that data, however, the size of the data you might +-- send at one go is limited to MAX_WORD32 bytes. We use 'cereal' for +-- serialization. +module System.Restricted.Worker.Protocol + ( + sendData + , getData + , getDataSafe + , DecodeResult + , ProtocolException(..) + ) where + +import Control.Applicative ((<$>)) +import Control.Exception (IOException, catch, throw) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Either (hoistEither, left, runEitherT) +import Data.ByteString (ByteString, hGet, hPut) +import qualified Data.ByteString as BS +import Data.Serialize (Serialize, decode, encode) +import Data.Word (Word32) +import GHC.IO.Handle (Handle, hFlush) + +import System.Restricted.Worker.Types + +-- | Result of the deserialization +type DecodeResult a = Either String a + +-- | Send some serialiazable data over a handle. +-- Returns 'ByteString' representing the encoded data. May throw +-- 'ProtocolException' +sendData :: Serialize a => Handle -> a -> IO ByteString +sendData h d = sendData' h d + `catch` \(e :: IOException) -> + throw (HandleException e) + +-- | Read the data from a handle and deserialize it. +-- May throw 'ProtocolException' +getData :: Serialize a => Handle -> IO a +getData h = getData' h + `catch` \(e :: IOException) -> + throw (HandleException e) + + +sendData' :: Serialize a => Handle -> a -> IO ByteString +sendData' hndl datum = do + let encoded = encode datum + let len = (fromIntegral . BS.length $ encoded) :: Word32 + hPut hndl (encode len) + hFlush hndl + hPut hndl encoded + hFlush hndl + return encoded + +getData' :: Serialize a => Handle -> IO a +getData' hndl = do + lenD :: DecodeResult Word32 <- decode <$> hGet hndl 4 + let len = case lenD of + Right i -> fromIntegral i + Left str -> throw (ConversionException $ "length\n" ++ str) + res <- decode <$> hGet hndl len + case res of + Left str -> throw (ConversionException $ "Deserialization error:\n" ++ str) + Right x -> return x + +-- | Safe version of 'getData' that doesn't throw 'ProtocolException' +getDataSafe :: Serialize a => Handle -> IO (DecodeResult a) +getDataSafe hndl = runEitherT $ do + lenD :: DecodeResult Word32 <- decode <$> lift (hGet hndl 4) + case lenD of + Left str -> left $ "Conversion error while reading length: " ++ str + Right len -> + hoistEither =<< decode <$> (lift (hGet hndl (fromIntegral len))) + diff --git a/src/System/Restricted/Worker/Types.hs b/src/System/Restricted/Worker/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Restricted/Worker/Types.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-| + Worker can be in one of three states + + [Uninitialized] Uninitialized worker is a worker that has a name, + a socket, possibly 'WData' but has not been forker + + [Initialized] Initialized worker has an associated forker process. + + [Active] A worker is active if it's initialized and it's being used + a client. Active/inactive workers are managed by a 'WorkersPool'. +-} +module System.Restricted.Worker.Types + ( + -- * Workers + Worker(..) + , RestartWorker + , WorkerData(..) + , IOWorker + -- * Other types + , ProtocolException(..) + -- * Helper functions + , initialized + ) where + +import Control.Exception (Exception, IOException) +import Data.Maybe (isJust) +import Data.Serialize (Serialize) +import Data.Typeable +import GHC.Generics +import System.Posix.Types (CPid (..), ProcessID) + +import System.Restricted.Types + +-- | A worker restarting function +type RestartWorker m a = Worker a -> m (Worker a) + +-- | A datatype representing a worker of type 'a' +data Worker a = Worker + { -- | Name of the worker + workerName :: String + -- | A filepath to the Unix socket that will be + -- used for communicating with the worker. + -- If the file is already present it will be unliked + -- during the initializatin step + , workerSocket :: FilePath + -- | Security restrictions for the worker + , workerLimits :: LimitSettings + -- | 'Just pid' if the worker's process ID is 'pid', + -- Nothing' if the worker is not active/initialized + , workerPid :: Maybe ProcessID + } deriving (Show, Eq, Typeable, Generic) + +deriving instance Generic CPid +instance Serialize CPid +instance Serialize (Worker a) + +-- | Types of data attached to a worker. +-- This might be a configuration file, a size of the packet, session data, etc. +class WorkerData w where + -- | Data that saves after restarts + type WData w :: * + -- | Monad in which the worker runs + type WMonad w :: * -> * + +{- | A simple type of worker that executes IO actions + +The definition of the 'WorkerData' instance for IOWorker looks like this: + +@ + instance WorkerData IOWorker where + type WData IOWorker = () + type WMonad IOWorker = IO +@ +-} +data IOWorker + +instance WorkerData IOWorker where + type WData IOWorker = () + type WMonad IOWorker = IO + +-- | Check whether the worker is initialized +initialized :: Worker a -> Bool +initialized = isJust . workerPid + +-- | An exception type used by 'Eval.Worker.Protocol' +data ProtocolException = + -- | There has been an error during the conversion step + ConversionException String + -- | There has been an error while using the handler + | HandleException IOException + deriving (Typeable, Show) + +instance Exception ProtocolException + +