-- This file is part of tasty-tmux
-- Copyright (C) 2017-2019 Róman Joost and Fraser Tweedale
--
-- tasty-tmux is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}

{- |

This module provides a test framework for user acceptance testing
(UAT) of command line or console applications.  The framework
establishes <https://github.com/tmux/tmux/wiki tmux> sessions for
test cases and provides functions for sending input to the tmux
session and making assertions about the state of the terminal (i.e.
what is on the screen).

-}
module Test.Tasty.Tmux
  (
  -- * User guide
  -- ** Synopsis
  -- $synopsis

  -- ** Terminal character encoding
  -- $encoding

  -- * API documentation
  -- ** Creating test cases
    testTmux
  , testTmux'
  , withTmuxSession
  , withTmuxSession'
  , TestCase

  -- *** Test environment
  , HasTmuxSession(..)
  , TmuxSession

  -- ** Sending input to a session
  , sendKeys
  , sendLiteralKeys
  , sendLine
  , tmuxSendKeys
  , TmuxKeysMode(..)
  , setEnvVarInSession

  -- ** Capturing terminal state
  , capture
  , snapshot
  , Capture
  , captureBytes
  , captureString

  -- ** Assertions
  , waitForCondition
  , Condition(..)
  , defaultRetries
  , defaultBackoff
  , assertCondition
  , assertSubstring
  , assertRegex

  -- *** State-aware assertions
  , assertConditionS
  , assertSubstringS
  , assertRegexS

  -- *** ANSI escape sequence regex helpers
  , AnsiAttrParam
  , AnsiFGParam
  , AnsiBGParam
  , buildAnsiRegex

  -- ** Re-exports
  , put

  ) where

import Control.Concurrent (threadDelay)
import Control.Exception (catch, IOException)
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (MonadIO, MonadReader, asks, runReaderT)
import Control.Monad.State (MonadState, get, put, runStateT)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as L
import Data.Char (isAscii, isAlphaNum)
import Data.Functor.Const (Const(..))
import Data.List (intercalate)
import Data.Semigroup ((<>))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import System.IO (hPutStrLn, stderr)

import System.Process.Typed
  ( proc, runProcess_, readProcessInterleaved_, ProcessConfig )
import Text.Regex.Posix ((=~))

import Test.Tasty (TestTree, TestName, testGroup, withResource)
import Test.Tasty.HUnit (assertBool, testCaseSteps)

