packages feed

restricted-workers (empty) → 0.1.0

raw patch · 16 files changed

+1509/−0 lines, 16 filesdep +asyncdep +basedep +bytestringsetup-changed

Dependencies added: async, base, bytestring, cereal, data-default, directory, either, filepath, monad-control, mtl, network, selinux, stm, text, transformers, transformers-base, unix

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -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 (<http://github.com/co-dan/interactive-diagrams>)+project. You can read more about security restrictions in the wiki: <https://github.com/co-dan/interactive-diagrams/wiki/Restricted-Workers>++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++<https://github.com/co-dan/interactive-diagrams/wiki/Restricted-Workers>++# 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+  ```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/CommandEvalProtocol.lhs view
@@ -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* ♫+```
+ examples/EchoPool.lhs view
@@ -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"+<....>+```+
+ examples/EchoWorker.lhs view
@@ -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 <ENTER> 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 <ENTER> 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 <ENTER> to restart the worker++Got: whatsup+Got: test+```++We can press enter to restart the worker:++```+Starting worker "Testworker"+Press <ENTER> to restart the worker++Got: whatsup+Got: test++Starting worker "Testworker"+Press <ENTER> to restart the worker++```
+ examples/NewWorkerType.lhs view
@@ -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+--------------------------------------------------+```
+ restricted-workers.cabal view
@@ -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+                     (<http://github.com/co-dan/interactive-diagrams>)+                     project. To read more about the idia behind the+                     library check out my GSoC report:+                     <http://parenz.wordpress.com/2013/07/15/interactive-diagrams-gsoc-progress-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+                     <https://github.com/co-dan/interactive-diagrams/tree/master/restricted-workers/README.md>+                     and+                     <https://github.com/co-dan/interactive-diagrams/wiki/Restricted-Workers>+                     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+
+ src/SignalHandlers.hs view
@@ -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
+ src/System/Restricted/Limits.hs view
@@ -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
+ src/System/Restricted/Types.hs view
@@ -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++
+ src/System/Restricted/Worker.hs view
@@ -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 ()+
+ src/System/Restricted/Worker/Internal.hs view
@@ -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+
+ src/System/Restricted/Worker/Pool.hs view
@@ -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+
+ src/System/Restricted/Worker/Protocol.hs view
@@ -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)))+
+ src/System/Restricted/Worker/Types.hs view
@@ -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++