module Chiasma.Test.Tmux where

import Chiasma.Data.TmuxError (TmuxError)
import Chiasma.Monad.Stream (runTmux)
import qualified Chiasma.Monad.Tmux as Tmux (write)
import Chiasma.Native.Api (TmuxNative(..))
import Control.Concurrent (threadDelay)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.Posix.IO (fdToHandle)
import System.Posix.Pty (Pty, createPty, resizePty)
import qualified System.Posix.Signals as Signal (killProcess, signalProcess)
import System.Posix.Terminal (openPseudoTerminal)
import System.Process (getPid)
import System.Process.Typed (
  Process,
  ProcessConfig,
  StreamSpec,
  proc,
  setStderr,
  setStdin,
  setStdout,
  unsafeProcessHandle,
  useHandleClose,
  withProcessWait,
  )
import UnliftIO (finally, throwString)
import UnliftIO.Exception (tryAny)
import UnliftIO.Temporary (withSystemTempDirectory)

import Chiasma.Test.File (fixture)

data Terminal = Terminal Handle Pty

data TmuxTestConf =
  TmuxTestConf {
    TmuxTestConf -> Int
ttcWidth :: Int,
    TmuxTestConf -> Int
ttcHeight :: Int,
    TmuxTestConf -> Int
ttcFontSize :: Int,
    TmuxTestConf -> Bool
ttcGui :: Bool
  }
  deriving (TmuxTestConf -> TmuxTestConf -> Bool
(TmuxTestConf -> TmuxTestConf -> Bool)
-> (TmuxTestConf -> TmuxTestConf -> Bool) -> Eq TmuxTestConf
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TmuxTestConf -> TmuxTestConf -> Bool
$c/= :: TmuxTestConf -> TmuxTestConf -> Bool
== :: TmuxTestConf -> TmuxTestConf -> Bool
$c== :: TmuxTestConf -> TmuxTestConf -> Bool
Eq, Int -> TmuxTestConf -> ShowS
[TmuxTestConf] -> ShowS
TmuxTestConf -> String
(Int -> TmuxTestConf -> ShowS)
-> (TmuxTestConf -> String)
-> ([TmuxTestConf] -> ShowS)
-> Show TmuxTestConf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TmuxTestConf] -> ShowS
$cshowList :: [TmuxTestConf] -> ShowS
show :: TmuxTestConf -> String
$cshow :: TmuxTestConf -> String
showsPrec :: Int -> TmuxTestConf -> ShowS
$cshowsPrec :: Int -> TmuxTestConf -> ShowS
Show)

instance Default TmuxTestConf where
  def :: TmuxTestConf
def = Int -> Int -> Int -> Bool -> TmuxTestConf
TmuxTestConf Int
240 Int
61 Int
18 Bool
True

usleep :: MonadIO f => Double -> f ()
usleep :: Double -> f ()
usleep =
  IO () -> f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> (Double -> IO ()) -> Double -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay (Int -> IO ()) -> (Double -> Int) -> Double -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round

sleep :: MonadIO f => Double -> f ()
sleep :: Double -> f ()
sleep Double
seconds =
  Double -> f ()
forall (f :: * -> *). MonadIO f => Double -> f ()
usleep (Double -> f ()) -> Double -> f ()
forall a b. (a -> b) -> a -> b
$ Double
seconds Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e6

unsafeTerminal :: IO Terminal
unsafeTerminal :: IO Terminal
unsafeTerminal = do
  (Fd
_, Fd
slave) <- IO (Fd, Fd)
openPseudoTerminal
  Maybe Pty
mayPty <- Fd -> IO (Maybe Pty)
createPty Fd
slave
  Handle
handle <- Fd -> IO Handle
fdToHandle Fd
slave
  Pty
pty <- IO Pty -> (Pty -> IO Pty) -> Maybe Pty -> IO Pty
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO Pty
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"couldn't spawn pty") Pty -> IO Pty
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pty
mayPty
  return $ Handle -> Pty -> Terminal
Terminal Handle
handle Pty
pty

urxvtArgs :: Int -> Int -> Int -> [Text]
urxvtArgs :: Int -> Int -> Int -> [Text]
urxvtArgs Int
width Int
height Int
fontSize =
  [Item [Text]
"-geometry", Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
width Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"x" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
height, Item [Text]
"-fn", Text
"xft:monospace:size=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
fontSize, Item [Text]
"-e", Item [Text]
"tmux"]

