test-sandbox 0.0.1.8 → 0.0.1.9

raw patch · 5 files changed

+450/−61 lines, 5 filesdep +QuickCheckdep +hastachedep +heredocdep ~basedep ~processdep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, hastache, heredoc, hspec, regex-posix, template-haskell, test-sandbox, text

Dependency ranges changed: base, process, transformers

API changes (from Hackage documentation)

Files

• src/Test/Sandbox.hs +32/−14
• src/Test/Sandbox/Internals.hs +145/−42
• src/Test/Sandbox/Process.hs +61/−0
• test-sandbox.cabal +29/−5
• test/test.hs +183/−0

@@ -1,3 +1,4 @@+{-#LANGUAGE ScopedTypeVariables#-} {- |    Module    : Test.Sandbox    Maintainer: Benjamin Surma <benjamin.surma@gmail.com>@@ -33,7 +34,12 @@    -- * Initialization   , sandbox+  , withSandbox +  -- * Calling sandbox on IO+  , runSandbox+  , runSandbox'+   -- * Registering processes   , register @@ -80,8 +86,7 @@ import Control.Exception.Lifted import Control.Monad import Control.Monad.Trans (liftIO)-import Control.Monad.Trans.Error (runErrorT)-import Control.Monad.Trans.Reader (runReaderT)+import Control.Monad.Reader (ask) import Control.Monad.Error.Class (catchError, throwError) import qualified Data.ByteString.Char8 as B import Data.Default@@ -91,25 +96,38 @@ import Data.Serialize (Serialize) import Network hiding (sendTo) import Prelude hiding (error)-import qualified Prelude (error) import System.Exit import System.IO import System.IO.Temp import System.Posix hiding (release)+import System.Environment  import Test.Sandbox.Internals +cleanUp :: Sandbox ()+cleanUp = do+  stopAll+  whenM isCleanUp $ do+    cleanUpProcesses+ -- | Creates a sandbox and execute the given actions in the IO monad. sandbox :: String    -- ^ Name of the sandbox environment         -> Sandbox a -- ^ Action to perform         -> IO a sandbox name actions = withSystemTempDirectory (name ++ "_") $ \dir -> do   env <- newSandboxState name dir-  (runReaderT . runErrorT . runSandbox) (actions `finally` stopAll) env >>= either+  runSandbox (actions `finally` cleanUp) env >>= either     (\error -> do hPutStrLn stderr error                   throwIO $ userError error)     return +withSandbox :: (SandboxStateRef -> IO a) -> IO a+withSandbox actions = do+  name <- getProgName+  sandbox name $ do+    ref <- ask+    liftIO $ actions ref+ -- | Optional parameters when registering a process in the Sandbox monad. data ProcessSettings = ProcessSettings {     psWait :: Maybe Int        -- ^ Time to wait (in s.) before checking that the process is still up@@ -155,14 +173,14 @@   displayBanner   sp <- getProcess process   whenM isVerbose $ liftIO $ putStr ("Starting process " ++ process ++ "... ") >> hFlush stdout-  updateProcess =<< startProcess sp+  _ <- updateProcess =<< startProcess sp   whenM isVerbose $ liftIO $ putStrLn "Done."  -- | Starts all registered processes (in their registration order) startAll :: Sandbox () startAll = uninterruptibleMask_ $ do   displayBanner-  whenM isVerbose $ liftIO $ putStr "Starting all sandbox processes... " >> hFlush stdout+  whenM isVerbose $ liftIO $ putStrLn "Starting all sandbox processes... " >> hFlush stdout   silently $ do env <- get                 mapM_ start (ssProcessOrder env)   whenM isVerbose $ liftIO $ putStrLn "Done."@@ -182,9 +200,9 @@      -> Sandbox () stop process = uninterruptibleMask_ $ do   sp <- getProcess process-  whenM isVerbose $ liftIO $ putStr ("Stopping process " ++ process ++ "... ") >> hFlush stdout-  updateProcess =<< stopProcess sp-  whenM isVerbose $ liftIO $ putStrLn "Done."+  whenM isVerbose $ liftIO $ putStrLn ("Stopping process " ++ process ++ "("++ show (spPid sp) ++ ")... ") >> hFlush stdout+  _ <- updateProcess =<< stopProcess sp+  whenM isVerbose $ liftIO $ putStrLn "Done." >> hFlush stdout  -- | Sends a POSIX signal to a process signal :: String     -- ^ Process name@@ -200,8 +218,8 @@ stopAll :: Sandbox () stopAll = uninterruptibleMask_ $ do   whenM isVerbose $ liftIO $ putStr "Stopping all sandbox processes... " >> hFlush stdout-  silently $ do env <- get-                mapM_ stop (reverse $ ssProcessOrder env)+  env <- get+  mapM_ stop (reverse $ ssProcessOrder env)   whenM isVerbose $ liftIO $ putStrLn "Done."  -- | Returns the effective binary path of a registered process.@@ -253,7 +271,7 @@   let port' = fromIntegral port   bindable <- liftIO $ isBindable (fromIntegral port)   if bindable then do env <- get-                      put (env { ssAllocatedPorts = M.insert name port' $ ssAllocatedPorts env })+                      _ <- put (env { ssAllocatedPorts = M.insert name port' $ ssAllocatedPorts env })                       return port'     else throwError $ "Unable to bind port " ++ show port @@ -264,7 +282,7 @@ setFile name contents = do   env <- get   (file, env') <- liftIO $ setFile' name contents env-  put env'+  _ <- put env'   return file  -- | Returns the path of a file previously created by setFile.@@ -284,7 +302,7 @@              -> Sandbox b withVariable key value action = bracket (do env <- get                                             let old = M.lookup key $ ssVariables env-                                            setVariable key value+                                            _ <- setVariable key value                                             return old)                                         (\old -> case old of                                                    Nothing -> unsetVariable key

@@ -4,21 +4,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Test.Sandbox.Internals where  import Control.Applicative (Applicative) import Control.Concurrent-import Control.Exception.Lifted+import Control.Exception.Lifted hiding (throwTo) import Control.Monad import Control.Monad.Base (MonadBase)-import Control.Monad.Error (MonadError, catchError, throwError)+import Control.Monad.Except (MonadError, catchError, throwError) import Control.Monad.Loops 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.Reader (ReaderT)+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char@@ -31,8 +33,6 @@ import GHC.IO.Handle import Network import Network.Socket-import Prelude hiding (error)-import qualified Prelude (error) import System.Directory import System.Exit import System.FilePath@@ -43,18 +43,32 @@ import System.Process.Internals (withProcessHandle, ProcessHandle__(OpenHandle)) import System.Random import System.Random.Shuffle+import Test.Sandbox.Process  type SandboxStateRef = IORef SandboxState  newtype Sandbox a = Sandbox {-    runSandbox :: ErrorT String (ReaderT SandboxStateRef IO) a+    runSB :: ExceptT 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 (ReaderT SandboxStateRef IO)) a }-  liftBaseWith f = Sandbox . liftBaseWith $ \run -> f (liftM StMSandbox . run . runSandbox)+  newtype StM Sandbox a = StMSandbox { runStMSandbox :: StM (ExceptT String (ReaderT SandboxStateRef IO)) a }+  liftBaseWith f = Sandbox . liftBaseWith $ \run -> f (liftM StMSandbox . run . runSB)   restoreM = Sandbox . restoreM . runStMSandbox +runSandbox :: Sandbox a -> SandboxStateRef -> IO (Either String a)+runSandbox = runReaderT . runExceptT . runSB++errorHandler :: String -> IO a+errorHandler error' = do+  hPutStrLn stderr error'+  throwIO $ userError error'++runSandbox' :: SandboxStateRef -> Sandbox a -> IO a+runSandbox' env' action = do+  val <- runSandbox action env'+  either errorHandler return val+ data SandboxState = SandboxState {     ssName :: String   , ssDataDir :: FilePath@@ -73,6 +87,8 @@   , spWait :: Maybe Int   , spCapture :: Maybe Capture   , spInstance :: Maybe SandboxedProcessInstance+  , spPid :: Maybe ProcessID+  , spPGid :: Maybe ProcessGroupID   }  data Capture = CaptureStdout@@ -93,19 +109,19 @@  pretty :: SandboxState -> String pretty env =-  header env ++-  "-- Data directory: " ++ ssDataDir env ++ "\n\-  \-- Allocated ports: " ++ unwords (map show $ M.assocs $ ssAllocatedPorts env) ++ "\n\-  \-- Configuration files: " ++ unwords (M.elems $ ssFiles env) ++ "\n\-  \-- Registered processes: " ++ unwords (ssProcessOrder env)+  header env+  ++ "-- Data directory: " ++ ssDataDir env ++ "\n"+  ++ "-- Allocated ports: " ++ unwords (map show $ M.assocs $ ssAllocatedPorts env) ++ "\n"+  ++ "-- Configuration files: " ++ unwords (M.elems $ ssFiles env) ++ "\n"+  ++ "-- Registered processes: " ++ unwords (ssProcessOrder env)   ++ footer  header :: SandboxState -> String header te =-  "\n\-  \##------------------------------------------------------------------------------\n\-  \ ## " ++ title ++ replicate (72 - length title) ' ' ++ "  --\n\-  \## ##---------------------------------------------------------------------------\n"+  "\n"+  ++ "##------------------------------------------------------------------------------\n"+  ++ " ## " ++ title ++ replicate (72 - length title) ' ' ++ "  --\n"+  ++ "## ##---------------------------------------------------------------------------\n"   where title = ssName te ++ " system test environment"  footer :: String@@ -116,7 +132,11 @@ newSandboxState name dir = do   gen <- newStdGen   let availablePorts = shuffle' userPorts (length userPorts) gen-                       where userPorts = [49152..65535]+                       where userPorts = [5001..32767]+      -- Ephemeral port is used by operating system which allocates it for tcp-client.+      -- The port area is below.+      -- IANN(freebsd and win7): [49152.. 65535],Linux: [32768..61000],WinXP: [1025..5000]+      -- Do not use these area for "userPorts" to avoid conflict.   newIORef $ SandboxState name dir M.empty [] M.empty availablePorts M.empty M.empty  registerProcess ::@@ -130,9 +150,10 @@   env <- get   if isJust (M.lookup name (ssProcesses env)) then     throwError $ "Process " ++ name ++ " is already registered in the test environment."-    else do let sp = SandboxedProcess name bin args wait capture Nothing-            put env { ssProcesses = M.insert name sp (ssProcesses env)-                    , ssProcessOrder = ssProcessOrder env ++ [name] }+    else do let sp = SandboxedProcess name bin args wait capture Nothing Nothing Nothing+            _ <- put env { ssProcesses = M.insert name sp (ssProcesses env)+                         , ssProcessOrder = ssProcessOrder env ++ [name]+                         }             return sp  isValidProcessName :: String -> Bool@@ -155,7 +176,7 @@                      Just oh' -> liftM Just $ liftIO $ hGetContents oh'                      Nothing -> return Nothing               let sp' = sp { spInstance = Just $ StoppedInstance ec' o }-              updateProcess sp'+              _ <- updateProcess sp'               return sp'             Nothing -> return sp         _ -> return sp@@ -164,7 +185,7 @@ updateProcess :: SandboxedProcess -> Sandbox SandboxedProcess updateProcess sp = do   env <- get-  put env { ssProcesses = M.insert (spName sp) sp (ssProcesses env) }+  _ <- put env { ssProcesses = M.insert (spName sp) sp (ssProcesses env) }   return sp  secondInµs :: Int@@ -211,16 +232,56 @@   case ssAvailablePorts env of     [] -> throwError "No user ports left."     ports -> do (port, ports') <- liftIO $ takeBindablePort' ports-                put env { ssAllocatedPorts = M.insert name port $ ssAllocatedPorts env-                        , ssAvailablePorts = ports' }+                _ <- put env { ssAllocatedPorts = M.insert name port $ ssAllocatedPorts env+                             , ssAvailablePorts = ports' }                 return port   where takeBindablePort' pl = do           pl' <- dropWhileM (liftM not . isBindable) pl           return (head pl', tail pl') ++#if defined __LINUX__ isBindable :: PortNumber -> IO Bool+isBindable port = do+  ports <- getPorts+  return $ not $ S.member (fromIntegral port) $ S.unions $ (map S.singleton $ ports)+  where+    getPort :: String -> Maybe Int+    getPort v =+      if v =~ pattern+        then+          case (v =~ pattern) of+            [[_str,port']] ->+              case readHex port' of+                [(port'',_)] -> Just port''+                _ -> Nothing+            _ -> Nothing+        else Nothing+      where+        pattern = "^ *[0-9]+: [0-9A-F]+:([0-9A-F]+) .*"++    getPorts :: IO [Int]+    getPorts = do+      let files = [+            "/proc/net/tcp",+            "/proc/net/tcp6",+            "/proc/net/udp",+            "/proc/net/udp6"]+      list <- forM files $ \file -> do {+        v <- readFile file ;+        v `seq` return $ catMaybes $ map getPort $ lines v+        } `catch` (\(_ :: SomeException) -> return [])+      return $ flatten list+      where+        flatten :: [[a]] -> [a]+        flatten [] = []+        flatten (x:xs) = x ++ flatten xs++#else+isBindable :: PortNumber -> IO Bool isBindable p = withSocketsDo $ do   s <- socket AF_INET Stream defaultProtocol+  setSocketOption s ReuseAddr 1   localhost <- inet_addr "127.0.0.1"   let sa = SockAddrInet p localhost   r <- (bind s sa >> isBound s)@@ -228,6 +289,10 @@   close s   return $! r +#endif+++ startProcess :: SandboxedProcess -> Sandbox SandboxedProcess startProcess sp =   case spInstance sp of@@ -248,16 +313,23 @@                                                              CaptureStderr -> return (Just hRO, Inherit, UseHandle hRW)                                                              CaptureBoth -> return (Just hRO, UseHandle hRW, UseHandle hRW)                                     Nothing -> return (Nothing, Inherit, Inherit)-      (Just ih, _, _, ph) <- liftIO $ createProcess $ (proc bin args) { std_in = CreatePipe+      (Just ih, _, _, ph) <- liftIO $ createProcess $ ((proc bin args) {create_group = True} ) { std_in = CreatePipe                                                                       , std_out = hOutRW                                                                       , std_err = hErrRW }       when (isJust $ spWait sp) $ liftIO . threadDelay $ fromJust (spWait sp) * secondInµs       errno <- liftIO $ getProcessExitCode ph       case errno of-        Nothing -> updateProcess sp { spInstance = Just $ RunningInstance ph ih hOutRO }-        Just errno' -> throwError $ "Process " ++ spName sp ++ " not running.\n\-                                    \ - command-line: " ++ formatCommandLine bin args ++ "\n\-                                    \ - exit code: " ++ show errno' +        Nothing -> do+          pid <- liftIO $ hGetProcessID ph+          pgid <- liftIO $ getProcessGroupIDOf pid+          updateProcess sp {+            spInstance = Just $ RunningInstance ph ih hOutRO+          , spPid = Just pid+          , spPGid = Just pgid+          }+        Just errno' -> throwError $ "Process " ++ spName sp ++ " not running.\n"+                                 ++ " - command-line: " ++ formatCommandLine bin args ++ "\n"+                                 ++ " - exit code: " ++ show errno'   formatCommandLine :: String -> [String] -> String formatCommandLine bin args = unwords $ bin : args@@ -267,13 +339,33 @@   case spInstance sp of     Just (RunningInstance ph _ _) -> do       let wait = if isNothing $ spWait sp then 50000 else fromJust (spWait sp) * secondInµs `div` 5+      whenM isVerbose $ liftIO $ putStrLn ("sending sigterm : " ++  spName sp)       liftIO $ do terminateProcess ph                   threadDelay wait       stillRunning <- liftM isNothing $ liftIO $ getProcessExitCode ph-      when stillRunning $ liftIO $ killProcess ph+      when stillRunning $ do+        whenM isVerbose $ liftIO $ putStrLn ("sending sigkill : " ++  spName sp)+        liftIO $ killProcess ph       stopProcess =<< getProcess (spName sp)     _ -> return sp +#if defined(__MACOSX__) ||  defined(__WIN32__)+#else+getAvailablePids :: Sandbox [ProcessID]+getAvailablePids = do+  stat <- get+  let pgids = catMaybes (map (\(_k,v) -> spPGid v) (M.toList (ssProcesses stat)))+  pids <- liftIO $ getProcessIDs pgids+  return pids+#endif++cleanUpProcesses :: Sandbox ()+cleanUpProcesses = do+  stat <- get+  let pgids = catMaybes (map (\(_k,v) -> spPGid v) (M.toList (ssProcesses stat)))+  whenM isVerbose $ liftIO $ putStrLn ("Starting to kill process groups " ++ show pgids)+  liftIO $ cleanUpProcessGroupIDs pgids+ hSignalProcess :: Signal -> ProcessHandle -> IO () hSignalProcess s h = do   pid <- hGetProcessID h@@ -285,7 +377,11 @@ hGetProcessID :: ProcessHandle -> IO ProcessID hGetProcessID h = withProcessHandle h $ \x ->   case x of+#if MIN_VERSION_process(1,2,0)+    OpenHandle pid -> return pid+#else     OpenHandle pid -> return (x, pid)+#endif     _ -> throwIO $ userError "Unable to retrieve child process ID."  interactWithProcess :: SandboxedProcess -> String -> Int -> Sandbox String@@ -301,15 +397,15 @@ getProcessInputHandle sp =     case spInstance sp of       Just (RunningInstance _ ih _) -> return ih-      _ -> throwError $ "No such handle for " ++ spName sp ++ ". \-                        \Is the process started?"+      _ -> throwError $ "No such handle for " ++ spName sp ++ ". "+                     ++ "Is the process started?"  getProcessCapturedOutputHandle :: SandboxedProcess -> Sandbox Handle getProcessCapturedOutputHandle sp =   case spInstance sp of     Just (RunningInstance _ _ (Just oh)) -> return oh-    _ -> throwError $ "No captured output handle for " ++ spName sp ++ ". \-                      \Is capture activated?"+    _ -> throwError $ "No captured output handle for " ++ spName sp ++ ". "+                   ++ "Is capture activated?"  getProcessBinary :: SandboxedProcess -> Sandbox FilePath getProcessBinary sp = do@@ -317,8 +413,8 @@   case existing of     exBin:_ -> return exBin     [] -> throwError $ "Unable to find the executable for the test process \""-                       ++ spName sp ++ "\"\r\n\-                       \Considered paths were: " ++ show bins+                    ++ spName sp ++ "\"\r\n"+                    ++ "Considered paths were: " ++ show bins   where bins = getProcessCandidateBinaries sp  findExecutables :: [FilePath] -> IO [FilePath]@@ -362,7 +458,7 @@             -> Sandbox a setVariable name new = do   env <- get-  put $ env { ssVariables = M.insert name (encode new) (ssVariables env) }+  _ <- put $ env { ssVariables = M.insert name (encode new) (ssVariables env) }   return new  -- | Checks that a custom sandbox variable is set.@@ -397,6 +493,12 @@ verbosityKey :: String verbosityKey = "__VERBOSITY__" +isCleanUp :: Sandbox Bool+isCleanUp = getVariable cleanUpKey True++cleanUpKey :: String+cleanUpKey = "__CLEANUP__"+ displayBanner :: Sandbox () displayBanner = do   displayed <- checkVariable var@@ -407,9 +509,10 @@ installSignalHandlers :: Sandbox () installSignalHandlers = do   installed <- checkVariable var-  unless installed $ liftIO . void $ do installHandler sigTERM handler Nothing-                                        installHandler sigQUIT handler Nothing-                                        installHandler sigABRT handler Nothing+  unless installed $ liftIO . void $ do _ <- installHandler sigTERM handler Nothing+                                        _ <- installHandler sigQUIT handler Nothing+                                        _ <- installHandler sigABRT handler Nothing+                                        return ()   void $ setVariable var True   where var = "__HANDLERS_INSTALLED__"         handler = Catch $ signalProcess sigINT =<< getProcessID

