mirror of
https://github.com/codedownio/sandwich.git
synced 2024-08-16 23:30:22 +03:00
Halfway through unliftio switch
This commit is contained in:
parent
057b11f5f8
commit
db5671f14c
@ -19,11 +19,11 @@ dependencies:
|
|||||||
- hedgehog
|
- hedgehog
|
||||||
- monad-control
|
- monad-control
|
||||||
- mtl
|
- mtl
|
||||||
- safe-exceptions
|
|
||||||
- sandwich >= 0.1.0.4
|
- sandwich >= 0.1.0.4
|
||||||
- string-interpolate
|
- string-interpolate
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
|
- unliftio
|
||||||
- wl-pprint-annotated
|
- wl-pprint-annotated
|
||||||
- vty
|
- vty
|
||||||
|
|
||||||
|
@ -47,11 +47,11 @@ library
|
|||||||
, hedgehog
|
, hedgehog
|
||||||
, monad-control
|
, monad-control
|
||||||
, mtl
|
, mtl
|
||||||
, safe-exceptions
|
|
||||||
, sandwich >=0.1.0.4
|
, sandwich >=0.1.0.4
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
|
, unliftio
|
||||||
, vty
|
, vty
|
||||||
, wl-pprint-annotated
|
, wl-pprint-annotated
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
@ -79,11 +79,11 @@ test-suite sandwich-hedgehog-test
|
|||||||
, hedgehog
|
, hedgehog
|
||||||
, monad-control
|
, monad-control
|
||||||
, mtl
|
, mtl
|
||||||
, safe-exceptions
|
|
||||||
, sandwich >=0.1.0.4
|
, sandwich >=0.1.0.4
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
|
, unliftio
|
||||||
, vty
|
, vty
|
||||||
, wl-pprint-annotated
|
, wl-pprint-annotated
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -56,7 +56,7 @@ module Test.Sandwich.Hedgehog (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad.Free
|
import Control.Monad.Free
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
@ -19,10 +19,10 @@ dependencies:
|
|||||||
- monad-control
|
- monad-control
|
||||||
- mtl
|
- mtl
|
||||||
- QuickCheck
|
- QuickCheck
|
||||||
- safe-exceptions
|
|
||||||
- sandwich >= 0.1.0.4
|
- sandwich >= 0.1.0.4
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
|
- unliftio
|
||||||
|
|
||||||
default-extensions:
|
default-extensions:
|
||||||
- OverloadedStrings
|
- OverloadedStrings
|
||||||
|
@ -1,10 +1,10 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.35.1.
|
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 496ab214547ab49a21ff2bed85694f6d3b52326cdd719476fd8f526488cae467
|
-- hash: 6f60d0ac0ceda196b8e70c79a5da77af10c4d52a9cba4791ffb053f667b9600f
|
||||||
|
|
||||||
name: sandwich-quickcheck
|
name: sandwich-quickcheck
|
||||||
version: 0.1.0.7
|
version: 0.1.0.7
|
||||||
@ -48,10 +48,10 @@ library
|
|||||||
, free
|
, free
|
||||||
, monad-control
|
, monad-control
|
||||||
, mtl
|
, mtl
|
||||||
, safe-exceptions
|
|
||||||
, sandwich >=0.1.0.4
|
, sandwich >=0.1.0.4
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
|
, unliftio
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
test-suite sandwich-quickcheck-test
|
test-suite sandwich-quickcheck-test
|
||||||
@ -77,8 +77,8 @@ test-suite sandwich-quickcheck-test
|
|||||||
, free
|
, free
|
||||||
, monad-control
|
, monad-control
|
||||||
, mtl
|
, mtl
|
||||||
, safe-exceptions
|
|
||||||
, sandwich >=0.1.0.4
|
, sandwich >=0.1.0.4
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
|
, unliftio
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -32,7 +32,7 @@ module Test.Sandwich.QuickCheck (
|
|||||||
, modifyMaxShrinks
|
, modifyMaxShrinks
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad.Free
|
import Control.Monad.Free
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
@ -23,12 +23,12 @@ dependencies:
|
|||||||
- monad-logger
|
- monad-logger
|
||||||
- mtl
|
- mtl
|
||||||
- safe
|
- safe
|
||||||
- safe-exceptions
|
|
||||||
- sandwich
|
- sandwich
|
||||||
- stm
|
- stm
|
||||||
- string-interpolate
|
- string-interpolate
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
|
- unliftio
|
||||||
- vector
|
- vector
|
||||||
- wreq
|
- wreq
|
||||||
|
|
||||||
|
@ -1,10 +1,10 @@
|
|||||||
cabal-version: 1.12
|
cabal-version: 1.12
|
||||||
|
|
||||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 6138f55d728f79ee3b7afe065d16ee37a3b075445596cb82a236df8f0e23bf47
|
-- hash: edb46ab628d2fbd67e7d2aaf706c9613379157b0dc955e7dc14e7793778b163e
|
||||||
|
|
||||||
name: sandwich-slack
|
name: sandwich-slack
|
||||||
version: 0.1.2.0
|
version: 0.1.2.0
|
||||||
@ -60,12 +60,12 @@ library
|
|||||||
, monad-logger
|
, monad-logger
|
||||||
, mtl
|
, mtl
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich
|
, sandwich
|
||||||
, stm
|
, stm
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
|
, unliftio
|
||||||
, vector
|
, vector
|
||||||
, wreq
|
, wreq
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
@ -98,13 +98,13 @@ executable sandwich-slack-exe
|
|||||||
, monad-logger
|
, monad-logger
|
||||||
, mtl
|
, mtl
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich
|
, sandwich
|
||||||
, sandwich-slack
|
, sandwich-slack
|
||||||
, stm
|
, stm
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
|
, unliftio
|
||||||
, vector
|
, vector
|
||||||
, wreq
|
, wreq
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
@ -138,12 +138,12 @@ test-suite sandwich-slack-test
|
|||||||
, monad-logger
|
, monad-logger
|
||||||
, mtl
|
, mtl
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich
|
, sandwich
|
||||||
, stm
|
, stm
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
|
, unliftio
|
||||||
, vector
|
, vector
|
||||||
, wreq
|
, wreq
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
@ -30,7 +30,7 @@ module Test.Sandwich.Formatters.Slack (
|
|||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger hiding (logError)
|
import Control.Monad.Logger hiding (logError)
|
||||||
|
@ -25,7 +25,6 @@ dependencies:
|
|||||||
- http-client
|
- http-client
|
||||||
- http-client-tls
|
- http-client-tls
|
||||||
- http-conduit
|
- http-conduit
|
||||||
- lifted-base
|
|
||||||
- microlens
|
- microlens
|
||||||
- microlens-aeson
|
- microlens-aeson
|
||||||
- monad-control
|
- monad-control
|
||||||
@ -36,13 +35,13 @@ dependencies:
|
|||||||
- random
|
- random
|
||||||
- retry
|
- retry
|
||||||
- safe
|
- safe
|
||||||
- safe-exceptions
|
|
||||||
- sandwich >= 0.1.0.3
|
- sandwich >= 0.1.0.3
|
||||||
- string-interpolate
|
- string-interpolate
|
||||||
- temporary
|
- temporary
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
- transformers
|
- transformers
|
||||||
|
- unliftio
|
||||||
- unordered-containers
|
- unordered-containers
|
||||||
- vector
|
- vector
|
||||||
- webdriver
|
- webdriver
|
||||||
|
@ -74,7 +74,6 @@ library
|
|||||||
, http-client
|
, http-client
|
||||||
, http-client-tls
|
, http-client-tls
|
||||||
, http-conduit
|
, http-conduit
|
||||||
, lifted-base
|
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-aeson
|
, microlens-aeson
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -85,13 +84,13 @@ library
|
|||||||
, random
|
, random
|
||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich >=0.1.0.3
|
, sandwich >=0.1.0.3
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, temporary
|
, temporary
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
|
, unliftio
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, vector
|
, vector
|
||||||
, webdriver
|
, webdriver
|
||||||
@ -151,7 +150,6 @@ executable sandwich-webdriver-exe
|
|||||||
, http-client
|
, http-client
|
||||||
, http-client-tls
|
, http-client-tls
|
||||||
, http-conduit
|
, http-conduit
|
||||||
, lifted-base
|
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-aeson
|
, microlens-aeson
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -162,7 +160,6 @@ executable sandwich-webdriver-exe
|
|||||||
, random
|
, random
|
||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich >=0.1.0.3
|
, sandwich >=0.1.0.3
|
||||||
, sandwich-webdriver
|
, sandwich-webdriver
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
@ -170,6 +167,7 @@ executable sandwich-webdriver-exe
|
|||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
|
, unliftio
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, vector
|
, vector
|
||||||
, webdriver
|
, webdriver
|
||||||
@ -230,7 +228,6 @@ test-suite sandwich-webdriver-test
|
|||||||
, http-client
|
, http-client
|
||||||
, http-client-tls
|
, http-client-tls
|
||||||
, http-conduit
|
, http-conduit
|
||||||
, lifted-base
|
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-aeson
|
, microlens-aeson
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -241,7 +238,6 @@ test-suite sandwich-webdriver-test
|
|||||||
, random
|
, random
|
||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich >=0.1.0.3
|
, sandwich >=0.1.0.3
|
||||||
, sandwich-webdriver
|
, sandwich-webdriver
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
|
@ -2,10 +2,10 @@
|
|||||||
|
|
||||||
module Test.Sandwich.WebDriver.Internal.Action where
|
module Test.Sandwich.WebDriver.Internal.Action where
|
||||||
|
|
||||||
import Control.Concurrent.MVar.Lifted
|
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Control.Monad.Catch (MonadCatch)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||||
@ -16,10 +16,12 @@ import Test.Sandwich
|
|||||||
import Test.Sandwich.WebDriver.Internal.Types
|
import Test.Sandwich.WebDriver.Internal.Types
|
||||||
import Test.Sandwich.WebDriver.Internal.Util
|
import Test.Sandwich.WebDriver.Internal.Util
|
||||||
import qualified Test.WebDriver as W
|
import qualified Test.WebDriver as W
|
||||||
|
import UnliftIO.Concurrent
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
|
|
||||||
-- | Close the given sessions
|
-- | Close the given sessions
|
||||||
closeSession :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => Session -> WebDriver -> m ()
|
closeSession :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => Session -> WebDriver -> m ()
|
||||||
closeSession session (WebDriver {wdSessionMap}) = do
|
closeSession session (WebDriver {wdSessionMap}) = do
|
||||||
toClose <- modifyMVar wdSessionMap $ \sessionMap ->
|
toClose <- modifyMVar wdSessionMap $ \sessionMap ->
|
||||||
case M.lookup session sessionMap of
|
case M.lookup session sessionMap of
|
||||||
@ -29,7 +31,7 @@ closeSession session (WebDriver {wdSessionMap}) = do
|
|||||||
whenJust toClose $ \sess -> liftIO $ W.runWD sess W.closeSession
|
whenJust toClose $ \sess -> liftIO $ W.runWD sess W.closeSession
|
||||||
|
|
||||||
-- | Close all sessions except those listed
|
-- | Close all sessions except those listed
|
||||||
closeAllSessionsExcept :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => [Session] -> WebDriver -> m ()
|
closeAllSessionsExcept :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => [Session] -> WebDriver -> m ()
|
||||||
closeAllSessionsExcept toKeep (WebDriver {wdSessionMap}) = do
|
closeAllSessionsExcept toKeep (WebDriver {wdSessionMap}) = do
|
||||||
toClose <- modifyMVar wdSessionMap $ return . M.partitionWithKey (\name _ -> name `elem` toKeep)
|
toClose <- modifyMVar wdSessionMap $ return . M.partitionWithKey (\name _ -> name `elem` toKeep)
|
||||||
|
|
||||||
@ -38,11 +40,11 @@ closeAllSessionsExcept toKeep (WebDriver {wdSessionMap}) = do
|
|||||||
(\(e :: SomeException) -> warn [i|Failed to destroy session '#{name}': '#{e}'|])
|
(\(e :: SomeException) -> warn [i|Failed to destroy session '#{name}': '#{e}'|])
|
||||||
|
|
||||||
-- | Close all sessions
|
-- | Close all sessions
|
||||||
closeAllSessions :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => WebDriver -> m ()
|
closeAllSessions :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => WebDriver -> m ()
|
||||||
closeAllSessions = closeAllSessionsExcept []
|
closeAllSessions = closeAllSessionsExcept []
|
||||||
|
|
||||||
-- | Close the current session
|
-- | Close the current session
|
||||||
closeCurrentSession :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadReader context m, HasLabel context "webdriver" WebDriver, HasLabel context "webdriverSession" WebDriverSession) => m ()
|
closeCurrentSession :: (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadReader context m, HasLabel context "webdriver" WebDriver, HasLabel context "webdriverSession" WebDriverSession) => m ()
|
||||||
closeCurrentSession = do
|
closeCurrentSession = do
|
||||||
webDriver <- getContext webdriver
|
webDriver <- getContext webdriver
|
||||||
(session, _) <- getContext webdriverSession
|
(session, _) <- getContext webdriverSession
|
||||||
|
@ -14,6 +14,7 @@ import Control.Exception
|
|||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Catch
|
import Control.Monad.Catch
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
@ -23,7 +24,6 @@ import GHC.Stack
|
|||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO.Temp
|
|
||||||
import System.Process
|
import System.Process
|
||||||
import Test.Sandwich.Expectations
|
import Test.Sandwich.Expectations
|
||||||
import Test.Sandwich.Logging
|
import Test.Sandwich.Logging
|
||||||
@ -32,14 +32,13 @@ import Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox
|
|||||||
import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
|
import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
|
||||||
import Test.Sandwich.WebDriver.Internal.Types
|
import Test.Sandwich.WebDriver.Internal.Types
|
||||||
import Test.Sandwich.WebDriver.Internal.Util
|
import Test.Sandwich.WebDriver.Internal.Util
|
||||||
|
import UnliftIO.Temporary
|
||||||
|
|
||||||
|
|
||||||
type Constraints m = (
|
type Constraints m = (
|
||||||
HasCallStack
|
HasCallStack
|
||||||
, MonadLogger m
|
, MonadLogger m
|
||||||
, MonadIO m
|
, MonadUnliftIO m
|
||||||
, MonadBaseControl IO m
|
|
||||||
, MonadMask m
|
|
||||||
)
|
)
|
||||||
|
|
||||||
-- * Obtaining binaries
|
-- * Obtaining binaries
|
||||||
@ -51,7 +50,7 @@ defaultSeleniumJarUrl = "https://selenium-release.storage.googleapis.com/3.141/s
|
|||||||
|
|
||||||
-- | Manually obtain a Selenium server JAR file, according to the 'SeleniumToUse' policy,
|
-- | Manually obtain a Selenium server JAR file, according to the 'SeleniumToUse' policy,
|
||||||
-- storing it under the provided 'FilePath' if necessary and returning the exact path.
|
-- storing it under the provided 'FilePath' if necessary and returning the exact path.
|
||||||
obtainSelenium :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => FilePath -> SeleniumToUse -> m (Either T.Text FilePath)
|
obtainSelenium :: (MonadUnliftIO m, MonadLogger m) => FilePath -> SeleniumToUse -> m (Either T.Text FilePath)
|
||||||
obtainSelenium toolsDir (DownloadSeleniumFrom url) = do
|
obtainSelenium toolsDir (DownloadSeleniumFrom url) = do
|
||||||
let path = [i|#{toolsDir}/selenium-server-standalone.jar|]
|
let path = [i|#{toolsDir}/selenium-server-standalone.jar|]
|
||||||
unlessM (liftIO $ doesFileExist path) $
|
unlessM (liftIO $ doesFileExist path) $
|
||||||
@ -69,7 +68,7 @@ obtainSelenium _ (UseSeleniumAt path) = liftIO (doesFileExist path) >>= \case
|
|||||||
-- | Manually obtain a chromedriver binary, according to the 'ChromeDriverToUse' policy,
|
-- | Manually obtain a chromedriver binary, according to the 'ChromeDriverToUse' policy,
|
||||||
-- storing it under the provided 'FilePath' if necessary and returning the exact path.
|
-- storing it under the provided 'FilePath' if necessary and returning the exact path.
|
||||||
obtainChromeDriver :: (
|
obtainChromeDriver :: (
|
||||||
MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadMask m
|
MonadUnliftIO m, MonadLogger m
|
||||||
) => FilePath -> ChromeDriverToUse -> m (Either T.Text FilePath)
|
) => FilePath -> ChromeDriverToUse -> m (Either T.Text FilePath)
|
||||||
obtainChromeDriver toolsDir (DownloadChromeDriverFrom url) = do
|
obtainChromeDriver toolsDir (DownloadChromeDriverFrom url) = do
|
||||||
let path = [i|#{toolsDir}/#{chromeDriverExecutable}|]
|
let path = [i|#{toolsDir}/#{chromeDriverExecutable}|]
|
||||||
@ -93,7 +92,7 @@ obtainChromeDriver _ (UseChromeDriverAt path) = liftIO (doesFileExist path) >>=
|
|||||||
|
|
||||||
-- | Manually obtain a geckodriver binary, according to the 'GeckoDriverToUse' policy,
|
-- | Manually obtain a geckodriver binary, according to the 'GeckoDriverToUse' policy,
|
||||||
-- storing it under the provided 'FilePath' if necessary and returning the exact path.
|
-- storing it under the provided 'FilePath' if necessary and returning the exact path.
|
||||||
obtainGeckoDriver :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => FilePath -> GeckoDriverToUse -> m (Either T.Text FilePath)
|
obtainGeckoDriver :: (MonadUnliftIO m, MonadLogger m) => FilePath -> GeckoDriverToUse -> m (Either T.Text FilePath)
|
||||||
obtainGeckoDriver toolsDir (DownloadGeckoDriverFrom url) = do
|
obtainGeckoDriver toolsDir (DownloadGeckoDriverFrom url) = do
|
||||||
let path = [i|#{toolsDir}/#{geckoDriverExecutable}|]
|
let path = [i|#{toolsDir}/#{geckoDriverExecutable}|]
|
||||||
unlessM (liftIO $ doesFileExist path) $
|
unlessM (liftIO $ doesFileExist path) $
|
||||||
@ -160,7 +159,7 @@ geckoDriverExecutable = case detectPlatform of
|
|||||||
Windows -> "geckodriver.exe"
|
Windows -> "geckodriver.exe"
|
||||||
_ -> "geckodriver"
|
_ -> "geckodriver"
|
||||||
|
|
||||||
downloadAndUnzipToPath :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadMask m) => T.Text -> FilePath -> m (Either T.Text ())
|
downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())
|
||||||
downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
|
downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
|
||||||
info [i|Downloading #{downloadPath} to #{localPath}|]
|
info [i|Downloading #{downloadPath} to #{localPath}|]
|
||||||
liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
|
liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
|
||||||
@ -180,7 +179,7 @@ downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do
|
|||||||
>>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
|
>>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
|
||||||
xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]
|
xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]
|
||||||
|
|
||||||
downloadAndUntarballToPath :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadThrow m) => T.Text -> FilePath -> m (Either T.Text ())
|
downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())
|
||||||
downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
|
downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
|
||||||
info [i|Downloading #{downloadPath} to #{localPath}|]
|
info [i|Downloading #{downloadPath} to #{localPath}|]
|
||||||
liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
|
liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
|
||||||
@ -189,7 +188,7 @@ downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do
|
|||||||
createProcessWithLogging (shell [i|chmod u+x #{localPath}|])
|
createProcessWithLogging (shell [i|chmod u+x #{localPath}|])
|
||||||
>>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
|
>>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)
|
||||||
|
|
||||||
curlDownloadToPath :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => String -> FilePath -> m ()
|
curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m) => String -> FilePath -> m ()
|
||||||
curlDownloadToPath downloadPath localPath = do
|
curlDownloadToPath downloadPath localPath = do
|
||||||
info [i|Downloading #{downloadPath} to #{localPath}|]
|
info [i|Downloading #{downloadPath} to #{localPath}|]
|
||||||
liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
|
liftIO $ createDirectoryIfMissing True (takeDirectory localPath)
|
||||||
|
@ -1,12 +1,14 @@
|
|||||||
{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, CPP, QuasiQuotes, RecordWildCards #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
-- |
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Test.Sandwich.WebDriver.Internal.Screenshots where
|
module Test.Sandwich.WebDriver.Internal.Screenshots where
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Exception.Lifted
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
@ -15,13 +17,14 @@ import Network.HTTP.Client
|
|||||||
import System.FilePath
|
import System.FilePath
|
||||||
import Test.Sandwich.WebDriver.Internal.Types
|
import Test.Sandwich.WebDriver.Internal.Types
|
||||||
import Test.WebDriver
|
import Test.WebDriver
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
saveScreenshots :: (HasCallStack) => T.Text -> WebDriver -> FilePath -> IO ()
|
saveScreenshots :: (HasCallStack) => T.Text -> WebDriver -> FilePath -> IO ()
|
||||||
saveScreenshots screenshotName (WebDriver {..}) resultsDir = do
|
saveScreenshots screenshotName (WebDriver {..}) resultsDir = do
|
||||||
-- For every session, and for every window, try to get a screenshot for the results dir
|
-- For every session, and for every window, try to get a screenshot for the results dir
|
||||||
sessionMap <- readMVar wdSessionMap
|
sessionMap <- readMVar wdSessionMap
|
||||||
forM_ (M.toList sessionMap) $ \(browser, sess) -> runWD sess $
|
forM_ (M.toList sessionMap) $ \(browser, sess) ->
|
||||||
handle (\(e :: HttpException) -> case e of
|
handle (\(e :: HttpException) -> case e of
|
||||||
(HttpExceptionRequest _ content) -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{content}'|]
|
(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}'|])
|
e -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e}'|])
|
||||||
(saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])
|
(runWD sess $ saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])
|
||||||
|
@ -1,19 +1,18 @@
|
|||||||
{-# LANGUAGE ConstraintKinds #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
{-# LANGUAGE OverloadedLists #-}
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
module Test.Sandwich.WebDriver.Internal.StartWebDriver where
|
module Test.Sandwich.WebDriver.Internal.StartWebDriver where
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Catch (MonadMask)
|
import Control.Monad.Catch (MonadMask)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
||||||
import Control.Retry
|
import Control.Retry
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
import Data.Default
|
import Data.Default
|
||||||
@ -40,6 +39,7 @@ import Test.Sandwich.WebDriver.Internal.Types
|
|||||||
import Test.Sandwich.WebDriver.Internal.Util
|
import Test.Sandwich.WebDriver.Internal.Util
|
||||||
import qualified Test.WebDriver as W
|
import qualified Test.WebDriver as W
|
||||||
import qualified Test.WebDriver.Firefox.Profile as FF
|
import qualified Test.WebDriver.Firefox.Profile as FF
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
|
import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
|
||||||
@ -57,7 +57,7 @@ fromText = id
|
|||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
|
||||||
type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)
|
type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m)
|
||||||
|
|
||||||
-- | Spin up a Selenium WebDriver and create a WebDriver
|
-- | Spin up a Selenium WebDriver and create a WebDriver
|
||||||
startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver
|
startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver
|
||||||
|
@ -2,16 +2,16 @@
|
|||||||
|
|
||||||
module Test.Sandwich.WebDriver.Internal.Util where
|
module Test.Sandwich.WebDriver.Internal.Util where
|
||||||
|
|
||||||
import Control.Exception
|
|
||||||
import qualified Control.Exception.Lifted as E
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Process
|
import System.Process
|
||||||
import qualified System.Random as R
|
import qualified System.Random as R
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
#ifdef mingw32_HOST_OS
|
#ifdef mingw32_HOST_OS
|
||||||
import System.IO
|
import System.IO
|
||||||
@ -29,8 +29,8 @@ moveAndTruncate from to = do
|
|||||||
|
|
||||||
where
|
where
|
||||||
tryTruncateFile :: FilePath -> IO ()
|
tryTruncateFile :: FilePath -> IO ()
|
||||||
tryTruncateFile path = E.catch (truncateFile path)
|
tryTruncateFile path = catch (truncateFile path)
|
||||||
(\(e :: E.SomeException) -> putStrLn [i|Failed to truncate file #{path}: #{e}|])
|
(\(e :: SomeException) -> putStrLn [i|Failed to truncate file #{path}: #{e}|])
|
||||||
|
|
||||||
truncateFile :: FilePath -> IO ()
|
truncateFile :: FilePath -> IO ()
|
||||||
#ifdef mingw32_HOST_OS
|
#ifdef mingw32_HOST_OS
|
||||||
@ -41,11 +41,11 @@ moveAndTruncate from to = do
|
|||||||
|
|
||||||
-- * Exceptions
|
-- * Exceptions
|
||||||
|
|
||||||
leftOnException :: (MonadIO m, MonadBaseControl IO m) => m (Either T.Text a) -> m (Either T.Text a)
|
leftOnException :: (MonadUnliftIO m) => m (Either T.Text a) -> m (Either T.Text a)
|
||||||
leftOnException = E.handle (\(e :: SomeException) -> return $ Left $ T.pack $ show e)
|
leftOnException = handle (\(e :: SomeException) -> return $ Left $ T.pack $ show e)
|
||||||
|
|
||||||
leftOnException' :: (MonadIO m, MonadBaseControl IO m) => m a -> m (Either T.Text a)
|
leftOnException' :: (MonadUnliftIO m) => m a -> m (Either T.Text a)
|
||||||
leftOnException' action = E.catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ T.pack $ show e)
|
leftOnException' action = catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ T.pack $ show e)
|
||||||
|
|
||||||
-- * Util
|
-- * Util
|
||||||
|
|
||||||
|
@ -23,7 +23,7 @@ module Test.Sandwich.WebDriver.Types (
|
|||||||
, WebDriverSessionMonad
|
, WebDriverSessionMonad
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception.Safe as ES
|
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||||
@ -35,6 +35,7 @@ import Test.Sandwich.WebDriver.Internal.Types
|
|||||||
import qualified Test.WebDriver.Class as W
|
import qualified Test.WebDriver.Class as W
|
||||||
import qualified Test.WebDriver.Internal as WI
|
import qualified Test.WebDriver.Internal as WI
|
||||||
import qualified Test.WebDriver.Session as W
|
import qualified Test.WebDriver.Session as W
|
||||||
|
import UnliftIO.Exception as ES
|
||||||
|
|
||||||
|
|
||||||
type ContextWithSession context = LabelValue "webdriverSession" WebDriverSession :> context
|
type ContextWithSession context = LabelValue "webdriverSession" WebDriverSession :> context
|
||||||
|
@ -18,11 +18,9 @@ module Test.Sandwich.WebDriver.Video (
|
|||||||
, defaultGdigrabOptions
|
, defaultGdigrabOptions
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger hiding (logError)
|
import Control.Monad.Logger hiding (logError)
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
@ -35,9 +33,10 @@ import Test.Sandwich.WebDriver.Internal.Video
|
|||||||
import Test.Sandwich.WebDriver.Windows
|
import Test.Sandwich.WebDriver.Windows
|
||||||
import Test.WebDriver.Class as W
|
import Test.WebDriver.Class as W
|
||||||
import Test.WebDriver.Commands
|
import Test.WebDriver.Commands
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
|
|
||||||
type BaseVideoConstraints context m = (MonadLoggerIO m, MonadReader context m, HasWebDriverContext context, MonadBaseControl IO m)
|
type BaseVideoConstraints context m = (MonadLoggerIO m, MonadReader context m, HasWebDriverContext context)
|
||||||
|
|
||||||
-- | Wrapper around 'startVideoRecording' which uses the full screen dimensions.
|
-- | Wrapper around 'startVideoRecording' which uses the full screen dimensions.
|
||||||
startFullScreenVideoRecording :: (
|
startFullScreenVideoRecording :: (
|
||||||
|
@ -11,7 +11,7 @@ module Test.Sandwich.WebDriver.Windows (
|
|||||||
, getScreenResolution
|
, getScreenResolution
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
import Control.Monad.Catch (MonadMask)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger (MonadLogger)
|
import Control.Monad.Logger (MonadLogger)
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
@ -23,6 +23,7 @@ import Test.Sandwich.WebDriver.Internal.Types
|
|||||||
import Test.Sandwich.WebDriver.Resolution
|
import Test.Sandwich.WebDriver.Resolution
|
||||||
import Test.WebDriver
|
import Test.WebDriver
|
||||||
import qualified Test.WebDriver.Class as W
|
import qualified Test.WebDriver.Class as W
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
|
|
||||||
-- | Position the window on the left 50% of the screen.
|
-- | Position the window on the left 50% of the screen.
|
||||||
|
@ -11,6 +11,7 @@ module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb (
|
|||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad.Catch (MonadMask)
|
import Control.Monad.Catch (MonadMask)
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||||
import Control.Retry
|
import Control.Retry
|
||||||
@ -39,7 +40,7 @@ newtype Fd = Fd FD
|
|||||||
handleToFd h = Fd <$> HFD.handleToFd h
|
handleToFd h = Fd <$> HFD.handleToFd h
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)
|
type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m)
|
||||||
|
|
||||||
|
|
||||||
makeXvfbSession :: Constraints m => Maybe (Int, Int) -> Bool -> FilePath -> m (XvfbSession, [(String, String)])
|
makeXvfbSession :: Constraints m => Maybe (Int, Int) -> Bool -> FilePath -> m (XvfbSession, [(String, String)])
|
||||||
|
@ -5,7 +5,7 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger (LogLevel(..))
|
import Control.Monad.Logger (LogLevel(..))
|
||||||
|
@ -39,7 +39,6 @@ dependencies:
|
|||||||
- exceptions
|
- exceptions
|
||||||
- filepath
|
- filepath
|
||||||
- free
|
- free
|
||||||
- lifted-async
|
|
||||||
- microlens
|
- microlens
|
||||||
- microlens-th
|
- microlens-th
|
||||||
- monad-control
|
- monad-control
|
||||||
@ -50,13 +49,13 @@ dependencies:
|
|||||||
- process
|
- process
|
||||||
- retry
|
- retry
|
||||||
- safe
|
- safe
|
||||||
- safe-exceptions
|
|
||||||
- stm
|
- stm
|
||||||
- string-interpolate
|
- string-interpolate
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
- transformers
|
- transformers
|
||||||
- transformers-base
|
- transformers-base
|
||||||
|
- unliftio
|
||||||
- unliftio-core
|
- unliftio-core
|
||||||
- vector
|
- vector
|
||||||
- vty >= 6
|
- vty >= 6
|
||||||
|
@ -123,7 +123,6 @@ library
|
|||||||
, filepath
|
, filepath
|
||||||
, free
|
, free
|
||||||
, haskell-src-exts
|
, haskell-src-exts
|
||||||
, lifted-async
|
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-th
|
, microlens-th
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -134,7 +133,6 @@ library
|
|||||||
, process
|
, process
|
||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, stm
|
, stm
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, template-haskell
|
, template-haskell
|
||||||
@ -142,6 +140,7 @@ library
|
|||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, transformers-base
|
, transformers-base
|
||||||
|
, unliftio
|
||||||
, unliftio-core
|
, unliftio-core
|
||||||
, vector
|
, vector
|
||||||
, vty >=6
|
, vty >=6
|
||||||
@ -187,7 +186,6 @@ executable sandwich-demo
|
|||||||
, filepath
|
, filepath
|
||||||
, free
|
, free
|
||||||
, haskell-src-exts
|
, haskell-src-exts
|
||||||
, lifted-async
|
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-th
|
, microlens-th
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -198,7 +196,6 @@ executable sandwich-demo
|
|||||||
, process
|
, process
|
||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich
|
, sandwich
|
||||||
, stm
|
, stm
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
@ -207,6 +204,7 @@ executable sandwich-demo
|
|||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, transformers-base
|
, transformers-base
|
||||||
|
, unliftio
|
||||||
, unliftio-core
|
, unliftio-core
|
||||||
, vector
|
, vector
|
||||||
, vty >=6
|
, vty >=6
|
||||||
@ -249,7 +247,6 @@ executable sandwich-discover
|
|||||||
, filepath
|
, filepath
|
||||||
, free
|
, free
|
||||||
, haskell-src-exts
|
, haskell-src-exts
|
||||||
, lifted-async
|
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-th
|
, microlens-th
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -260,7 +257,6 @@ executable sandwich-discover
|
|||||||
, process
|
, process
|
||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich
|
, sandwich
|
||||||
, stm
|
, stm
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
@ -269,6 +265,7 @@ executable sandwich-discover
|
|||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, transformers-base
|
, transformers-base
|
||||||
|
, unliftio
|
||||||
, unliftio-core
|
, unliftio-core
|
||||||
, vector
|
, vector
|
||||||
, vty >=6
|
, vty >=6
|
||||||
@ -316,7 +313,6 @@ executable sandwich-test
|
|||||||
, filepath
|
, filepath
|
||||||
, free
|
, free
|
||||||
, haskell-src-exts
|
, haskell-src-exts
|
||||||
, lifted-async
|
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-th
|
, microlens-th
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -327,7 +323,6 @@ executable sandwich-test
|
|||||||
, process
|
, process
|
||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich
|
, sandwich
|
||||||
, stm
|
, stm
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
@ -336,6 +331,7 @@ executable sandwich-test
|
|||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, transformers-base
|
, transformers-base
|
||||||
|
, unliftio
|
||||||
, unliftio-core
|
, unliftio-core
|
||||||
, vector
|
, vector
|
||||||
, vty >=6
|
, vty >=6
|
||||||
@ -384,7 +380,6 @@ test-suite sandwich-test-suite
|
|||||||
, filepath
|
, filepath
|
||||||
, free
|
, free
|
||||||
, haskell-src-exts
|
, haskell-src-exts
|
||||||
, lifted-async
|
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-th
|
, microlens-th
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -395,7 +390,6 @@ test-suite sandwich-test-suite
|
|||||||
, process
|
, process
|
||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, safe-exceptions
|
|
||||||
, sandwich
|
, sandwich
|
||||||
, stm
|
, stm
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
@ -404,6 +398,7 @@ test-suite sandwich-test-suite
|
|||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
, transformers-base
|
, transformers-base
|
||||||
|
, unliftio
|
||||||
, unliftio-core
|
, unliftio-core
|
||||||
, vector
|
, vector
|
||||||
, vty >=6
|
, vty >=6
|
||||||
|
@ -67,7 +67,7 @@ module Test.Sandwich (
|
|||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Free
|
import Control.Monad.Free
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
@ -4,42 +4,44 @@
|
|||||||
|
|
||||||
module Test.Sandwich.Expectations where
|
module Test.Sandwich.Expectations where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import qualified Data.List as L
|
import qualified Data.List as L
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import GHC.Stack
|
import GHC.Stack
|
||||||
import Test.Sandwich.Types.Spec
|
import Test.Sandwich.Types.Spec
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
-- * Manually fail a test or mark as pending
|
-- * Manually fail a test or mark as pending
|
||||||
|
|
||||||
-- | General-purpose function to throw a test exception with a 'String'.
|
-- | General-purpose function to throw a test exception with a 'String'.
|
||||||
expectationFailure :: (HasCallStack, MonadThrow m) => String -> m a
|
expectationFailure :: (HasCallStack, MonadIO m) => String -> m a
|
||||||
expectationFailure = throwIO . Reason (Just callStack)
|
expectationFailure = throwIO . Reason (Just callStack)
|
||||||
|
|
||||||
-- | Throws a 'Pending' exception, which will cause the test to be marked as pending.
|
-- | Throws a 'Pending' exception, which will cause the test to be marked as pending.
|
||||||
pending :: (HasCallStack, MonadThrow m) => m a
|
pending :: (HasCallStack, MonadIO m) => m a
|
||||||
pending = throwIO $ Pending (Just callStack) Nothing
|
pending = throwIO $ Pending (Just callStack) Nothing
|
||||||
|
|
||||||
-- | Throws a 'Pending' exception with a message to add additional details.
|
-- | Throws a 'Pending' exception with a message to add additional details.
|
||||||
pendingWith :: (HasCallStack, MonadThrow m) => String -> m a
|
pendingWith :: (HasCallStack, MonadIO m) => String -> m a
|
||||||
pendingWith msg = throwIO $ Pending (Just callStack) (Just msg)
|
pendingWith msg = throwIO $ Pending (Just callStack) (Just msg)
|
||||||
|
|
||||||
-- | Shorthand for a pending test example. You can quickly mark an 'it' node as pending by putting an "x" in front of it.
|
-- | Shorthand for a pending test example. You can quickly mark an 'it' node as pending by putting an "x" in front of it.
|
||||||
xit :: (HasCallStack, MonadThrow m) => String -> ExampleT context m1 () -> SpecFree context m ()
|
xit :: (HasCallStack, MonadIO m) => String -> ExampleT context m1 () -> SpecFree context m ()
|
||||||
xit name _ex = it name (throwIO $ Pending (Just callStack) Nothing)
|
xit name _ex = it name (throwIO $ Pending (Just callStack) Nothing)
|
||||||
|
|
||||||
-- * Expecting failures
|
-- * Expecting failures
|
||||||
|
|
||||||
-- | Assert that a given action should fail with some 'FailureReason'.
|
-- | Assert that a given action should fail with some 'FailureReason'.
|
||||||
shouldFail :: (HasCallStack, MonadCatch m) => m () -> m ()
|
shouldFail :: (HasCallStack, MonadUnliftIO m) => m () -> m ()
|
||||||
shouldFail action = do
|
shouldFail action = do
|
||||||
try action >>= \case
|
try action >>= \case
|
||||||
Left (_ :: FailureReason) -> return ()
|
Left (_ :: FailureReason) -> return ()
|
||||||
Right () -> expectationFailure [i|Expected test to fail|]
|
Right () -> expectationFailure [i|Expected test to fail|]
|
||||||
|
|
||||||
-- | Assert that a given action should fail with some 'FailureReason' matching a predicate.
|
-- | Assert that a given action should fail with some 'FailureReason' matching a predicate.
|
||||||
shouldFailPredicate :: (HasCallStack, MonadCatch m) => (FailureReason -> Bool) -> m () -> m ()
|
shouldFailPredicate :: (HasCallStack, MonadUnliftIO m) => (FailureReason -> Bool) -> m () -> m ()
|
||||||
shouldFailPredicate p action = do
|
shouldFailPredicate p action = do
|
||||||
try action >>= \case
|
try action >>= \case
|
||||||
Left (err :: FailureReason) -> case p err of
|
Left (err :: FailureReason) -> case p err of
|
||||||
@ -48,7 +50,7 @@ shouldFailPredicate p action = do
|
|||||||
Right () -> expectationFailure [i|Expected test to fail, but it succeeded|]
|
Right () -> expectationFailure [i|Expected test to fail, but it succeeded|]
|
||||||
|
|
||||||
-- | Asserts that an action should throw an exception. Accepts a predicate to determine if the exception matches.
|
-- | Asserts that an action should throw an exception. Accepts a predicate to determine if the exception matches.
|
||||||
shouldThrow :: (HasCallStack, MonadCatch m, Exception e) =>
|
shouldThrow :: (HasCallStack, MonadUnliftIO m, Exception e) =>
|
||||||
m a
|
m a
|
||||||
-- ^ The action to run.
|
-- ^ The action to run.
|
||||||
-> (e -> Bool)
|
-> (e -> Bool)
|
||||||
@ -63,65 +65,65 @@ shouldThrow action f = do
|
|||||||
-- * Assertions
|
-- * Assertions
|
||||||
|
|
||||||
-- | Asserts that two things are equal.
|
-- | Asserts that two things are equal.
|
||||||
shouldBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
|
shouldBe :: (HasCallStack, MonadIO m, Eq a, Show a) => a -> a -> m ()
|
||||||
shouldBe x y
|
shouldBe x y
|
||||||
| x == y = return ()
|
| x == y = return ()
|
||||||
| otherwise = throwIO (ExpectedButGot (Just callStack) (SEB y) (SEB x))
|
| otherwise = throwIO (ExpectedButGot (Just callStack) (SEB y) (SEB x))
|
||||||
|
|
||||||
-- | Asserts that two things are not equal.
|
-- | Asserts that two things are not equal.
|
||||||
shouldNotBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()
|
shouldNotBe :: (HasCallStack, MonadIO m, Eq a, Show a) => a -> a -> m ()
|
||||||
shouldNotBe x y
|
shouldNotBe x y
|
||||||
| x /= y = return ()
|
| x /= y = return ()
|
||||||
| otherwise = throwIO (DidNotExpectButGot (Just callStack) (SEB y))
|
| otherwise = throwIO (DidNotExpectButGot (Just callStack) (SEB y))
|
||||||
|
|
||||||
-- | Asserts that the given list contains a subsequence.
|
-- | Asserts that the given list contains a subsequence.
|
||||||
shouldContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()
|
shouldContain :: (HasCallStack, MonadIO m, Eq a, Show a) => [a] -> [a] -> m ()
|
||||||
shouldContain haystack needle = case needle `L.isInfixOf` haystack of
|
shouldContain haystack needle = case needle `L.isInfixOf` haystack of
|
||||||
True -> return ()
|
True -> return ()
|
||||||
False -> expectationFailure [i|Expected #{show haystack} to contain #{show needle}|] -- TODO: custom exception type
|
False -> expectationFailure [i|Expected #{show haystack} to contain #{show needle}|] -- TODO: custom exception type
|
||||||
|
|
||||||
-- | Asserts that the given list contains an item matching a predicate.
|
-- | Asserts that the given list contains an item matching a predicate.
|
||||||
shouldContainPredicate :: (HasCallStack, MonadThrow m, Show a) => [a] -> (a -> Bool) -> m ()
|
shouldContainPredicate :: (HasCallStack, MonadIO m, Show a) => [a] -> (a -> Bool) -> m ()
|
||||||
shouldContainPredicate haystack p = case L.find p haystack of
|
shouldContainPredicate haystack p = case L.find p haystack of
|
||||||
Just _ -> return ()
|
Just _ -> return ()
|
||||||
Nothing -> expectationFailure [i|Expected #{show haystack} to contain an item matching the predicate|]
|
Nothing -> expectationFailure [i|Expected #{show haystack} to contain an item matching the predicate|]
|
||||||
|
|
||||||
-- | Asserts that the given list does not contain a subsequence.
|
-- | Asserts that the given list does not contain a subsequence.
|
||||||
shouldNotContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()
|
shouldNotContain :: (HasCallStack, MonadIO m, Eq a, Show a) => [a] -> [a] -> m ()
|
||||||
shouldNotContain haystack needle = case needle `L.isInfixOf` haystack of
|
shouldNotContain haystack needle = case needle `L.isInfixOf` haystack of
|
||||||
True -> expectationFailure [i|Expected #{show haystack} not to contain #{show needle}|]
|
True -> expectationFailure [i|Expected #{show haystack} not to contain #{show needle}|]
|
||||||
False -> return ()
|
False -> return ()
|
||||||
|
|
||||||
-- | Asserts that the given list contains an item matching a predicate.
|
-- | Asserts that the given list contains an item matching a predicate.
|
||||||
shouldNotContainPredicate :: (HasCallStack, MonadThrow m, Show a) => [a] -> (a -> Bool) -> m ()
|
shouldNotContainPredicate :: (HasCallStack, MonadIO m, Show a) => [a] -> (a -> Bool) -> m ()
|
||||||
shouldNotContainPredicate haystack p = case L.find p haystack of
|
shouldNotContainPredicate haystack p = case L.find p haystack of
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
Just _ -> expectationFailure [i|Expected #{show haystack} not to contain an item matching the predicate|]
|
Just _ -> expectationFailure [i|Expected #{show haystack} not to contain an item matching the predicate|]
|
||||||
|
|
||||||
-- | Asserts that the given 'Maybe' is 'Nothing'.
|
-- | Asserts that the given 'Maybe' is 'Nothing'.
|
||||||
shouldBeNothing :: (HasCallStack, MonadThrow m, Show a) => Maybe a -> m ()
|
shouldBeNothing :: (HasCallStack, MonadIO m, Show a) => Maybe a -> m ()
|
||||||
shouldBeNothing Nothing = return ()
|
shouldBeNothing Nothing = return ()
|
||||||
shouldBeNothing x = expectationFailure [i|Expected Nothing but got #{x}|]
|
shouldBeNothing x = expectationFailure [i|Expected Nothing but got #{x}|]
|
||||||
|
|
||||||
-- | Asserts that the given 'Maybe' is 'Just'.
|
-- | Asserts that the given 'Maybe' is 'Just'.
|
||||||
shouldBeJust :: (HasCallStack, MonadThrow m) => Maybe a -> m ()
|
shouldBeJust :: (HasCallStack, MonadIO m) => Maybe a -> m ()
|
||||||
shouldBeJust (Just _) = return ()
|
shouldBeJust (Just _) = return ()
|
||||||
shouldBeJust Nothing = expectationFailure [i|Expected Just but got Nothing.|]
|
shouldBeJust Nothing = expectationFailure [i|Expected Just but got Nothing.|]
|
||||||
|
|
||||||
-- | Asserts that the given 'Either' is 'Left'.
|
-- | Asserts that the given 'Either' is 'Left'.
|
||||||
shouldBeLeft :: (HasCallStack, MonadThrow m, Show a, Show b) => Either a b -> m ()
|
shouldBeLeft :: (HasCallStack, MonadIO m, Show a, Show b) => Either a b -> m ()
|
||||||
shouldBeLeft (Left _) = return ()
|
shouldBeLeft (Left _) = return ()
|
||||||
shouldBeLeft x = expectationFailure [i|Expected Left but got #{x}|]
|
shouldBeLeft x = expectationFailure [i|Expected Left but got #{x}|]
|
||||||
|
|
||||||
-- | Asserts that the given 'Either' is 'Right'.
|
-- | Asserts that the given 'Either' is 'Right'.
|
||||||
shouldBeRight :: (HasCallStack, MonadThrow m, Show a, Show b) => Either a b -> m ()
|
shouldBeRight :: (HasCallStack, MonadIO m, Show a, Show b) => Either a b -> m ()
|
||||||
shouldBeRight (Right _) = return ()
|
shouldBeRight (Right _) = return ()
|
||||||
shouldBeRight x = expectationFailure [i|Expected Right but got #{x}.|]
|
shouldBeRight x = expectationFailure [i|Expected Right but got #{x}.|]
|
||||||
|
|
||||||
-- | Asserts that the given text contains a substring.
|
-- | Asserts that the given text contains a substring.
|
||||||
textShouldContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()
|
textShouldContain :: (HasCallStack, MonadIO m) => T.Text -> T.Text -> m ()
|
||||||
t `textShouldContain` txt = ((T.unpack t) :: String) `shouldContain` (T.unpack txt)
|
t `textShouldContain` txt = ((T.unpack t) :: String) `shouldContain` (T.unpack txt)
|
||||||
|
|
||||||
-- | Asserts that the given text does not contain a substring.
|
-- | Asserts that the given text does not contain a substring.
|
||||||
textShouldNotContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()
|
textShouldNotContain :: (HasCallStack, MonadIO m) => T.Text -> T.Text -> m ()
|
||||||
t `textShouldNotContain` txt = ((T.unpack t) :: String) `shouldNotContain` (T.unpack txt)
|
t `textShouldNotContain` txt = ((T.unpack t) :: String) `shouldNotContain` (T.unpack txt)
|
||||||
|
@ -6,7 +6,7 @@ module Test.Sandwich.Formatters.Print.FailureReason (
|
|||||||
printFailureReason
|
printFailureReason
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import qualified Data.List as L
|
import qualified Data.List as L
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
|
@ -31,7 +31,7 @@ import Brick.Widgets.List
|
|||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger hiding (logError)
|
import Control.Monad.Logger hiding (logError)
|
||||||
|
@ -5,7 +5,7 @@ module Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget where
|
|||||||
|
|
||||||
import Brick
|
import Brick
|
||||||
import Brick.Widgets.Border
|
import Brick.Widgets.Border
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import qualified Data.List as L
|
import qualified Data.List as L
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
@ -22,7 +22,6 @@ module Test.Sandwich.Golden (
|
|||||||
, goldenFailFirstTime
|
, goldenFailFirstTime
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Free
|
import Control.Monad.Free
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
@ -37,6 +36,7 @@ import System.FilePath
|
|||||||
import Test.Sandwich
|
import Test.Sandwich
|
||||||
import Test.Sandwich.Golden.Update
|
import Test.Sandwich.Golden.Update
|
||||||
import Test.Sandwich.Types.Spec
|
import Test.Sandwich.Types.Spec
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
|
|
||||||
data Golden a = Golden {
|
data Golden a = Golden {
|
||||||
@ -90,7 +90,7 @@ goldenShowable = mkGolden (\f x -> writeFile f (show x)) ((read <$>) . readFile)
|
|||||||
|
|
||||||
-- | Runs a Golden test.
|
-- | Runs a Golden test.
|
||||||
|
|
||||||
golden :: (MonadIO m, MonadThrow m, Eq str, Show str) => Golden str -> Free (SpecCommand context m) ()
|
golden :: (MonadIO m, Eq str, Show str) => Golden str -> Free (SpecCommand context m) ()
|
||||||
golden (Golden {..}) = it goldenName $ do
|
golden (Golden {..}) = it goldenName $ do
|
||||||
let goldenTestDir = takeDirectory goldenFile
|
let goldenTestDir = takeDirectory goldenFile
|
||||||
liftIO $ createDirectoryIfMissing True goldenTestDir
|
liftIO $ createDirectoryIfMissing True goldenTestDir
|
||||||
|
@ -6,13 +6,13 @@ module Test.Sandwich.Golden.Update (
|
|||||||
, defaultDirGoldenTest
|
, defaultDirGoldenTest
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import System.Console.ANSI
|
import System.Console.ANSI
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.Environment
|
import System.Environment
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
|
|
||||||
defaultDirGoldenTest :: FilePath
|
defaultDirGoldenTest :: FilePath
|
||||||
|
@ -11,7 +11,7 @@ module Test.Sandwich.Interpreters.StartTree (
|
|||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
|
@ -22,14 +22,12 @@ module Test.Sandwich.Logging (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Concurrent.Async.Lifted hiding (wait)
|
|
||||||
import Control.DeepSeq (rnf)
|
import Control.DeepSeq (rnf)
|
||||||
import qualified Control.Exception as C
|
import qualified Control.Exception as C
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Logger hiding (logOther)
|
import Control.Monad.Logger hiding (logOther)
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import Data.Text
|
import Data.Text
|
||||||
import Foreign.C.Error
|
import Foreign.C.Error
|
||||||
@ -38,6 +36,8 @@ import GHC.Stack
|
|||||||
import System.IO
|
import System.IO
|
||||||
import System.IO.Error (mkIOError)
|
import System.IO.Error (mkIOError)
|
||||||
import System.Process
|
import System.Process
|
||||||
|
import UnliftIO.Async hiding (wait)
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,13,0)
|
#if !MIN_VERSION_base(4,13,0)
|
||||||
import Control.Monad.Fail
|
import Control.Monad.Fail
|
||||||
@ -74,11 +74,11 @@ logOther = logOtherCS callStack
|
|||||||
|
|
||||||
-- | Spawn a process with its stdout and stderr connected to the logging system.
|
-- | Spawn a process with its stdout and stderr connected to the logging system.
|
||||||
-- Every line output by the process will be fed to a 'debug' call.
|
-- Every line output by the process will be fed to a 'debug' call.
|
||||||
createProcessWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> m ProcessHandle
|
createProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> m ProcessHandle
|
||||||
createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)
|
createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)
|
||||||
|
|
||||||
-- | Spawn a process with its stdout and stderr connected to the logging system.
|
-- | Spawn a process with its stdout and stderr connected to the logging system.
|
||||||
createProcessWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle
|
createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle
|
||||||
createProcessWithLogging' logLevel cp = do
|
createProcessWithLogging' logLevel cp = do
|
||||||
(hRead, hWrite) <- liftIO createPipe
|
(hRead, hWrite) <- liftIO createPipe
|
||||||
|
|
||||||
@ -95,11 +95,11 @@ createProcessWithLogging' logLevel cp = do
|
|||||||
|
|
||||||
-- | Like 'readCreateProcess', but capture the stderr output in the logs.
|
-- | Like 'readCreateProcess', but capture the stderr output in the logs.
|
||||||
-- Every line output by the process will be fed to a 'debug' call.
|
-- Every line output by the process will be fed to a 'debug' call.
|
||||||
readCreateProcessWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m String
|
readCreateProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> String -> m String
|
||||||
readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)
|
readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)
|
||||||
|
|
||||||
-- | Like 'readCreateProcess', but capture the stderr output in the logs.
|
-- | Like 'readCreateProcess', but capture the stderr output in the logs.
|
||||||
readCreateProcessWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String
|
readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String
|
||||||
readCreateProcessWithLogging' logLevel cp input = do
|
readCreateProcessWithLogging' logLevel cp input = do
|
||||||
(hReadErr, hWriteErr) <- liftIO createPipe
|
(hReadErr, hWriteErr) <- liftIO createPipe
|
||||||
|
|
||||||
@ -131,8 +131,8 @@ readCreateProcessWithLogging' logLevel cp input = do
|
|||||||
-- wait on the process
|
-- wait on the process
|
||||||
ex <- waitForProcess p
|
ex <- waitForProcess p
|
||||||
return (ex, output)
|
return (ex, output)
|
||||||
(Nothing, _) -> liftIO $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."
|
(Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."
|
||||||
(_, Nothing) -> liftIO $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."
|
(_, Nothing) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."
|
||||||
|
|
||||||
case ex of
|
case ex of
|
||||||
ExitSuccess -> return output
|
ExitSuccess -> return output
|
||||||
@ -149,11 +149,11 @@ readCreateProcessWithLogging' logLevel cp input = do
|
|||||||
|
|
||||||
-- | Spawn a process with its stdout and stderr connected to the logging system.
|
-- | Spawn a process with its stdout and stderr connected to the logging system.
|
||||||
-- Every line output by the process will be fed to a 'debug' call.
|
-- Every line output by the process will be fed to a 'debug' call.
|
||||||
createProcessWithLoggingAndStdin :: (HasCallStack, MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle
|
createProcessWithLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle
|
||||||
createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)
|
createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)
|
||||||
|
|
||||||
-- | Spawn a process with its stdout and stderr connected to the logging system.
|
-- | Spawn a process with its stdout and stderr connected to the logging system.
|
||||||
createProcessWithLoggingAndStdin' :: (HasCallStack, MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
|
createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle
|
||||||
createProcessWithLoggingAndStdin' logLevel cp input = do
|
createProcessWithLoggingAndStdin' logLevel cp input = do
|
||||||
(hRead, hWrite) <- liftIO createPipe
|
(hRead, hWrite) <- liftIO createPipe
|
||||||
|
|
||||||
@ -179,11 +179,11 @@ createProcessWithLoggingAndStdin' logLevel cp input = do
|
|||||||
return p
|
return p
|
||||||
|
|
||||||
-- | Higher level version of 'createProcessWithLogging', accepting a shell command.
|
-- | Higher level version of 'createProcessWithLogging', accepting a shell command.
|
||||||
callCommandWithLogging :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
|
callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => String -> m ()
|
||||||
callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)
|
callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)
|
||||||
|
|
||||||
-- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
|
-- | Higher level version of 'createProcessWithLogging'', accepting a shell command.
|
||||||
callCommandWithLogging' :: (HasCallStack, MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()
|
callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> String -> m ()
|
||||||
callCommandWithLogging' logLevel cmd = do
|
callCommandWithLogging' logLevel cmd = do
|
||||||
(hRead, hWrite) <- liftIO createPipe
|
(hRead, hWrite) <- liftIO createPipe
|
||||||
|
|
||||||
@ -199,7 +199,7 @@ callCommandWithLogging' logLevel cmd = do
|
|||||||
|
|
||||||
liftIO (waitForProcess p) >>= \case
|
liftIO (waitForProcess p) >>= \case
|
||||||
ExitSuccess -> return ()
|
ExitSuccess -> return ()
|
||||||
ExitFailure r -> liftIO $ throw $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
|
ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]
|
||||||
|
|
||||||
|
|
||||||
-- * Util
|
-- * Util
|
||||||
|
@ -1,8 +1,8 @@
|
|||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE ConstraintKinds #-}
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
-- | Wrapper around 'parallel' for limiting the threads using a semaphore.
|
-- | Wrapper around 'parallel' for limiting the threads using a semaphore.
|
||||||
|
|
||||||
@ -20,24 +20,25 @@ module Test.Sandwich.ParallelN (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Concurrent.QSem
|
import Control.Concurrent.QSem
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import Test.Sandwich.Contexts
|
import Test.Sandwich.Contexts
|
||||||
import Test.Sandwich.Types.ArgParsing
|
import Test.Sandwich.Types.ArgParsing
|
||||||
import Test.Sandwich.Types.RunTree
|
import Test.Sandwich.Types.RunTree
|
||||||
import Test.Sandwich.Types.Spec
|
import Test.Sandwich.Types.Spec
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
-- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads.
|
-- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads.
|
||||||
parallelN :: (
|
parallelN :: (
|
||||||
MonadIO m, MonadMask m
|
MonadUnliftIO m
|
||||||
) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
|
) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
|
||||||
parallelN = parallelN' defaultParallelNodeOptions
|
parallelN = parallelN' defaultParallelNodeOptions
|
||||||
|
|
||||||
parallelN' :: (
|
parallelN' :: (
|
||||||
MonadIO m, MonadMask m
|
MonadUnliftIO m
|
||||||
) => NodeOptions -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
|
) => NodeOptions -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
|
||||||
parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $
|
parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $
|
||||||
parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children
|
parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children
|
||||||
@ -47,12 +48,12 @@ parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" par
|
|||||||
|
|
||||||
-- | Same as 'parallelN', but extracts the semaphore size from the command line options.
|
-- | Same as 'parallelN', but extracts the semaphore size from the command line options.
|
||||||
parallelNFromArgs :: forall context a m. (
|
parallelNFromArgs :: forall context a m. (
|
||||||
MonadIO m, MonadMask m, HasCommandLineOptions context a
|
MonadUnliftIO m, HasCommandLineOptions context a
|
||||||
) => (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
|
) => (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
|
||||||
parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions
|
parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions
|
||||||
|
|
||||||
parallelNFromArgs' :: forall context a m. (
|
parallelNFromArgs' :: forall context a m. (
|
||||||
MonadIO m, MonadMask m, HasCommandLineOptions context a
|
MonadUnliftIO m, HasCommandLineOptions context a
|
||||||
) => NodeOptions -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
|
) => NodeOptions -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()
|
||||||
parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $
|
parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $
|
||||||
parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children
|
parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children
|
||||||
|
@ -6,8 +6,8 @@
|
|||||||
module Test.Sandwich.TestTimer where
|
module Test.Sandwich.TestTimer where
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.State
|
import Control.Monad.Trans.State
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
@ -26,6 +26,7 @@ import Test.Sandwich.Types.RunTree
|
|||||||
import Test.Sandwich.Types.Spec
|
import Test.Sandwich.Types.Spec
|
||||||
import Test.Sandwich.Types.TestTimer
|
import Test.Sandwich.Types.TestTimer
|
||||||
import Test.Sandwich.Util (whenJust)
|
import Test.Sandwich.Util (whenJust)
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
|
|
||||||
type EventName = T.Text
|
type EventName = T.Text
|
||||||
@ -34,14 +35,14 @@ type ProfileName = T.Text
|
|||||||
-- * User functions
|
-- * User functions
|
||||||
|
|
||||||
-- | Time a given action with a given event name. This name will be the "stack frame" of the given action in the profiling results. This function will use the current timing profile name.
|
-- | Time a given action with a given event name. This name will be the "stack frame" of the given action in the profiling results. This function will use the current timing profile name.
|
||||||
timeAction :: (MonadMask m, MonadIO m, MonadReader context m, HasBaseContext context, HasTestTimer context) => EventName -> m a -> m a
|
timeAction :: (MonadUnliftIO m, MonadReader context m, HasBaseContext context, HasTestTimer context) => EventName -> m a -> m a
|
||||||
timeAction eventName action = do
|
timeAction eventName action = do
|
||||||
tt <- asks getTestTimer
|
tt <- asks getTestTimer
|
||||||
BaseContext {baseContextTestTimerProfile} <- asks getBaseContext
|
BaseContext {baseContextTestTimerProfile} <- asks getBaseContext
|
||||||
timeAction' tt baseContextTestTimerProfile eventName action
|
timeAction' tt baseContextTestTimerProfile eventName action
|
||||||
|
|
||||||
-- | Time a given action with a given profile name and event name. Use when you want to manually specify the profile name.
|
-- | Time a given action with a given profile name and event name. Use when you want to manually specify the profile name.
|
||||||
timeActionByProfile :: (MonadMask m, MonadIO m, MonadReader context m, HasTestTimer context) => ProfileName -> EventName -> m a -> m a
|
timeActionByProfile :: (MonadUnliftIO m, MonadReader context m, HasTestTimer context) => ProfileName -> EventName -> m a -> m a
|
||||||
timeActionByProfile profileName eventName action = do
|
timeActionByProfile profileName eventName action = do
|
||||||
tt <- asks getTestTimer
|
tt <- asks getTestTimer
|
||||||
timeAction' tt profileName eventName action
|
timeAction' tt profileName eventName action
|
||||||
@ -81,7 +82,7 @@ finalizeSpeedScopeTestTimer (SpeedScopeTestTimer {..}) = do
|
|||||||
whenJust testTimerHandle hClose
|
whenJust testTimerHandle hClose
|
||||||
readMVar testTimerSpeedScopeFile >>= BL.writeFile (testTimerBasePath </> "speedscope.json") . A.encode
|
readMVar testTimerSpeedScopeFile >>= BL.writeFile (testTimerBasePath </> "speedscope.json") . A.encode
|
||||||
|
|
||||||
timeAction' :: (MonadMask m, MonadIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a
|
timeAction' :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a
|
||||||
timeAction' NullTestTimer _ _ = id
|
timeAction' NullTestTimer _ _ = id
|
||||||
timeAction' (SpeedScopeTestTimer {..}) profileName eventName = bracket_
|
timeAction' (SpeedScopeTestTimer {..}) profileName eventName = bracket_
|
||||||
(liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do
|
(liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do
|
||||||
|
@ -20,8 +20,8 @@
|
|||||||
module Test.Sandwich.Types.Spec where
|
module Test.Sandwich.Types.Spec where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Exception.Safe
|
|
||||||
import Control.Monad.Base
|
import Control.Monad.Base
|
||||||
|
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
|
||||||
import Control.Monad.Free
|
import Control.Monad.Free
|
||||||
import Control.Monad.Free.TH
|
import Control.Monad.Free.TH
|
||||||
import Control.Monad.IO.Unlift
|
import Control.Monad.IO.Unlift
|
||||||
@ -37,6 +37,7 @@ import GHC.Stack
|
|||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
import Graphics.Vty.Image (Image)
|
import Graphics.Vty.Image (Image)
|
||||||
import Safe
|
import Safe
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,13,0)
|
#if !MIN_VERSION_base(4,13,0)
|
||||||
import Control.Monad.Fail
|
import Control.Monad.Fail
|
||||||
@ -70,7 +71,7 @@ instance (MonadBaseControl b m) => MonadBaseControl b (ExampleT context m) where
|
|||||||
liftBaseWith = defaultLiftBaseWith
|
liftBaseWith = defaultLiftBaseWith
|
||||||
restoreM = defaultRestoreM
|
restoreM = defaultRestoreM
|
||||||
|
|
||||||
instance (Monad m, MonadThrow m) => MonadFail (ExampleT context m) where
|
instance (MonadIO m) => MonadFail (ExampleT context m) where
|
||||||
fail :: (HasCallStack) => String -> ExampleT context m a
|
fail :: (HasCallStack) => String -> ExampleT context m a
|
||||||
fail = throwIO . Reason (Just callStack)
|
fail = throwIO . Reason (Just callStack)
|
||||||
|
|
||||||
|
@ -4,7 +4,7 @@ module Around where
|
|||||||
|
|
||||||
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Writer
|
import Control.Monad.Trans.Writer
|
||||||
|
@ -2,7 +2,7 @@
|
|||||||
|
|
||||||
module Before where
|
module Before where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Writer
|
import Control.Monad.Trans.Writer
|
||||||
import qualified Data.List as L
|
import qualified Data.List as L
|
||||||
|
@ -2,7 +2,7 @@
|
|||||||
|
|
||||||
module Describe where
|
module Describe where
|
||||||
|
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Writer
|
import Control.Monad.Trans.Writer
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
|
@ -6,7 +6,7 @@ module Introduce where
|
|||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.Writer
|
import Control.Monad.Trans.Writer
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
|
@ -3,7 +3,7 @@
|
|||||||
module TestUtil where
|
module TestUtil where
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Exception.Safe
|
import UnliftIO.Exception
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
import Control.Monad.Trans.Writer
|
import Control.Monad.Trans.Writer
|
||||||
|
Loading…
Reference in New Issue
Block a user