mirror of
https://github.com/codedownio/sandwich.git
synced 2024-09-11 11:56:32 +03:00
Move things around and introduce sandwich-webdriver
This commit is contained in:
parent
54e471f2e1
commit
3d0fd057e8
2
sandwich-webdriver/.gitignore
vendored
Normal file
2
sandwich-webdriver/.gitignore
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
.stack-work/
|
||||
*~
|
3
sandwich-webdriver/ChangeLog.md
Normal file
3
sandwich-webdriver/ChangeLog.md
Normal file
@ -0,0 +1,3 @@
|
||||
# Changelog for sandwich-webdriver
|
||||
|
||||
## Unreleased changes
|
1
sandwich-webdriver/README.md
Normal file
1
sandwich-webdriver/README.md
Normal file
@ -0,0 +1 @@
|
||||
# sandwich-webdriver
|
26
sandwich-webdriver/app/Main.hs
Normal file
26
sandwich-webdriver/app/Main.hs
Normal file
@ -0,0 +1,26 @@
|
||||
module Main where
|
||||
|
||||
import Data.Time.Clock
|
||||
import Test.Sandwich
|
||||
import Test.Sandwich.Formatters.TerminalUI
|
||||
import Test.Sandwich.Types.Options
|
||||
import Test.Sandwich.WebDriver
|
||||
import Test.WebDriver
|
||||
|
||||
wdOptions = defaultWdOptions "/tmp/tools"
|
||||
|
||||
simple :: TopSpec
|
||||
simple = introduceWebdriver wdOptions $ do
|
||||
it "does the thing 1" $ do
|
||||
wdSession <- getContext webdriver
|
||||
openPage "www.google.com"
|
||||
return ()
|
||||
it "does the thing 2" $ do
|
||||
return ()
|
||||
|
||||
options = defaultOptions {
|
||||
optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)
|
||||
}
|
||||
|
||||
main :: IO ()
|
||||
main = runSandwich options defaultTerminalUIFormatter simple
|
84
sandwich-webdriver/package.yaml
Normal file
84
sandwich-webdriver/package.yaml
Normal file
@ -0,0 +1,84 @@
|
||||
name: sandwich-webdriver
|
||||
version: 0.1.0.0
|
||||
github: "githubuser/sandwich-webdriver"
|
||||
license: BSD3
|
||||
author: "Author name here"
|
||||
maintainer: "example@example.com"
|
||||
copyright: "2020 Author name here"
|
||||
|
||||
extra-source-files:
|
||||
- README.md
|
||||
- ChangeLog.md
|
||||
|
||||
# Metadata used when publishing your package
|
||||
# synopsis: Short description of your package
|
||||
# category: Web
|
||||
|
||||
# To avoid duplicated efforts in documentation and dealing with the
|
||||
# complications of embedding Haddock markup inside cabal files, it is
|
||||
# common to point users to the README.md file.
|
||||
description: Please see the README on GitHub at <https://github.com/githubuser/sandwich-webdriver#readme>
|
||||
|
||||
dependencies:
|
||||
- aeson
|
||||
- async
|
||||
- base >= 4.7 && < 5
|
||||
- containers
|
||||
- convertible
|
||||
- data-default
|
||||
- directory
|
||||
- filepath
|
||||
- http-client
|
||||
- http-conduit
|
||||
- interpolate
|
||||
- lifted-base
|
||||
- monad-control
|
||||
- network
|
||||
- process
|
||||
- random
|
||||
- retry
|
||||
- safe
|
||||
- safe-exceptions
|
||||
- sandwich
|
||||
- temporary
|
||||
- text
|
||||
- transformers
|
||||
- transformers-base
|
||||
- unix
|
||||
- webdriver
|
||||
|
||||
default-extensions:
|
||||
- OverloadedStrings
|
||||
- QuasiQuotes
|
||||
- NamedFieldPuns
|
||||
- RecordWildCards
|
||||
- ScopedTypeVariables
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- LambdaCase
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
executables:
|
||||
sandwich-webdriver-exe:
|
||||
main: Main.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- sandwich-webdriver
|
||||
- time
|
||||
|
||||
tests:
|
||||
sandwich-webdriver-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- sandwich-webdriver
|
150
sandwich-webdriver/sandwich-webdriver.cabal
Normal file
150
sandwich-webdriver/sandwich-webdriver.cabal
Normal file
@ -0,0 +1,150 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.33.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 6bb4d7fc32b1edd7ca4d9795dd60df74ed0137546ecce8a536dea98501f6f390
|
||||
|
||||
name: sandwich-webdriver
|
||||
version: 0.1.0.0
|
||||
description: Please see the README on GitHub at <https://github.com/githubuser/sandwich-webdriver#readme>
|
||||
homepage: https://github.com/githubuser/sandwich-webdriver#readme
|
||||
bug-reports: https://github.com/githubuser/sandwich-webdriver/issues
|
||||
author: Author name here
|
||||
maintainer: example@example.com
|
||||
copyright: 2020 Author name here
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
build-type: Simple
|
||||
extra-source-files:
|
||||
README.md
|
||||
ChangeLog.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/githubuser/sandwich-webdriver
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Lib
|
||||
Test.Sandwich.WebDriver
|
||||
Test.Sandwich.WebDriver.Internal.Action
|
||||
Test.Sandwich.WebDriver.Internal.Binaries
|
||||
Test.Sandwich.WebDriver.Internal.Binaries.Util
|
||||
Test.Sandwich.WebDriver.Internal.Exceptions
|
||||
Test.Sandwich.WebDriver.Internal.Ports
|
||||
Test.Sandwich.WebDriver.Internal.Screenshots
|
||||
Test.Sandwich.WebDriver.Internal.Types
|
||||
Test.Sandwich.WebDriver.Internal.Util
|
||||
other-modules:
|
||||
Paths_sandwich_webdriver
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions: OverloadedStrings QuasiQuotes NamedFieldPuns RecordWildCards ScopedTypeVariables FlexibleContexts FlexibleInstances LambdaCase
|
||||
build-depends:
|
||||
aeson
|
||||
, async
|
||||
, base >=4.7 && <5
|
||||
, containers
|
||||
, convertible
|
||||
, data-default
|
||||
, directory
|
||||
, filepath
|
||||
, http-client
|
||||
, http-conduit
|
||||
, interpolate
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, network
|
||||
, process
|
||||
, random
|
||||
, retry
|
||||
, safe
|
||||
, safe-exceptions
|
||||
, sandwich
|
||||
, temporary
|
||||
, text
|
||||
, transformers
|
||||
, transformers-base
|
||||
, unix
|
||||
, webdriver
|
||||
default-language: Haskell2010
|
||||
|
||||
executable sandwich-webdriver-exe
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Paths_sandwich_webdriver
|
||||
hs-source-dirs:
|
||||
app
|
||||
default-extensions: OverloadedStrings QuasiQuotes NamedFieldPuns RecordWildCards ScopedTypeVariables FlexibleContexts FlexibleInstances LambdaCase
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson
|
||||
, async
|
||||
, base >=4.7 && <5
|
||||
, containers
|
||||
, convertible
|
||||
, data-default
|
||||
, directory
|
||||
, filepath
|
||||
, http-client
|
||||
, http-conduit
|
||||
, interpolate
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, network
|
||||
, process
|
||||
, random
|
||||
, retry
|
||||
, safe
|
||||
, safe-exceptions
|
||||
, sandwich
|
||||
, sandwich-webdriver
|
||||
, temporary
|
||||
, text
|
||||
, time
|
||||
, transformers
|
||||
, transformers-base
|
||||
, unix
|
||||
, webdriver
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite sandwich-webdriver-test
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Paths_sandwich_webdriver
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions: OverloadedStrings QuasiQuotes NamedFieldPuns RecordWildCards ScopedTypeVariables FlexibleContexts FlexibleInstances LambdaCase
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson
|
||||
, async
|
||||
, base >=4.7 && <5
|
||||
, containers
|
||||
, convertible
|
||||
, data-default
|
||||
, directory
|
||||
, filepath
|
||||
, http-client
|
||||
, http-conduit
|
||||
, interpolate
|
||||
, lifted-base
|
||||
, monad-control
|
||||
, network
|
||||
, process
|
||||
, random
|
||||
, retry
|
||||
, safe
|
||||
, safe-exceptions
|
||||
, sandwich
|
||||
, sandwich-webdriver
|
||||
, temporary
|
||||
, text
|
||||
, transformers
|
||||
, transformers-base
|
||||
, unix
|
||||
, webdriver
|
||||
default-language: Haskell2010
|
6
sandwich-webdriver/src/Lib.hs
Normal file
6
sandwich-webdriver/src/Lib.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Lib
|
||||
( someFunc
|
||||
) where
|
||||
|
||||
someFunc :: IO ()
|
||||
someFunc = putStrLn "someFunc"
|
234
sandwich-webdriver/src/Test/Sandwich/WebDriver.hs
Normal file
234
sandwich-webdriver/src/Test/Sandwich/WebDriver.hs
Normal file
@ -0,0 +1,234 @@
|
||||
{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns, TypeOperators, LambdaCase, DataKinds, UndecidableInstances, MultiParamTypeClasses #-}
|
||||
|
||||
-- |
|
||||
|
||||
module Test.Sandwich.WebDriver (
|
||||
webdriver
|
||||
, introduceWebdriver
|
||||
, allocateWebDriver
|
||||
, cleanupWebDriver
|
||||
|
||||
, WdOptions
|
||||
, defaultWdOptions
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Retry
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Default
|
||||
import qualified Data.List as L
|
||||
import Data.Maybe
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Network.Socket (PortNumber)
|
||||
import Safe
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import System.IO.Temp
|
||||
import System.Process
|
||||
import Test.Sandwich
|
||||
import Test.Sandwich.WebDriver.Internal.Action
|
||||
import Test.Sandwich.WebDriver.Internal.Binaries
|
||||
import Test.Sandwich.WebDriver.Internal.Ports
|
||||
import Test.Sandwich.WebDriver.Internal.Types
|
||||
import Test.Sandwich.WebDriver.Internal.Util
|
||||
import qualified Test.WebDriver.Capabilities as W
|
||||
import qualified Test.WebDriver.Config as W
|
||||
import qualified Test.WebDriver.Session as W
|
||||
|
||||
|
||||
#ifdef linux_HOST_OS
|
||||
import System.Posix.IO
|
||||
import System.Posix.Types
|
||||
#endif
|
||||
|
||||
webdriver = Label :: Label "webdriver" WdSession
|
||||
|
||||
introduceWebdriver :: (HasBaseContext context) => WdOptions -> Spec (LabelValue "webdriver" WdSession :> context) () -> Spec context ()
|
||||
introduceWebdriver wdOptions = introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver
|
||||
|
||||
allocateWebDriver wdOptions = do
|
||||
maybeRunRoot <- getRunRoot
|
||||
let runRoot = fromMaybe "/tmp" maybeRunRoot
|
||||
liftIO $ startWebDriver wdOptions runRoot
|
||||
|
||||
cleanupWebDriver :: (HasBaseContext context) => ExampleM (LabelValue "webdriver" WdSession :> context) ()
|
||||
cleanupWebDriver = do
|
||||
session <- getContext webdriver
|
||||
liftIO $ closeAllSessions session
|
||||
liftIO $ stopWebDriver session
|
||||
|
||||
instance (HasLabel context "webdriver" WdSession) => W.WDSessionState (ExampleM context) where
|
||||
getSession = undefined
|
||||
putSession = undefined
|
||||
|
||||
instance MonadBaseControl IO (ExampleM context) where
|
||||
liftBaseWith = undefined
|
||||
restoreM = undefined
|
||||
|
||||
-- * Lower level
|
||||
|
||||
-- | Spin up a Selenium WebDriver and create a WdSession
|
||||
startWebDriver :: WdOptions -> FilePath -> IO WdSession
|
||||
startWebDriver wdOptions@(WdOptions {capabilities=capabilities', ..}) runRoot = do
|
||||
-- Set up config
|
||||
port <- findFreePortOrException
|
||||
let capabilities = case runMode of
|
||||
RunHeadless -> capabilities' { W.browser = browser'}
|
||||
where browser' = case W.browser capabilities of
|
||||
x@(W.Chrome {..}) -> x { W.chromeOptions = "--headless":chromeOptions }
|
||||
x -> error [i|Headless mode not yet supported for browser '#{x}'|]
|
||||
_ -> capabilities'
|
||||
let wdConfig = (def { W.wdPort = fromIntegral port, W.wdCapabilities = capabilities })
|
||||
|
||||
-- Get the CreateProcess
|
||||
createDirectoryIfMissing True toolsRoot
|
||||
(wdCreateProcess, maybeXvfbSession) <- getWebdriverCreateProcess wdOptions runRoot port >>= \case
|
||||
Left err -> error [i|Failed to create webdriver process: '#{err}'|]
|
||||
Right x -> return x
|
||||
|
||||
-- Open output handles
|
||||
let logsDir = runRoot </> "selenium_logs"
|
||||
createDirectoryIfMissing True logsDir
|
||||
hout <- openFile (logsDir </> seleniumOutFileName) AppendMode
|
||||
herr <- openFile (logsDir </> seleniumErrFileName) AppendMode
|
||||
|
||||
-- Start the process and wait for it to be ready
|
||||
(_, _, _, p) <- createProcess $ wdCreateProcess {
|
||||
std_in = Inherit
|
||||
, std_out = UseHandle hout
|
||||
, std_err = UseHandle herr
|
||||
, create_group = True
|
||||
}
|
||||
-- Normally Selenium prints the ready message to stderr. However, when we're running under
|
||||
-- XVFB the two streams get combined and sent to stdout; see
|
||||
-- https://bugs.launchpad.net/ubuntu/+source/xorg-server/+bug/1059947
|
||||
-- As a result, we poll both files
|
||||
let readyMessage = "Selenium Server is up and running"
|
||||
-- Retry every 60ms, for up to 60s before admitting defeat
|
||||
let retryPolicy = constantDelay 60000 <> limitRetries 1000
|
||||
success <- retrying retryPolicy (\_retryStatus result -> return (not result)) $ const $
|
||||
T.readFile (logsDir </> seleniumErrFileName) >>= \case
|
||||
t | readyMessage `T.isInfixOf` t -> return True
|
||||
_ -> T.readFile (logsDir </> seleniumOutFileName) >>= \case
|
||||
t | readyMessage `T.isInfixOf` t -> return True
|
||||
_ -> return False
|
||||
unless success $ do
|
||||
interruptProcessGroupOf p >> waitForProcess p
|
||||
error [i|Selenium server failed to start after 60 seconds|]
|
||||
|
||||
-- Make the WdSession
|
||||
WdSession <$> pure []
|
||||
<*> pure (hout, herr, p, logsDir </> seleniumOutFileName, logsDir </> seleniumErrFileName, maybeXvfbSession)
|
||||
<*> pure wdOptions
|
||||
<*> newMVar mempty
|
||||
<*> newMVar 0
|
||||
<*> newMVar (A.object [])
|
||||
<*> newMVar mempty
|
||||
<*> pure wdConfig
|
||||
|
||||
|
||||
stopWebDriver :: WdSession -> IO ()
|
||||
stopWebDriver (WdSession {wdWebDriver=(hout, herr, h, _, _, maybeXvfbSession)}) = do
|
||||
interruptProcessGroupOf h >> waitForProcess h
|
||||
hClose hout
|
||||
hClose herr
|
||||
|
||||
whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do
|
||||
interruptProcessGroupOf xvfbProcess >> waitForProcess xvfbProcess
|
||||
|
||||
-- * Util
|
||||
|
||||
seleniumOutFileName = "selenium_stdout.txt"
|
||||
seleniumErrFileName = "selenium_stderr.txt"
|
||||
|
||||
getWebdriverCreateProcess :: WdOptions -> FilePath -> PortNumber -> IO (Either T.Text (CreateProcess, Maybe XvfbSession))
|
||||
getWebdriverCreateProcess (WdOptions {toolsRoot, runMode}) runRoot port = runExceptT $ do
|
||||
chromeDriverPath <- ExceptT $ downloadChromeDriverIfNecessary toolsRoot
|
||||
seleniumPath <- ExceptT $ downloadSeleniumIfNecessary toolsRoot
|
||||
|
||||
case runMode of
|
||||
Normal -> return ((proc "java" [
|
||||
[i|-Dwebdriver.chrome.driver=#{chromeDriverPath}|]
|
||||
, "-jar", seleniumPath
|
||||
, "-port", show port
|
||||
]) { cwd = Just runRoot }
|
||||
, Nothing)
|
||||
|
||||
RunHeadless ->
|
||||
-- Headless mode is controlled in the capabilities
|
||||
return ((proc "java" [
|
||||
[i|-Dwebdriver.chrome.driver=#{chromeDriverPath}|]
|
||||
, "-jar", seleniumPath
|
||||
, "-port", show port
|
||||
]) { cwd = Just runRoot }
|
||||
, Nothing)
|
||||
|
||||
#ifdef linux_HOST_OS
|
||||
RunInXvfb (XvfbConfig {xvfbResolution}) -> do
|
||||
let (w, h) = fromMaybe (1920, 1080) xvfbResolution
|
||||
liftIO $ createDirectoryIfMissing True runRoot
|
||||
|
||||
tmpDir <- liftIO getCanonicalTemporaryDirectory
|
||||
(path, tmpHandle) <- liftIO $ openTempFile tmpDir "x11_server_num"
|
||||
Fd fd <- liftIO $ handleToFd tmpHandle
|
||||
|
||||
serverNum <- liftIO findFreeServerNum
|
||||
|
||||
-- Start the Xvfb session
|
||||
let authFile = runRoot </> ".Xauthority"
|
||||
liftIO $ createDirectoryIfMissing True runRoot
|
||||
liftIO $ writeFile authFile ""
|
||||
(_, _, _, p) <- liftIO $ createProcess $ (proc "Xvfb" [":" <> show serverNum
|
||||
, "-screen", "0", [i|#{w}x#{h}x24|]
|
||||
, "-displayfd", [i|#{fd}|]
|
||||
, "-auth", authFile
|
||||
]) { cwd = Just runRoot
|
||||
, create_group = True }
|
||||
|
||||
-- When a displayfd filepath is provided, try to obtain the X11 screen
|
||||
xvfbSession@(XvfbSession {..}) <- liftIO $ do
|
||||
let retryPolicy = constantDelay 10000 <> limitRetries 1000
|
||||
recoverAll retryPolicy $ \_ ->
|
||||
readFile path >>= \contents -> case readMay contents of
|
||||
Nothing -> throwIO $ userError [i|Couldn't determine X11 screen to use. Got data: '#{contents}'. File was '#{path}'|]
|
||||
Just x -> return $ XvfbSession { xvfbDisplayNum = x
|
||||
, xvfbXauthority = runRoot </> ".Xauthority"
|
||||
, xvfbDimensions = (w, h)
|
||||
, xvfbProcess = p }
|
||||
|
||||
-- TODO: allow verbose logging to be controlled with an option:
|
||||
env' <- liftIO getEnvironment
|
||||
let env = L.nubBy (\x y -> fst x == fst y) $ [("DISPLAY", ":" <> show serverNum)
|
||||
, ("XAUTHORITY", xvfbXauthority)] <> env'
|
||||
return ((proc "java" [[i|-Dwebdriver.chrome.driver=#{chromeDriverPath}|]
|
||||
, [i|-Dwebdriver.chrome.logfile=#{runRoot </> "chromedriver.log"}|]
|
||||
, [i|-Dwebdriver.chrome.verboseLogging=true|]
|
||||
, "-jar", seleniumPath
|
||||
, "-port", show port]) { env = Just env }, Just xvfbSession)
|
||||
|
||||
|
||||
#else
|
||||
RunInXvfb (XvfbConfig { xvfbResolution }) -> error [i|RunInXvfb can only be used on Linux.|]
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
-- * Util
|
||||
|
||||
findFreeServerNum :: IO Int
|
||||
findFreeServerNum = findFreeServerNum' 99
|
||||
where
|
||||
findFreeServerNum' :: Int -> IO Int
|
||||
findFreeServerNum' candidate = do
|
||||
doesPathExist [i|/tmp/.X11-unix/X#{candidate}|] >>= \case
|
||||
True -> findFreeServerNum' (candidate + 1)
|
||||
False -> return candidate
|
@ -0,0 +1,74 @@
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
-- |
|
||||
|
||||
module Test.Sandwich.WebDriver.Internal.Action where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import qualified Control.Exception.Lifted as EL
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Map as M
|
||||
import Data.String.Interpolate.IsString
|
||||
import GHC.Stack
|
||||
import Test.Sandwich.WebDriver.Internal.Exceptions
|
||||
import Test.Sandwich.WebDriver.Internal.Types
|
||||
import Test.Sandwich.WebDriver.Internal.Util
|
||||
import qualified Test.WebDriver as W
|
||||
import qualified Test.WebDriver.Config as W
|
||||
import qualified Test.WebDriver.Session as W
|
||||
|
||||
runActionWithBrowser :: (HasCallStack) => Browser -> W.WD a -> WdSession -> IO a
|
||||
runActionWithBrowser browser action sessionWithLabels@(WdSession {..}) = do
|
||||
-- Create new session if necessary (this can throw an exception)
|
||||
sess <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup browser sessionMap of
|
||||
Just sess -> return (sessionMap, sess)
|
||||
Nothing -> do
|
||||
sess'' <- W.mkSession wdConfig
|
||||
let sess' = sess'' { W.wdSessHistUpdate = W.unlimitedHistory }
|
||||
sess <- W.runWD sess' $ W.createSession $ W.wdCapabilities wdConfig
|
||||
return (M.insert browser sess sessionMap, sess)
|
||||
|
||||
-- Run the test example, handling the exception specially
|
||||
(liftIO $ tryAny $ W.runWD sess $ do
|
||||
-- After the action, grab the updated session and save it before we return
|
||||
EL.finally action $ do
|
||||
sess' <- W.getSession
|
||||
liftIO $ modifyMVar_ wdSessionMap $ return . M.insert browser sess'
|
||||
) >>= \case
|
||||
Left e -> liftIO $ do
|
||||
-- handleTestException sessionWithLabels e
|
||||
throw e -- Rethrow for the test framework to handle
|
||||
Right x -> return x
|
||||
|
||||
runWithBrowser' :: (HasCallStack, HasWdSession a) => Browser -> W.WD () -> a -> IO ()
|
||||
runWithBrowser' browser action hasSession = do
|
||||
runActionWithBrowser browser action (getWdSession hasSession)
|
||||
|
||||
runEveryBrowser' :: (HasCallStack, HasWdSession a) => W.WD () -> a -> IO ()
|
||||
runEveryBrowser' action (getWdSession -> session@(WdSession {wdSessionMap})) = do
|
||||
sessionMap <- readMVar wdSessionMap
|
||||
forM_ (M.toList sessionMap) $ \(browser, _) -> do
|
||||
runActionWithBrowser browser action session
|
||||
|
||||
executeWithBrowser :: (HasCallStack) => Browser -> WdSession -> W.WD a -> W.WD a
|
||||
executeWithBrowser browser session action = do
|
||||
liftIO $ runActionWithBrowser browser action session
|
||||
|
||||
closeSession :: (HasCallStack) => Browser -> WdSession -> IO ()
|
||||
closeSession browser (WdSession {wdSessionMap}) = do
|
||||
modifyMVar_ wdSessionMap $ \sessionMap -> do
|
||||
whenJust (M.lookup browser sessionMap) $ \sess ->
|
||||
W.runWD sess W.closeSession
|
||||
return $ M.delete browser sessionMap
|
||||
|
||||
closeAllSessionsExcept :: (HasCallStack) => [Browser] -> WdSession -> IO ()
|
||||
closeAllSessionsExcept toKeep (WdSession {wdSessionMap}) = do
|
||||
modifyMVar_ wdSessionMap $ \sessionMap -> do
|
||||
forM_ (M.toList sessionMap) $ \(name, sess) -> unless (name `elem` toKeep) $
|
||||
catch (W.runWD sess W.closeSession)
|
||||
(\(e :: SomeException) -> putStrLn [i|Failed to destroy session '#{name}': '#{e}'|])
|
||||
return $ M.fromList [(b, s) | (b, s) <- M.toList sessionMap, b `elem` toKeep]
|
||||
|
||||
closeAllSessions :: (HasCallStack) => WdSession -> IO ()
|
||||
closeAllSessions = closeAllSessionsExcept []
|
@ -0,0 +1,50 @@
|
||||
{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns, Rank2Types #-}
|
||||
|
||||
module Test.Sandwich.WebDriver.Internal.Binaries (
|
||||
downloadSeleniumIfNecessary
|
||||
, downloadChromeDriverIfNecessary
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Text as T
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
import Test.Sandwich.WebDriver.Internal.Binaries.Util
|
||||
import Test.Sandwich.WebDriver.Internal.Util
|
||||
|
||||
downloadSeleniumIfNecessary :: FilePath -> IO (Either T.Text FilePath)
|
||||
downloadSeleniumIfNecessary toolsDir = leftOnException' $ do
|
||||
let seleniumPath = [i|#{toolsDir}/selenium-server.jar|]
|
||||
liftIO (doesFileExist seleniumPath >>= flip unless (downloadSelenium seleniumPath))
|
||||
return seleniumPath
|
||||
|
||||
downloadSelenium :: FilePath -> IO ()
|
||||
downloadSelenium seleniumPath = void $ do
|
||||
putStrLn [i|Downloading selenium-server.jar to #{seleniumPath}|]
|
||||
createDirectoryIfMissing True (takeDirectory seleniumPath)
|
||||
readCreateProcess (shell [i|curl https://selenium-release.storage.googleapis.com/3.141/selenium-server-standalone-3.141.59.jar -o #{seleniumPath}|]) ""
|
||||
|
||||
downloadChromeDriverIfNecessary :: FilePath -> IO (Either T.Text FilePath)
|
||||
downloadChromeDriverIfNecessary toolsDir = runExceptT $ do
|
||||
chromeVersion <- ExceptT detectChromeVersion
|
||||
chromeDriverVersion@(w, x, y, z) <- ExceptT $ getChromeDriverVersion chromeVersion
|
||||
let downloadPath = getChromeDriverDownloadPath chromeDriverVersion detectPlatform
|
||||
|
||||
let executableName = case detectPlatform of
|
||||
Windows -> "chromedriver.exe"
|
||||
_ -> "chromedriver"
|
||||
let chromeDriverPath = [i|#{toolsDir}/chromedrivers/#{w}.#{x}.#{y}.#{z}/#{executableName}|]
|
||||
(liftIO $ doesFileExist chromeDriverPath) >>= flip unless (ExceptT $ downloadAndUnzipToPath downloadPath chromeDriverPath)
|
||||
|
||||
return chromeDriverPath
|
||||
|
||||
downloadAndUnzipToPath :: T.Text -> FilePath -> IO (Either T.Text ())
|
||||
downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
|
||||
putStrLn [i|Downloading #{downloadPath} to #{localPath}|]
|
||||
createDirectoryIfMissing True (takeDirectory localPath)
|
||||
void $ readCreateProcess (shell [i|wget -nc -O - #{downloadPath} | gunzip - > #{localPath}|]) ""
|
||||
void $ readCreateProcess (shell [i|chmod u+x #{localPath}|]) ""
|
@ -0,0 +1,63 @@
|
||||
{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns, MultiWayIf, ViewPatterns #-}
|
||||
|
||||
module Test.Sandwich.WebDriver.Internal.Binaries.Util (
|
||||
detectPlatform
|
||||
, detectChromeVersion
|
||||
, getChromeDriverVersion
|
||||
, getChromeDriverDownloadPath
|
||||
, Platform(..)
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.Convertible
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Conduit
|
||||
import Safe
|
||||
import System.Exit
|
||||
import qualified System.Info as SI
|
||||
import System.Process
|
||||
import Test.Sandwich.WebDriver.Internal.Util
|
||||
|
||||
data Platform = Linux | OSX | Windows deriving (Show, Eq)
|
||||
|
||||
detectPlatform :: Platform
|
||||
detectPlatform = case SI.os of
|
||||
"windows" -> Windows
|
||||
"linux" -> Linux
|
||||
"darwin" -> OSX
|
||||
_ -> error [i|Couldn't determine host platform from string: '#{SI.os}'|]
|
||||
|
||||
detectChromeVersion :: IO (Either T.Text (Int, Int, Int, Int))
|
||||
detectChromeVersion = leftOnException $ runExceptT $ do
|
||||
(exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell [i|google-chrome --version | grep -Eo "[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+"|]) ""
|
||||
|
||||
rawString <- case exitCode of
|
||||
ExitFailure _ -> throwE [i|Couldn't parse google-chrome version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|]
|
||||
ExitSuccess -> return $ T.strip $ convert stdout
|
||||
|
||||
case T.splitOn "." rawString of
|
||||
[tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return (w, x, y, z)
|
||||
_ -> throwE [i|Failed to parse google-chrome version from string: '#{rawString}'|]
|
||||
|
||||
getChromeDriverVersion :: (Int, Int, Int, Int) -> IO (Either T.Text (Int, Int, Int, Int))
|
||||
getChromeDriverVersion (w, x, y, _) = do
|
||||
let url = [i|https://chromedriver.storage.googleapis.com/LATEST_RELEASE_#{w}.#{x}.#{y}|]
|
||||
handle (\(e :: HttpException) -> do
|
||||
return $ Left [i|Error when requesting '#{url}': '#{e}'|]
|
||||
)
|
||||
(do
|
||||
result :: T.Text <- convert <$> simpleHttp url
|
||||
case T.splitOn "." result of
|
||||
[tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right (w, x, y, z)
|
||||
_ -> return $ Left [i|Failed to parse chromedriver version from string: '#{result}'|]
|
||||
)
|
||||
|
||||
getChromeDriverDownloadPath :: (Int, Int, Int, Int) -> Platform -> T.Text
|
||||
getChromeDriverDownloadPath (w, x, y, z) Linux = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_linux64.zip|]
|
||||
getChromeDriverDownloadPath (w, x, y, z) OSX = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_mac64.zip|]
|
||||
getChromeDriverDownloadPath (w, x, y, z) Windows = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_win32.zip|]
|
||||
|
||||
tReadMay = readMay . convert
|
@ -0,0 +1,60 @@
|
||||
{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, CPP, QuasiQuotes, RecordWildCards #-}
|
||||
|
||||
module Test.Sandwich.WebDriver.Internal.Exceptions where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception.Lifted as EL
|
||||
import Control.Monad
|
||||
import qualified Data.Map as M
|
||||
import Data.String.Interpolate.IsString
|
||||
import GHC.Stack
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.IO
|
||||
import Test.Sandwich.WebDriver.Internal.Screenshots
|
||||
import Test.Sandwich.WebDriver.Internal.Types
|
||||
import Test.Sandwich.WebDriver.Internal.Util
|
||||
import Test.WebDriver
|
||||
import Text.Printf
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
-- Note: one day, if directory-1.3.1.0 or later is ever on Stackage, we can use System.Directory.createDirectoryLink
|
||||
import System.Posix.Files (createSymbolicLink)
|
||||
#else
|
||||
import Data.String
|
||||
import Shelly hiding (sleep, (</>), FilePath, run)
|
||||
#endif
|
||||
|
||||
|
||||
handleTestException :: (HasCallStack) => WdSession -> FilePath -> FilePath -> EL.SomeException -> IO ()
|
||||
handleTestException session@(WdSession {wdOptions=(WdOptions {}), ..}) runRoot resultsDir e = do
|
||||
-- Put the error message in the results dir
|
||||
writeFile (resultsDir </> "error_info.txt") (show e)
|
||||
|
||||
saveScreenshots "error_screenshot" session resultsDir
|
||||
|
||||
-- Update the failure counter
|
||||
failureNum <- modifyMVar wdFailureCounter $ \n -> return (n + 1, n)
|
||||
|
||||
-- Make a symlink to the results dir in the "errors" folder
|
||||
let errorsDir = runRoot </> "errors"
|
||||
createDirectoryIfMissing True errorsDir
|
||||
|
||||
let paddedNum :: String = printf "%04d" failureNum
|
||||
let errorFolderName = [i|#{paddedNum}_|] <> head wdLabels
|
||||
#ifdef mingw32_HOST_OS
|
||||
-- Windows is stupid about symlinks, let's just copy
|
||||
shelly $ silently $ cp_r (fromString resultsDir) (fromString (dir </> errorFolderName))
|
||||
#else
|
||||
-- Make the symlink relative so that it still works when test results are tarballed
|
||||
catch (createSymbolicLink (".." </> makeRelative runRoot resultsDir) (errorsDir </> errorFolderName))
|
||||
(\(e :: SomeException) -> putStrLn [i|Error: failed to create symlink on test exception: #{e}|])
|
||||
#endif
|
||||
|
||||
saveSeleniumMessages :: (HasCallStack) => WdSession -> FilePath -> IO ()
|
||||
saveSeleniumMessages session@(WdSession {..}) resultsDir = do
|
||||
sessionMap <- readMVar wdSessionMap
|
||||
forM_ (M.toList sessionMap) $ \(browser, sess) -> do
|
||||
hist <- runWD sess getSessionHistory
|
||||
withFile (resultsDir </> [i|#{browser}_selenium_messages.txt|]) WriteMode $ \h ->
|
||||
forM_ hist $ hPrint h
|
@ -0,0 +1,53 @@
|
||||
{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables #-}
|
||||
|
||||
module Test.Sandwich.WebDriver.Internal.Ports (
|
||||
findFreePortOrException
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Retry
|
||||
import Data.Maybe
|
||||
import Network.Socket
|
||||
import System.Random (randomRIO)
|
||||
|
||||
-- |Find an unused port in a given range
|
||||
findFreePortInRange' :: RetryPolicy -> (PortNumber, PortNumber) -> [PortNumber] -> IO (Maybe PortNumber)
|
||||
findFreePortInRange' retryPolicy (start, end) blacklist = retrying retryPolicy (\_retryStatus result -> return $ isNothing result) (const findFreePortInRange')
|
||||
where getAcceptableCandidate :: IO PortNumber
|
||||
getAcceptableCandidate = do
|
||||
candidate <- (fromInteger) <$> randomRIO (fromIntegral start, fromIntegral end)
|
||||
if | candidate `elem` blacklist -> getAcceptableCandidate
|
||||
| otherwise -> return candidate
|
||||
|
||||
findFreePortInRange' :: IO (Maybe PortNumber)
|
||||
findFreePortInRange' = do
|
||||
candidate <- getAcceptableCandidate
|
||||
catch (tryOpenAndClosePort candidate >> return (Just candidate)) (\(_ :: SomeException) -> return Nothing)
|
||||
where
|
||||
tryOpenAndClosePort :: PortNumber -> IO PortNumber
|
||||
tryOpenAndClosePort port = do
|
||||
sock <- socket AF_INET Stream 0
|
||||
setSocketOption sock ReuseAddr 1
|
||||
let hostAddress = tupleToHostAddress (127, 0, 0, 1)
|
||||
bind sock (SockAddrInet port hostAddress)
|
||||
close sock
|
||||
return $ fromIntegral port
|
||||
|
||||
|
||||
findFreePortInRange :: (PortNumber, PortNumber) -> [PortNumber] -> IO (Maybe PortNumber)
|
||||
findFreePortInRange = findFreePortInRange' (limitRetries 50)
|
||||
|
||||
-- |Find an unused port in the ephemeral port range.
|
||||
-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers
|
||||
-- This works without a timeout since there should always be a port in the somewhere;
|
||||
-- it might be advisable to wrap in a timeout anyway.
|
||||
findFreePort :: IO (Maybe PortNumber)
|
||||
findFreePort = findFreePortInRange (49152, 65535) []
|
||||
|
||||
findFreePortOrException :: IO PortNumber
|
||||
findFreePortOrException = findFreePort >>= \case
|
||||
Just port -> return port
|
||||
Nothing -> error "Couldn't find free port"
|
||||
|
||||
-- findFreePortNotIn :: [PortNumber] -> IO (Maybe PortNumber)
|
||||
-- findFreePortNotIn = findFreePortInRange (49152, 65535)
|
@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, CPP, QuasiQuotes, RecordWildCards #-}
|
||||
-- |
|
||||
|
||||
module Test.Sandwich.WebDriver.Internal.Screenshots where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception.Lifted
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Map as M
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Text as T
|
||||
import GHC.Stack
|
||||
import Network.HTTP.Client
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import Test.Sandwich.WebDriver.Internal.Types
|
||||
import Test.Sandwich.WebDriver.Internal.Util
|
||||
import Test.WebDriver
|
||||
|
||||
saveScreenshots :: (HasCallStack) => T.Text -> WdSession -> FilePath -> IO ()
|
||||
saveScreenshots screenshotName sessionWithLabels@(WdSession {..}) resultsDir = do
|
||||
-- For every session, and for every window, try to get a screenshot for the results dir
|
||||
sessionMap <- readMVar wdSessionMap
|
||||
forM_ (M.toList sessionMap) $ \(browser, sess) -> runWD sess $
|
||||
handle (\(e :: HttpException) -> case e of
|
||||
(HttpExceptionRequest _ content) -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{content}'|]
|
||||
e -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e}'|])
|
||||
(saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])
|
130
sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs
Normal file
130
sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs
Normal file
@ -0,0 +1,130 @@
|
||||
{-# LANGUAGE TypeFamilies, InstanceSigs, RecordWildCards, ScopedTypeVariables, QuasiQuotes, Rank2Types, NamedFieldPuns #-}
|
||||
|
||||
module Test.Sandwich.WebDriver.Internal.Types where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Default
|
||||
import qualified Data.Map as M
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Text as T
|
||||
import System.IO
|
||||
import System.Process
|
||||
import qualified Test.WebDriver as W
|
||||
import qualified Test.WebDriver.Session as W
|
||||
|
||||
type Browser = String
|
||||
|
||||
class HasWdSession a where
|
||||
getWdSession :: a -> WdSession
|
||||
|
||||
instance HasWdSession WdSession where
|
||||
getWdSession = id
|
||||
|
||||
type ToolsRoot = FilePath
|
||||
|
||||
data WhenToSave = Always | OnException | Never deriving (Show, Eq)
|
||||
|
||||
-- | Headless and Xvfb modes are useful because they allow you to run tests in the background, without popping up browser windows.
|
||||
-- This is useful for development or for running on a CI server, and is also more reproducible since the screen resolution can be fixed.
|
||||
-- In addition, Xvfb mode allows videos to be recorded of tests.
|
||||
data RunMode = Normal
|
||||
-- ^ Normal Selenium behavior; will pop up a web browser.
|
||||
| RunHeadless
|
||||
-- ^ Run with a headless browser. Supports screenshots but videos will be black.
|
||||
| RunInXvfb XvfbConfig
|
||||
-- ^ Run inside <https://en.wikipedia.org/wiki/Xvfb Xvfb> so that tests run in their own X11 display.
|
||||
-- xvfb-run script must be installed and on the PATH.
|
||||
|
||||
data WdOptions = WdOptions {
|
||||
toolsRoot :: ToolsRoot
|
||||
-- ^ Folder where any necessary binaries (chromedriver, Selenium, etc.) will be downloaded if needed. Required.
|
||||
|
||||
, capabilities :: W.Capabilities
|
||||
-- ^ The WebDriver capabilities to use
|
||||
|
||||
, saveSeleniumMessageHistory :: WhenToSave
|
||||
-- ^ When to save a record of Selenium requests and responses
|
||||
|
||||
, saveLogSettings :: SaveLogSettings
|
||||
-- ^ When to save a record of Selenium requests and responses
|
||||
|
||||
, runMode :: RunMode
|
||||
-- ^ How to handle opening the browser (in a popup window, headless, etc.)
|
||||
}
|
||||
|
||||
data XvfbConfig = XvfbConfig {
|
||||
xvfbResolution :: Maybe (Int, Int)
|
||||
-- ^ Resolution for the virtual screen. Defaults to (1920, 1080)
|
||||
}
|
||||
|
||||
instance Default XvfbConfig where
|
||||
def = XvfbConfig Nothing
|
||||
|
||||
defaultWdOptions :: FilePath -> WdOptions
|
||||
defaultWdOptions toolsRoot = WdOptions toolsRoot def OnException mempty Normal
|
||||
|
||||
type SaveLogSettings = M.Map W.LogType (W.LogEntry -> Bool, W.LogEntry -> T.Text, W.LogEntry -> Bool)
|
||||
|
||||
data WdSession = WdSession { wdLabels :: [String]
|
||||
, wdWebDriver :: (Handle, Handle, ProcessHandle, FilePath, FilePath, Maybe XvfbSession)
|
||||
, wdOptions :: WdOptions
|
||||
, wdSessionMap :: MVar (M.Map Browser W.WDSession)
|
||||
, wdFailureCounter :: MVar Int
|
||||
, wdTimingInfo :: MVar A.Value
|
||||
, wdSaveBrowserLogs :: MVar SaveLogSettings
|
||||
, wdConfig :: W.WDConfig }
|
||||
|
||||
data InvalidLogsException = InvalidLogsException [W.LogEntry]
|
||||
deriving (Show)
|
||||
|
||||
instance Exception InvalidLogsException
|
||||
|
||||
data XvfbSession = XvfbSession { xvfbDisplayNum :: Int
|
||||
, xvfbXauthority :: FilePath
|
||||
, xvfbDimensions :: (Int, Int)
|
||||
, xvfbProcess :: ProcessHandle }
|
||||
|
||||
instance Show XvfbSession where
|
||||
show (XvfbSession {xvfbDisplayNum}) = [i|<XVFB session with server num #{xvfbDisplayNum}>|]
|
||||
|
||||
-- * Video stuff
|
||||
|
||||
fastX11VideoOptions = ["-an"
|
||||
, "-r", "30"
|
||||
, "-vcodec"
|
||||
, "libxvid"
|
||||
, "-qscale:v", "1"
|
||||
, "-threads", "0"]
|
||||
|
||||
qualityX11VideoOptions = ["-an"
|
||||
, "-r", "30"
|
||||
, "-vcodec", "libx264"
|
||||
, "-preset", "veryslow"
|
||||
, "-crf", "0"
|
||||
, "-threads", "0"]
|
||||
|
||||
defaultAvfoundationOptions = ["-r", "30"
|
||||
, "-an"
|
||||
, "-vcodec", "libxvid"
|
||||
, "-qscale:v", "1"
|
||||
, "-threads", "0"]
|
||||
|
||||
defaultGdigrabOptions = ["-framerate", "30"]
|
||||
|
||||
data VideoSettings = VideoSettings { x11grabOptions :: [String]
|
||||
-- ^ Arguments to x11grab, used with Linux.
|
||||
, avfoundationOptions :: [String]
|
||||
-- ^ Arguments to avfoundation, used with OS X.
|
||||
, gdigrabOptions :: [String]
|
||||
-- ^ Arguments to gdigrab, used with Windows.
|
||||
, hideMouseWhenRecording :: Bool
|
||||
-- ^ Hide the mouse while recording video. Linux and Windows only.
|
||||
}
|
||||
|
||||
instance Default VideoSettings where
|
||||
def = VideoSettings { x11grabOptions = fastX11VideoOptions
|
||||
, avfoundationOptions = defaultAvfoundationOptions
|
||||
, gdigrabOptions = defaultGdigrabOptions
|
||||
, hideMouseWhenRecording = False }
|
@ -0,0 +1,60 @@
|
||||
{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns #-}
|
||||
|
||||
module Test.Sandwich.WebDriver.Internal.Util where
|
||||
|
||||
import Control.Exception
|
||||
import qualified Control.Exception.Lifted as E
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
import Data.Convertible
|
||||
import qualified Data.List as L
|
||||
import Data.String.Interpolate.IsString
|
||||
import qualified Data.Text as T
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
import Test.Sandwich.WebDriver.Internal.Types
|
||||
|
||||
-- * Truncating log files
|
||||
|
||||
moveAndTruncate :: FilePath -> String -> IO ()
|
||||
moveAndTruncate from to = do
|
||||
exists <- doesFileExist from
|
||||
when exists $ do
|
||||
copyFile from to
|
||||
tryTruncateFile from
|
||||
|
||||
where
|
||||
tryTruncateFile :: FilePath -> IO ()
|
||||
tryTruncateFile path = E.catch (truncateFile path)
|
||||
(\(e :: E.SomeException) -> putStrLn [i|Failed to truncate file #{path}: #{e}|])
|
||||
|
||||
truncateFile :: FilePath -> IO ()
|
||||
#ifdef mingw32_HOST_OS
|
||||
truncateFile path = withFile path WriteMode $ flip hPutStr "\n" -- Not exactly truncation, but close enough?
|
||||
#else
|
||||
truncateFile path = void $ readCreateProcess (shell [i|> #{path}|]) ""
|
||||
#endif
|
||||
|
||||
-- * Exceptions
|
||||
|
||||
leftOnException :: (MonadIO m, MonadBaseControl IO m) => m (Either T.Text a) -> m (Either T.Text a)
|
||||
leftOnException = E.handle (\(e :: SomeException) -> return $ Left $ convert $ show e)
|
||||
|
||||
leftOnException' :: (MonadIO m, MonadBaseControl IO m) => m a -> m (Either T.Text a)
|
||||
leftOnException' action = E.catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ convert $ show e)
|
||||
|
||||
-- * Util
|
||||
|
||||
whenJust :: (Monad m) => Maybe a -> (a -> m b) -> m ()
|
||||
whenJust Nothing _ = return ()
|
||||
whenJust (Just x) action = void $ action x
|
||||
|
||||
whenLeft :: (Monad m) => Either a b -> (a -> m ()) -> m ()
|
||||
whenLeft (Left x) action = action x
|
||||
whenLeft (Right _) _ = return ()
|
||||
|
||||
whenRight :: (Monad m) => Either a b -> (b -> m ()) -> m ()
|
||||
whenRight (Left _) _ = return ()
|
||||
whenRight (Right x) action = action x
|
10
sandwich-webdriver/stack.yaml
Normal file
10
sandwich-webdriver/stack.yaml
Normal file
@ -0,0 +1,10 @@
|
||||
|
||||
resolver: lts-16.1
|
||||
|
||||
packages:
|
||||
- .
|
||||
- ../sandwich
|
||||
|
||||
extra-deps:
|
||||
- git: https://github.com/codedownio/hs-webdriver
|
||||
commit: 8bc94c291838d6d4152138cf4ab94d1db6f8da7e
|
23
sandwich-webdriver/stack.yaml.lock
Normal file
23
sandwich-webdriver/stack.yaml.lock
Normal file
@ -0,0 +1,23 @@
|
||||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
name: webdriver
|
||||
version: 0.9.0.1
|
||||
git: https://github.com/codedownio/hs-webdriver
|
||||
pantry-tree:
|
||||
size: 2934
|
||||
sha256: 94104badd5973a0ddbb9588fc1cb05923eb5202291b0ef08613c6b2329bcf1ce
|
||||
commit: 8bc94c291838d6d4152138cf4ab94d1db6f8da7e
|
||||
original:
|
||||
git: https://github.com/codedownio/hs-webdriver
|
||||
commit: 8bc94c291838d6d4152138cf4ab94d1db6f8da7e
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 531237
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/1.yaml
|
||||
sha256: 954b6b14b0c8130732cf4773f7ebb4efc9a44600d1a5265d142868bf93462bc6
|
||||
original: lts-16.1
|
2
sandwich-webdriver/test/Spec.hs
Normal file
2
sandwich-webdriver/test/Spec.hs
Normal file
@ -0,0 +1,2 @@
|
||||
main :: IO ()
|
||||
main = putStrLn "Test suite not yet implemented"
|
30
sandwich/LICENSE
Normal file
30
sandwich/LICENSE
Normal file
@ -0,0 +1,30 @@
|
||||
Copyright Author name here (c) 2020
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* 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.
|
||||
|
||||
* Neither the name of Author name here nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
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
|
||||
OWNER 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.
|
2
sandwich/Setup.hs
Normal file
2
sandwich/Setup.hs
Normal file
@ -0,0 +1,2 @@
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
@ -74,15 +74,15 @@ medium = do
|
||||
|
||||
introduce "Database" database (return $ Database "outer") (return ()) $ do
|
||||
it "uses the DB 1" $ do
|
||||
db <- askLabel database
|
||||
db <- getContext database
|
||||
debug [i|Got db: #{db}|]
|
||||
|
||||
introduce "Database again" database (return $ Database "shadowing") (return ()) $ do
|
||||
introduce "Database again" otherDatabase (return $ Database "other") (return ()) $ do
|
||||
it "uses the DB 2" $ do
|
||||
db <- askLabel database
|
||||
db <- getContext database
|
||||
debug [i|Got db: #{db}|]
|
||||
otherDb <- askLabel otherDatabase
|
||||
otherDb <- getContext otherDatabase
|
||||
debug [i|Got otherDb: #{otherDb}|]
|
||||
|
||||
afterEach "after each" (return ()) $ do
|
@ -32,6 +32,7 @@ dependencies:
|
||||
- interpolate
|
||||
- microlens
|
||||
- microlens-th
|
||||
- monad-control
|
||||
- monad-logger
|
||||
- mtl
|
||||
- random
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 526a389b9fd63e58ec5862149a9c31cbdc0abe1d0488020b8abc3ecb8a88f9a1
|
||||
-- hash: 3e4c233024226223a25a92dc8176ba06ace126aedc39e32e7cbc24894b0ff1ea
|
||||
|
||||
name: sandwich
|
||||
version: 0.1.0.0
|
||||
@ -66,6 +66,7 @@ library
|
||||
, interpolate
|
||||
, microlens
|
||||
, microlens-th
|
||||
, monad-control
|
||||
, monad-logger
|
||||
, mtl
|
||||
, random
|
||||
@ -99,6 +100,7 @@ executable sandwich-exe
|
||||
, interpolate
|
||||
, microlens
|
||||
, microlens-th
|
||||
, monad-control
|
||||
, monad-logger
|
||||
, mtl
|
||||
, random
|
||||
@ -134,6 +136,7 @@ test-suite sandwich-test
|
||||
, interpolate
|
||||
, microlens
|
||||
, microlens-th
|
||||
, monad-control
|
||||
, monad-logger
|
||||
, mtl
|
||||
, random
|
@ -14,14 +14,18 @@ module Test.Sandwich (
|
||||
, afterEach
|
||||
, around
|
||||
|
||||
, TopSpec
|
||||
|
||||
, defaultOptions
|
||||
|
||||
, Result(..)
|
||||
, FailureReason(..)
|
||||
|
||||
, askLabel
|
||||
, Label(..)
|
||||
|
||||
, Spec, HasBaseContext, HasLabel, LabelValue, (:>), ExampleM -- Used in sandwich-webdriver
|
||||
|
||||
, module Test.Sandwich.Contexts
|
||||
, module Test.Sandwich.Expectations
|
||||
, module Test.Sandwich.Logging
|
||||
|
22
sandwich/src/Test/Sandwich/Contexts.hs
Normal file
22
sandwich/src/Test/Sandwich/Contexts.hs
Normal file
@ -0,0 +1,22 @@
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
-- |
|
||||
|
||||
module Test.Sandwich.Contexts where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import GHC.Stack
|
||||
import Test.Sandwich.Types.Spec
|
||||
|
||||
getContext :: (HasLabel context l a, HasCallStack) => Label l a -> ExampleM context a
|
||||
getContext = asks . getLabelValue
|
||||
|
||||
getRunRoot :: (HasBaseContext context) => ExampleM context (Maybe FilePath)
|
||||
getRunRoot = do
|
||||
ctx <- ask
|
||||
let BaseContext {..} = getBaseContext ctx
|
||||
return baseContextRunRoot
|
||||
|
||||
getCurrentFolder :: (HasBaseContext context) => ExampleM context (Maybe FilePath)
|
||||
getCurrentFolder = undefined
|
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE RoleAnnotations #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
@ -15,6 +14,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | The core Spec/SpecCommand types, used to define the test free monad.
|
||||
|
||||
@ -26,6 +26,7 @@ import Control.Monad.Free
|
||||
import Control.Monad.Free.TH
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Trans.Control
|
||||
import Data.Functor.Classes
|
||||
import Data.Sequence hiding ((:>))
|
||||
import Data.String.Interpolate
|
||||
@ -35,9 +36,27 @@ import Test.Sandwich.Types.Options
|
||||
|
||||
-- * ExampleM monad
|
||||
|
||||
newtype ExampleM context a = ExampleM { unExampleM :: ReaderT context (ExceptT FailureReason (LoggingT IO)) a }
|
||||
newtype ExampleM context a = ExampleT { unExampleM :: ReaderT context (ExceptT FailureReason (LoggingT IO)) a }
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadReader context, MonadError FailureReason, MonadLogger)
|
||||
|
||||
type ExampleT = ExampleM
|
||||
|
||||
-- newtype ExampleT context m a = ExampleT { unExampleT :: ReaderT context (ExceptT FailureReason (LoggingT m)) a }
|
||||
-- deriving (Functor, Applicative, Monad, MonadIO, MonadReader context, MonadError FailureReason, MonadLogger)
|
||||
|
||||
-- type ExampleM context = ExampleT context IO
|
||||
|
||||
-- type WrappedT context m a = ReaderT context (ExceptT FailureReason (LoggingT m)) a
|
||||
-- instance MonadTransControl (ExampleT context) where
|
||||
-- type StT (ExampleT context) a = StT (WrappedT context) a
|
||||
-- liftWith = defaultLiftWith ExampleT unExampleT
|
||||
-- restoreT = defaultRestoreT ExampleT
|
||||
|
||||
|
||||
-- instance MonadBaseControl IO (ExampleM context) where
|
||||
-- liftBaseWith = undefined -- defaultLiftBaseWith
|
||||
-- restoreM = undefined -- defaultRestoreM
|
||||
|
||||
-- * Results
|
||||
|
||||
data Result = Success
|
||||
@ -214,8 +233,8 @@ beforeEach l f (Free x@(It {..})) = Free (Before l f (Free (x { next = Pure () }
|
||||
beforeEach _ _ (Pure x) = Pure x
|
||||
beforeEach l f (Free (Introduce li cl alloc clean subspec next)) = Free (Introduce li cl alloc clean (beforeEach l f' subspec) (beforeEach l f next))
|
||||
where f' = do
|
||||
let ExampleM r = f
|
||||
ExampleM $ withReaderT (\(_ :> context) -> context) r
|
||||
let ExampleT r = f
|
||||
ExampleT $ withReaderT (\(_ :> context) -> context) r
|
||||
|
||||
-- | Perform an action after each example in a given spec tree.
|
||||
afterEach ::
|
||||
@ -232,8 +251,8 @@ afterEach l f (Free x@(It {..})) = Free (After l f (Free (x { next = Pure () }))
|
||||
afterEach _ _ (Pure x) = Pure x
|
||||
afterEach l f (Free (Introduce li cl alloc clean subspec next)) = Free (Introduce li cl alloc clean (afterEach l f' subspec) (afterEach l f next))
|
||||
where f' = do
|
||||
let ExampleM r = f
|
||||
ExampleM $ withReaderT (\(_ :> context) -> context) r
|
||||
let ExampleT r = f
|
||||
ExampleT $ withReaderT (\(_ :> context) -> context) r
|
||||
|
||||
aroundEach ::
|
||||
String
|
||||
@ -250,5 +269,5 @@ aroundEach _ _ (Pure x) = Pure x
|
||||
aroundEach l f (Free (Introduce li cl alloc clean subspec next)) = Free (Introduce li cl alloc clean (aroundEach l f' subspec) (aroundEach l f next))
|
||||
where
|
||||
f' action = do
|
||||
let ExampleM r = f action
|
||||
ExampleM $ withReaderT (\(_ :> context) -> context) r
|
||||
let ExampleT r = f action
|
||||
ExampleT $ withReaderT (\(_ :> context) -> context) r
|
7
sandwich/stack.yaml
Normal file
7
sandwich/stack.yaml
Normal file
@ -0,0 +1,7 @@
|
||||
|
||||
resolver: lts-16.1
|
||||
|
||||
packages:
|
||||
- .
|
||||
|
||||
extra-deps: []
|
12
sandwich/stack.yaml.lock
Normal file
12
sandwich/stack.yaml.lock
Normal file
@ -0,0 +1,12 @@
|
||||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 531237
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/1.yaml
|
||||
sha256: 954b6b14b0c8130732cf4773f7ebb4efc9a44600d1a5265d142868bf93462bc6
|
||||
original: lts-16.1
|
@ -1,12 +0,0 @@
|
||||
{-# LANGUAGE MonoLocalBinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
-- |
|
||||
|
||||
module Test.Sandwich.Contexts where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import GHC.Stack
|
||||
import Test.Sandwich.Types.Spec
|
||||
|
||||
askLabel :: (HasLabel context l a, HasCallStack) => Label l a -> ExampleM context a
|
||||
askLabel = asks . getLabelValue
|
67
stack.yaml
67
stack.yaml
@ -1,67 +0,0 @@
|
||||
# This file was automatically generated by 'stack init'
|
||||
#
|
||||
# Some commonly used options have been documented as comments in this file.
|
||||
# For advanced use and comprehensive documentation of the format, please see:
|
||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||
|
||||
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||
# A snapshot resolver dictates the compiler version and the set of packages
|
||||
# to be used for project dependencies. For example:
|
||||
#
|
||||
# resolver: lts-3.5
|
||||
# resolver: nightly-2015-09-21
|
||||
# resolver: ghc-7.10.2
|
||||
#
|
||||
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver: lts-16.0
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
#
|
||||
# packages:
|
||||
# - some-directory
|
||||
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||
# subdirs:
|
||||
# - auto-update
|
||||
# - wai
|
||||
packages:
|
||||
- .
|
||||
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||
# These entries can reference officially published versions as well as
|
||||
# forks / in-progress versions pinned to a git hash. For example:
|
||||
#
|
||||
# extra-deps:
|
||||
# - acme-missiles-0.3
|
||||
# - git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
#
|
||||
extra-deps:
|
||||
- ncurses-0.2.16@sha256:8ad9fe6562a80d28166d76adbac1eb4d40c6511fe4e9272ed6e1166dc2f1cdf1,3575
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
# flags: {}
|
||||
|
||||
# Extra package databases containing global packages
|
||||
# extra-package-dbs: []
|
||||
|
||||
# Control whether we use the GHC we find on the path
|
||||
# system-ghc: true
|
||||
#
|
||||
# Require a specific version of stack, using version ranges
|
||||
# require-stack-version: -any # Default
|
||||
# require-stack-version: ">=2.3"
|
||||
#
|
||||
# Override the architecture used by stack, especially useful on Windows
|
||||
# arch: i386
|
||||
# arch: x86_64
|
||||
#
|
||||
# Extra directories used by stack for building
|
||||
# extra-include-dirs: [/path/to/dir]
|
||||
# extra-lib-dirs: [/path/to/dir]
|
||||
#
|
||||
# Allow a newer minor version of GHC than the snapshot specifies
|
||||
# compiler-check: newer-minor
|
@ -1,19 +0,0 @@
|
||||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
hackage: ncurses-0.2.16@sha256:8ad9fe6562a80d28166d76adbac1eb4d40c6511fe4e9272ed6e1166dc2f1cdf1,3575
|
||||
pantry-tree:
|
||||
size: 674
|
||||
sha256: 093bdc85ed518c81724f5b6b81c24ab4ebdd231551861f4feaa43361136f70b7
|
||||
original:
|
||||
hackage: ncurses-0.2.16@sha256:8ad9fe6562a80d28166d76adbac1eb4d40c6511fe4e9272ed6e1166dc2f1cdf1,3575
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 531237
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/0.yaml
|
||||
sha256: 210e15b7043e2783115afe16b0d54914b1611cdaa73f3ca3ca7f8e0847ff54e5
|
||||
original: lts-16.0
|
Loading…
Reference in New Issue
Block a user