Skip to content
Permalink
Browse files

tests: use "keepalive" tmux session and unique session names

We have experienced problems with the `tmux new-session` command:
a race of server availability when the server is being torn down
after the previous session gets killed.  Create a "keepalive"
session whose lifetime is the whole of the acceptance tests, to
prevent the server from being killed.

Also sequentially number the test sessions to avoid any potential
races when sessions are being killed and started.

Fixes: #123
  • Loading branch information
frasertweedale authored and romanofski committed Jan 4, 2018
1 parent 8427f4e commit 689dc02082101d0705a77364d7845e94f1e29303
Showing with 79 additions and 51 deletions.
  1. +79 −51 test/TestUserAcceptance.hs
@@ -8,6 +8,7 @@ module TestUserAcceptance where

import qualified Data.Text as T
import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory)
import Data.Functor (($>))
import Data.Ini (parseIni, writeIniFileWith, KeySeparator(..), WriteIniSettings(..))
import Data.Semigroup ((<>))
import Control.Concurrent (threadDelay)
@@ -19,7 +20,7 @@ import Data.Maybe (isJust)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (runReaderT, ask, ReaderT)

import Control.Lens (view, _3, _2)
import Control.Lens (Lens', view)
import Data.List (isInfixOf, intercalate)
import System.Process (callProcess, readProcess)
import System.Directory
@@ -37,20 +38,24 @@ data Condition
systemTests ::
TestTree
systemTests =
testGroup
"user acceptance tests"
[ testUserViewsMailSuccessfully
, testUserCanManipulateNMQuery
, testUserCanSwitchBackToIndex
, testCanToggleHeaders
, testSetsMailToRead
, testErrorHandling
, testHelp
, testManageTagsOnMails
, testManageTagsOnThreads
]

testManageTagsOnMails :: TestTree
withResource pre post $ \_ ->
testGroup "user acceptance tests" $ zipWith ($) tests [0..]
where
pre = let n = "keepalive" in setUpTmuxSession n $> n
post = cleanUpTmuxSession
tests =
[ testUserViewsMailSuccessfully
, testUserCanManipulateNMQuery
, testUserCanSwitchBackToIndex
, testCanToggleHeaders
, testSetsMailToRead
, testErrorHandling
, testHelp
, testManageTagsOnMails
, testManageTagsOnThreads
]

testManageTagsOnMails :: Int -> TestTree
testManageTagsOnMails = withTmuxSession "manage tags on mails" $
\step -> do
startApplication
@@ -95,7 +100,7 @@ testManageTagsOnMails = withTmuxSession "manage tags on mails" $

pure ()

testManageTagsOnThreads :: TestTree
testManageTagsOnThreads :: Int -> TestTree
testManageTagsOnThreads = withTmuxSession "manage tags on threads" $
\step -> do
startApplication
@@ -117,7 +122,7 @@ testManageTagsOnThreads = withTmuxSession "manage tags on threads" $

pure ()

testHelp :: TestTree
testHelp :: Int -> TestTree
testHelp = withTmuxSession "help view" $
\step -> do
startApplication
@@ -128,8 +133,7 @@ testHelp = withTmuxSession "help view" $
sendKeys "Escape" (Literal "Purebred")
pure ()

testErrorHandling ::
TestTree
testErrorHandling :: Int -> TestTree
testErrorHandling = withTmuxSession "error handling" $
\step -> do
startApplication
@@ -149,8 +153,7 @@ testErrorHandling = withTmuxSession "error handling" $

pure ()

testSetsMailToRead ::
TestTree
testSetsMailToRead :: Int -> TestTree
testSetsMailToRead = withTmuxSession "user can toggle read tag" $
\step -> do
startApplication
@@ -166,8 +169,7 @@ testSetsMailToRead = withTmuxSession "user can toggle read tag" $
sendKeys "t" (Regex (buildAnsiRegex ["1"] ["37"] ["43"] <> ".*Testmail"))
pure ()

testCanToggleHeaders ::
TestTree
testCanToggleHeaders :: Int -> TestTree
testCanToggleHeaders = withTmuxSession "user can toggle Headers" $
\step -> do
startApplication
@@ -184,8 +186,7 @@ testCanToggleHeaders = withTmuxSession "user can toggle Headers" $
out <- sendKeys "h" (Literal "This is a test mail")
assertRegex "Purebred.*\n.*[Ff]rom" out

testUserViewsMailSuccessfully ::
TestTree
testUserViewsMailSuccessfully :: Int -> TestTree
testUserViewsMailSuccessfully = withTmuxSession "user can view mail" $
\step -> do
startApplication
@@ -200,8 +201,7 @@ testUserViewsMailSuccessfully = withTmuxSession "user can view mail" $
sendKeys "Enter" (Literal "This is a test mail")
pure ()

testUserCanManipulateNMQuery ::
TestTree
testUserCanManipulateNMQuery :: Int -> TestTree
testUserCanManipulateNMQuery =
withTmuxSession
"manipulating notmuch search query results in empty index" $
@@ -234,8 +234,7 @@ testUserCanManipulateNMQuery =
sendKeys "Enter" (Literal "HOLY PUREBRED")
pure ()

testUserCanSwitchBackToIndex ::
TestTree
testUserCanSwitchBackToIndex :: Int -> TestTree
testUserCanSwitchBackToIndex =
withTmuxSession "user can switch back to mail index during composition" $
\step -> do
@@ -268,8 +267,6 @@ testUserCanSwitchBackToIndex =
sendKeys "Tab" (Literal "test subject")
pure ()

type Env = (String, String, String)

assertSubstrInOutput :: String -> String -> ReaderT Env IO ()
assertSubstrInOutput substr out = liftIO $ assertBool (substr <> " not found in\n\n" <> out) $ substr `isInfixOf` out

@@ -282,16 +279,35 @@ assertRegex regex out = liftIO $ assertBool
defaultSessionName :: String
defaultSessionName = "purebredtest"

tearDown :: (String, String, String) -> IO ()
tearDown (testdir, _, _)= do
data Env = Env
{ _envDir :: FilePath
, _envMaildir :: FilePath
, _envSessionName :: String
}

envDir :: Lens' Env FilePath
envDir f (Env a b c) = fmap (\a' -> Env a' b c) (f a)

envMaildir :: Lens' Env FilePath
envMaildir f (Env a b c) = fmap (\b' -> Env a b' c) (f b)

envSessionName :: Lens' Env String
envSessionName f (Env a b c) = fmap (\c' -> Env a b c') (f c)
{-# ANN envSessionName ("HLint: ignore Avoid lambda" :: String) #-}

-- | Tear down a test session
tearDown :: Env -> IO ()
tearDown (Env testdir _ sessionName) = do
removeDirectoryRecursive testdir
cleanUpTmuxSession defaultSessionName
cleanUpTmuxSession sessionName

setUp :: IO (String, String, String)
setUp = do
let sessionname = defaultSessionName
(testdir, testmdir) <- setUpTmuxSession sessionname >> setUpTempMaildir
pure (testdir, testmdir, sessionname)
-- | Set up a test session.
setUp :: Int -> IO Env
setUp i = do
let sessionName = defaultSessionName <> show i
setUpTmuxSession sessionName
(testdir, maildir) <- setUpTempMaildir
pure $ Env testdir maildir sessionName

setUpTempMaildir :: IO (String, String)
setUpTempMaildir = do
@@ -358,22 +374,28 @@ cleanUpTmuxSession sessionname =


-- | Run all application steps in a session defined by session name.
withTmuxSession :: TestName -> ((String -> IO ()) -> ReaderT Env IO ()) -> TestTree
withTmuxSession tcname testfx =
withResource setUp tearDown $
withTmuxSession
:: TestName
-> ((String -> IO ()) -> ReaderT Env IO ())
-> Int -- ^ session sequence number (will be appended to session name)
-> TestTree
withTmuxSession tcname testfx i =
withResource (setUp i) tearDown $
\env -> testCaseSteps tcname $ \stepfx -> env >>= runReaderT (testfx stepfx)

-- | Send keys into the program and wait for the condition to be
-- met, failing the test if the condition is not met after some
-- time.
sendKeys :: String -> Condition -> ReaderT Env IO String
sendKeys keys expect = do
liftIO $ callProcess "tmux" $ communicateSessionArgs keys False
sessionName <- getSessionName
liftIO $ callProcess "tmux" $ communicateSessionArgs sessionName keys False
waitForCondition expect defaultCountdown

sendLiteralKeys :: String -> ReaderT Env IO String
sendLiteralKeys keys = do
liftIO $ callProcess "tmux" $ communicateSessionArgs keys True
sessionName <- getSessionName
liftIO $ callProcess "tmux" $ communicateSessionArgs sessionName keys True
waitForString keys defaultCountdown

capture :: ReaderT Env IO String
@@ -382,10 +404,10 @@ capture = do
liftIO $ readProcess "tmux" ["capture-pane", "-e", "-p", "-t", sessionname] []

getSessionName :: ReaderT Env IO String
getSessionName = view (_3 . ask)
getSessionName = view (envSessionName . ask)

getTestMaildir :: ReaderT Env IO String
getTestMaildir = view (_2 . ask)
getTestMaildir :: ReaderT Env IO FilePath
getTestMaildir = view (envMaildir . ask)

holdOffTime :: Int
holdOffTime = 10^6
@@ -436,12 +458,18 @@ defaultCountdown = 5
startApplication :: ReaderT Env IO ()
startApplication = do
testmdir <- getTestMaildir
liftIO $ callProcess "tmux" $ communicateSessionArgs ("purebred --database " <> testmdir <> "\r") False
sessionName <- getSessionName
liftIO $ callProcess "tmux" $
communicateSessionArgs sessionName ("purebred --database " <> testmdir <> "\r") False
void $ waitForString "Purebred: Item" defaultCountdown

communicateSessionArgs :: String -> Bool -> [String]
communicateSessionArgs keys asLiteral =
["send-keys", "-t", defaultSessionName] <> ["-l" | asLiteral] <> [keys]
communicateSessionArgs
:: String -- ^ session name
-> String -- ^ keys
-> Bool -- ^ send the keys literally
-> [String]
communicateSessionArgs sessionName keys asLiteral =
["send-keys", "-t", sessionName] <> ["-l" | asLiteral] <> [keys]


type AnsiAttrParam = String

0 comments on commit 689dc02

Please sign in to comment.
You can’t perform that action at this time.