{- $synopsis

Test cases ('TestCase')
are defined using 'withTmuxSession'.  The 'testTmux' function groups
test cases into a /Tasty/ 'TestTree'.  Test cases are executed
sequentially, each in a separate tmux session.  Each test case can
have a setup and teardown action, and there can also be a setup and
teardown around the whole group of tests.

Let's look at a specific usage example.  You want to test some
program.  There are two tests.  Each test needs a dedicated
temporary directory, but they also need a separate, shared temporary
directory.  We want the setup routines to create these directories
and the teardown routines to remove them.  Assume the
existence of @mkTempDir :: IO FilePath@ and @rmDir :: FilePath
-> IO ()@.

Looking first at 'testTmux':

@
data SharedEnv = SharedEnv FilePath

myTests :: TestTree
myTests = 'testTmux' pre post [test1, test2]
  where
  pre = SharedEnv \<$\> mkTempDir
  post (SharedEnv path) = rmDir path
@

The shared setup action @pre@ returns a @SharedEnv@ value that will
be propagated to each test case, as well as the @teardown@ action,
after all test cases have run.

@test1@ and @test2@ are defined thus:

@
test1 :: TestCase SharedEnv
test1 = 'withTmuxSession' setup teardown "putFile" $ \\step -> do
  -- test environment is availabe via 'ask'
  TestEnv _ sharedDir testDir <- 'ask'

  -- send a command to the tmux session and wait for \"Done\"
  'sendLine' ("myProg putFile " <> sharedDir) (Substring "Done.")

  -- save a snapshot of the terminal state and make some assertions
  'snapshot'
  'assertSubstringS' "The output should contain this substring"
  'assertRegexS' "The output should match this [Rr]eg[Ee]x"

test2 :: TestCase SharedEnv
test2 = 'withTmuxSession' setup teardown "checkFile" $ \\step -> do
  TestEnv _ sharedDir testDir <- 'ask'

  -- use 'step' to label different stages of the test
  step "Run program"
  sendLine ("myProg checkFile " <> sharedDir) (Substring "Yep, it's there.")

  step "Check exit code"
  sendLine "echo status $?" (Substring "status 0")
@

Further discussion of the setup action is warranted.  This function,
at minimum, must incorporate the 'TmuxSession' argument into the
value it returns.  The type it returns must have an instance of
'HasTmuxSession'; this provides the name of the tmux session to the
framework functions that interact with tmux.

In our example, it also creates a per-test case temporary directory.
The value returned by the setup action is provided to the teardown
action.

@
data TestEnv = TestEnv
  { _session    :: 'TmuxSession'
  , _sharedDir  :: FilePath
  , _testDir    :: FilePath
  }

instance 'HasTmuxSession' TestEnv where
  'tmuxSession' = 'lens' _session (\\s b -> s { _session = b })

setup :: SharedEnv -> TmuxSession -> IO TestEnv
setup (SharedEnv sharedDir) session = TestEnv session sharedDir \<$\> mkTempDir

teardown :: TestEnv -> IO ()
teardown (TestEnv _ _ testDir) = rmDir testDir
@

If either shared or test-specific setup and teardown are not needed,
the 'testTmux'' and 'withTmuxSession'' functions are provided for
convenience.

-}

{- $encoding

/tasty-tmux/ does not make any assumptions about terminal
character encoding.  The only exception is 'captureString'
which assumes UTF-8 encoding.  All other functions deal with
'B.ByteString'.

Be careful when using 'OverloadedStrings' - the 'IsString'
instance for 'B.ByteString' messes up characters > 127.  If
you need to include high characters in 'String' or 'Regex'
assertions, encoding them using the expected terminal
character encoding (you can encode in UTF-8 via
'Data.Text.Encoding.encodeUtf8').

-}


-- | A condition to check for in the output of the program
data Condition
  = Unconditional
  | Substring B.ByteString
  | Regex B.ByteString
  | Not Condition
  deriving (Int -> Condition -> ShowS
[Condition] -> ShowS
Condition -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Condition] -> ShowS
$cshowList :: [Condition] -> ShowS
show :: Condition -> String
$cshow :: Condition -> String
showsPrec :: Int -> Condition -> ShowS
$cshowsPrec :: Int -> Condition -> ShowS
Show)

-- | A captured pane.  For now this just contains the string content,
-- but in the future perhaps we will augment it with terminal title,
-- terminal dimensions, timestamp, etc.
--
-- Use 'captureBytes' to get the raw terminal output.
--
newtype Capture = Capture { Capture -> ByteString
_captureBytes :: B.ByteString }

-- | Get the captured terminal content as a string, including
-- escape sequences.  Assumes UTF-8 encoding and uses
-- replacement characters for bad encoding or unknown code
-- points.
--
captureString :: Capture -> String
captureString :: Capture -> String
captureString = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Capture -> ByteString
_captureBytes

-- | Get the raw bytes of the capture, including escape sequences.
captureBytes :: Capture -> B.ByteString
captureBytes :: Capture -> ByteString
captureBytes = Capture -> ByteString
_captureBytes

-- | A test case that will be executed in a dedicated tmux session.
-- Parameterised over the shared environment type.
type TestCase a = IO a -> Int -> TestTree

-- | tmux session name
type TmuxSession = String

