diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,25 @@ +BSD 2-Clause License + +Copyright (c) 2021, Rickard Andersson +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Mortred +import Prelude (IO) + +-- This `main` function just delegates to the library's definition of `main` +main :: IO () +main = runMain diff --git a/mortred.cabal b/mortred.cabal new file mode 100644 --- /dev/null +++ b/mortred.cabal @@ -0,0 +1,235 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: mortred +version: 0.0.1 +synopsis: Library for setting up and running scrapers with webdriver. +description: A set of setup- and helper-functions for using webdriver in Haskell, with auto-downloads of correct binaries. +category: web-scraping, selenium +maintainer: Rickard Andersson +license: BSD2 +license-file: LICENSE.txt +build-type: Simple + +library + exposed-modules: + Mortred + Mortred.Selenium + Mortred.Session + Mortred.Types + Mortred.Utilities + Mortred.Xvfb + other-modules: + Paths_mortred + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DeriveLift + DerivingStrategies + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + TypeApplications + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.9.1.0 && <5 + , binary-conduit + , bytestring + , conduit + , conduit-extra + , errors + , http-client + , http-client-tls + , http-conduit + , http-types + , rio + , text + , transformers + , typed-process + , webdriver + , zip-stream + default-language: Haskell2010 + +executable mortred + main-is: Main.hs + other-modules: + Paths_mortred + hs-source-dirs: + app + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DeriveLift + DerivingStrategies + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + TypeApplications + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.9.1.0 && <5 + , binary-conduit + , bytestring + , conduit + , conduit-extra + , errors + , http-client + , http-client-tls + , http-conduit + , http-types + , mortred + , rio + , text + , transformers + , typed-process + , webdriver + , zip-stream + default-language: Haskell2010 + +test-suite mortred-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_mortred + hs-source-dirs: + test + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DeriveLift + DerivingStrategies + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + EmptyCase + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeSynonymInstances + ViewPatterns + TypeApplications + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -Wall + build-depends: + base >=4.9.1.0 && <5 + , binary-conduit + , bytestring + , conduit + , conduit-extra + , errors + , hspec >=2.0.0 + , http-client + , http-client-tls + , http-conduit + , http-types + , mortred + , rio + , text + , transformers + , typed-process + , webdriver + , zip-stream + default-language: Haskell2010 diff --git a/src/Mortred.hs b/src/Mortred.hs new file mode 100644 --- /dev/null +++ b/src/Mortred.hs @@ -0,0 +1,66 @@ +module Mortred where + +import Mortred.Session +import Mortred.Types +import Mortred.Utilities +import RIO +import System.IO (print, putStrLn) +import Test.WebDriver + +webdriverConfig :: SeleniumPort -> WDConfig +webdriverConfig (SeleniumPort port) = + defaultConfig {wdPort = port} & useBrowser chromeNoSandbox + +chromeNoSandbox :: Browser +chromeNoSandbox = + Chrome + { chromeDriverVersion = Nothing, + chromeOptions = ["--no-sandbox"], + chromeBinary = Nothing, + chromeExtensions = [], + chromeExperimentalOptions = mempty + } + +applicationStart :: WD () +applicationStart = do + openPage "https://www.google.com/" + metaContents <- findElems (ByCSS "meta") >>= mapM (getAttribute "content") + liftIO $ print metaContents + closeSession + +getAttribute :: Text -> Element -> WD (Maybe Text) +getAttribute = flip attr + +data SessionRunTimedout = SessionRunTimedout + { port :: Int, + host :: String, + milliseconds :: Milliseconds + } + deriving (Show) + +instance Exception SessionRunTimedout + +-- | Wait N 'Milliseconds' for an action to succeed with a given WebDriver configuration. Throws a +-- 'SessionRunTimedout' exception if the action does not succeed within the alloted time. +waitRunSession :: (MonadThrow m, MonadUnliftIO m) => Milliseconds -> WDConfig -> WD a -> m a +waitRunSession milliseconds@(Milliseconds ms) configuration@WDConfig {wdPort, wdHost} action = do + fromMaybeM (SessionRunTimedout wdPort wdHost milliseconds) timeoutRun + where + timeoutRun = timeout (ms * 1000) runSession' + runSession' = do + result <- tryAny $ liftIO $ runSession configuration action + either (const runSession') pure result + +runMain :: IO () +runMain = do + maybeSeleniumProcess <- + tryStartSession SessionOnDemand $ SeleniumPath "./selenium-server-standalone-2.53.1.jar" + + case maybeSeleniumProcess of + Right (StartedOnDemand seleniumProcess@SeleniumProcess {port}) -> do + waitRunSession (Milliseconds 2500) (webdriverConfig port) applicationStart + `finally` stopSession seleniumProcess + Right (PremadeSession port) -> do + waitRunSession (Milliseconds 2500) (webdriverConfig port) applicationStart + Left e -> + putStrLn $ "Unable to start session: " <> show e diff --git a/src/Mortred/Selenium.hs b/src/Mortred/Selenium.hs new file mode 100644 --- /dev/null +++ b/src/Mortred/Selenium.hs @@ -0,0 +1,262 @@ +module Mortred.Selenium + ( startSelenium, + SeleniumStartError (..), + ChromeDriverSetupError (..), + ) +where + +import qualified Codec.Archive.Zip.Conduit.UnZip as UnZip +import Conduit +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Conduit.Binary as CB +import Data.Conduit.Serialization.Binary (ParseError) +import qualified Data.Text as DataText +import qualified Data.Text.IO as TIO +import Mortred.Types +import Mortred.Utilities +import Network.HTTP.Client (HttpException (..), Response (..), httpLbs, parseRequest) +import Network.HTTP.Client.TLS (getGlobalManager) +import Numeric (readHex) +import RIO +import qualified RIO.ByteString.Lazy as LazyByteString +import RIO.Directory + ( Permissions (..), + createDirectoryIfMissing, + doesDirectoryExist, + doesFileExist, + emptyPermissions, + listDirectory, + setPermissions, + ) +import RIO.FilePath (dropFileName, ()) +import qualified RIO.FilePath as FilePath +import qualified RIO.List as List +import qualified RIO.List.Partial as Partial +import qualified RIO.Text as Text +import System.Environment (getEnv) +import System.IO (openFile, putStrLn) +import System.Process.Typed + +-- | Error representing a failure to set up @chromedriver@. +data ChromeDriverSetupError + = -- | Unable to find @google-chrome@, which means we don't know which @chromedriver@ version to + -- download. + ChromeBinaryNotFound + | -- | The chrome version we have has no valid @chromedriver@ version to download. + NoValidChromeDriverUrl ChromeVersion + | -- | The extracted major version of @google-chrome@ or @chromedriver@ is not supported. + UnsupportedMajorVersion Text + | -- | Unable to read the output of @google-chrome --version@. + BadChromeVersionOutput LByteString + | -- | Something went wrong when getting the output of @google-chrome --version@. + UnableToReadChromeProcess FilePath IOException + | -- | Something went wrong when downloading @chromedriver@. + DownloadError Url HttpException + | -- | Something went wrong when unzipping @chromedriver@. + UnzipError ParseError + deriving (Show) + +instance Exception ChromeDriverSetupError + +-- | Represents a failure to start Selenium. +data SeleniumStartError + = -- | Unable to find Selenium at the given 'SeleniumPath'. + SeleniumNotFound SeleniumPath + | -- | We were unable to fulfill the pre-requisites of setting up @chromedriver@. + SeleniumStartChromeDriverError ChromeDriverSetupError + | -- | The @google-chrome@ and @chromedriver@ we have do not have matching major versions. + VersionMismatch ChromeVersion ChromeDriverVersion + deriving (Show) + +instance Exception SeleniumStartError + +-- | Starts a Selenium server backed by a given `Xvfb` process. The `SeleniumPath` parameter should +-- point to the actual JAR-file to run. Throws `SeleniumStartError` if the Selenium server cannot be +-- started. +startSelenium :: + (MonadThrow m, MonadUnliftIO m, PrimMonad m, MonadFail m) => + XvfbProcess -> + SeleniumPath -> + m SeleniumProcess +startSelenium xvfbProcess seleniumPath@(SeleniumPath sp) = do + let chromeDriverPath = FilePath.takeDirectory sp "chromedriver" + port@(SeleniumPort portNumber) <- allocateServerPort + chromeDriverExists <- doesChromeDriverExist seleniumPath + seleniumExists <- liftIO $ doesFileExist sp + if seleniumExists + then do + unless chromeDriverExists $ do + liftIO $ putStrLn "Downloading `chromedriver`" + downloadChromeDriver chromeDriverPath + chromeDriverVersion@(ChromeDriverVersion cdVersion) <- + getChromeDriverVersion chromeDriverPath + chromeBinary <- + fromMaybeM (SeleniumStartChromeDriverError ChromeBinaryNotFound) $ + searchPathForBinary "google-chrome" + chromeVersion@(ChromeVersion cVersion) <- getChromeVersion chromeBinary + when (cdVersion /= cVersion) $ do + throwM $ VersionMismatch chromeVersion chromeDriverVersion + let processConfiguration = + proc "java" ["-jar", sp, "-port", show portNumber] + & setStdin nullStream + & setStdout nullStream + & setStderr nullStream + & setEnv [("DISPLAY", xvfbProcess & displayNumber & unDisplayNumber & show & (":" <>))] + process <- startProcess processConfiguration + pure $ SeleniumProcess {xvfbProcess, process, port} + else throwM $ SeleniumNotFound seleniumPath + +downloadChromeDriver :: + (MonadThrow m, MonadUnliftIO m, PrimMonad m, MonadFail m) => + FilePath -> + m () +downloadChromeDriver path = do + manager <- liftIO getGlobalManager + chromeBinary <- fromMaybeM ChromeBinaryNotFound $ searchPathForBinary "google-chrome" + chromeVersion <- getChromeVersion chromeBinary + chromeDriverLink <- + fromEither $ note (NoValidChromeDriverUrl chromeVersion) $ getChromeDriverLink chromeVersion + request <- chromeDriverLink & unUrl & parseRequest + response <- mapExceptionM (DownloadError chromeDriverLink) $ liftIO $ httpLbs request manager + mapExceptionM UnzipError $ unzipIntoPath path $ responseBody response + liftIO $ setChromeDriverPermissions path + +setChromeDriverPermissions :: FilePath -> IO () +setChromeDriverPermissions path = do + setPermissions + path + ( emptyPermissions + { writable = True, + readable = True, + executable = True + } + ) + +allocateServerPort :: (MonadUnliftIO m) => m SeleniumPort +allocateServerPort = do + let lineToPort l = + case l & Text.strip & Text.words & take 2 & drop 1 & fmap (Text.split (== ':')) of + [[_localAddress, portText]] -> + portText & Text.unpack & readHex & Partial.head & fst + _other -> + error $ "Bad line in '/proc/net/tcp': '" <> show l <> "'" + procNetTcpContents <- readFileUtf8 "/proc/net/tcp" + procNetTcp6Contents <- readFileUtf8 "/proc/net/tcp6" + let takenPorts = procNetTcpContents & Text.lines & drop 1 & map lineToPort + takenIPV6Ports = procNetTcp6Contents & Text.lines & drop 1 & map lineToPort + allocate' p = if isTaken p then allocate' (p + 1) else p + isTaken = (`elem` (takenPorts <> takenIPV6Ports)) + pure $ SeleniumPort $ allocate' 4444 + +unzipIntoPath :: + (MonadThrow m, MonadUnliftIO m, PrimMonad m, MonadFail m) => + FilePath -> + LByteString -> + m () +unzipIntoPath path content = + void $ runConduitRes $ CB.sourceLbs content .| fuseUpstream UnZip.unZipStream (extract path) + +getBinaryVersionText :: (MonadThrow m, MonadUnliftIO m) => FilePath -> m LByteString +getBinaryVersionText path = do + let processConfiguration = + proc path ["--version"] + & setStdout byteStringOutput + & setStdin nullStream + & setStderr nullStream + (_exitCode, result) <- + mapExceptionM (UnableToReadChromeProcess path) $ readProcessStdout processConfiguration + pure result + +getChromeVersion :: (MonadThrow m, MonadUnliftIO m) => FilePath -> m ChromeVersion +getChromeVersion path = do + output <- liftIO $ getBinaryVersionText path + case output & LazyByteString.toStrict & decodeUtf8Lenient & Text.strip & Text.split (== ' ') of + _google : _chrome : version : _ -> + version + & Text.takeWhile (/= '.') + & textToMajorVersion + & note (UnsupportedMajorVersion version) + & fromEither + & fmap ChromeVersion + _other -> throwM $ BadChromeVersionOutput output + +getChromeDriverVersion :: (MonadThrow m, MonadUnliftIO m) => FilePath -> m ChromeDriverVersion +getChromeDriverVersion path = do + output <- liftIO $ getBinaryVersionText path + case output & LazyByteString.toStrict & decodeUtf8Lenient & Text.strip & Text.split (== ' ') of + _chromeDriver : version : _ -> + version + & Text.takeWhile (/= '.') + & textToMajorVersion + & note (UnsupportedMajorVersion version) + & fromEither + & fmap ChromeDriverVersion + _other -> throwM $ BadChromeVersionOutput output + +textToMajorVersion :: Text -> Maybe MajorVersion +textToMajorVersion "93" = Just $ MajorVersion 93 +textToMajorVersion "94" = Just $ MajorVersion 94 +textToMajorVersion "95" = Just $ MajorVersion 95 +textToMajorVersion _ = Nothing + +doesChromeDriverExist :: (MonadUnliftIO m) => SeleniumPath -> m Bool +doesChromeDriverExist (SeleniumPath sp) = do + let basePath = dropFileName sp + inSeleniumPath <- doesFileExist (basePath "chromedriver") + if inSeleniumPath then pure inSeleniumPath else isJust <$> searchPathForBinary "chromedriver" + +searchPathForBinary :: (MonadUnliftIO m) => FilePath -> m (Maybe FilePath) +searchPathForBinary binary = do + pathContents <- (Text.pack >>> Text.split (== ':')) <$> liftIO (getEnv "PATH") + let getBinariesForPath p = do + directoryContents <- listDirectory p + files <- filterM ((p ) >>> doesFileExist) directoryContents + pure (p, files) + binaries <- filterM doesDirectoryExist (Text.unpack <$> pathContents) >>= mapM getBinariesForPath + let maybeFoundInPath = List.find (\(_path, binaryNames) -> binary `elem` binaryNames) binaries + pure $ (fst >>> ( binary)) <$> maybeFoundInPath + +-- Lifted from https://github.com/dylex/zip-stream/blob/master/cmd/unzip.hs +extract :: + (MonadIO m, MonadFail m) => + FilePath -> + ConduitT (Either UnZip.ZipEntry ByteString) Void m () +extract path = awaitForever start + where + start (Left UnZip.ZipEntry {..}) = do + liftIO $ either TIO.putStrLn Char8.putStrLn zipEntryName + liftIO $ createDirectoryIfMissing True (FilePath.takeDirectory fullName) + if either DataText.last Char8.last zipEntryName == '/' + then when ((0 /=) `any` zipEntrySize) $ fail $ fullName ++ ": non-empty directory" + else do + h <- liftIO $ openFile fullName WriteMode + mapM_ (liftIO . hSetFileSize h . toInteger) zipEntrySize + write .| CB.sinkHandle h + liftIO $ hClose h + where + name = + either + (Text.unpack . Text.dropWhile ('/' ==)) + (Char8.unpack . Char8.dropWhile ('/' ==)) + zipEntryName + fullName = FilePath.takeDirectory path name + start (Right _) = fail "Unexpected leading or directory data contents" + write = await >>= maybe (return ()) block + block (Right b) = yield b >> write + block a = leftover a + +chromeDriverLinks :: [(ChromeVersion, Url)] +chromeDriverLinks = + [ ( ChromeVersion $ MajorVersion 95, + Url "https://chromedriver.storage.googleapis.com/95.0.4638.17/chromedriver_linux64.zip" + ), + ( ChromeVersion $ MajorVersion 94, + Url "https://chromedriver.storage.googleapis.com/94.0.4606.61/chromedriver_linux64.zip" + ), + ( ChromeVersion $ MajorVersion 93, + Url "https://chromedriver.storage.googleapis.com/93.0.4577.63/chromedriver_linux64.zip" + ) + ] + +getChromeDriverLink :: ChromeVersion -> Maybe Url +getChromeDriverLink chromeVersion = snd <$> List.find (fst >>> (== chromeVersion)) chromeDriverLinks diff --git a/src/Mortred/Session.hs b/src/Mortred/Session.hs new file mode 100644 --- /dev/null +++ b/src/Mortred/Session.hs @@ -0,0 +1,66 @@ +module Mortred.Session where + +import Mortred.Selenium +import Mortred.Types +import Mortred.Utilities +import Mortred.Xvfb +import RIO +import System.Process.Typed (stopProcess) + +-- | Defines how to handle potential starting up of Xvfb & Selenium. +data SessionMode + = -- | Start Xvfb and Selenium. + SessionOnDemand + | -- | Don't start Xvfb and Selenium. + SessionAlreadyStarted SeleniumPort + deriving (Eq, Show) + +-- | The result of successfully starting a session. +data SessionStartResult + = -- | Xvfb and Selenium were started and here is the Selenium process. + StartedOnDemand !SeleniumProcess + | -- | The session was premade and here is the port to connect to. + PremadeSession !SeleniumPort + deriving (Show) + +data SessionStartError + = XvfbSessionError XvfbStartError + | SeleniumSessionError SeleniumStartError + deriving (Show) + +instance Exception SessionStartError + +-- | Tries to start a session, returning 'Left' with a 'SessionStartError' if it fails or 'Right' +-- with a 'SessionStartResult' if it succeeds. Errors that can be expected to be caught here are +-- process read errors (for `google-chrome` & `chromedriver`), display allocation errors (for Xvfb), +-- and Selenium start errors (port allocation, unable to find selenium file) as well as HTTP errors +-- for automatically downloading `chromedriver`. +tryStartSession :: + (MonadUnliftIO m, MonadThrow m, PrimMonad m, MonadFail m) => + SessionMode -> + SeleniumPath -> + m (Either SessionStartError SessionStartResult) +tryStartSession sessionMode = + startSession sessionMode >>> try + +-- | Starts a session, throwing a 'SessionStartError' on failure. Use 'tryStartSession' in order to +-- automatically capture this error. +startSession :: + (MonadThrow m, MonadUnliftIO m, PrimMonad m, MonadFail m) => + SessionMode -> + SeleniumPath -> + m SessionStartResult +startSession SessionOnDemand seleniumPath = do + xvfbProcess@XvfbProcess {process} <- mapExceptionM XvfbSessionError startXvfb + (StartedOnDemand <$> startSelenium xvfbProcess seleniumPath) + `catch` ( \(e :: SeleniumStartError) -> do + stopProcess process + throwM $ SeleniumSessionError e + ) +startSession (SessionAlreadyStarted seleniumPort) _seleniumPath = do + pure $ PremadeSession seleniumPort + +stopSession :: SeleniumProcess -> IO () +stopSession SeleniumProcess {xvfbProcess = XvfbProcess {process = xvfbProcess}, process} = do + stopProcess process + stopProcess xvfbProcess diff --git a/src/Mortred/Types.hs b/src/Mortred/Types.hs new file mode 100644 --- /dev/null +++ b/src/Mortred/Types.hs @@ -0,0 +1,49 @@ +module Mortred.Types where + +import RIO +import System.Process.Typed (Process) + +data SessionDependencyConfiguration = SessionDependencyConfiguration + { chromeBinary :: FilePath, + chromeDriverBinary :: FilePath, + seleniumPath :: SeleniumPath + } + deriving (Eq, Show) + +data SeleniumProcess = SeleniumProcess + { xvfbProcess :: XvfbProcess, + process :: Process () () (), + port :: SeleniumPort + } + deriving (Show) + +data XvfbProcess = XvfbProcess + { displayNumber :: DisplayNumber, + process :: Process () () () + } + deriving (Show) + +newtype DisplayNumber = DisplayNumber {unDisplayNumber :: Int} + deriving (Eq, Show) + +-- | Represents the full path to a Selenium JAR-file. +newtype SeleniumPath = SeleniumPath {unSeleniumPath :: FilePath} + deriving (Eq, Show) + +newtype SeleniumPort = SeleniumPort {unSeleniumPort :: Int} + deriving (Eq, Show) + +newtype Url = Url {unUrl :: String} + deriving (Eq, Show) + +newtype MajorVersion = MajorVersion {unMajorVersion :: Int} + deriving (Eq, Show) + +newtype Milliseconds = Milliseconds {unMilliseconds :: Int} + deriving (Eq, Show) + +newtype ChromeVersion = ChromeVersion {unChromeVersion :: MajorVersion} + deriving (Eq, Show) + +newtype ChromeDriverVersion = ChromeDriverVersion {unChromeDriverVersion :: MajorVersion} + deriving (Eq, Show) diff --git a/src/Mortred/Utilities.hs b/src/Mortred/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Mortred/Utilities.hs @@ -0,0 +1,25 @@ +module Mortred.Utilities where + +import RIO + +-- | Re-throws an exception after applying a transformation from one exception type to another. +mapExceptionM :: (Exception e1, Exception e2, MonadUnliftIO m) => (e1 -> e2) -> m a -> m a +mapExceptionM f = handle (f >>> throwIO) + +-- | Takes a 'Maybe' and turns it into an 'Either', with an error value for when the 'Maybe' is +-- 'Nothing'. +note :: e -> Maybe a -> Either e a +note _e (Just a) = Right a +note e Nothing = Left e + +-- | Takes a monadic action producing a @m Maybe@ and throws a given exception @e@ from it. This +-- is just a specialization of @'fromEitherM' '$' note e '<$>' action@. +fromMaybeM :: (Exception e, MonadUnliftIO m) => e -> m (Maybe a) -> m a +fromMaybeM e = fmap (note e) >>> fromEitherM + +-- | Lifted version of 'Data.List.find'. +findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a) +findM _p [] = pure Nothing +findM p (a : as) = do + result <- p a + if result then pure (Just a) else findM p as diff --git a/src/Mortred/Xvfb.hs b/src/Mortred/Xvfb.hs new file mode 100644 --- /dev/null +++ b/src/Mortred/Xvfb.hs @@ -0,0 +1,46 @@ +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}