Move things around and introduce sandwich-webdriver

sandwich-webdriver/.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

sandwich-webdriver/ChangeLog.md

@@ -0,0 +1,3 @@
+# Changelog for sandwich-webdriver
+
+## Unreleased changes

sandwich-webdriver/README.md

@@ -0,0 +1 @@
+# sandwich-webdriver

sandwich-webdriver/app/Main.hs

@@ -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

sandwich-webdriver/package.yaml

@@ -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

sandwich-webdriver/sandwich-webdriver.cabal

@@ -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

sandwich-webdriver/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

sandwich-webdriver/src/Test/Sandwich/WebDriver.hs

@@ -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

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Action.hs

@@ -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 []

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs

@@ -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}|]) ""

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs

@@ -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

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Exceptions.hs

@@ -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

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs

@@ -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)

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Screenshots.hs

@@ -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|])

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs

@@ -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 }

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Util.hs

@@ -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

sandwich-webdriver/stack.yaml

@@ -0,0 +1,10 @@
+
+resolver: lts-16.1
+
+packages:
+- .
+- ../sandwich
+
+extra-deps:
+- git: https://github.com/codedownio/hs-webdriver
+  commit: 8bc94c291838d6d4152138cf4ab94d1db6f8da7e

sandwich-webdriver/stack.yaml.lock

@@ -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

sandwich-webdriver/test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"

sandwich/LICENSE

@@ -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.

sandwich/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

sandwich/app/Main.hs

@@ -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

sandwich/package.yaml

@@ -32,6 +32,7 @@ dependencies:
 - interpolate
 - microlens
 - microlens-th
+- monad-control
 - monad-logger
 - mtl
 - random

sandwich/sandwich.cabal

@@ -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

sandwich/src/Test/Sandwich.hs

@@ -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
 

sandwich/src/Test/Sandwich/Contexts.hs

@@ -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

sandwich/src/Test/Sandwich/Types/Spec.hs

@@ -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

sandwich/stack.yaml

@@ -0,0 +1,7 @@
+
+resolver: lts-16.1
+
+packages:
+- .
+
+extra-deps: []

sandwich/stack.yaml.lock

@@ -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

src/Test/Sandwich/Contexts.hs

@@ -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

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

stack.yaml.lock

@@ -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