-- | This class provides access to a tmux session name.  Test
-- environment types must have an instance of this class.
class HasTmuxSession a where
  -- | Lens to the 'TmuxSession'
  tmuxSession :: Functor f => (TmuxSession -> f TmuxSession) -> a -> f a

instance HasTmuxSession TmuxSession where
  tmuxSession :: forall (f :: * -> *).
Functor f =>
(String -> f String) -> String -> f String
tmuxSession = forall a. a -> a
id

view :: MonadReader s m => ((a -> Const a a) -> s -> Const a s) -> m a
view :: forall s (m :: * -> *) a.
MonadReader s m =>
((a -> Const a a) -> s -> Const a s) -> m a
view (a -> Const a a) -> s -> Const a s
l = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall {k} a (b :: k). Const a b -> a
getConst forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const a a) -> s -> Const a s
l forall {k} a (b :: k). a -> Const a b
Const)


-- | Run a series of tests in tmux sessions.
--
-- Tests are executed sequentially.  Each test case is executed in a
-- new tmux session.  The name of the session is derived from the
-- name of the test and prepended with the sequence number.
--
-- A session called "keepalive" is created before any test cases are
-- run, and killed after all the test cases have finished.  This
-- session ensures that the tmux server remains alive, avoiding some race
-- conditions.
--
testTmux
  :: IO a
  -- ^ Set-up action.  Executed one time, after the keepalive
  -- session is created but before any test cases are executed.
  -> (a -> IO ())
  -- ^ Tear-down action.  Executed after all test cases have
  -- finished but before the keepalive session gets killed.
  -> [TestCase a]
  -> TestTree
testTmux :: forall a. IO a -> (a -> IO ()) -> [TestCase a] -> TestTree
testTmux IO a
pre a -> IO ()
post [TestCase a]
tests =
  forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO String
frameworkPre forall {p}. p -> IO ()
frameworkPost forall a b. (a -> b) -> a -> b
$ \IO String
ioKeepalive ->
    forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource (IO String
ioKeepalive forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO a
pre) a -> IO ()
post forall a b. (a -> b) -> a -> b
$ \IO a
env ->
      String -> [TestTree] -> TestTree
testGroup String
"user acceptance tests" forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b. (a -> b) -> a -> b
$ IO a
env) [TestCase a]
tests [Int
0..]
  where
    keepaliveSessionName :: String
keepaliveSessionName = String
"keepalive"
    frameworkPre :: IO String
frameworkPre = String -> IO String
setUpTmuxSession String
keepaliveSessionName
    frameworkPost :: p -> IO ()
frameworkPost p
_ = String -> IO ()
cleanUpTmuxSession String
keepaliveSessionName

-- | Like 'testTmux' but with no setup or teardown
testTmux' :: [TestCase ()] -> TestTree
testTmux' :: [TestCase ()] -> TestTree
testTmux' = forall a. IO a -> (a -> IO ()) -> [TestCase a] -> TestTree
testTmux (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ())


-- | ANSI attribute
type AnsiAttrParam = String
-- | ANSI foreground colour
type AnsiFGParam = String
-- | ANSI background colour
type AnsiBGParam = String

-- | Generate a regex for an escape sequence, setting the given
-- foreground and background parameters.
--
-- tmux <
-- <https://github.com/tmux/tmux/commit/03d01eabb5c5227f56b6b44d04964c1328802628 03d01ea>
-- (first released in tmux-2.5) ran attributes, foreground
-- colour and background colour params separated by semicolons
-- (foreground first).
-- After that commit, attributes, foreground colours and background
-- colours are written in separate escape sequences.  Therefore for
-- compatibility with different versions of tmux there are two
-- patterns to check.
--
buildAnsiRegex :: [AnsiAttrParam] -> [AnsiFGParam] -> [AnsiBGParam] -> B.ByteString
buildAnsiRegex :: [String] -> [String] -> [String] -> ByteString
buildAnsiRegex [String]
attrs [String]
fgs [String]
bgs =
  let
    withSemis :: [String] -> String
