{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb (
  makeXvfbSession
  ) where

import Control.Exception
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Retry
import qualified Data.List as L
import Data.Maybe
import Data.String.Interpolate
import GHC.Stack
import Safe
import System.Directory
import System.Environment
import System.IO.Temp
import System.Process
import Test.Sandwich
import Test.Sandwich.WebDriver.Internal.Binaries.Xvfb
import Test.Sandwich.WebDriver.Internal.OnDemand
import Test.Sandwich.WebDriver.Internal.Types
import UnliftIO.MVar


#ifdef linux_HOST_OS
import System.Posix.IO as Posix
import System.Posix.Types
#endif

#ifdef darwin_HOST_OS
import GHC.IO.FD
import qualified GHC.IO.Handle.FD as HFD
newtype Fd = Fd FD
handleToFd h = Fd <$> HFD.handleToFd h
#endif

type Constraints m context = (
  HasCallStack, MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m
  , MonadReader context m, HasBaseContext context
  )


makeXvfbSession :: (
  Constraints m context
  ) => Maybe (Int, Int) -> Bool -> FilePath -> XvfbToUse -> MVar (OnDemand FilePath) -> m (XvfbSession, [(String, String)])
makeXvfbSession :: forall (m :: * -> *) context.
Constraints m context =>
Maybe (Int, Int)
-> Bool
-> FilePath
-> XvfbToUse
-> MVar (OnDemand FilePath)
-> m (XvfbSession, [(FilePath, FilePath)])
makeXvfbSession Maybe (Int, Int)
xvfbResolution Bool
xvfbStartFluxbox FilePath
webdriverRoot XvfbToUse
xvfbOnDemand MVar (OnDemand FilePath)
xvfbToUse = do
  let (Int
w, Int
h) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
1920, Int
1080) Maybe (Int, Int)
xvfbResolution
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
webdriverRoot

  let policy :: RetryPolicyM m
policy = Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
10000 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
1000
  (Int
serverNum :: Int, ProcessHandle
p, FilePath
authFile, Int
displayNum) <- RetryPolicyM m
-> (RetryStatus -> m (Int, ProcessHandle, FilePath, Int))
-> m (Int, ProcessHandle, FilePath, Int)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll RetryPolicyM m
policy ((RetryStatus -> m (Int, ProcessHandle, FilePath, Int))
 -> m (Int, ProcessHandle, FilePath, Int))
-> (RetryStatus -> m (Int, ProcessHandle, FilePath, Int))
-> m (Int, ProcessHandle, FilePath, Int)
forall a b. (a -> b) -> a -> b
$ \RetryStatus
_ -> do
    FilePath
-> FilePath
-> (FilePath -> Handle -> m (Int, ProcessHandle, FilePath, Int))
-> m (Int, ProcessHandle, FilePath, Int)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
FilePath -> FilePath -> (FilePath -> Handle -> m a) -> m a
withTempFile FilePath
webdriverRoot FilePath
"x11_server_num" ((FilePath -> Handle -> m (Int, ProcessHandle, FilePath, Int))
 -> m (Int, ProcessHandle, FilePath, Int))
-> (FilePath -> Handle -> m (Int, ProcessHandle, FilePath, Int))
-> m (Int, ProcessHandle, FilePath, Int)
forall a b. (a -> b) -> a -> b
$ \FilePath
path Handle
tmpHandle -> do
      Fd
fd <- IO Fd -> m Fd
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Fd -> m Fd) -> IO Fd -> m Fd
forall a b. (a -> b) -> a -> b
$ Handle -> IO Fd
handleToFd Handle
tmpHandle
      (Int
serverNum, ProcessHandle
p, FilePath
authFile) <- FilePath
-> Int
-> Int
-> Fd
-> XvfbToUse
-> MVar (OnDemand FilePath)
-> m (Int, ProcessHandle, FilePath)
forall (m :: * -> *) context.
Constraints m context =>
FilePath
-> Int
-> Int
-> Fd
-> XvfbToUse
-> MVar (OnDemand FilePath)
-> m (Int, ProcessHandle, FilePath)
createXvfbSession FilePath
webdriverRoot Int
w Int
h Fd
fd XvfbToUse
xvfbOnDemand MVar (OnDemand FilePath)
xvfbToUse

      Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Trying to determine display number for auth file '#{authFile}', using '#{path}'|]

      Int
displayNum <-
        RetryPolicyM m -> (RetryStatus -> m Int) -> m Int
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll RetryPolicyM m
policy ((RetryStatus -> m Int) -> m Int)
-> (RetryStatus -> m Int) -> m Int
forall a b. (a -> b) -> a -> b
$ \RetryStatus
_ ->
          (IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
path) m FilePath -> (FilePath -> m Int) -> m Int
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
contents -> case FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMay FilePath
contents of -- hGetContents readHandle
            Maybe Int
Nothing -> IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IOError -> IO Int
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO Int) -> IOError -> IO Int
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError [i|Couldn't determine X11 screen to use. Got data: '#{contents}'. Path was '#{path}'|]
            Just (Int
x :: Int) -> Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
x

      (Int, ProcessHandle, FilePath, Int)
-> m (Int, ProcessHandle, FilePath, Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
serverNum, ProcessHandle
p, FilePath
authFile, Int
displayNum)

  Maybe ProcessHandle
fluxboxProcess <- if Bool
xvfbStartFluxbox then ProcessHandle -> Maybe ProcessHandle
forall a. a -> Maybe a
Just (ProcessHandle -> Maybe ProcessHandle)
-> m ProcessHandle -> m (Maybe ProcessHandle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> Int -> m ProcessHandle
forall (m :: * -> *) context.
Constraints m context =>
FilePath -> Int -> m ProcessHandle
startFluxBoxOnDisplay FilePath
webdriverRoot Int
displayNum) else Maybe ProcessHandle -> m (Maybe ProcessHandle)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessHandle
forall a. Maybe a
Nothing

  let xvfbSession :: XvfbSession
xvfbSession = XvfbSession {
        xvfbDisplayNum :: Int
xvfbDisplayNum = Int
displayNum
        , xvfbXauthority :: FilePath
xvfbXauthority = FilePath
authFile
        , xvfbDimensions :: (Int, Int)
xvfbDimensions = (Int
w, Int
h)
        , xvfbProcess :: ProcessHandle
xvfbProcess = ProcessHandle
p
        , xvfbFluxboxProcess :: Maybe ProcessHandle
xvfbFluxboxProcess = Maybe ProcessHandle
fluxboxProcess
        }

  -- TODO: allow verbose logging to be controlled with an option:
  [(FilePath, FilePath)]
env' <- IO [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(FilePath, FilePath)]
getEnvironment
  let env :: [(FilePath, FilePath)]
env = ((FilePath, FilePath) -> (FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (\(FilePath, FilePath)
x (FilePath, FilePath)
y -> (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst (FilePath, FilePath)
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst (FilePath, FilePath)
y) ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ [(FilePath
"DISPLAY", FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
serverNum)
                                               , (FilePath
"XAUTHORITY", XvfbSession -> FilePath
xvfbXauthority XvfbSession
xvfbSession)] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. Semigroup a => a -> a -> a
<> [(FilePath, FilePath)]
env'
  (XvfbSession, [(FilePath, FilePath)])
-> m (XvfbSession, [(FilePath, FilePath)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (XvfbSession
xvfbSession, [(FilePath, FilePath)]
env)


createXvfbSession :: (
  Constraints m context
  ) => FilePath -> Int -> Int -> Fd -> XvfbToUse -> MVar (OnDemand FilePath) -> m (Int, ProcessHandle, FilePath)
createXvfbSession :: forall (m :: * -> *) context.
Constraints m context =>
FilePath
-> Int
-> Int
-> Fd
-> XvfbToUse
-> MVar (OnDemand FilePath)
-> m (Int, ProcessHandle, FilePath)
createXvfbSession FilePath
webdriverRoot Int
w Int
h (Fd CInt
fd) XvfbToUse
xvfbToUse MVar (OnDemand FilePath)
xvfbOnDemand = do
  FilePath
xvfb <- MVar (OnDemand FilePath) -> m (Either Text FilePath) -> m FilePath
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
MVar (OnDemand a) -> m (Either Text a) -> m a
getOnDemand MVar (OnDemand FilePath)
xvfbOnDemand (XvfbToUse -> m (Either Text FilePath)
forall context (m :: * -> *).
(MonadReader context m, HasBaseContext context, MonadUnliftIO m,
 MonadLoggerIO m) =>
XvfbToUse -> m (Either Text FilePath)
obtainXvfb XvfbToUse
xvfbToUse)

  Int
serverNum <- IO Int -> m Int
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
findFreeServerNum

  -- Start the Xvfb session
  FilePath
authFile <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> IO FilePath
writeTempFile FilePath
webdriverRoot FilePath
".Xauthority" FilePath
""
  ProcessHandle
p <- CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging (CreateProcess -> m ProcessHandle)
-> CreateProcess -> m ProcessHandle
forall a b. (a -> b) -> a -> b
$ (
    FilePath -> [FilePath] -> CreateProcess
proc FilePath
xvfb [FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
serverNum
              , FilePath
"-screen", FilePath
"0", [i|#{w}x#{h}x24|]
              , FilePath
"-displayfd", [i|#{fd}|]
              , FilePath
"-auth", FilePath
authFile
              ]) {
      cwd = Just webdriverRoot
      , create_group = True
      }

  (Int, ProcessHandle, FilePath) -> m (Int, ProcessHandle, FilePath)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
serverNum, ProcessHandle
p, FilePath
authFile)


findFreeServerNum :: IO Int
findFreeServerNum :: IO Int
findFreeServerNum = Int -> IO Int
findFreeServerNum' Int
99
  where
    findFreeServerNum' :: Int -> IO Int
    findFreeServerNum' :: Int -> IO Int
findFreeServerNum' Int
candidate = do
      FilePath -> IO Bool
doesPathExist [i|/tmp/.X11-unix/X#{candidate}|] IO Bool -> (Bool -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Int -> IO Int
findFreeServerNum' (Int
candidate Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        Bool
False -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
candidate


startFluxBoxOnDisplay :: Constraints m context => FilePath -> Int -> m ProcessHandle
startFluxBoxOnDisplay :: forall (m :: * -> *) context.
Constraints m context =>
FilePath -> Int -> m ProcessHandle
startFluxBoxOnDisplay FilePath
webdriverRoot Int
x = do
  FilePath
logPath <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> IO FilePath
writeTempFile FilePath
webdriverRoot FilePath
"fluxbox.log" FilePath
""

  Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Starting fluxbox on logPath '#{logPath}'|]

  let args :: [FilePath]
args = [FilePath
"-display", FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
x
             , FilePath
"-log", FilePath
logPath]

  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
 -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"fluxbox" [FilePath]
args) {
    cwd = Just webdriverRoot
    , create_group = True
    , std_out = CreatePipe
    , std_err = CreatePipe
    }

  -- TODO: confirm fluxbox started successfully

  ProcessHandle -> m ProcessHandle
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
p