testTmuxProcessConfig :: TmuxTestConf -> FilePath -> FilePath -> Terminal -> IO (ProcessConfig () () ())
testTmuxProcessConfig :: TmuxTestConf
-> String -> String -> Terminal -> IO (ProcessConfig () () ())
testTmuxProcessConfig (TmuxTestConf Int
width Int
height Int
fontSize Bool
gui) String
socket String
confFile (Terminal Handle
handle Pty
pty) = do
  Bool
confFileExists <- String -> IO Bool
doesFileExist String
confFile
  Pty -> (Int, Int) -> IO ()
resizePty Pty
pty (Int
width, Int
height)
  let
    stream :: StreamSpec st ()
    stream :: StreamSpec st ()
stream = Handle -> StreamSpec st ()
forall (anyStreamType :: StreamType).
Handle -> StreamSpec anyStreamType ()
useHandleClose Handle
handle
    stdio :: ProcessConfig stdin0 stdout0 stderr0 -> ProcessConfig () () ()
stdio = StreamSpec 'STInput ()
-> ProcessConfig stdin0 () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput ()
forall (st :: StreamType). StreamSpec st ()
stream (ProcessConfig stdin0 () () -> ProcessConfig () () ())
-> (ProcessConfig stdin0 stdout0 stderr0
    -> ProcessConfig stdin0 () ())
-> ProcessConfig stdin0 stdout0 stderr0
-> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamSpec 'STOutput ()
-> ProcessConfig stdin0 stdout0 () -> ProcessConfig stdin0 () ()
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput ()
forall (st :: StreamType). StreamSpec st ()
stream (ProcessConfig stdin0 stdout0 () -> ProcessConfig stdin0 () ())
-> (ProcessConfig stdin0 stdout0 stderr0
    -> ProcessConfig stdin0 stdout0 ())
-> ProcessConfig stdin0 stdout0 stderr0
-> ProcessConfig stdin0 () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamSpec 'STOutput ()
-> ProcessConfig stdin0 stdout0 stderr0
-> ProcessConfig stdin0 stdout0 ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput ()
forall (st :: StreamType). StreamSpec st ()
stream
    tmuxArgs :: [Text]
tmuxArgs = [Item [Text]
"-S", String -> Text
forall a. ToText a => a -> Text
toText String
socket, Item [Text]
"-f", String -> Text
forall a. ToText a => a -> Text
toText String
confFileArg]
    confFileArg :: String
confFileArg = if Bool
confFileExists then String
confFile else String
"/dev/null"
    prc :: ProcessConfig () () ()
prc =
      if Bool
gui
      then String -> [String] -> ProcessConfig () () ()