withSemis = forall a. [a] -> [[a]] -> [a]
intercalate String
";"
    wrap :: [String] -> String
wrap [] = String
""
    wrap [String]
xs = String
"\ESC\\[" forall a. Semigroup a => a -> a -> a
<> [String] -> String
withSemis [String]
xs forall a. Semigroup a => a -> a -> a
<> String
"m"
    tmux24 :: String
tmux24 = [String] -> String
wrap ([String]
attrs forall a. Semigroup a => a -> a -> a
<> [String]
fgs forall a. Semigroup a => a -> a -> a
<> [String]
bgs)
    tmux25 :: String
tmux25 = [String] -> String
wrap [String]
attrs forall a. Semigroup a => a -> a -> a
<> [String] -> String
wrap [String]
fgs forall a. Semigroup a => a -> a -> a
<> [String] -> String
wrap [String]
bgs
    choice :: String -> ShowS
choice String
"" String
"" = String
""
    choice String
"" String
r = String
r
    choice String
l String
"" = String
l
    choice String
l String
r = String
"(" forall a. Semigroup a => a -> a -> a
<> String
l forall a. Semigroup a => a -> a -> a
<> String
"|" forall a. Semigroup a => a -> a -> a
<> String
r forall a. Semigroup a => a -> a -> a
<> String
")"
  in
    String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ String -> ShowS
choice String
tmux24 String
tmux25

-- | Sets a shell environment variable.
--
-- Note: The tmux program provides a command to set environment variables for
-- running sessions, yet they seem to be not inherited by the shell.
--
-- This assumes that a standard shell prompt is ready in the session.
-- No attempt is made to check this; it just blindly send they keystrokes.
--
setEnvVarInSession
  :: (HasTmuxSession a, MonadReader a m, MonadIO m)
  => String -> String -> m ()
setEnvVarInSession :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
String -> String -> m ()
setEnvVarInSession String
name String
value =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
String -> Condition -> m Capture
sendLine (String
"export " forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
"=" forall a. Semigroup a => a -> a -> a
<> String
value) Condition
Unconditional

-- | Send interpreted 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
  :: (HasTmuxSession a, MonadReader a m, MonadIO m)
  => String -> Condition -> m Capture
sendKeys :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
String -> Condition -> m Capture
sendKeys String
keys Condition
expect = do
    forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
TmuxKeysMode -> String -> m ()
tmuxSendKeys TmuxKeysMode
InterpretKeys String
keys
    forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
Condition -> Int -> Int -> m Capture
waitForCondition Condition
expect Int
defaultRetries Int
defaultBackoff

-- | Send literal keys to the terminal and wait for the condition to
-- be satisfied, with default timeout.
sendLiteralKeys
  :: (HasTmuxSession a, MonadReader a m, MonadIO m)
  => String -> Condition -> m Capture
sendLiteralKeys :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
String -> Condition -> m Capture
sendLiteralKeys String
keys Condition
cond = do
    forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
TmuxKeysMode -> String -> m ()
tmuxSendKeys TmuxKeysMode
LiteralKeys String
keys
    forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
Condition -> Int -> Int -> m Capture
waitForCondition Condition
cond Int
defaultRetries Int
defaultBackoff

-- | Send the literal string to the terminal, followed by @Enter@,
-- then wait for the condition be satisfied, with default timeout.
sendLine
  :: (HasTmuxSession a, MonadReader a m, MonadIO m)
  => String -> Condition -> m Capture
sendLine :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
String -> Condition -> m Capture
sendLine String
s Condition
cond = do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
String -> Condition -> m Capture
sendLiteralKeys String
s Condition
Unconditional
  forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
String -> Condition -> m Capture
sendKeys String
"Enter" Condition
cond