@@ -0,0 +1,61 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++module Test.Sandbox.Process where+import System.Posix.Types+import System.Posix.Signals+import Text.Regex.Posix+import Data.Maybe+import Control.Exception+import Control.Monad+import System.Directory+import qualified Data.Set as S++#if defined(__MACOSX__) ||  defined(__WIN32__)+#else+data ProcessInfo = ProcessInfo {+   piPid  :: ProcessID+,  piStat :: String+,  piPpid :: ProcessID+,  piPgid :: ProcessGroupID+} deriving (Show,Eq,Read)++getProcessInfo :: String -> Maybe ProcessInfo+getProcessInfo v =+  if v =~ pattern+    then+      case v =~ pattern of+        [[_str,pid,stat,ppid,pgid]] -> Just $ ProcessInfo (read pid) stat (read ppid) (read pgid)+        _ -> Nothing+    else+      Nothing+  where+    pattern = "^([0-9]+) \\([^\\)]*\\) ([RSDZTW]) ([0-9]+) ([0-9]+) [0-9]+ .*"++getProcessInfos :: IO [ProcessInfo]+getProcessInfos = do+  dirs <- getDirectoryContents "/proc"+  let processes = filter ( =~ "[0-9]+") dirs+  stats <- forM processes $ \ps -> do {+    file <- (readFile $ "/proc/" ++ ps ++ "/stat") ;+    file `seq` return $ getProcessInfo file+    } `catch` (\(_ :: SomeException) -> return Nothing)+  return $ catMaybes stats++getProcessGroupIDs :: IO [ProcessGroupID]+getProcessGroupIDs = do+  infos <- getProcessInfos+  return $ map (\info -> piPgid info) infos++getProcessIDs :: [ProcessGroupID] -> IO [ProcessID]+getProcessIDs pgids = do+  infos <- getProcessInfos+  let pgids' = S.fromList $ pgids+  return $ map (\info -> piPid info) $ filter (\info -> S.member (piPgid info) pgids') infos+#endif++cleanUpProcessGroupIDs :: [ProcessGroupID] -> IO ()+cleanUpProcessGroupIDs pgids = do+  forM_ pgids $ \pgid -> do+    signalProcessGroup sigKILL pgid `catch`  (\(_::SomeException) -> return ())+

