Xvfb.hs

module Mortred.Xvfb
  ( startXvfb,
    XvfbStartError (..),
  )
where

import Mortred.Types
import Mortred.Utilities
import RIO
import RIO.Directory (doesFileExist)
import System.Process.Typed
  ( nullStream,
    proc,
    setStderr,
    setStdin,
    setStdout,
    startProcess,
  )

data XvfbStartError
  = XvfbProcessError IOException
  | UnableToAllocateDisplay
  deriving (Eq, Show)

instance Exception XvfbStartError

-- | Attempts to start an `Xvfb` process. Throws 'XvfbStartError' on failure.
startXvfb :: (MonadThrow m, MonadUnliftIO m) => m XvfbProcess
startXvfb = do
  (DisplayNumber d) <- fromMaybeM UnableToAllocateDisplay allocateDisplayNumber
  let processConfiguration =
        proc "Xvfb" [":" <> show d, "-screen", show d, "1920x1080x24"]
          & setStdin nullStream
          & setStdout nullStream
          & setStderr nullStream
  process <- mapExceptionM XvfbProcessError $ startProcess processConfiguration
  pure $ XvfbProcess {displayNumber = DisplayNumber d, process}

allocateDisplayNumber :: (MonadUnliftIO m) => m (Maybe DisplayNumber)
allocateDisplayNumber =
  fmap DisplayNumber <$> findM (DisplayNumber >>> xFileDoesNotExist) [0 .. 199]

xFileDoesNotExist :: (MonadUnliftIO m) => DisplayNumber -> m Bool
xFileDoesNotExist (DisplayNumber d) = do
  let filename = "/tmp/.X11-unix/X" <> show d
  liftIO $ not <$> doesFileExist filename