-- | Whether to tell tmux to treat keys literally or interpret
-- sequences like "Enter" or "C-x".
--
data TmuxKeysMode = LiteralKeys | InterpretKeys
  deriving (TmuxKeysMode -> TmuxKeysMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TmuxKeysMode -> TmuxKeysMode -> Bool
$c/= :: TmuxKeysMode -> TmuxKeysMode -> Bool
== :: TmuxKeysMode -> TmuxKeysMode -> Bool
$c== :: TmuxKeysMode -> TmuxKeysMode -> Bool
Eq)

-- | Send keystrokes into a tmux session.
--
tmuxSendKeys
  :: (HasTmuxSession a, MonadReader a m, MonadIO m)
  => TmuxKeysMode -> String -> m ()
tmuxSendKeys :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
TmuxKeysMode -> String -> m ()
tmuxSendKeys TmuxKeysMode
mode String
keys = forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m) =>
TmuxKeysMode -> String -> m (ProcessConfig () () ())
tmuxSendKeysProc TmuxKeysMode
mode String
keys forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_

-- | Construct the 'ProcessConfig' for a tmux command.  The session
-- name is read from the 'MonadReader' environment.
--
tmuxSendKeysProc
  :: (HasTmuxSession a, MonadReader a m)
  => TmuxKeysMode -> String -> m (ProcessConfig () () ())
tmuxSendKeysProc :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m) =>
TmuxKeysMode -> String -> m (ProcessConfig () () ())
tmuxSendKeysProc TmuxKeysMode
mode String
keys = forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m) =>
String -> [String] -> m (ProcessConfig () () ())
tmuxSessionProc String
"send-keys" ([String
"-l" | TmuxKeysMode
mode forall a. Eq a => a -> a -> Bool
== TmuxKeysMode
LiteralKeys] forall a. Semigroup a => a -> a -> a
<> [String
keys])

-- | Create a 'ProcessConfig' for a tmux command, taking the session
-- name from the 'MonadReader' environment.
--
tmuxSessionProc
  :: (HasTmuxSession a, MonadReader a m)
  => String -> [String] -> m (ProcessConfig () () ())
tmuxSessionProc :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m) =>
String -> [String] -> m (ProcessConfig () () ())
tmuxSessionProc String
cmd [String]
args = do
  String
sessionName <- forall s (m :: * -> *) a.
MonadReader s m =>
((a -> Const a a) -> s -> Const a s) -> m a
view forall a (f :: * -> *).
(HasTmuxSession a, Functor f) =>
(String -> f String) -> a -> f a
tmuxSession
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> [String] -> ProcessConfig () () ()
proc String
"tmux" (String
cmd forall a. a -> [a] -> [a]
: String
"-t" forall a. a -> [a] -> [a]
: String
sessionName forall a. a -> [a] -> [a]
: [String]
args)

-- | Capture the pane and check for a condition, optionally retrying
-- with exponential backoff.  If the condition is not met after the
-- final attempt, the test fails.
waitForCondition
  :: (HasTmuxSession a, MonadReader a m, MonadIO m)
  => Condition
  -> Int  -- ^ Number of retries allowed
  -> Int  -- ^ Initial microseconds to back off.  Multiplied by 4 on each retry.
  -> m Capture  -- ^ Return the successful capture (or throw an exception)
waitForCondition :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
Condition -> Int -> Int -> m Capture
waitForCondition Condition
cond Int
n Int
backOff = do
  Capture
cap <- forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
m Capture
capture
  case Condition -> ByteString -> Bool
checkCondition Condition
cond (Capture -> ByteString
captureBytes Capture
cap) of
    Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Capture
cap
    Bool
_ | Int
n forall a. Ord a => a -> a -> Bool
> Int
0 -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
backOff
          forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
Condition -> Int -> Int -> m Capture
waitForCondition Condition
cond (Int
n forall a. Num a => a -> a -> a
- Int
1) (Int
backOff forall a. Num a => a -> a -> a
* Int
4)
      | Bool