proc String
"urxvt" (Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Int -> [Text]
urxvtArgs Int
width Int
height Int
fontSize [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
tmuxArgs)
      else String -> [String] -> ProcessConfig () () ()
proc String
"tmux" (Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
tmuxArgs)
  ProcessConfig () () () -> IO (ProcessConfig () () ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessConfig () () () -> IO (ProcessConfig () () ()))
-> ProcessConfig () () () -> IO (ProcessConfig () () ())
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> ProcessConfig () () ()
forall stdin0 stdout0 stderr0.
ProcessConfig stdin0 stdout0 stderr0 -> ProcessConfig () () ()
stdio ProcessConfig () () ()
prc

killPid :: Integral a => a -> IO ()
killPid :: a -> IO ()
killPid =
  IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> (a -> IO (Either SomeException ())) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (IO () -> IO (Either SomeException ()))
-> (a -> IO ()) -> a -> IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> ProcessID -> IO ()
Signal.signalProcess Signal
Signal.killProcess (ProcessID -> IO ()) -> (a -> ProcessID) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ProcessID
forall a b. (Integral a, Num b) => a -> b
fromIntegral

killProcess :: TmuxNative -> Process () () () -> IO ()
killProcess :: TmuxNative -> Process () () () -> IO ()
killProcess TmuxNative
api Process () () ()
prc = do
  Either TmuxError ()
_ <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
forall (m :: * -> *) a.
ExceptT TmuxError m a -> m (Either TmuxError a)
runExceptT @TmuxError (ExceptT TmuxError IO () -> IO (Either TmuxError ()))
-> ExceptT TmuxError IO () -> IO (Either TmuxError ())
forall a b. (a -> b) -> a -> b
$ TmuxNative
-> TmuxProg (ExceptT TmuxError IO) () -> ExceptT TmuxError IO ()
forall (m :: * -> *) e api a.
(MonadIO m, MonadDeepError e TmuxError m, TmuxApi m api) =>
api -> TmuxProg m a -> m a
runTmux TmuxNative
api (TmuxProg (ExceptT TmuxError IO) () -> ExceptT TmuxError IO ())
-> TmuxProg (ExceptT TmuxError IO) () -> ExceptT TmuxError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> TmuxProg (ExceptT TmuxError IO) ()
forall (m :: * -> *).
MonadFree TmuxThunk m =>
Text -> [Text] -> m ()
Tmux.write Text
"kill-server" []
  let handle :: ProcessHandle
handle = Process () () () -> ProcessHandle
forall stdin stdout stderr.
Process stdin stdout stderr -> ProcessHandle
unsafeProcessHandle Process () () ()
prc
  Maybe ProcessID
mayPid <- ProcessHandle -> IO (Maybe ProcessID)
getPid ProcessHandle
handle
  IO () -> (ProcessID -> IO ()) -> Maybe ProcessID -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ProcessID -> IO ()
forall a. Integral a => a -> IO ()
killPid Maybe ProcessID
mayPid

-- FIXME find a way to wait for tmux deterministically instead of sleeping
-- if the first tmux control mode process from a TmuxProg runs before urxvt has started the server,
-- it will not use the test tmux.conf
-- maybe start tmux first, then urxvt?
runAndKillTmux :: (TmuxNative -> IO a) -> TmuxNative -> Process () () () -> IO a
runAndKillTmux :: (TmuxNative -> IO a) -> TmuxNative -> Process () () () -> IO a
runAndKillTmux TmuxNative -> IO a
thunk TmuxNative
api Process () () ()
prc = do
  Double -> IO ()
forall (f :: * -> *). MonadIO f => Double -> f ()
sleep Double
0.2
  IO a -> IO () -> IO a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (TmuxNative -> IO a
thunk TmuxNative
api) (TmuxNative -> Process () () () -> IO ()
killProcess TmuxNative
api Process () () ()
prc)

withTestTmux :: TmuxTestConf -> (TmuxNative -> IO a) -> FilePath -> IO a
withTestTmux :: TmuxTestConf -> (TmuxNative -> IO a) -> String -> IO a
withTestTmux TmuxTestConf
tConf TmuxNative -> IO a
thunk String
tempDir = do
  let socket :: String
socket = String
tempDir String -> ShowS
</> String
"tmux_socket"
  String
conf <- Text -> String -> IO String
forall (m :: * -> *). MonadIO m => Text -> String -> m String
fixture Text
"u" String
"tmux.conf"
  Terminal
terminal <- IO Terminal
unsafeTerminal
  ProcessConfig () () ()
pc <- TmuxTestConf
-> String -> String -> Terminal -> IO (ProcessConfig () () ())
testTmuxProcessConfig TmuxTestConf
tConf String
socket String
conf Terminal
terminal
  ProcessConfig () () () -> (Process () () () -> IO a) -> IO a
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait ProcessConfig () () ()
pc ((Process () () () -> IO a) -> IO a)
-> (Process () () () -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (TmuxNative -> IO a) -> TmuxNative -> Process () () () -> IO a
forall a.
(TmuxNative -> IO a) -> TmuxNative -> Process () () () -> IO a
runAndKillTmux TmuxNative -> IO a
thunk (Maybe String -> TmuxNative
TmuxNative (Maybe String -> TmuxNative) -> Maybe String -> TmuxNative
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
socket)

tmuxSpec' :: TmuxTestConf -> (TmuxNative -> IO a) -> IO a
tmuxSpec' :: TmuxTestConf -> (TmuxNative -> IO a) -> IO a
tmuxSpec' TmuxTestConf
conf TmuxNative -> IO a
thunk =
  String -> (String -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"chiasma-test" ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ TmuxTestConf -> (TmuxNative -> IO a) -> String -> IO a
forall a. TmuxTestConf -> (TmuxNative -> IO a) -> String -> IO a
withTestTmux TmuxTestConf
conf TmuxNative -> IO a
thunk

tmuxSpec :: (TmuxNative -> IO a) -> IO a
tmuxSpec :: (TmuxNative -> IO a) -> IO a
tmuxSpec =
  TmuxTestConf -> (TmuxNative -> IO a) -> IO a
forall a. TmuxTestConf -> (TmuxNative -> IO a) -> IO a
tmuxSpec' TmuxTestConf
forall a. Default a => a
def { $sel:ttcGui:TmuxTestConf :: Bool
ttcGui = Bool
False }

tmuxGuiSpec :: (TmuxNative -> IO a) -> IO a
tmuxGuiSpec :: (TmuxNative -> IO a) -> IO a
tmuxGuiSpec =
  TmuxTestConf -> (TmuxNative -> IO a) -> IO a
forall a. TmuxTestConf -> (TmuxNative -> IO a) -> IO a
tmuxSpec' TmuxTestConf
forall a. Default a => a
def