{- |
   Module    : Test.Sandbox
   Maintainer: Benjamin Surma <benjamin.surma@gree.net>

Configuration and management of processes in a sandboxed environment for system testing.

This module contains extensive documentation. Please scroll down to the Introduction section to continue reading.
-}
module Test.Sandbox (
  -- * Introduction
  -- $introduction

  -- ** Features
  -- $features

  -- ** History
  -- $history

  -- * Usage examples
  -- $usage

  -- ** Communication via TCP
  -- $usage_tcp

  -- ** Communication via standard I/O
  -- $usage_io

  -- Types
    Sandbox
  , ProcessSettings (..)
  , def
  , Capture (..)

  -- * Initialization
  , sandbox

  -- * Registering processes
  , register

  -- * Managing sandboxed processes
  , run
  , withProcess
  , start
  , startAll
  , stop
  , stopAll
  , signal
  , silently

  -- * Communication
  , interactWith
  , sendTo
  , readLastCapturedOutput
  , getHandles
  , getPort

  -- * Sandbox state management
  , getBinary
  , setPort
  , getFile
  , setFile
  , getDataDir
  , bracket
  , checkVariable
  , getVariable
  , setVariable
  , unsetVariable
  , withVariable

  -- * Sandbox exception handling
  , catchError
  , throwError

  -- * Sandbox I/O handling
  , liftIO
  ) where

import Control.Concurrent (threadDelay)
import Control.Exception.Lifted hiding (bracket)
import Control.Monad
import Control.Monad.Trans (lift, liftIO)
import Control.Monad.Trans.Error (runErrorT)
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
import qualified Data.Map as M
import Data.Maybe
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 Test.Sandbox.Internals