otherwise -> Capture
cap forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). MonadIO m => Condition -> Capture -> m ()
assertCondition Condition
cond Capture
cap

checkCondition :: Condition -> B.ByteString -> Bool
checkCondition :: Condition -> ByteString -> Bool
checkCondition Condition
Unconditional = forall a b. a -> b -> a
const Bool
True
checkCondition (Substring ByteString
s) = (ByteString
s ByteString -> ByteString -> Bool
`B.isInfixOf`)
checkCondition (Regex ByteString
re) = (forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ ByteString
re)
checkCondition (Not Condition
cond) = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Condition -> ByteString -> Bool
checkCondition Condition
cond

-- | Assert that the capture satisfies a condition
assertCondition :: (MonadIO m) => Condition -> Capture -> m ()
assertCondition :: forall (m :: * -> *). MonadIO m => Condition -> Capture -> m ()
assertCondition Condition
cond Capture
cap =
  let s :: String
s = Capture -> String
captureString Capture
cap
  in forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> Bool -> IO ()
assertBool
    ( String
"Condition not met: '" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Condition
cond
      -- TODO we probably should emit terminal reset sequence
      -- after outputting the capture.
      forall a. Semigroup a => a -> a -> a
<> String
"'.  Last capture:\n\n " forall a. Semigroup a => a -> a -> a
<> String
s forall a. Semigroup a => a -> a -> a
<> String
"\n\n"
      forall a. Semigroup a => a -> a -> a
<> String
" raw: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show String
s )
    (Condition -> ByteString -> Bool
checkCondition Condition
cond (Capture -> ByteString
captureBytes Capture
cap))

-- | Substring assertion.
assertSubstring :: (MonadIO m) => B.ByteString -> Capture -> m ()
assertSubstring :: forall (m :: * -> *). MonadIO m => ByteString -> Capture -> m ()
assertSubstring = forall (m :: * -> *). MonadIO m => Condition -> Capture -> m ()
assertCondition forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Condition
Substring

-- | Regex assertion.
assertRegex :: (MonadIO m) => B.ByteString -> Capture -> m ()
assertRegex :: forall (m :: * -> *). MonadIO m => ByteString -> Capture -> m ()
assertRegex = forall (m :: * -> *). MonadIO m => Condition -> Capture -> m ()
assertCondition forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Condition
Regex

-- | Assert that the saved capture satisfies a condition.
--
-- Use 'snapshot' to save a capture:
--
-- @
-- snapshot
-- assertConditionS (Regex "[Ff][Oo][Oo]")
-- @
--
-- Alternatively, use 'put' on the result of any action that returns
-- a 'Capture':
--
-- @
-- 'sendKeys' "Enter" Unconditional >>= 'put'
-- assertConditionS (Substring "Doing thing...")
-- @
--
-- See also 'assertSubstringS' and 'assertRegexS'.
--
assertConditionS :: (MonadIO m, MonadState Capture m) => Condition -> m ()
assertConditionS :: forall (m :: * -> *).
(MonadIO m, MonadState Capture m) =>
Condition -> m ()
assertConditionS Condition
cond = forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadIO m => Condition -> Capture -> m ()
assertCondition Condition
cond

-- | State-aware substring assertion.
assertSubstringS :: (MonadIO m, MonadState Capture m) => B.ByteString -> m ()
assertSubstringS :: forall (m :: * -> *).
(MonadIO m, MonadState Capture m) =>
ByteString -> m ()
assertSubstringS ByteString
s = forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadIO m => ByteString -> Capture -> m ()
assertSubstring ByteString
s

-- | State-aware regex assertion.
assertRegexS :: (MonadIO m, MonadState Capture m) => B.ByteString -> m ()
assertRegexS :: forall (m :: * -> *).
(MonadIO m, MonadState Capture m) =>
ByteString -> m ()
assertRegexS ByteString
s = forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadIO m => ByteString -> Capture -> m ()
assertRegex ByteString
s