@@ -1,5 +1,5 @@ Name:           test-sandbox-Version:        0.0.1.8+Version:        0.0.1.9 Cabal-Version:  >= 1.14 Category:       Testing Synopsis:       Sandbox for system tests@@ -25,18 +25,42 @@ Source-Repository this     Type:       git     Location:   https://github.com/gree/haskell-test-sandbox-    Tag:        test-sandbox_0.0.1.8+    Tag:        test-sandbox_0.0.1.9  Library     Exposed-modules:    Test.Sandbox                         Test.Sandbox.Internals+                        Test.Sandbox.Process      Build-Depends:      base >=4 && <5, bytestring, cereal, containers,                         data-default, directory, filepath, lifted-base,-                        monad-control, monad-loops, mtl, network, process >= 1.1 && < 1.2,-                        random, random-shuffle, temporary, transformers,-                        transformers-base, unix+                        monad-control, monad-loops, mtl, network, process,+                        random, random-shuffle, temporary, transformers >= 0.4,+                        transformers-base, unix, regex-posix      Hs-source-dirs:     src+    Default-Language:   Haskell2010+    ghc-options:       -Wall +test-suite test+    type:              exitcode-stdio-1.0+    main-is:           test.hs+    hs-source-dirs:    test,dist/build/autogen+    ghc-options:       -Wall++    build-depends: base+                 , test-sandbox+                 , hspec+                 , template-haskell+                 , heredoc+                 , hastache+                 , text+                 , containers+                 , unix+                 , mtl+                 , transformers+                 , regex-posix+                 , directory+                 , process+                 , QuickCheck     Default-Language:   Haskell2010

