{-# 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

#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 = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)


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

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

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

      Int
displayNum <-
        forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll RetryPolicyM m
policy forall a b. (a -> b) -> a -> b
$ \RetryStatus
_ ->
          (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
path) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
contents -> case forall a. Read a => FilePath -> Maybe a
readMay FilePath
contents of -- hGetContents readHandle
            Maybe Int
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO 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) -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
x

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

  Maybe ProcessHandle
fluxboxProcess <- if Bool
xvfbStartFluxbox then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *).
Constraints m =>
FilePath -> Int -> m ProcessHandle
startFluxBoxOnDisplay FilePath
webdriverRoot Int
displayNum) else forall (m :: * -> *) a. Monad m => a -> m a
return 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' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(FilePath, FilePath)]
getEnvironment
  let env :: [(FilePath, FilePath)]
env = forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (\(FilePath, FilePath)
x (FilePath, FilePath)
y -> forall a b. (a, b) -> a
fst (FilePath, FilePath)
x forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst (FilePath, FilePath)
y) forall a b. (a -> b) -> a -> b
$ [(FilePath
"DISPLAY", FilePath
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Int
serverNum)
                                               , (FilePath
"XAUTHORITY", XvfbSession -> FilePath
xvfbXauthority XvfbSession
xvfbSession)] forall a. Semigroup a => a -> a -> a
<> [(FilePath, FilePath)]
env'
  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 :: forall (m :: * -> *).
Constraints m =>
FilePath -> Int -> Int -> Fd -> m (Int, ProcessHandle, FilePath)
createXvfbSession FilePath
webdriverRoot Int
w Int
h (Fd CInt
fd) = do
  Int
serverNum <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
findFreeServerNum

  -- Start the Xvfb session
  FilePath
authFile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> IO FilePath
writeTempFile FilePath
webdriverRoot FilePath
".Xauthority" FilePath
""
  ProcessHandle
p <- forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging forall a b. (a -> b) -> a -> b
$ (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"Xvfb" [FilePath
":" forall a. Semigroup a => a -> a -> a
<> 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 = forall a. a -> Maybe a
Just FilePath
webdriverRoot
                                                  , create_group :: Bool
create_group = Bool
True }

  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}|] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> Int -> IO Int
findFreeServerNum' (Int
candidate forall a. Num a => a -> a -> a
+ Int
1)
        Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
candidate


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

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

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

  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess forall a b. (a -> b) -> a -> b
$ (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"fluxbox" [FilePath]
args) {
    cwd :: Maybe FilePath
cwd = 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

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