-- | 5
defaultRetries :: Int
defaultRetries :: Int
defaultRetries = Int
5

-- | Run all application steps in a session defined by session name.
withTmuxSession
  :: (HasTmuxSession testEnv)
  => (sharedEnv -> TmuxSession -> IO testEnv)
  -- ^ Set up session.  The tmux session is established before this
  -- action is run.  Takes the shared environment and Tmux session
  -- and constructs a test environment value (which must make the
  -- 'TmuxSession' available via its 'HasTmuxSession' instance).
  -> (testEnv -> IO ())
  -- ^ Tear down the session.  The tmux session will be torn down
  -- /after/ this action.
  -> TestName
  -- ^ Name of the test (a string).
  -> ( forall m. (MonadReader testEnv m, MonadState Capture m, MonadIO m)
       => (String -> m ()) -> m a
     )
  -- ^ The main test function.  The argument is the "step" function
  -- which can be called with a description to label the steps of
  -- the test procedure.
  -> TestCase sharedEnv
withTmuxSession :: forall testEnv sharedEnv a.
HasTmuxSession testEnv =>
(sharedEnv -> String -> IO testEnv)
-> (testEnv -> IO ())
-> String
-> (forall (m :: * -> *).
    (MonadReader testEnv m, MonadState Capture m, MonadIO m) =>
    (String -> m ()) -> m a)
-> TestCase sharedEnv
withTmuxSession sharedEnv -> String -> IO testEnv
pre testEnv -> IO ()
post String
desc forall (m :: * -> *).
(MonadReader testEnv m, MonadState Capture m, MonadIO m) =>
(String -> m ()) -> m a
f IO sharedEnv
getGEnv Int
i =
  forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource
    (IO sharedEnv
getGEnv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \sharedEnv
gEnv -> IO String
frameworkPre forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= sharedEnv -> String -> IO testEnv
pre sharedEnv
gEnv)
    (\testEnv
env -> testEnv -> IO ()
post testEnv
env forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> IO ()
cleanUpTmuxSession (forall s (m :: * -> *) a.
MonadReader s m =>
((a -> Const a a) -> s -> Const a s) -> m a
view forall a (f :: * -> *).
(HasTmuxSession a, Functor f) =>
(String -> f String) -> a -> f a
tmuxSession testEnv
env))
    forall a b. (a -> b) -> a -> b
$ \IO testEnv
env -> String -> ((String -> IO ()) -> IO ()) -> TestTree
testCaseSteps String
desc forall a b. (a -> b) -> a -> b
$
        \String -> IO ()
step -> IO testEnv
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall (m :: * -> *).
(MonadReader testEnv m, MonadState Capture m, MonadIO m) =>
(String -> m ()) -> m a
f (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
step)) forall {a}. a
initCap)
  where
    initCap :: a
initCap = forall a. HasCallStack => String -> a
error String
"no Capture; use 'snapshot' first"
    frameworkPre :: IO String
frameworkPre =
      let
        -- FIXME? customisable session name prefix?
        sessionName :: String
sessionName = forall a. [a] -> [[a]] -> [a]
intercalate String
"-" (String
"tasty-tmux" forall a. a -> [a] -> [a]
: forall a. Show a => a -> String
show Int
i forall a. a -> [a] -> [a]
: [String]
descWords)
        descWords :: [String]
descWords = String -> [String]
words forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\Char
c -> Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& (Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
' ')) String
desc
      in
        String -> IO String
setUpTmuxSession String
sessionName

-- | Like 'withTmuxSession' but without setup and teardown.  Shared
-- environment value (and its type) is ignored.
withTmuxSession'
  :: TestName
  -> ( forall m. (MonadReader TmuxSession m, MonadState Capture m, MonadIO m)
       => (String -> m ()) -> m a
     )
  -- ^ The main test function.  The argument is the "step" function
  -- which can be called with a description to label the steps of
  -- the test procedure.
  -> TestCase sharedEnv
