test-sandbox 0.0.1.4 → 0.0.1.5
raw patch · 3 files changed
+52/−48 lines, 3 files
Files
- src/Test/Sandbox.hs +18/−26
- src/Test/Sandbox/Internals.hs +32/−20
- test-sandbox.cabal +2/−2
src/Test/Sandbox.hs view
@@ -78,10 +78,10 @@ import Control.Concurrent (threadDelay) import Control.Exception.Lifted hiding (bracket) import Control.Monad-import Control.Monad.Trans (lift, liftIO)+import Control.Monad.Trans (liftIO) import Control.Monad.Trans.Error (runErrorT)+import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Error.Class (catchError, throwError)-import Control.Monad.Trans.State.Strict import qualified Data.ByteString.Char8 as B import Data.Default import Data.Either@@ -104,16 +104,10 @@ -> IO a sandbox name actions = withSystemTempDirectory (name ++ "_") $ \dir -> do env <- newSandboxState name dir- (evalStateT . runErrorT . runSandbox) (actions `catches` handlers `finally` stopAll) env >>= either+ (runReaderT . runErrorT . runSandbox) (actions `finally` stopAll) env >>= either (\error -> do hPutStrLn stderr error throwIO $ userError error) return- where handlers = [ Handler exitHandler- , Handler otherHandler ]- exitHandler :: ExitCode -> Sandbox a- exitHandler e = stopAll >> throw e- otherHandler :: SomeException -> Sandbox a- otherHandler _ = stopAll >> liftIO exitFailure -- | Optional parameters when registering a process in the Sandbox monad. data ProcessSettings = ProcessSettings {@@ -168,9 +162,8 @@ startAll = uninterruptibleMask_ $ do displayBanner whenM isVerbose $ liftIO $ putStr "Starting all sandbox processes... " >> hFlush stdout- silently $ Sandbox $ do env <- lift get- mapM_ (runSandbox . start) (ssProcessOrder env)- lift get >>= lift . put+ silently $ do env <- get+ mapM_ start (ssProcessOrder env) whenM isVerbose $ liftIO $ putStrLn "Done." waitFor :: String -> Int -> Sandbox (ExitCode, Maybe String)@@ -206,9 +199,8 @@ stopAll :: Sandbox () stopAll = uninterruptibleMask_ $ do whenM isVerbose $ liftIO $ putStr "Stopping all sandbox processes... " >> hFlush stdout- silently $ Sandbox $ do env <- lift get- mapM_ (runSandbox . stop) (reverse $ ssProcessOrder env)- lift get >>= lift . put+ silently $ do env <- get+ mapM_ stop (reverse $ ssProcessOrder env) whenM isVerbose $ liftIO $ putStrLn "Done." -- | Returns the effective binary path of a registered process.@@ -247,7 +239,7 @@ getPort :: String -- ^ Port name for future reference -> Sandbox PortNumber getPort name = do- env <- Sandbox $ lift get+ env <- get case M.lookup name $ ssAllocatedPorts env of Just port -> return port Nothing -> getNewPort name@@ -256,11 +248,11 @@ setPort :: String -- ^ Port name for future reference -> Int -- ^ TCP port number -> Sandbox PortNumber-setPort name port = Sandbox $ do+setPort name port = do let port' = fromIntegral port bindable <- liftIO $ isBindable (fromIntegral port)- if bindable then do env <- lift get- lift $ put (env { ssAllocatedPorts = M.insert name port' $ ssAllocatedPorts env })+ if bindable then do env <- get+ put (env { ssAllocatedPorts = M.insert name port' $ ssAllocatedPorts env }) return port' else throwError $ "Unable to bind port " ++ show port @@ -268,17 +260,17 @@ setFile :: String -- ^ File name for future reference -> String -- ^ File contents -> Sandbox FilePath-setFile name contents = Sandbox $ do- env <- lift get+setFile name contents = do+ env <- get (file, env') <- liftIO $ setFile' name contents env- lift $ put env'+ put env' return file -- | Returns the path of a file previously created by setFile. getFile :: String -- ^ File name used during setFile -> Sandbox FilePath-getFile name = Sandbox $ do- env <- lift get+getFile name = do+ env <- get case M.lookup name $ ssFiles env of Just file -> return file Nothing -> throwError $ "Config file " ++ name ++ " does not exist."@@ -300,7 +292,7 @@ -> a -- ^ Variable value -> Sandbox b -- ^ Action to run -> Sandbox b-withVariable key value action = bracket (do env <- Sandbox $ lift get+withVariable key value action = bracket (do env <- get let old = M.lookup key $ ssVariables env setVariable key value return old)@@ -311,7 +303,7 @@ -- | Returns the temporary directory used to host the sandbox environment. getDataDir :: Sandbox FilePath-getDataDir = Sandbox $ liftM ssDataDir (lift get)+getDataDir = liftM ssDataDir get -- | Executes the given action silently. silently :: Sandbox a -- ^ Action to execute
src/Test/Sandbox/Internals.hs view
@@ -14,14 +14,15 @@ import Control.Monad.Base (MonadBase) import Control.Monad.Error (MonadError, catchError, throwError) import Control.Monad.Loops-import Control.Monad.State (MonadState, get, put)-import Control.Monad.Trans (MonadIO, lift, liftIO)+import Control.Monad.Reader (MonadReader, ask)+import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Error (ErrorT)-import Control.Monad.Trans.State.Strict (StateT)+import Control.Monad.Trans.Reader (ReaderT) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char+import Data.IORef import Data.Map (Map) import qualified Data.Map as M import Data.Maybe@@ -43,12 +44,14 @@ import System.Random import System.Random.Shuffle +type SandboxStateRef = IORef SandboxState+ newtype Sandbox a = Sandbox {- runSandbox :: ErrorT String (StateT SandboxState IO) a- } deriving (Applicative, Functor, Monad, MonadBase IO, MonadError String, MonadState SandboxState, MonadIO)+ runSandbox :: ErrorT String (ReaderT SandboxStateRef IO) a+ } deriving (Applicative, Functor, Monad, MonadBase IO, MonadError String, MonadReader (IORef SandboxState), MonadIO) instance MonadBaseControl IO Sandbox where- newtype StM Sandbox a = StMSandbox { runStMSandbox :: StM (ErrorT String (StateT SandboxState IO)) a }+ newtype StM Sandbox a = StMSandbox { runStMSandbox :: StM (ErrorT String (ReaderT SandboxStateRef IO)) a } liftBaseWith f = Sandbox . liftBaseWith $ \run -> f (liftM StMSandbox . run . runSandbox) restoreM = Sandbox . restoreM . runStMSandbox @@ -79,6 +82,15 @@ data SandboxedProcessInstance = RunningInstance ProcessHandle Handle (Maybe Handle) | StoppedInstance ExitCode (Maybe String) +get :: Sandbox SandboxState+get = ask >>= liftIO . readIORef++put :: SandboxState -> Sandbox SandboxState+put state = do+ ref <- ask+ liftIO $ writeIORef ref state+ return state+ pretty :: SandboxState -> String pretty env = header env ++@@ -100,12 +112,12 @@ footer = "\n--------------------------------------------------------------------------------\n" -newSandboxState :: String -> FilePath -> IO SandboxState+newSandboxState :: String -> FilePath -> IO SandboxStateRef newSandboxState name dir = do gen <- newStdGen let availablePorts = shuffle' userPorts (length userPorts) gen where userPorts = [49152..65535]- return $ SandboxState name dir M.empty [] M.empty availablePorts M.empty M.empty+ newIORef $ SandboxState name dir M.empty [] M.empty availablePorts M.empty M.empty registerProcess :: String -> FilePath -> [String] -> Maybe Int -> Maybe Capture@@ -131,7 +143,7 @@ getProcess :: String -> Sandbox SandboxedProcess getProcess name = do- env <- Sandbox get+ env <- get case M.lookup name (ssProcesses env) of Just sp -> let spi = spInstance sp in case spi of@@ -348,16 +360,16 @@ => String -- ^ Variable key for future reference -> a -- ^ Variable value -> Sandbox a-setVariable name new = Sandbox $ do- env <- lift get- lift . put $ env { ssVariables = M.insert name (encode new) (ssVariables env) }+setVariable name new = do+ env <- get+ put $ env { ssVariables = M.insert name (encode new) (ssVariables env) } return new -- | Checks that a custom sandbox variable is set. checkVariable :: String -- ^ Variable key -> Sandbox Bool-checkVariable name = Sandbox $ do- env <- lift get+checkVariable name = do+ env <- get return $ M.member name $ ssVariables env -- | Returns the value of a previously set sandbox variable (or a provided default value if unset)@@ -365,8 +377,8 @@ => String -- ^ Variable key -> a -- ^ Default value if not found -> Sandbox a-getVariable name defval = Sandbox $ do- env <- lift get+getVariable name defval = do+ env <- get let var = case M.lookup name $ ssVariables env of Nothing -> Right defval Just var' -> decode var'@@ -375,9 +387,9 @@ -- | Unsets a custom variable. unsetVariable :: String -- ^ Variable key -> Sandbox ()-unsetVariable name = Sandbox $ do- env <- lift get- lift . put $ env { ssVariables = M.delete name $ ssVariables env }+unsetVariable name = do+ env <- get+ void $ put env { ssVariables = M.delete name $ ssVariables env } isVerbose :: Sandbox Bool isVerbose = getVariable verbosityKey True@@ -388,7 +400,7 @@ displayBanner :: Sandbox () displayBanner = do displayed <- checkVariable var- unless displayed $ Sandbox $ lift get >>= liftIO . putStrLn . pretty+ unless displayed $ get >>= liftIO . putStrLn . pretty void $ setVariable var True where var = "__BANNER__DISPLAYED__"
test-sandbox.cabal view
@@ -1,5 +1,5 @@ Name: test-sandbox-Version: 0.0.1.4+Version: 0.0.1.5 Cabal-Version: >= 1.14 Category: Testing Synopsis: Sandbox for system tests@@ -25,7 +25,7 @@ Source-Repository this Type: git Location: https://github.com/gree/haskell-test-sandbox- Tag: test-sandbox_0.0.1.4+ Tag: test-sandbox_0.0.1.5 Library Exposed-modules: Test.Sandbox