mortred (empty) → 0.0.1
raw patch · 10 files changed
+783/−0 lines, 10 filesdep +basedep +binary-conduitdep +bytestring
Dependencies added: base, binary-conduit, bytestring, conduit, conduit-extra, errors, hspec, http-client, http-client-tls, http-conduit, http-types, mortred, rio, text, transformers, typed-process, webdriver, zip-stream
Files
- LICENSE.txt +25/−0
- app/Main.hs +8/−0
- mortred.cabal +235/−0
- src/Mortred.hs +66/−0
- src/Mortred/Selenium.hs +262/−0
- src/Mortred/Session.hs +66/−0
- src/Mortred/Types.hs +49/−0
- src/Mortred/Utilities.hs +25/−0
- src/Mortred/Xvfb.hs +46/−0
- test/Spec.hs +1/−0
+ LICENSE.txt view
@@ -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.
+ app/Main.hs view
@@ -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
+ mortred.cabal view
@@ -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 <gonz@severnatazvezda.com>+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
+ src/Mortred.hs view
@@ -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
+ src/Mortred/Selenium.hs view
@@ -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
+ src/Mortred/Session.hs view
@@ -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
+ src/Mortred/Types.hs view
@@ -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)
+ src/Mortred/Utilities.hs view
@@ -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
+ src/Mortred/Xvfb.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}