-- | 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
  (evalStateT . runErrorT . runSandbox) (actions `catches` handlers `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 {
    psWait :: Maybe Int        -- ^ Time to wait (in s.) before checking that the process is still up
  , psCapture :: Maybe Capture -- ^ Which outputs to capture (if any)
  }

instance Default ProcessSettings where
  def = ProcessSettings (Just 1) Nothing

-- | Registers a process in the Sandbox monad.
register :: String          -- ^ Process name
         -> FilePath        -- ^ Path to the application binary
         -> [String]        -- ^ Arguments to pass on the command-line
         -> ProcessSettings -- ^ Process settings
         -> Sandbox String
register name bin args params = registerProcess name bin args (psWait params) (psCapture params) >> return name

-- | Communicates with a sandboxed process via TCP and returns the answered message as a string.
sendTo :: String         -- ^ Name of the registered port 
       -> String         -- ^ Input string
       -> Int            -- ^ Time to wait before timeout (in milli-seconds)
       -> Sandbox String
sendTo = sendToPort

-- | Starts the given process, runs the action, then stops the process.
-- The process is managed by the functions start and stop respectively.
withProcess :: String    -- ^ Process name
            -> Sandbox a -- ^ Action to run
            -> Sandbox a
withProcess name action = bracket (start name) (const $ stop name) (const action)

-- | Helper function: starts a process, wait for it to terminate and return its captured output.
run :: String -> Int -> Sandbox (ExitCode, Maybe String)
run name timeout = do
  silently $ start name
  waitFor name timeout `catchError` (\e -> silently (stop name) >> throwError e)

-- | Starts a previously registered process (verbose)
start :: String     -- ^ Process name
      -> Sandbox ()
start process = uninterruptibleMask_ $ do
  displayBanner
  sp <- getProcess process
  whenM isVerbose $ liftIO $ putStr ("Starting process " ++ process ++ "... ") >> hFlush stdout
  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
  silently $ Sandbox $ do env <- lift get
                          mapM_ (runSandbox . start) (ssProcessOrder env)
                          lift get >>= lift . put
  whenM isVerbose $ liftIO $ putStrLn "Done."

waitFor :: String -> Int -> Sandbox (ExitCode, Maybe String)
waitFor name timeout = waitFor' 0
  where waitFor' tick = do
          sp <- getProcess name
          case spInstance sp of
            Just (StoppedInstance ec o) -> return (ec, o)
            _ -> if tick > timeout then throwError $ "Process " ++ name ++ " still running after " ++ show timeout ++ "s timeout."
                   else do liftIO $ threadDelay secondInµs
                           waitFor' $! tick + 1

-- | Gracefully stops a previously started process (verbose)
stop :: String     -- ^ Process name
     -> 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."

-- | Sends a POSIX signal to a process
signal :: String     -- ^ Process name
       -> Signal     -- ^ Signal to send
       -> Sandbox ()
signal process sig = uninterruptibleMask_ $ do
  sp <- getProcess process
  case spInstance sp of
    Just (RunningInstance ph _ _) -> liftIO $ hSignalProcess sig ph
    _ -> throwError $ "Process " ++ process ++ " is not running."

-- | Gracefully stops all registered processes (in their reverse registration order)
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
  whenM isVerbose $ liftIO $ putStrLn "Done."

-- | Returns the effective binary path of a registered process.
getBinary :: String           -- ^ Process name
          -> Sandbox FilePath
getBinary process = getProcess process >>= getProcessBinary

-- | Returns the handles used to communicate with a registered process using standard I/O.
getHandles :: String                   -- ^ Process name
           -> Sandbox (Handle, Handle)
getHandles process = do
  sp <- getProcess process
  input <- getProcessInputHandle sp
  output <- getProcessCapturedOutputHandle sp
  return (input, output)

-- | Returns the last captured output of a started process.
readLastCapturedOutput :: String         -- ^ Process name
                       -> Sandbox String
readLastCapturedOutput process = do
  sp <- getProcess process
  h <- getProcessCapturedOutputHandle sp
  b <- hReadWithTimeout h 0
  return $! B.unpack b

-- | Interacts with a sandboxed process via standard I/O.
interactWith :: String         -- ^ Process name
             -> String         -- ^ Input string
             -> Int            -- ^ Time to wait before timeout (in milli-seconds)
             -> Sandbox String
interactWith process input timeout = do
  sp <- getProcess process
  interactWithProcess sp input timeout

-- | Returns an unbound user TCP port and stores it for future reference.
getPort :: String             -- ^ Port name for future reference
        -> Sandbox PortNumber
getPort name = do
  env <- Sandbox $ lift get
  case M.lookup name $ ssAllocatedPorts env of
    Just port -> return port
    Nothing -> getNewPort name

-- | Explicitely sets a port to be returned by getPort.
setPort :: String             -- ^ Port name for future reference
        -> Int                -- ^ TCP port number
        -> Sandbox PortNumber
setPort name port = Sandbox $ 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 })
                      return port'
    else throwError $ "Unable to bind port " ++ show port

-- | Creates a temporary file in the sandbox and returns its path.
setFile :: String           -- ^ File name for future reference
        -> String           -- ^ File contents
        -> Sandbox FilePath
setFile name contents = Sandbox $ do
  env <- lift get
  (file, env') <- liftIO $ setFile' name contents env
  lift $ 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
  case M.lookup name $ ssFiles env of
    Just file -> return file
    Nothing -> throwError $ "Config file " ++ name ++ " does not exist."

-- | A variant of bracket from Control.Exception which works in the Sandbox monad.
bracket :: Sandbox a       -- ^ Computation to run first ("acquire resource")
        -> (a -> Sandbox b) -- ^ Computation to run last ("release resource")
        -> (a -> Sandbox c) -- ^ Computation to run in-between
        -> Sandbox c
bracket acquire release between = do
  stuff <- acquire
  result <- between stuff `catchError` (\e -> release stuff >> throwError e)
  release stuff
  return result

-- | Temporarily sets a variable for the execution of the given action.
withVariable :: (Serialize a)
             => String    -- ^ Variable key
             -> a         -- ^ Variable value
             -> Sandbox b -- ^ Action to run
             -> Sandbox b
withVariable key value action = bracket (do env <- Sandbox $ lift get
                                            let old = M.lookup key $ ssVariables env
                                            setVariable key value
                                            return old)
                                        (\old -> case old of
                                                   Nothing -> unsetVariable key
                                                   Just old' -> void $ setVariable key old')
                                        (const action)

-- | Returns the temporary directory used to host the sandbox environment.
getDataDir :: Sandbox FilePath
getDataDir = Sandbox $ liftM ssDataDir (lift get)

-- | Executes the given action silently.
silently :: Sandbox a -- ^ Action to execute
       -> Sandbox a
silently = withVariable verbosityKey False

----------------------------------------------------------------------
-- Docs
----------------------------------------------------------------------

{- $introduction

test-sandbox is a framework to manage external applications
and communicate with them via TCP or standard I/O for system testing
in a sandboxed environment. The Test.Sandbox monad can either be used
stand-alone or in conjunction with HUnit, QuickCheck and the
test-framework packages to build a complete test suite.

The API is meant to be simple to understand yet flexible enough
to meet most of the needs of application testers.
-}

{- $features

 * Register, start and stop programs in a sandboxed environment.

 * Automatic cleaning at shutdown: started processes are shutdown,
   temporary files are deleted.

 * Ask the framework to provide you with random,
   guaranteed not bound TCP ports for your tests:
   no more collisions when running 2 sets of tests at the same time.

 * Generate your temporary configuration files programatically
   in a secure manner.

 * Easily share variables between your tests and modify them
   at runtime.

 * Combine with the test-framework package for standardized output
   and XML test result generation.

 * Use the QuickCheck library to write property tests and generate
   automatic test cases for your external application;
   enjoy the full power of the Haskell test harness, even if
   the application to test is written in a different language!
-}

{- $history

At GREE, we spend lots of time meticulously testing
our internally-developed middleware.
We have solutions not only developed in Haskell, but also C++
and PHP, but wanted a simple and robust test framework to perform
end-to-end testing, and this is how test-sandbox is born.
-}

{- $usage

A basic test-sandbox usecase would be as follows:

 1. Initialize a Test.Sandbox monad

 2. Register one or several processes to test
    a. Ask the Sandbox to provide you with some free TCP ports
       if needed
    a. Prepare temporary configuration files if required
       by your application

 3. Start some processes

 4. Communicate with them via TCP or standard IO

 5. Analyze the received answers and check whether they match
    an expected pattern

 6. Error handling is done via the @throwError@ and @catchError@
    functions.

Once all tests are done, the started processes are automatically
killed, and all temporary files are deleted.
-}

{- $usage_tcp

The following example shows a simple test for the "memcached"
NoSQL key-value store.

First, the sandbox is initialized with the @sandbox@ function;
then, it is asked to provide a free TCP port, which will be used
by the memcached process.
Once the program is registered with the @register@ function,
it is started with the @start@ function.
Please note that the Sandbox monad keeps an internal state: processes
registered in a function can be referenced in another without issues.

Communication via TCP is performed with the @sendTo@ function:
its arguments are the port name (given at the time of @getPort@),
the input string, and a timeout in milli-seconds. The function
returns the received TCP answer, if one was received in the correct
timeframe, or fails by throwing an error (which can be caught by
@catchError@).

The test is performed with the @assertEqual@ function from the HUnit
package. In case of matching failure, it will throw an exception,
which, if uncaught (like it is) will cause the Sandbox to perform
cleaning and rethrow the exception.

> import Test.Sandbox
> import Test.Sandbox.HUnit
> 
> setup :: Sandbox ()
> setup = do
>   port <- getPort "memcached"
>   register "memcached" "memcached" [ "-p", show port ] def
> 
> main :: IO ()
> main = sandbox $ do
>   setup
>   start "memcached"
>   output <- sendTo "memcached" "set key 0 0 5\r\nvalue\r\n" 1
>   assertEqual "item is stored" "STORED\r\n" output
-}

{- $usage_io
The next example is a hypothetic system test for the popular "sed",
the popular Unix stream editor.

Please note that at registration time, the @psCapture@ parameter is
set to @CaptureStdout@. This is required by the @interactWith@
function, used for communication on the standard input, which will
return the captured output on each request.

> import Test.Sandbox
> import Test.Sandbox.HUnit
> 
> main :: IO ()
> main = sandbox $ do
>   start =<< register "sed_regex" "sed" [ "-u", "s/a/b/" ] def { psCapture = CaptureStdout }
>   assertEqual "a->b" "b\n" =<< interactWith "sed_regex_ "a\n" 5
-}