withTmuxSession' :: forall a sharedEnv.
String
-> (forall (m :: * -> *).
    (MonadReader String m, MonadState Capture m, MonadIO m) =>
    (String -> m ()) -> m a)
-> TestCase sharedEnv
withTmuxSession' = forall testEnv sharedEnv a.
HasTmuxSession testEnv =>
(sharedEnv -> String -> IO testEnv)
-> (testEnv -> IO ())
-> String
-> (forall (m :: * -> *).
    (MonadReader testEnv m, MonadState Capture m, MonadIO m) =>
    (String -> m ()) -> m a)
-> TestCase sharedEnv
withTmuxSession (forall a b. a -> b -> a
const forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Capture the current terminal state.
capture :: (HasTmuxSession a, MonadReader a m, MonadIO m) => m Capture
capture :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
m Capture
capture = ByteString -> Capture
Capture forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.toStrict
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m) =>
String -> [String] -> m (ProcessConfig () () ())
tmuxSessionProc String
"capture-pane"
    [ String
"-e"  -- include escape sequences
    , String
"-p"  -- send output to stdout
    , String
"-J"  -- join wrapped lines and preserve trailing whitespace
    ]
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored -> m ByteString
readProcessInterleaved_)

-- | Snapshot the current terminal state.
--
-- @
-- snapshot = 'capture' >>= 'put'
-- @
--
-- Use functions like 'assertConditionS' to make assertions on the
-- most recent snapshot.
--
snapshot :: (HasTmuxSession a, MonadReader a m, MonadState Capture m, MonadIO m) => m ()
snapshot :: forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadState Capture m,
 MonadIO m) =>
m ()
snapshot = forall a (m :: * -> *).
(HasTmuxSession a, MonadReader a m, MonadIO m) =>
m Capture
capture forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall s (m :: * -> *). MonadState s m => s -> m ()
put

-- | 20 milliseconds
defaultBackoff :: Int
defaultBackoff :: Int
defaultBackoff = Int
20 forall a. Num a => a -> a -> a
* Int
10 forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
3 :: Int)

-- | create a tmux session running in the background
-- Note: the width and height are the default values tmux uses, but I thought
-- it's better to be explicit.
--
-- Returns the session name (whatever the input was) for convenience.
setUpTmuxSession :: TmuxSession -> IO TmuxSession
setUpTmuxSession :: String -> IO String
setUpTmuxSession String
sessionname = String
sessionname forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
        (forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ forall a b. (a -> b) -> a -> b
$ String -> [String] -> ProcessConfig () () ()
proc
             String
"tmux"
             [ String
"new-session"
             , String
"-x"
             , String
"80"
             , String
"-y"
             , String
"24"
             , String
"-d"
             , String
"-s"
             , String
sessionname
             , String
"-n"
             , String
"tasty-tmux"])
        (\IOException
e ->
              do let err :: String
err = forall a. Show a => a -> String
show (IOException
e :: IOException)
                 Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"\nException during setUp: " forall a. Semigroup a => a -> a -> a
<> String
err)
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Kills the whole session including pane and application
cleanUpTmuxSession :: String -> IO ()
cleanUpTmuxSession :: String -> IO ()
cleanUpTmuxSession String
sessionname =
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
        (forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ forall a b. (a -> b) -> a -> b
$ String -> [String] -> ProcessConfig () () ()
proc String
"tmux" [String
"kill-session", String
"-t", String
sessionname])
        (\IOException
e ->
              do let err :: String
err = forall a. Show a => a -> String
show (IOException
e :: IOException)
                 Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"\nException when killing session: " forall a. Semigroup a => a -> a -> a
<> String
err)
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure ())