{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
-- |

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.Logger
import Control.Monad.Trans.Control (MonadBaseControl)
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.Types


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


type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)


makeXvfbSession :: Constraints m => Maybe (Int, Int) -> Bool -> FilePath -> m (XvfbSession, [(String, String)])
makeXvfbSession :: Maybe (Int, Int)
-> Bool -> FilePath -> m (XvfbSession, [(FilePath, FilePath)])
makeXvfbSession Maybe (Int, Int)
xvfbResolution Bool
xvfbStartFluxbox FilePath
webdriverRoot = 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 (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 -> RetryPolicy
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 (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 -> m (Int, ProcessHandle, FilePath)
forall (m :: * -> *).
Constraints m =>
FilePath -> Int -> Int -> Fd -> m (Int, ProcessHandle, FilePath)
createXvfbSession FilePath
webdriverRoot Int
w Int
h Fd
fd

      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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Int
x

      (Int, ProcessHandle, FilePath, Int)
-> m (Int, ProcessHandle, FilePath, Int)
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 :: * -> *).
Constraints m =>
FilePath -> Int -> m ProcessHandle
startFluxBoxOnDisplay FilePath
webdriverRoot Int
displayNum) else Maybe ProcessHandle -> m (Maybe ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessHandle
forall a. Maybe a
Nothing

  let xvfbSession :: XvfbSession
xvfbSession = XvfbSession :: Int
-> FilePath
-> (Int, Int)
-> ProcessHandle
-> Maybe ProcessHandle
-> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (XvfbSession
xvfbSession, [(FilePath, FilePath)]
env)


createXvfbSession :: Constraints m => FilePath -> Int -> Int -> Fd -> m (Int, ProcessHandle, FilePath)
createXvfbSession :: FilePath -> Int -> Int -> Fd -> m (Int, ProcessHandle, FilePath)
createXvfbSession FilePath
webdriverRoot Int
w Int
h (Fd CInt
fd) = do
  Int
serverNum <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
findFreeServerNum

  -- Start the Xvfb session
  FilePath
authFile <- IO FilePath -> m FilePath
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 :: * -> *).
(MonadIO m, MonadBaseControl IO 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 :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
webdriverRoot
                                                  , create_group :: Bool
create_group = Bool
True }

  (Int, ProcessHandle, FilePath) -> m (Int, ProcessHandle, FilePath)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Int
candidate


startFluxBoxOnDisplay :: Constraints m => FilePath -> Int -> m ProcessHandle
startFluxBoxOnDisplay :: FilePath -> Int -> m ProcessHandle
startFluxBoxOnDisplay FilePath
webdriverRoot Int
x = do
  FilePath
logPath <- IO FilePath -> m FilePath
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 (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 :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
webdriverRoot
    , create_group :: Bool
create_group = Bool
True
    , std_out :: StdStream
std_out = StdStream
CreatePipe
    , std_err :: StdStream
std_err = StdStream
CreatePipe
    }

  -- TODO: confirm fluxbox started successfully

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