@@ -0,0 +1,183 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Monadic (assert,monadicIO)+import Test.Sandbox+import qualified Test.Sandbox.Internals as I+import Text.Heredoc+import qualified Text.Hastache as H+import qualified Text.Hastache.Context as H+import qualified Data.Text.Lazy as TL+import qualified Data.Text as T+import qualified Data.Map as M+import System.Posix.Files+import Data.IORef+import Data.Char+import Control.Concurrent++a2b :: String -> String+a2b [] = []+a2b ('a':xs) = 'b':xs+a2b (x:xs) = x:a2b xs++a2btest :: I.SandboxStateRef -> [Char] -> Property+a2btest ref str' = a2btest' ref $ filter isAlphaNum str'++a2btest' :: I.SandboxStateRef -> [Char] -> Property+a2btest' ref str' =+  monadicIO $ do+    v <- liftIO $ runSandbox' ref $ interactWith "sed_regex" (str' ++ "\n") 1+    assert $ v == ((a2b str') ++ "\n")++main :: IO ()+main = withSandbox $ \gref -> do+  hspec $ do+    describe "Basic Test" $ do+      it "interactive Test by sandbox" $ do+        sandbox "hogehoge" $ do+          start =<< register "sed_regex" "sed" [ "-u", "s/a/b/" ] def { psCapture = Just CaptureStdout }+          v <- interactWith "sed_regex" "a\n" 1+          liftIO $ v `shouldBe` "b\n"+      it "interactive Test by withSandbox" $ do+        withSandbox $ \ref -> do+          val <- runSandbox' ref $ do+            start =<< register "sed_regex" "sed" [ "-u", "s/a/b/" ] def { psCapture = Just CaptureStdout }+            interactWith "sed_regex" "a\n" 1+          val `shouldBe` "b\n"+      it "interactive Test : QuickCheck(setup)" $ do+        val <- runSandbox' gref $ do+          start =<< register "sed_regex" "sed" [ "-u", "s/a/b/" ] def { psCapture = Just CaptureStdout }+          interactWith "sed_regex" "a\n" 1+        val `shouldBe` "b\n"+      it "interactive Test : QuickCheck(run)" $+        property $ a2btest gref+      it "setFile" $ do+        withSandbox $ \ref -> do+          let content =+                  [str|#!/bin/env bash+                      |while true ; do echo hhh ; sleep 1;done+                      |]+          putStr content+          file <- runSandbox' ref $ setFile "str1" content+          readFile file `shouldReturn`  content+      it "set/getVariable" $ do+        withSandbox $ \ref -> do+          runSandbox' ref $ do+            v <- I.isVerbose+            liftIO $ v `shouldBe` True+            _ <- setVariable I.verbosityKey False+            v' <- I.isVerbose+            liftIO $ v' `shouldBe` False+          runSandbox' ref I.isVerbose `shouldReturn` False+          _ <- runSandbox' ref $ setVariable I.verbosityKey True+          runSandbox' ref I.isVerbose `shouldReturn` True+#if defined(__MACOSX__) ||  defined(__WIN32__)+#else+    describe "signal test" $ do+      it "send kill signal for process groups" $ do+        val <- newIORef $ error "do not eval this"+        withSandbox $ \ref -> runSandbox' ref $ do+          file <- setFile "str1"+                  [str|#!/usr/bin/env bash+                      |trap "echo catch signal" 1 2 3 15+                      |while true ; do echo hhh ; sleep 1;done+                      |]+          liftIO $ setExecuteMode file+          fil2 <- setFile' "str2"+                  [("file",file)]+                  [str|#!/usr/bin/env bash+                      |trap "echo catch signal" 1 2 3 15+                      |{{file}}&+                      |{{file}}&+                      |{{file}}&+                      |while true ; do echo hhh ; sleep 1;done+                      |]+          liftIO $ setExecuteMode fil2+          _ <- register "scr1" fil2 [] def+          startAll+          liftIO $ writeIORef val ref+          pids <- I.getAvailablePids+          liftIO $ threadDelay $ 1 * 1000 * 1000+          liftIO $ (length pids >= 4) `shouldBe` True+        ref' <- readIORef val+        pids <- runSandbox' ref' $ I.getAvailablePids+        length pids `shouldBe` 0++      it "send kill signal for process groups" $ do+        sandbox "test" $ do+          file <- setFile "str1"+                  [str|#!/usr/bin/env bash+                      |trap "echo catch signal" 1 2 3 15+                      |while true ; do echo hhh ; sleep 1;done+                      |]+          liftIO $ setExecuteMode file+          fil2 <- setFile' "str2"+                  [("file",file)]+                  [str|#!/usr/bin/env bash+                      |trap "echo catch signal" 1 2 3 15+                      |{{file}}&+                      |{{file}}&+                      |{{file}}&+                      |while true ; do echo hhh ; sleep 1;done+                      |]+          liftIO $ setExecuteMode fil2+          _ <- register "scr1" fil2 [] def+          startAll+          pids <- I.getAvailablePids+          liftIO $ (length pids >= 4) `shouldBe` True+      it "not send kill signal for process groups" $ do+        val <- newIORef $ error "do not eval this"+        withSandbox $ \ref -> runSandbox' ref $ do+          file <- setFile "str1"+                  [str|#!/usr/bin/env bash+                      |trap "echo catch signal" 1 2 3 15+                      |while true ; do echo hhh ; sleep 1;done+                      |]+          liftIO $ setExecuteMode file+          fil2 <- setFile' "str2"+                  [("file",file)]+                  [str|#!/usr/bin/env bash+                      |trap "echo catch signal" 1 2 3 15+                      |{{file}}&+                      |{{file}}&+                      |{{file}}&+                      |while true ; do echo hhh ; sleep 1;done+                      |]+          liftIO $ setExecuteMode fil2+          _ <- register "scr1" fil2 [] def+          startAll+          _ <- setVariable I.cleanUpKey False+          pids <- I.getAvailablePids+          liftIO $ writeIORef val ref+          liftIO $ do+            (length pids >= 4) `shouldBe` True+        ref' <- readIORef val+        pids <- runSandbox' ref' $ I.getAvailablePids+        (length pids > 0 ) `shouldBe` True+        pids' <- runSandbox' ref' $ do+          I.cleanUpProcesses+          I.getAvailablePids+        length pids' `shouldBe` 0+#endif++setFile' :: H.MuVar a+         => String+         -> [(String, a)]+         -> String+         -> Sandbox FilePath+setFile' filename keyValues template  = do+  str' <- H.hastacheStr+          H.defaultConfig+          (H.encodeStr template)+          (H.mkStrContext context')+  setFile filename $ T.unpack $ TL.toStrict str'+  where+    context' str' = (M.fromList (map (\(k,v) -> (k,H.MuVariable v)) keyValues)) M.! str'++setExecuteMode :: FilePath -> IO ()+setExecuteMode file = do+  stat <- getFileStatus file+  setFileMode file (fileMode stat `unionFileModes` ownerExecuteMode)