packages feed

sandwich-contexts (empty) → 0.3.0.0

raw patch · 21 files changed

+2351/−0 lines, 21 filesdep +HTTPdep +aesondep +base

Dependencies added: HTTP, aeson, base, conduit, conduit-extra, connection, containers, crypton-connection, data-default, exceptions, filepath, http-client, http-conduit, http-types, monad-logger, mtl, network, postgresql-simple, process, random, relude, retry, safe, sandwich, sandwich-contexts, streaming-commons, string-interpolate, temporary, text, time, transformers, unix-compat, unliftio, unliftio-core, vector

Files

+ lib/Test/Sandwich/Contexts/Container.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}++{-|+Helper module for working with containers.+-}++module Test.Sandwich.Contexts.Container (+  ContainerSystem (..)+  , waitForHealth++  -- * Container/host conversions+  , containerPortToHostPort+  , containerNameToContainerId++  -- * Misc+  , isInContainer+  ) where++import Control.Monad.Catch+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.Aeson as A+import Data.Aeson.TH as A+import qualified Data.List as L+import qualified Data.Map as M+import Data.String.Interpolate+import qualified Data.Text as T+import Network.Socket (PortNumber)+import Relude+import Safe+import System.Exit+import Test.Sandwich+import qualified Text.Show+import UnliftIO.Process+++-- | Type to represent which container system we're using.+data ContainerSystem = ContainerSystemDocker | ContainerSystemPodman+  deriving (Eq)++instance Show ContainerSystem where+  show ContainerSystemDocker = "docker"+  show ContainerSystemPodman = "podman"++-- | Test if the test process is currently running in a container.+isInContainer :: MonadIO m => m Bool+isInContainer = do+  output <- toText <$> readCreateProcess (shell "cat /proc/1/sched | head -n 1") ""+  return $ not $+    ("init" `T.isInfixOf` output)+    || ("systemd" `T.isInfixOf` output)+    || ("bwrap" `T.isInfixOf` output)++-- | Wait for a container to be in a healthy state.+waitForHealth :: forall m. (HasCallStack, MonadLoggerIO m, MonadMask m) => ContainerSystem -> Text -> m ()+waitForHealth containerSystem containerID = do+  let policy = limitRetriesByCumulativeDelay (60 * 1_000_000) $ capDelay 1_000_000 $ exponentialBackoff 1000+  recoverAll policy $ \_ -> do+    health <- (T.strip . toText) <$> (readCreateProcess (+      shell [i|#{containerSystem} inspect --format "{{json .State.Health.Status }}" #{containerID}|]) ""+      )++    case health of+      "\"healthy\"" -> return ()+      _ -> do+        -- Try running the health check manually, when possible.+        -- This is a workaround for rootless podman failing to have working healthchecks.+        when (containerSystem == ContainerSystemPodman) $ do+          -- TODO: use createProcessWithLogging here?+          (exitCode, sout, serr) <- readCreateProcessWithExitCode (proc "podman" ["healthcheck", "run", toString containerID]) ""+          when (exitCode /= ExitSuccess) $ do+            warn [i|Failed to manually run healthcheck. Code: #{exitCode}. Stdout: '#{sout}'. Stderr: '#{serr}'.|]++        expectationFailure [i|Health was: #{health}|]+++data HostPortInfo = HostPortInfo {+  hostPortInfoHostIp :: Text+  , hostPortInfoHostPort :: Text+  }+deriveJSON (A.defaultOptions { A.fieldLabelModifier = L.drop (L.length ("hostPortInfo" :: String)) }) ''HostPortInfo++-- | Map a port number inside a container to a port number on the host.+containerPortToHostPort :: (HasCallStack, MonadIO m) => ContainerSystem -> Text -> PortNumber -> m PortNumber+containerPortToHostPort containerSystem containerName containerPort = do+  let inspectPortCmd = [i|#{containerSystem} inspect --format='{{json .NetworkSettings.Ports}}' #{containerName}|]++  rawNetworkSettings <- liftIO (readCreateProcessWithExitCode (shell inspectPortCmd) "") >>= \case+    (ExitSuccess, sout, _serr) -> return $ T.strip $ toText sout+    (ExitFailure n, sout, serr) -> expectationFailure [i|Failed to read container ports (error code #{n}). Stdout: '#{sout}'. Stderr: '#{serr}'.|]++  networkSettings :: Map Text [HostPortInfo] <- case A.eitherDecode (encodeUtf8 rawNetworkSettings) of+    Left err -> expectationFailure [i|Failed to decode network settings: #{err}. Settings were #{rawNetworkSettings}.|]+    Right x -> pure x++  rawPort <- case M.lookup [i|#{containerPort}/tcp|] networkSettings of+    Just (x:_) -> pure $ hostPortInfoHostPort x+    _ -> expectationFailure [i|Couldn't find any host ports corresponding to container port #{containerPort}. Network settings: #{A.encode networkSettings}|]++  case readMay (toString rawPort) of+    Just x -> pure x+    Nothing -> expectationFailure [i|Couldn't read container port number: '#{rawPort}'|]++-- | Convert a container name to a container ID.+containerNameToContainerId :: (HasCallStack, MonadIO m) => ContainerSystem -> Text -> m Text+containerNameToContainerId containerSystem containerName = do+  let cmd = [i|#{containerSystem} inspect --format='{{.Id}}' #{containerName}|]+  liftIO (readCreateProcessWithExitCode (shell cmd) "") >>= \case+    (ExitSuccess, sout, _serr) -> return $ T.strip $ toText sout+    (ExitFailure n, sout, serr) -> expectationFailure [i|Failed to obtain container ID for container named '#{containerName}'. Code: #{n}. Stdout: '#{sout}'. Stderr: '#{serr}'.|]
+ lib/Test/Sandwich/Contexts/FakeSmtpServer.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++{-|++This module provides functions for introducing a mock SMTP server, represented by 'FakeSmtpServer'.++If you send emails to this server, you can read them out to confirm they were received correctly.++-}++module Test.Sandwich.Contexts.FakeSmtpServer (+  -- * Introduce a fake SMTP server+  introduceFakeSmtpServerNix+  , introduceFakeSmtpServerNix'+  , introduceFakeSmtpServer++  -- * Bracket-style version+  , withFakeSMTPServer++  -- * Nix derivation+  , fakeSmtpServerDerivation++  -- * Types+  , fakeSmtpServer+  , FakeSmtpServerOptions(..)+  , defaultFakeSmtpServerOptions+  , FakeSmtpServer(..)+  , EmailInfo(..)+  ) where++import Control.Monad+import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Retry+import qualified Data.Aeson as A+import qualified Data.Aeson.TH as A+import Data.String.Interpolate+import GHC.TypeLits+import Network.HTTP.Client+import Network.Socket (PortNumber)+import Relude+import System.FilePath+import System.IO+import System.Process+import Test.Sandwich+import Test.Sandwich.Contexts.FakeSmtpServer.Derivation+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.HttpWaits+import Test.Sandwich.Contexts.Nix+import Test.Sandwich.Contexts.Util.Aeson+import UnliftIO.Directory+import UnliftIO.Exception+++-- * Types++data FakeSmtpServerOptions = FakeSmtpServerOptions {+  -- | Username and password. If not provided, the server will not be configured with authentication.+  fakeSmtpServerAuth :: Maybe (String, String)+  -- | Whether to allow insecure login.+  , fakeSmtpServerAllowInsecureLogin :: Bool+  } deriving (Show, Eq)++defaultFakeSmtpServerOptions :: FakeSmtpServerOptions+defaultFakeSmtpServerOptions = FakeSmtpServerOptions {+  fakeSmtpServerAuth = Just ("user", "password")+  , fakeSmtpServerAllowInsecureLogin = True+  }++-- | An email, as received by the server.+data EmailInfo = EmailInfo {+  emailInfoAttachments :: A.Value+  , emailInfoText :: Text+  , emailInfoTextAsHtml :: Text+  , emailInfoSubject :: Text+  , emailInfoDate :: Maybe Text+  , emailInfoTo :: A.Value+  , emailInfoFrom :: A.Value+  , emailInfoMessageId :: Maybe Text+  , emailInfoHtml :: Text+  } deriving (Show, Eq)+-- These Aeson options need to match the return values from fake_smtp_server+$(A.deriveJSON (A.defaultOptions { A.fieldLabelModifier = dropNAndCamelCase (length ("emailInfo" :: String)) }) ''EmailInfo)++data FakeSmtpServer = FakeSmtpServer {+  -- | The port on which the fake SMTP server is running.+  fakeSmtpServerSmtpPort :: PortNumber+  -- | Callback to retrieve the emails the server has received.+  , fakeSmtpServerGetEmails :: forall m. (MonadLoggerIO m, MonadUnliftIO m, MonadThrow m) => m [EmailInfo]+  }++fakeSmtpServer :: Label "fakeSmtpServer" FakeSmtpServer+fakeSmtpServer = Label++-- * Functions++type BaseMonad context m = (HasBaseContext context, MonadMask m, MonadUnliftIO m)++type FakeSmtpServerContext context =+  LabelValue "fakeSmtpServer" FakeSmtpServer+  :> LabelValue (AppendSymbol "file-" "fake-smtp-server") (EnvironmentFile "fake-smtp-server")+  :> context++-- | Introduce a fake SMTP server using a Nix derivation hardcoded into this package as 'fakeSmtpServerDerivation'.+introduceFakeSmtpServerNix :: (+  BaseMonad context m, HasNixContext context+  )+  -- | Options+  => FakeSmtpServerOptions+  -- | Child spec+  -> SpecFree (FakeSmtpServerContext context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceFakeSmtpServerNix = introduceFakeSmtpServerNix' fakeSmtpServerDerivation++-- | Same as 'introduceFakeSmtpServerNix', but allows you to specify the derivation.+introduceFakeSmtpServerNix' :: (+  BaseMonad context m, HasNixContext context+  )+  -- | Nix derivation+  => Text+  -- | Options+  -> FakeSmtpServerOptions+  -- | Child spec+  -> SpecFree (FakeSmtpServerContext context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceFakeSmtpServerNix' derivation options =+  introduceBinaryViaNixDerivation @"fake-smtp-server" derivation . introduceFakeSmtpServer options++-- | Introduce a fake SMTP server given a binary already available via 'HasFile'.+introduceFakeSmtpServer :: (+  BaseMonad context m, HasFile context "fake-smtp-server"+  )+  -- | Options+  => FakeSmtpServerOptions+  -> SpecFree (LabelValue "fakeSmtpServer" FakeSmtpServer :> context) m ()+  -> SpecFree context m ()+introduceFakeSmtpServer options = introduceWith "fake SMTP server" fakeSmtpServer (withFakeSMTPServer options)++-- | Bracket-style version of 'introduceFakeSmtpServer'.+withFakeSMTPServer :: (+  BaseMonad context m, MonadReader context m, MonadLoggerIO m, HasFile context "fake-smtp-server"+  )+  -- | Options+  => FakeSmtpServerOptions+  -> (FakeSmtpServer -> m [Result])+  -> m ()+withFakeSMTPServer (FakeSmtpServerOptions {..}) action = do+  folder <- getCurrentFolder >>= \case+    Nothing -> expectationFailure "withFakeSMTPServer must be run with a run root"+    Just x -> return x++  let httpPortFile = folder </> "http-port-file"+  let smtpPortFile = folder </> "smtp-port-file"++  fakeSmtpServerPath <- askFile @"fake-smtp-server"++  bracket (do+              let authFlag = case fakeSmtpServerAuth of+                    Just (username, password) -> ["--auth",  [i|#{username}:#{password}|]]+                    Nothing -> []+              let insecureLoginFlag = if fakeSmtpServerAllowInsecureLogin then "--allow-insecure-login" else ""+              createProcessWithLogging ((proc fakeSmtpServerPath ([insecureLoginFlag+                                                                  , "--smtp-port", "0"+                                                                  , "--smtp-port-file", smtpPortFile+                                                                  , "--http-port", "0"+                                                                  , "--http-port-file", httpPortFile+                                                                  ] <> authFlag)) {+                                           create_group = True+                                           })+          )+          (\p -> do+              void $ liftIO (interruptProcessGroupOf p >> waitForProcess p)+          )+          (\_ -> do+              httpPort <- waitForPortFile 120.0 httpPortFile+              smtpPort <- waitForPortFile 120.0 smtpPortFile++              let authPart = case fakeSmtpServerAuth of+                    Just (username, password) -> [i|#{username}:#{password}@|] :: Text+                    Nothing -> ""++              waitUntilStatusCodeWithTimeout (2, 0, 0) (1_000_000 * 60 * 2) YesVerify [i|http://#{authPart}localhost:#{httpPort}/api/emails|]++              manager <- liftIO $ newManager defaultManagerSettings+              void $ action $ FakeSmtpServer smtpPort (getEmails manager authPart httpPort)+          )+++waitForPortFile :: (MonadLoggerIO m) => Double -> FilePath -> m PortNumber+waitForPortFile timeoutSeconds path = do+  let policy = limitRetriesByCumulativeDelay (round (timeoutSeconds * 1_000_000)) $ capDelay 1_000_000 $ exponentialBackoff 1000+  liftIO $ recoverAll policy $ \(RetryStatus {}) -> do+    unlessM (doesPathExist path) $+      expectationFailure [i|Port file '#{path}' didn't exist yet.|]++    contents <- System.IO.readFile path+    case readMaybe contents of+      Nothing -> expectationFailure [i|Couldn't read port number: '#{contents}'|]+      Just n -> pure n++getEmails :: (+  MonadLoggerIO m, MonadUnliftIO m, MonadThrow m+  ) => Manager -> Text -> PortNumber -> m [EmailInfo]+getEmails manager authPart httpPort = do+  req <- liftIO $ parseRequest [i|http://#{authPart}localhost:#{httpPort}/api/emails|]+  try (liftIO $ httpLbs req manager) >>= \case+    Left (err :: HttpException) -> expectationFailure [i|Failed to fetch emails: #{err}|]+    Right response ->+      case A.eitherDecode (responseBody response) of+        Left err -> expectationFailure [i|Couldn't decode emails: '#{err}'. Response body  '#{responseBody response}'. Response: '#{response}'.|]+        Right (emails :: [EmailInfo]) -> return emails
+ lib/Test/Sandwich/Contexts/FakeSmtpServer/Derivation.hs view
@@ -0,0 +1,50 @@++module Test.Sandwich.Contexts.FakeSmtpServer.Derivation (+  fakeSmtpServerDerivation+  ) where++import Data.String.Interpolate+import Relude+++-- | A Nix derivation to build a fake Node.js SMTP server, based on+-- https://github.com/ReachFive/fake-smtp-server.+fakeSmtpServerDerivation :: Text+fakeSmtpServerDerivation = [i|+{ callPackage+, fetchFromGitHub+, node2nix+, nodejs_18+, stdenv+}:++let++  nixified = stdenv.mkDerivation {+    pname = "fake-smtp-server";+    version = "0.8.1";++    src = fetchFromGitHub {+      owner = "codedownio";+      repo = "fake-smtp-server";+      rev = "1adbffb35d6c90bcb2ad9fac3049fa2028a34d2f";+      sha256 = "sha256-zXaNM7sp2c3IEvmoZ81M+7LrcC1I0JhlqG0A+gOA38E=";+    };++    dontConfigure = true;++    buildInputs = [node2nix];++    buildPhase = ''+      node2nix -- --nodejs-18 --lock package-lock.json+    '';++    installPhase = ''+      cp -r ./. $out+    '';+  };++in++(callPackage nixified { nodejs = nodejs_18; }).package+|]
+ lib/Test/Sandwich/Contexts/Files.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-|++This module contains tools for introducing files and making them available to tests. It uses type-level strings, and is mostly intended to be used with -XTypeApplications.++For example:++@+introduceFile \@"grep" "\/path\/to\/grep" $ do+  it "uses grep for something" $ do+    grep <- askFile \@"grep"+    results <- readCreateProcess (proc grep ["foo"]) ""+    todo -- Do something with results+@++For reproducibility, you can leverage a 'NixContext' that's already been introduced to introduce binaries, either by specifying a Nixpkgs package name or by writing out a full derivation.++-}++module Test.Sandwich.Contexts.Files (+  -- * Introduce a file directly+  introduceFile+  , introduceFile'++  -- * Introduce a binary from the environment+  , introduceBinaryViaEnvironment+  , introduceBinaryViaEnvironment'++  -- * Introduce a binary from a Nix package+  , introduceBinaryViaNixPackage+  , introduceBinaryViaNixPackage'+  , getBinaryViaNixPackage+  , getBinaryViaNixPackage'++  -- * Introduce file from a Nix package+  , introduceFileViaNixPackage+  , introduceFileViaNixPackage'+  , introduceFileViaNixPackage''+  , getFileViaNixPackage++  -- * Introduce a binary from a Nix derivation+  , introduceBinaryViaNixDerivation+  , introduceBinaryViaNixDerivation'+  , getBinaryViaNixDerivation+  , getBinaryViaNixDerivation'++  -- * Introduce a file from a Nix derivation+  , introduceFileViaNixDerivation+  , introduceFileViaNixDerivation'+  , introduceFileViaNixDerivation''+  , getFileViaNixDerivation++  -- * Get a file+  , askFile+  , askFile'++  -- * Helpers for file-finding callbacks+  , defaultFindFile+  , findFirstFile++  -- * Low-level+  , mkFileLabel+  , defaultFileContextVisibilityThreshold++  -- * Types+  , EnvironmentFile(..)+  , HasFile+  , FileValue+  ) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Trans.Except+import Data.String.Interpolate+import GHC.TypeLits+import Relude+import System.FilePath+import Test.Sandwich+import Test.Sandwich.Contexts.Files.Types+import Test.Sandwich.Contexts.Nix+import UnliftIO.Directory+++-- | Introduce a file by providing its path.+introduceFile :: forall a context m. (+  MonadUnliftIO m, KnownSymbol a+  )+  -- | Path to the file+  => FilePath+  -- | Child spec+  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceFile path = introduceFile' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold }) path++-- | Same as 'introduceFile', but allows passing custom 'NodeOptions'.+introduceFile' :: forall a context m. (+  MonadUnliftIO m, KnownSymbol a+  )+  => NodeOptions+  -> FilePath+  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+  -> SpecFree context m ()+introduceFile' nodeOptions path = introduce' nodeOptions [i|#{binaryName} (binary from PATH)|] (mkFileLabel @a) (return $ EnvironmentFile path) (const $ return ())+  where+    -- Saw a bug where we couldn't embed "symbolVal proxy" directly in the quasi-quote above.+    -- Failed with "Couldn't match kind ‘Bool’ with ‘Symbol’"+    binaryName :: String+    binaryName = symbolVal (Proxy @a)++-- | Introduce a file from the PATH, which must be present when tests are run.+-- Useful when you want to set up your own environment with binaries etc. to use in tests.+-- Throws an exception if the desired file is not available.+introduceBinaryViaEnvironment :: forall a context m. (+  MonadUnliftIO m, KnownSymbol a+  )+  -- | Parent spec+  => SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+  -- | Child spec+  -> SpecFree context m ()+introduceBinaryViaEnvironment = introduceBinaryViaEnvironment' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })++-- | Same as 'introduceBinaryViaEnvironment', but allows you to pass custom 'NodeOptions'.+introduceBinaryViaEnvironment' :: forall a context m. (+  MonadUnliftIO m, KnownSymbol a+  )+  => NodeOptions+  -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+  -> SpecFree context m ()+introduceBinaryViaEnvironment' nodeOptions = introduce' nodeOptions [i|#{binaryName} (binary from PATH)|] (mkFileLabel @a) alloc cleanup+  where+    binaryName :: String+    binaryName = symbolVal (Proxy @a)++    alloc = do+      liftIO (findExecutable binaryName) >>= \case+        Nothing -> expectationFailure [i|Couldn't find binary '#{binaryName}' on PATH|]+        Just path -> return $ EnvironmentFile path++    cleanup _ = return ()++type NixPackageName = Text++-- | Introduce a given 'EnvironmentFile' from the 'NixContext' in scope.+-- It's recommended to use this with -XTypeApplications.+introduceFileViaNixPackage :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a+  ) =>+    -- | Nix package name which contains the desired file.+    -- This package will be evaluated using the configured Nixpkgs version of the 'NixContext'.+    NixPackageName+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceFileViaNixPackage name = introduceFileViaNixPackage' @a name (defaultFindFile (symbolVal (Proxy @a)))++-- | Same as 'introduceFileViaNixPackage', but allows you to customize the search callback.+introduceFileViaNixPackage' :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a+  ) =>+    -- | Nix package name which contains the desired file.+    -- This package will be evaluated using the configured Nixpkgs version of the 'NixContext'.+    NixPackageName+    -- | Callback to find the desired file within the Nix derivation path.+    -- It will be passed the derivation path, and should return the file. For example,+    -- tryFindFile "\/nix\/store\/...selenium-server-standalone-3.141.59" may return+    -- "\/nix\/store\/...selenium-server-standalone-3.141.59\/share\/lib\/selenium-server-standalone-3.141.59\/selenium-server-standalone-3.141.59.jar".+    -> (FilePath -> IO FilePath)+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceFileViaNixPackage' = introduceFileViaNixPackage'' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })++-- | Same as 'introduceFileViaNixPackage'', but allows passing custom 'NodeOptions'.+introduceFileViaNixPackage'' :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a+  ) => NodeOptions+    -- | Nix package name which contains the desired file.+    -> NixPackageName+    -- | Callback to find the desired file within the Nix derivation path.+    -- It will be passed the derivation path, and should return the file. For example,+    -- tryFindFile "\/nix\/store\/...selenium-server-standalone-3.141.59" may return+    -- "\/nix\/store\/...selenium-server-standalone-3.141.59\/share\/lib\/selenium-server-standalone-3.141.59\/selenium-server-standalone-3.141.59.jar".+    -> (FilePath -> IO FilePath)+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceFileViaNixPackage'' nodeOptions packageName tryFindFile = introduce' nodeOptions [i|#{binaryName} (file via Nix package #{packageName})|] (mkFileLabel @a) alloc (const $ return ())+  where+    binaryName :: String+    binaryName = symbolVal (Proxy @a)++    alloc = buildNixSymlinkJoin [packageName] >>= \p -> EnvironmentFile <$> liftIO (tryFindFile p)++-- | Lower-level version of 'introduceFileViaNixPackage'.+getFileViaNixPackage :: forall context m. (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadLoggerIO m+  ) =>+    -- | Nix package name which contains the desired file.+    NixPackageName+    -- | Callback to find the desired file, as in 'introduceFileViaNixPackage'.+    -> (FilePath -> IO FilePath)+    -> m FilePath+getFileViaNixPackage packageName tryFindFile = buildNixSymlinkJoin [packageName] >>= liftIO . tryFindFile++-- | Introduce a given 'EnvironmentFile' from the 'NixContext' in scope.+-- It's recommended to use this with -XTypeApplications.+introduceBinaryViaNixPackage :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a+  ) =>+    -- | Nix package name which contains the desired binary.+    -- This package will be evaluated using the configured Nixpkgs version of the 'NixContext'.+    -- For example, you can use the "hello" binary from the "hello" package like this:+    --+    -- introduceBinaryViaNixPackage' @"hello" "hello"+    NixPackageName+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceBinaryViaNixPackage = introduceBinaryViaNixPackage' @a (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })++-- | Same as 'introduceBinaryViaNixPackage', but allows passing custom 'NodeOptions'.+introduceBinaryViaNixPackage' :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a+  ) => NodeOptions+    -- | Nix package name which contains the desired binary.+    -> NixPackageName+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceBinaryViaNixPackage' nodeOptions packageName = introduce' nodeOptions [i|#{binaryName} (binary via Nix package #{packageName})|] (mkFileLabel @a) alloc (const $ return ())+  where+    binaryName :: String+    binaryName = symbolVal (Proxy @a)++    alloc = buildNixSymlinkJoin [packageName] >>= tryFindBinary binaryName++-- | Lower-level version of 'introduceBinaryViaNixPackage'.+getBinaryViaNixPackage :: forall a context m. (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadLoggerIO m, KnownSymbol a+  ) =>+    -- | Nix package name which contains the desired binary.+    NixPackageName+    -> m FilePath+getBinaryViaNixPackage packageName = do+  unEnvironmentFile <$> (buildNixSymlinkJoin [packageName] >>= tryFindBinary (symbolVal (Proxy @a)))++-- | Lower-level version of 'introduceBinaryViaNixPackage'.+getBinaryViaNixPackage' :: forall a context m. (+  HasBaseContext context, MonadReader context m+  , MonadLogger m, MonadUnliftIO m, KnownSymbol a+  ) =>+    -- | 'NixContext' to use.+    NixContext+    -- | Nix package name which contains the desired binary.+    -> NixPackageName+    -> m FilePath+getBinaryViaNixPackage' nc packageName = do+  unEnvironmentFile <$> (buildNixSymlinkJoin' nc [packageName] >>= tryFindBinary (symbolVal (Proxy @a)))++-- | Introduce a given 'EnvironmentFile' from the 'NixContext' in scope.+-- It's recommended to use this with -XTypeApplications.+introduceBinaryViaNixDerivation :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, MonadMask m, KnownSymbol a+  ) =>+    -- | Nix derivation as a string.+    Text+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceBinaryViaNixDerivation = introduceBinaryViaNixDerivation' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })++-- | Same as 'introduceBinaryViaNixDerivation', but allows passing custom 'NodeOptions'.+introduceBinaryViaNixDerivation' :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, MonadMask m, KnownSymbol a+  ) => NodeOptions+    -- | Nix derivation as a string.+    -> Text+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceBinaryViaNixDerivation' nodeOptions derivation = introduce' nodeOptions [i|#{binaryName} (binary via Nix derivation)|] (mkFileLabel @a) alloc (const $ return ())+  where+    binaryName :: String+    binaryName = symbolVal (Proxy @a)++    alloc = buildNixCallPackageDerivation derivation >>= tryFindBinary binaryName++-- | Lower-level version of 'introduceBinaryViaNixDerivation'.+getBinaryViaNixDerivation :: forall a context m. (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadLoggerIO m, MonadMask m, KnownSymbol a+  ) =>+    -- | Nix derivation as a string.+    Text+    -> m FilePath+getBinaryViaNixDerivation derivation =+  unEnvironmentFile <$> (buildNixCallPackageDerivation derivation >>= tryFindBinary (symbolVal (Proxy @a)))++-- | Lower-level version of 'getBinaryViaNixDerivation'.+getBinaryViaNixDerivation' :: forall a context m. (+  HasBaseContextMonad context m+  , MonadUnliftIO m, MonadLoggerIO m, MonadMask m, KnownSymbol a+  )+  -- | Nix context.+  => NixContext+  -- | Nix derivation as a string.+  -> Text+  -> m FilePath+getBinaryViaNixDerivation' nc derivation =+  unEnvironmentFile <$> (buildNixCallPackageDerivation' nc derivation >>= tryFindBinary (symbolVal (Proxy @a)))++-- | Introduce a given 'EnvironmentFile' from the 'NixContext' in scope.+-- It's recommended to use this with -XTypeApplications.+introduceFileViaNixDerivation :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, MonadMask m, KnownSymbol a+  ) =>+    -- | Nix derivation as a string.+    Text+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceFileViaNixDerivation derivation = introduceFileViaNixDerivation' @a derivation (defaultFindFile (symbolVal (Proxy @a)))++-- | Same as 'introduceFileViaNixDerivation', but allows configuring the file finding callback.+introduceFileViaNixDerivation' :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, MonadMask m, KnownSymbol a+  ) =>+    -- | Nix derivation as a string.+    Text+    -- | Callback to find the desired file.+    -> (FilePath -> IO FilePath)+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceFileViaNixDerivation' = introduceFileViaNixDerivation'' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })++-- | Same as 'introduceFileViaNixDerivation'', but allows passing custom 'NodeOptions'.+introduceFileViaNixDerivation'' :: forall a context m. (+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, MonadMask m, KnownSymbol a+  ) => NodeOptions+    -- | Nix derivation as a string.+    -> Text+    -- | Callback to find the desired file.+    -> (FilePath -> IO FilePath)+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()+    -> SpecFree context m ()+introduceFileViaNixDerivation'' nodeOptions derivation tryFindFile = introduce' nodeOptions [i|#{binaryName} (file via Nix derivation)|] (mkFileLabel @a) alloc (const $ return ())+  where+    binaryName :: String+    binaryName = symbolVal (Proxy @a)++    alloc = EnvironmentFile <$> (buildNixCallPackageDerivation derivation >>= liftIO . tryFindFile)++-- | Lower-level version of 'introduceFileViaNixDerivation'.+getFileViaNixDerivation :: forall context m. (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadLoggerIO m, MonadMask m+  ) =>+    -- | Nix derivation as a string.+    Text+    -- | Callback to find the desired file.+    -> (FilePath -> IO FilePath)+    -> m FilePath+getFileViaNixDerivation derivation tryFindFile = buildNixCallPackageDerivation derivation >>= liftIO . tryFindFile+++tryFindBinary :: (MonadIO m) => String -> FilePath -> m (EnvironmentFile a)+tryFindBinary binaryName env = do+  findExecutablesInDirectories [env </> "bin"] binaryName >>= \case+    (x:_) -> return $ EnvironmentFile x+    _ -> expectationFailure [i|Couldn't find binary '#{binaryName}' in #{env </> "bin"}|]++-- | Find a file whose name exactly matches a string, using 'findFirstFile'.+-- This calls 'takeFileName', so it only matches against the name, not the relative path.+defaultFindFile :: String -> FilePath -> IO FilePath+defaultFindFile name = findFirstFile (\x -> return (takeFileName x == name))++-- | Find the first file under the given directory (recursively) which matches the predicate.+-- Note that the callback receives the full relative path to the file from the root dir.+-- Throws using 'expectationFailure' when the file is not found.+findFirstFile :: (FilePath -> IO Bool) -> FilePath -> IO FilePath+findFirstFile predicate dir = runExceptT (go dir) >>= \case+  Left x -> return x+  Right () -> expectationFailure [i|Couldn't find file in '#{dir}'|]+  where+    go :: FilePath -> ExceptT FilePath IO ()+    go currentDir = do+      contents <- liftIO $ listDirectory currentDir+      forM_ contents $ \name -> do+        let path = currentDir </> name+        doesDirectoryExist path >>= \case+          True -> go path+          False -> whenM (liftIO $ predicate path) (throwE path)
+ lib/Test/Sandwich/Contexts/Files/Types.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.Contexts.Files.Types (+  askFile+  , askFile'++  , EnvironmentFile(..)+  , HasFile+  , mkFileLabel++  , FileValue+  ) where++import GHC.TypeLits+import Relude+import Test.Sandwich+++-- | Retrieve a file context.+askFile :: forall a context m. (MonadReader context m, HasFile context a) => m FilePath+askFile = askFile' (Proxy @a)++-- | Variant of 'askFile' that you can use with a 'Proxy' rather than a type application.+askFile' :: forall a context m. (MonadReader context m, HasFile context a) => Proxy a -> m FilePath+askFile' _ = unEnvironmentFile <$> getContext (mkFileLabel @a)++-- | A file path to make available to tests.+-- For example, this can be an external binary like "minikube" if a given test context wants+-- to use it to start a Minikube cluster.+-- But you can use this for any kind of file you want to inject into tests.+data EnvironmentFile a = EnvironmentFile { unEnvironmentFile :: FilePath }++-- | Has-* class for asserting a given file is available.+type HasFile context a = HasLabel context (AppendSymbol "file-" a) (EnvironmentFile a)++mkFileLabel :: Label (AppendSymbol "file-" a) (EnvironmentFile a)+mkFileLabel = Label++-- | Shorthand for 'LabelValue's containing 'EnvironmentFile's.+type FileValue file = LabelValue (AppendSymbol "file-" file) (EnvironmentFile file)
+ lib/Test/Sandwich/Contexts/HttpWaits.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}++{-|++HTTP(S)-specific wait functions, for waiting on servers.++-}+++module Test.Sandwich.Contexts.HttpWaits (+  -- * HTTP waits+  waitUntilStatusCode+  , waitUntilStatusCodeWithTimeout++  -- * Types+  , VerifyCerts(..)+  , WaitConstraints+  ) where++import Control.Concurrent+import Control.Monad+import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.Maybe+import Data.String.Interpolate+import GHC.Stack+import Network.Connection (TLSSettings(..))+import Network.HTTP.Conduit+import Network.HTTP.Types.Status (statusCode)+import Network.Stream hiding (Result)+import Relude+import Test.Sandwich+import UnliftIO.Exception+import UnliftIO.Timeout++#ifdef MIN_VERSION_crypton_connection+#if MIN_VERSION_crypton_connection(0,4,0)+import Data.Default (def)+#endif+#endif+++timePerRequest :: Int+timePerRequest = 10_000_000++type WaitConstraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadThrow m)++-- | Whether to verify certificates or not when connecting to an HTTPS endpoint.+data VerifyCerts = YesVerify | NoVerify+  deriving (Eq)++tlsNoVerifySettings :: ManagerSettings+tlsNoVerifySettings = mkManagerSettings tlsSettings Nothing+  where+    tlsSettings = TLSSettingsSimple {+      settingDisableCertificateValidation = True+      , settingDisableSession = False+      , settingUseServerName = False+#ifdef MIN_VERSION_crypton_connection+#if MIN_VERSION_crypton_connection(0,4,0)+      , settingClientSupported = def+#endif+#endif+      }++-- | Send HTTP requests to a URL until we get a response with an given code.+waitUntilStatusCode :: (WaitConstraints m) => (Int, Int, Int) -> VerifyCerts -> String -> m ()+waitUntilStatusCode code verifyCerts url = do+  debug [i|Beginning waitUntilStatusCode request to #{url}|]+  req <- parseRequest url+  man <- liftIO $ newManager (if verifyCerts == YesVerify then tlsManagerSettings else tlsNoVerifySettings)+  timeout timePerRequest (handleException $ (Right <$>) $ httpLbs req man) >>= \case+    Just (Right resp)+      | statusCode (responseStatus resp) == statusToInt code -> return ()+      | otherwise -> do+          debug [i|Unexpected response in waitUntilStatusCode request to #{url}: #{responseStatus resp}. Wanted #{code}. Body is #{responseBody resp}|]+          retry+    Just (Left err) -> do+      debug [i|Failure in waitUntilStatusCode request to #{url}: #{err}|]+      retry+    Nothing -> do+      debug [i|Timeout in waitUntilStatusCode request to #{url} (after #{timePerRequest}us)|]+      retry+  where+    retry = liftIO (threadDelay 1_000_000) >> waitUntilStatusCode code verifyCerts url+    handleException = handle (\(e :: SomeException) -> return $ Left $ ErrorMisc [i|Exception in waitUntilStatusCode: #{e}|])+    statusToInt (x, y, z) = 100 * x + 10 * y + z++-- | Same as 'waitUntilStatusCode', but with a customizable timeout in microseconds.+waitUntilStatusCodeWithTimeout :: (WaitConstraints m) => (Int, Int, Int) -> Int -> VerifyCerts -> String -> m ()+waitUntilStatusCodeWithTimeout code timeInMicroseconds verifyCerts url = do+  maybeSuccess <- timeout timeInMicroseconds $ waitUntilStatusCode code verifyCerts url+  when (isNothing maybeSuccess) $+    expectationFailure [i|Failed to connect to URL "#{url}" in waitUntilStatusCodeWithTimeout'...|]+++#if !MIN_VERSION_time(1,9,1)+secondsToNominalDiffTime :: Pico -> NominalDiffTime+secondsToNominalDiffTime = realToFrac++nominalDiffTimeToSeconds :: NominalDiffTime -> Pico+nominalDiffTimeToSeconds = realToFrac+#endif
+ lib/Test/Sandwich/Contexts/Nix.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++{-|++This module contains tools for working with Nix, in order to provide Nix-built artifacts to tests.++The Nix package set (Nixpkgs) is one of the largest package sets in the world, and can be a great way to get artifacts reproducibly. All you need is a @nix@ binary available on the PATH.++For example, the following will build a Nix environment based on Nixpkgs release 24.05, containing Emacs and Firefox.++@+introduceNixContext nixpkgsRelease2405 $+  introduceNixEnvironment ["emacs", "firefox"] $ do+    it "uses the environment" $ do+      envPath <- getContext nixEnvironment++      emacsVersion <- readCreateProcess (proc (envPath <\/\> "bin" <\/\> "emacs") ["--version"]) ""+      info [i|Emacs version: #{emacsVersion}|]++      firefoxVersion <- readCreateProcess (proc (envPath <\/\> "bin" <\/\> "firefox") ["--version"]) ""+      info [i|Firefox version: #{firefoxVersion}|]+@++-}++module Test.Sandwich.Contexts.Nix (+  -- * Nix contexts+  introduceNixContext+  , introduceNixContext'+  , introduceNixContext''++  -- * Nix environments+  , introduceNixEnvironment+  , introduceNixEnvironment'+  , buildNixSymlinkJoin+  , buildNixSymlinkJoin'+  , buildNixExpression+  , buildNixExpression'+  , buildNixCallPackageDerivation+  , buildNixCallPackageDerivation'++  -- * Nixpkgs releases+  , nixpkgsReleaseDefault+  , nixpkgsRelease2405+  , nixpkgsRelease2311++  -- * Types+  , nixContext+  , NixContext(..)+  , HasNixContext++  , nixEnvironment+  , HasNixEnvironment++  , NixpkgsDerivation(..)++  , defaultFileContextVisibilityThreshold+  ) where++import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.Aeson as A+import qualified Data.Map as M+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Vector as V+import Relude+import System.FilePath+import System.IO.Temp+import Test.Sandwich+import Test.Sandwich.Contexts.Files.Types+import Test.Sandwich.Contexts.Util.Aeson+import qualified Text.Show+import UnliftIO.Async+import UnliftIO.Directory+import UnliftIO.Environment+import UnliftIO.MVar (modifyMVar)+import UnliftIO.Process++-- * Types++nixContext :: Label "nixContext" NixContext+nixContext = Label++data NixContext = NixContext {+  nixContextNixBinary :: FilePath+  , nixContextNixpkgsDerivation :: NixpkgsDerivation+  , nixContextBuildCache :: MVar (Map Text (Async FilePath))+  }+instance Show NixContext where+  show (NixContext {}) = "<NixContext>"++type HasNixContext context = HasLabel context "nixContext" NixContext++nixEnvironment :: Label "nixEnvironment" FilePath+nixEnvironment = Label++type HasNixEnvironment context = HasLabel context "nixEnvironment" FilePath++defaultFileContextVisibilityThreshold :: Int+defaultFileContextVisibilityThreshold = 150++data NixpkgsDerivation =+  NixpkgsDerivationFetchFromGitHub {+    nixpkgsDerivationOwner :: Text+    , nixpkgsDerivationRepo :: Text+    , nixpkgsDerivationRev :: Text+    , nixpkgsDerivationSha256 :: Text++    -- | Set the environment variable NIXPKGS_ALLOW_UNFREE=1 when building with this derivation.+    -- Useful when you want to use packages with unfree licenses, like @google-chrome@.+    , nixpkgsDerivationAllowUnfree :: Bool+    } deriving (Show, Eq)++-- | Nixpkgs release 24.05, accessed 6\/10\/2024.+-- You can compute updated values for this release (or others) by running+-- nix-prefetch-github NixOS nixpkgs --rev release-24.05+nixpkgsRelease2405 :: NixpkgsDerivation+nixpkgsRelease2405 = NixpkgsDerivationFetchFromGitHub {+  nixpkgsDerivationOwner = "NixOS"+  , nixpkgsDerivationRepo = "nixpkgs"+  , nixpkgsDerivationRev = "869cab745a802b693b45d193b460c9184da671f3"+  , nixpkgsDerivationSha256 = "sha256-zliqz7ovpxYdKIK+GlWJZxifXsT9A1CHNQhLxV0G1Hc="+  , nixpkgsDerivationAllowUnfree = False+  }++-- | Nixpkgs release 23.11, accessed 2\/19\/2023.+-- You can compute updated values for this release (or others) by running+-- nix-prefetch-github NixOS nixpkgs --rev release-23.11+nixpkgsRelease2311 :: NixpkgsDerivation+nixpkgsRelease2311 = NixpkgsDerivationFetchFromGitHub {+  nixpkgsDerivationOwner = "NixOS"+  , nixpkgsDerivationRepo = "nixpkgs"+  , nixpkgsDerivationRev = "cc86e0769882886f7831de9c9373b62ea2c06e3f"+  , nixpkgsDerivationSha256 = "sha256-1eAZINWjTTA8nWJiN979JVSwvCYzUWnMpzMHGUCLgZk="+  , nixpkgsDerivationAllowUnfree = False+  }++-- | Currently set to 'nixpkgsRelease2405'.+nixpkgsReleaseDefault :: NixpkgsDerivation+nixpkgsReleaseDefault = nixpkgsRelease2405++-- | Introduce a 'NixContext', which contains information about where to find Nix and what+-- version of Nixpkgs to use. This can be leveraged to introduce Nix packages in tests.+--+-- The 'NixContext' contains a build cache, so if you build a given derivation more than+-- once in your tests under this node, runs after the first one will be fast.+--+-- This function requires a @nix@ binary to be in the PATH and will throw an exception if it+-- isn't found.+introduceNixContext :: (+  MonadUnliftIO m, MonadThrow m+  )+  -- | Nixpkgs derivation to use+  => NixpkgsDerivation+  -- | Child spec+  -> SpecFree (LabelValue "nixContext" NixContext :> context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceNixContext = introduceNixContext' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })++-- | Same as 'introduceNixContext', but allows passing custom 'NodeOptions'.+introduceNixContext' :: (+  MonadUnliftIO m, MonadThrow m+  )+  -- | Custom 'NodeOptions'+  => NodeOptions+  -- | Nixpkgs derivation to use+  -> NixpkgsDerivation+  -- | Child spec+  -> SpecFree (LabelValue "nixContext" NixContext :> context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceNixContext' nodeOptions nixpkgsDerivation = introduce' nodeOptions "Introduce Nix context" nixContext getNixContext (const $ return ())+  where+    getNixContext = findExecutable "nix" >>= \case+      Nothing -> expectationFailure [i|Couldn't find "nix" binary when introducing Nix context. A Nix binary and store must already be available in the environment.|]+      Just p -> do+        -- TODO: make sure the Nixpkgs derivation works+        buildCache <- newMVar mempty+        pure (NixContext p nixpkgsDerivation buildCache)++-- | Same as 'introduceNixContext'', but allows specifying the Nix binary via 'HasFile'.+introduceNixContext'' :: (+  MonadUnliftIO m+  , MonadThrow m+  , HasFile context "nix"+  )+  -- | Custom 'NodeOptions'+  => NodeOptions+  -- | Nixpkgs derivation to use+  -> NixpkgsDerivation+  -- | Child spec+  -> SpecFree (LabelValue "nixContext" NixContext :> context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceNixContext'' nodeOptions nixpkgsDerivation = introduce' nodeOptions "Introduce Nix context" nixContext getNixContext (const $ return ())+  where+    getNixContext = do+      nix <- askFile @"nix"+      -- TODO: make sure the Nixpkgs derivation works+      buildCache <- newMVar mempty+      pure (NixContext nix nixpkgsDerivation buildCache)++-- | Introduce a Nix environment containing the given list of packages, using the current 'NixContext'.+-- These packages are mashed together using the Nix @symlinkJoin@ function. Their binaries will generally+-- be found in "\<environment path\>\/bin".+introduceNixEnvironment :: (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m+  )+  -- | List of package names to include in the Nix environment+  => [Text]+  -> SpecFree (LabelValue "nixEnvironment" FilePath :> context) m ()+  -> SpecFree context m ()+introduceNixEnvironment = introduceNixEnvironment' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })++-- | Same as 'introduceNixEnvironment', but allows passing custom 'NodeOptions'.+introduceNixEnvironment' :: (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m+  )+  -- | Custom 'NodeOptions'+  => NodeOptions+  -- | List of package names to include in the Nix environment+  -> [Text]+  -> SpecFree (LabelValue "nixEnvironment" FilePath :> context) m ()+  -> SpecFree context m ()+introduceNixEnvironment' nodeOptions packageNames = introduce' nodeOptions "Introduce Nix environment" nixEnvironment (buildNixSymlinkJoin packageNames) (const $ return ())++-- | Build a Nix environment, as in 'introduceNixEnvironment'.+buildNixSymlinkJoin :: (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadLogger m+  )+  -- | Package names+  => [Text] -> m FilePath+buildNixSymlinkJoin packageNames = do+  NixContext {..} <- getContext nixContext+  buildNixExpression $ renderNixSymlinkJoin nixContextNixpkgsDerivation packageNames++-- | Lower-level version of 'buildNixSymlinkJoin'.+buildNixSymlinkJoin' :: (+  HasBaseContextMonad context m+  , MonadUnliftIO m, MonadLogger m+  )+  -- | Nix context+  => NixContext+  -- | Package names+  -> [Text]+  -> m FilePath+buildNixSymlinkJoin' nc@(NixContext {..}) packageNames = do+  buildNixExpression' nc $ renderNixSymlinkJoin nixContextNixpkgsDerivation packageNames++-- | Build a Nix environment expressed as a derivation expecting a list of dependencies, as in the+-- Nix "callPackage" design pattern. I.e.+-- "{ git, gcc, stdenv, ... }: stdenv.mkDerivation {...}"+buildNixCallPackageDerivation :: (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadLogger m, MonadMask m+  )+  -- | Nix derivation+  => Text+  -> m FilePath+buildNixCallPackageDerivation derivation = do+  nc <- getContext nixContext+  buildNixCallPackageDerivation' nc derivation++-- | Lower-level version of 'buildNixCallPackageDerivation'+buildNixCallPackageDerivation' :: (+  HasBaseContextMonad context m+  , MonadUnliftIO m, MonadLogger m, MonadMask m+  )+  -- | Nix context.+  => NixContext+  -- | Nix derivation.+  -> Text+  -> m FilePath+buildNixCallPackageDerivation' nc@(NixContext {..}) derivation = do+  wait =<< modifyMVar nixContextBuildCache (\m ->+    case M.lookup derivation m of+      Just x -> return (m, x)+      Nothing -> do+        asy <- async $ do+          maybeNixExpressionDir <- getCurrentFolder >>= \case+            Just dir -> (Just <$>) $ liftIO $ createTempDirectory dir "nix-expression"+            Nothing -> return Nothing++          withDerivationPath maybeNixExpressionDir $ \derivationPath -> do+            liftIO $ T.writeFile derivationPath derivation+            runNixBuild' nc (renderCallPackageDerivation nixContextNixpkgsDerivation derivationPath) ((</> "gcroot") <$> maybeNixExpressionDir)++        return (M.insert derivation asy m, asy)+    )+  where+    withDerivationPath (Just nixExpressionDir) action = action (nixExpressionDir </> "default.nix")+    withDerivationPath Nothing action = withSystemTempDirectory "nix-expression" $ \dir -> action (dir </> "default.nix")+++-- | Build a Nix environment containing the given list of packages, using the current 'NixContext'.+-- These packages are mashed together using the Nix "symlinkJoin" function. Their binaries will generally+-- be found in "\<environment path\>\/bin".+buildNixExpression :: (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadLogger m+  )+  -- | Nix expression+  => Text -> m FilePath+buildNixExpression expr = getContext nixContext >>= (`buildNixExpression'` expr)++-- | Lower-level version of 'buildNixExpression'.+buildNixExpression' :: (+  HasBaseContextMonad context m+  , MonadUnliftIO m, MonadLogger m+  )+  -- | Nix expression+  => NixContext -> Text -> m FilePath+buildNixExpression' nc@(NixContext {..}) expr = do+  wait =<< modifyMVar nixContextBuildCache (\m ->+    case M.lookup expr m of+      Just x -> return (m, x)+      Nothing -> do+        asy <- async $ do+          maybeNixExpressionDir <- getCurrentFolder >>= \case+            Just dir -> (Just <$>) $ liftIO $ createTempDirectory dir "nix-expression"+            Nothing -> pure Nothing+          runNixBuild' nc expr ((</> "gcroot") <$> maybeNixExpressionDir)++        return (M.insert expr asy m, asy)+    )++-- runNixBuild :: (MonadUnliftIO m, MonadLogger m, MonadReader context m, HasNixContext context) => Text -> String -> m String+-- runNixBuild expr outputPath = do+--   nc <- getContext nixContext+--   runNixBuild' nc expr outputPath++runNixBuild' :: (MonadUnliftIO m, MonadLogger m) => NixContext -> Text -> Maybe String -> m String+runNixBuild' (NixContext {nixContextNixpkgsDerivation}) expr maybeOutputPath = do+  maybeEnv <- case nixpkgsDerivationAllowUnfree nixContextNixpkgsDerivation of+    False -> pure Nothing+    True -> do+      env <- getEnvironment+      return $ Just (("NIXPKGS_ALLOW_UNFREE", "1") : env)++  -- TODO: switch this to using nix-build so we can avoid the "--impure" flag?+  output <- readCreateProcessWithLogging (+    (proc "nix" (["build"+                 , "--impure"+                 , "--extra-experimental-features", "nix-command"+                 , "--expr", toString expr+                 , "--json"+                 ] <> (case maybeOutputPath of Nothing -> []; Just p -> ["-o", p])+                )) { env = maybeEnv }+    ) ""++  case A.eitherDecodeStrict (encodeUtf8 output) of+    Right (A.Array (V.toList -> ((A.Object (aesonLookup "outputs" -> Just (A.Object (aesonLookup "out" -> Just (A.String p))))):_))) -> pure (toString p)+    Right (A.Array (V.toList -> ((A.Object (aesonLookup "outputs" -> Just (A.Object (aesonLookup "bin" -> Just (A.String p))))):_))) -> pure (toString p)+    x -> expectationFailure [i|Couldn't parse Nix build JSON output: #{x} (output was #{A.encode output})|]++renderNixSymlinkJoin :: NixpkgsDerivation -> [Text] -> Text+renderNixSymlinkJoin (NixpkgsDerivationFetchFromGitHub {..}) packageNames = [i|+\# Use the ambient <nixpkgs> channel to bootstrap+with {+  inherit (import (<nixpkgs>) {})+  fetchgit fetchFromGitHub;+};++let+  nixpkgs = fetchFromGitHub {+    owner = "#{nixpkgsDerivationOwner}";+    repo = "#{nixpkgsDerivationRepo}";+    rev = "#{nixpkgsDerivationRev}";+    sha256 = "#{nixpkgsDerivationSha256}";+  };++  pkgs = import nixpkgs {};+in++pkgs.symlinkJoin { name = "test-contexts-environment"; paths = with pkgs; [#{T.intercalate " " packageNames}]; }+|]++renderCallPackageDerivation :: NixpkgsDerivation -> FilePath -> Text+renderCallPackageDerivation (NixpkgsDerivationFetchFromGitHub {..}) derivationPath = [i|+\# Use the ambient <nixpkgs> channel to bootstrap+with {+  inherit (import (<nixpkgs>) {})+  fetchgit fetchFromGitHub;+};++let+  nixpkgs = fetchFromGitHub {+    owner = "#{nixpkgsDerivationOwner}";+    repo = "#{nixpkgsDerivationRepo}";+    rev = "#{nixpkgsDerivationRev}";+    sha256 = "#{nixpkgsDerivationSha256}";+  };++  pkgs = import nixpkgs {};+in++pkgs.callPackage #{show derivationPath :: String} {}+|]
+ lib/Test/Sandwich/Contexts/PostgreSQL.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++{-|++This module provides tools for introducing PostgreSQL databases, either via a container (Docker or Podman) or+via a raw process (typically obtaining the binary from Nix).++The container method is traditional, but the raw method can be nice because it tends to leave less junk on the+system such as container images, networks, and volumes.++A note about raw processes and random TCP ports: starting a Postgres process on a randomly chosen port is tricky,+because Postgres currently lacks a setting for choosing its own port and reporting it back to us. So, the only way+to start it on a random TCP port is to first manually  find a free port on the system and then start Postgres+with it. Since this procedure is inherently racy, it can cause failures if your tests are starting lots of+Postgres instances (or other network-using processes) in parallel. This module takes a different approach: it starts+the Postgres instance on a Unix socket, which can never fail. You can connect to it via the Unix socket directly if+you like. If you use the TCP-based methods like 'introducePostgresViaNix', they will open a TCP socket inside the+test process and then run a proxy to forward packets to the Postgres server's Unix socket.++-}++module Test.Sandwich.Contexts.PostgreSQL (+#ifndef mingw32_HOST_OS+  -- * Raw PostgreSQL via Nix (TCP socket)+  introducePostgresViaNix+  , withPostgresViaNix++  -- * Raw PostgreSQL via Nix (Unix socket)+  , introducePostgresUnixSocketViaNix+  , withPostgresUnixSocketViaNix++  -- * Containerized PostgreSQL+  , introducePostgresViaContainer+  , withPostgresContainer++  -- * Types+  , PostgresNixOptions(..)+  , defaultPostgresNixOptions++  , postgres+  , PostgresContext(..)++  , PostgresContainerOptions(..)+  , defaultPostgresContainerOptions++  -- * Re-exports+  , NetworkAddress(..)+#endif+  ) where++#ifndef mingw32_HOST_OS+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.Map as M+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Relude hiding (withFile)+import System.Exit+import System.FilePath+import System.IO.Temp+import System.PosixCompat.Files (getFileStatus, isSocket)+import Test.Sandwich+import Test.Sandwich.Contexts.Container+import Test.Sandwich.Contexts.Nix+import Test.Sandwich.Contexts.ReverseProxy.TCP+import Test.Sandwich.Contexts.Types.Network+import Test.Sandwich.Contexts.Util.UUID+import UnliftIO.Directory+import UnliftIO.Environment+import UnliftIO.Exception+import UnliftIO.IO (hClose, withFile)+import UnliftIO.Process++-- * Labels++postgres :: Label "postgres" PostgresContext+postgres = Label++-- * Types++data PostgresNixOptions = PostgresNixOptions {+  -- | Postgres version to use within the Nixpkgs snapshot of your 'NixContext'.+  -- Defaults to "postgresql", but you can pick specific versions like @postgresql_15@.+  -- See @\<nixpkgs\>\/top-level\/all-packages.nix@ for the available versions in your+  -- snapshot.+  postgresNixPostgres :: Text+  -- | Postgres username. Default to @postgres@.+  , postgresNixUsername :: Text+  -- | Postgres password. Default to @postgres@.+  , postgresNixPassword :: Text+  -- | Postgres default database. The @postgres@ database is always created, but you+  -- can create an additional one here. Defaults to @test@.+  , postgresNixDatabase :: Text+  }+defaultPostgresNixOptions :: PostgresNixOptions+defaultPostgresNixOptions = PostgresNixOptions {+  postgresNixPostgres = "postgresql"+  , postgresNixUsername = "postgres"+  , postgresNixPassword = "postgres"+  , postgresNixDatabase = "test"+  }++data PostgresContext = PostgresContext {+  postgresUsername :: Text+  , postgresPassword :: Text+  , postgresDatabase :: Text+  , postgresAddress :: NetworkAddress+  , postgresConnString :: Text+  -- | The address of the database server within its container (if it was started+  -- using a container).+  -- Useful when the test is also in a container, and containers are networked together.+  , postgresContainerAddress :: Maybe NetworkAddress+  } deriving (Show)+++-- * Binary++-- initdb -D mydb+-- echo "listen_addresses=''" >> mydb/postgresql.conf+-- pg_ctl -D mydb -l logfile -o "--unix_socket_directories='$PWD'" start --wait+-- pg_ctl -D mydb -l logfile stop --wait++-- | Introduce a PostgreSQL instance, using a suitable package from Nix.+introducePostgresViaNix :: (+  HasBaseContext context, HasNixContext context+  , MonadUnliftIO m, MonadMask m+  )+  -- | Options+  => PostgresNixOptions+  -> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()+  -> SpecFree context m ()+introducePostgresViaNix opts = introduceWith "PostgreSQL via Nix" postgres $ \action ->+  withPostgresViaNix opts (void . action)++-- | Bracket-style variant of 'introducePostgresViaNix'.+withPostgresViaNix :: (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadMask m, MonadFail m, MonadLogger m+  )+  -- | Options+  => PostgresNixOptions+  -> (PostgresContext -> m a)+  -> m a+withPostgresViaNix opts@(PostgresNixOptions {..}) action = do+  withPostgresUnixSocketViaNix opts $ \unixSocket ->+    withProxyToUnixSocket unixSocket $ \port ->+      action $ PostgresContext {+        postgresUsername = postgresNixUsername+        , postgresPassword = postgresNixPassword+        , postgresDatabase = postgresNixDatabase+        , postgresAddress = NetworkAddressTCP "localhost" port+        , postgresConnString = [i|postgresql://#{postgresNixUsername}:#{postgresNixPassword}@localhost:#{port}/#{postgresNixDatabase}|]+        , postgresContainerAddress = Nothing+        }++-- | Same as 'introducePostgresViaNix', but the 'postgresAddress' of the 'PostgresContext' will be a Unix socket.+introducePostgresUnixSocketViaNix :: (+  HasBaseContext context, HasNixContext context+  , MonadUnliftIO m, MonadMask m+  )+  -- | Options+  => PostgresNixOptions+  -> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()+  -> SpecFree context m ()+introducePostgresUnixSocketViaNix opts@(PostgresNixOptions {..}) = introduceWith "PostgreSQL via Nix" postgres $ \action -> do+  withPostgresUnixSocketViaNix opts $ \unixSocket -> do+    void $ action $ PostgresContext {+      postgresUsername = postgresNixUsername+      , postgresPassword = postgresNixPassword+      , postgresDatabase = postgresNixDatabase+      , postgresAddress = NetworkAddressUnix unixSocket+      , postgresConnString = [i|postgresql://#{postgresNixUsername}:#{postgresNixPassword}@/#{postgresNixDatabase}?host=#{takeDirectory unixSocket}|]+      , postgresContainerAddress = Nothing+      }++-- | Bracket-style variant of 'introducePostgresUnixSocketViaNix'.+withPostgresUnixSocketViaNix :: (+  HasBaseContextMonad context m, HasNixContext context+  , MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m+  )+  -- | Options+  => PostgresNixOptions+  -> (FilePath -> m a)+  -> m a+withPostgresUnixSocketViaNix (PostgresNixOptions {..}) action = do+  postgresBinDir <- (</> "bin") <$> buildNixSymlinkJoin [postgresNixPostgres]+  withPostgresUnixSocket postgresBinDir postgresNixUsername postgresNixPassword postgresNixDatabase action++-- | The lowest-level raw process version.+withPostgresUnixSocket :: (+  HasBaseContextMonad context m+  , MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m+  )+  -- | Postgres binary dir+  => FilePath+  -- | Username+  -> Text+  -- | Password+  -> Text+  -- | Database+  -> Text+  -- | Action callback+  -> (FilePath -> m a)+  -> m a+withPostgresUnixSocket postgresBinDir username password database action = do+  Just dir <- getCurrentFolder+  baseDir <- liftIO $ createTempDirectory dir "postgres-nix"+  let dbDirName = baseDir </> "db"+  let logfileName = baseDir </> "logfile"++  -- The Unix socket can't live in the sandwich test tree because it has an absurdly short length+  -- requirement (107 bytes on Linux). See+  -- https://unix.stackexchange.com/questions/367008/why-is-socket-path-length-limited-to-a-hundred-chars+  withSystemTempDirectory "postgres-nix-unix-socks" $ \unixSockDir -> do+    bracket+      (do+          -- Run initdb+          baseEnv <- getEnvironment+          let env = ("LC_ALL", "C")+                  : ("LC_CTYPE", "C")+                  : baseEnv+          withTempFile baseDir "pwfile" $ \pwfile h -> do+            liftIO $ T.hPutStrLn h password+            hClose h+            createProcessWithLogging ((proc (postgresBinDir </> "initdb") [dbDirName+                                                                            , "--username", toString username+                                                                            , "-A", "md5"+                                                                            , "--pwfile", pwfile+                                                                            ]) {+                                         cwd = Just dir+                                         , env = Just env+                                         })+              >>= waitForProcess >>= (`shouldBe` ExitSuccess)++          -- Turn off the TCP interface; we'll have it listen solely on a Unix socket+          withFile (dir </> dbDirName </> "postgresql.conf") AppendMode $ \h -> liftIO $ do+            T.hPutStr h "\n"+            T.hPutStrLn h [i|listen_addresses=''|]++          -- Run pg_ctl to start the DB+          createProcessWithLogging ((proc (postgresBinDir </> "pg_ctl") [+                                        "-D", dbDirName+                                        , "-l", logfileName+                                        , "-o", [i|--unix_socket_directories='#{unixSockDir}'|]+                                        , "start" , "--wait"+                                        ]) { cwd = Just dir })+            >>= waitForProcess >>= (`shouldBe` ExitSuccess)++          -- Create the default db+          createProcessWithLogging ((proc (postgresBinDir </> "psql") [+                                        -- "-h", unixSockDir+                                        -- , "--username", toString postgresNixUsername+                                        [i|postgresql://#{username}:#{password}@/?host=#{unixSockDir}|]+                                        , "-c", [i|CREATE DATABASE #{database};|]+                                        ]) { cwd = Just dir })+            >>= waitForProcess >>= (`shouldBe` ExitSuccess)+++          files <- listDirectory unixSockDir+          filterM ((isSocket <$>) . liftIO . getFileStatus) [unixSockDir </> f | f <- files] >>= \case+            [f] -> pure f+            [] -> expectationFailure [i|Couldn't find Unix socket for PostgreSQL server (check output and logfile for errors).|]+            xs -> expectationFailure [i|Found multiple Unix sockets for PostgreSQL server, not sure which one to use: #{xs}|]+      )+      (\_ -> do+          void $ readCreateProcessWithLogging ((proc (postgresBinDir </> "pg_ctl") [+                                                   "-D", dbDirName+                                                   , "-l", logfileName+                                                   , "stop" , "--wait"+                                                   ]) { cwd = Just dir }) ""+      )+      (\socketPath -> action socketPath)++-- * Container++data PostgresContainerOptions = PostgresContainerOptions {+  postgresContainerUser :: Text+  , postgresContainerPassword :: Text+  , postgresContainerLabels :: Map Text Text+  , postgresContainerContainerName :: Maybe Text+  , postgresContainerContainerSystem :: ContainerSystem+  , postgresContainerImage :: Text+  } deriving (Show, Eq)+defaultPostgresContainerOptions :: PostgresContainerOptions+defaultPostgresContainerOptions = PostgresContainerOptions {+  postgresContainerUser = "postgres"+  , postgresContainerPassword = "password"+  , postgresContainerLabels = mempty+  , postgresContainerContainerName = Nothing+  , postgresContainerContainerSystem = ContainerSystemPodman+  , postgresContainerImage = "docker.io/postgres:15"+  }++-- | Introduce a PostgresSQL instance via a container (either Docker or Podman).+introducePostgresViaContainer :: (+  HasBaseContext context+  , MonadUnliftIO m, MonadMask m+  )+  -- | Options+  => PostgresContainerOptions+  -> SpecFree (LabelValue "postgres" PostgresContext :> context) m ()+  -> SpecFree context m ()+introducePostgresViaContainer opts = introduceWith "PostgreSQL via container" postgres $ \action -> do+  withPostgresContainer opts (void . action)++-- | Bracket-style variant of 'introducePostgresViaContainer'.+withPostgresContainer :: (+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadMask m, HasBaseContextMonad context m+  )+  -- | Options+  => PostgresContainerOptions+  -> (PostgresContext -> m a)+  -> m a+withPostgresContainer options action = do+  bracket (createPostgresDatabase options)+          (\(containerName, _p) -> timeAction "cleanup Postgres database" $ do+              info [i|Doing #{postgresContainerContainerSystem options} rm -f --volumes #{containerName}|]+              (exitCode, sout, serr) <-  liftIO $ readCreateProcessWithExitCode (shell [i|#{postgresContainerContainerSystem options} rm -f --volumes #{containerName}|]) ""+              when (exitCode /= ExitSuccess) $+                expectationFailure [i|Failed to destroy Postgres container. Stdout: '#{sout}'. Stderr: '#{serr}'|]+          )+          (waitForPostgresDatabase options >=> action)++createPostgresDatabase :: (+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m+  ) => PostgresContainerOptions -> m (Text, ProcessHandle)+createPostgresDatabase (PostgresContainerOptions {..}) = timeAction "create Postgres database" $ do+  containerName <- maybe (("postgres-" <>) <$> makeUUID) return postgresContainerContainerName++  let containerSystem = postgresContainerContainerSystem+  let labelArgs = mconcat [["-l", [i|#{k}=#{v}|]] | (k, v) <- M.toList postgresContainerLabels]+  let args = ["run"+             , "-d"+             , "-e", [i|POSTGRES_USER=#{postgresContainerUser}|]+             , "-e", [i|POSTGRES_PASSWORD=#{postgresContainerPassword}|]+             , "-p", "5432"+             , "--health-cmd", [i|pg_isready -U #{postgresContainerUser}|]+             , "--health-interval=100ms"+             , "--name", containerName+             ]+             <> labelArgs+             <> [postgresContainerImage]++  info [i|cmd: #{containerSystem} #{T.unwords args}|]++  p <- createProcessWithLogging (proc (show containerSystem) (fmap toString args))+  return (containerName, p)++waitForPostgresDatabase :: (+  MonadUnliftIO m, MonadLoggerIO m, MonadMask m+  ) => PostgresContainerOptions -> (Text, ProcessHandle) -> m PostgresContext+waitForPostgresDatabase (PostgresContainerOptions {..}) (containerName, p) = do+  containerID <- waitForProcess p >>= \case+    ExitSuccess -> containerNameToContainerId postgresContainerContainerSystem containerName+    _ -> expectationFailure [i|Failed to start Postgres container.|]++  debug [i|Postgres container ID: #{containerID}|]++  localPort <- containerPortToHostPort postgresContainerContainerSystem containerName 5432++  waitForHealth postgresContainerContainerSystem containerID++  let pc = PostgresContext {+        postgresUsername = postgresContainerUser+        , postgresPassword = postgresContainerPassword+        , postgresDatabase = postgresContainerUser+        , postgresAddress = NetworkAddressTCP "localhost" localPort+        , postgresConnString = [i|postgresql://#{postgresContainerUser}:#{postgresContainerPassword}@localhost:#{localPort}/#{postgresContainerUser}|]+        , postgresContainerAddress = Just $ NetworkAddressTCP (toString containerName) 5432+        }++  -- TODO: might be a good idea to do this here, rather than wrap a retry around the initial migrate later on+  -- waitForSimpleQuery pc++  return pc++#endif
+ lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}++-- | This module is inspired by the http-reverse-proxy package:+-- https://hackage.haskell.org/package/http-reverse-proxy++module Test.Sandwich.Contexts.ReverseProxy.TCP where++#ifndef mingw32_HOST_OS++import Control.Monad.IO.Unlift+import Data.Conduit+import qualified Data.Conduit.Network as DCN+import qualified Data.Conduit.Network.Unix as DCNU+import Data.Streaming.Network (setAfterBind)+import Data.String.Interpolate+import Network.Socket+import Relude+import Test.Sandwich (expectationFailure)+import UnliftIO.Async+import UnliftIO.Exception+++withProxyToUnixSocket :: MonadUnliftIO m => FilePath -> (PortNumber -> m a) -> m a+withProxyToUnixSocket socketPath f = do+  portVar <- newEmptyMVar+  let ss = DCN.serverSettings 0 "*"+         & setAfterBind (\sock -> do+             getSocketName sock >>= \case+               SockAddrInet port _ -> putMVar portVar port+               SockAddrInet6 port _ _ _ -> putMVar portVar port+               x -> expectationFailure [i|withProxyToUnixSocket: expected to bind a TCP socket, but got other addr: #{x}|]+           )+  withAsync (liftIO $ DCN.runTCPServer ss app `onException` (putMVar portVar 0)) $ \_ ->+    readMVar portVar >>= f++  where+    app appdata = DCNU.runUnixClient (DCNU.clientSettings socketPath) $ \appdataServer ->+      concurrently_+        (runConduit $ DCN.appSource appdata .| DCN.appSink appdataServer)+        (runConduit $ DCN.appSource appdataServer .| DCN.appSink appdata)++#endif
+ lib/Test/Sandwich/Contexts/Types/Network.hs view
@@ -0,0 +1,17 @@++{-|+Helper module for working network addresses (which may be Unix sockets).+-}+++module Test.Sandwich.Contexts.Types.Network where++import Network.Socket+import Relude+++data NetworkAddress =+  NetworkAddressTCP { networkAddressTcpHostname :: String+                    , networkAddressTcpPort :: PortNumber }+  | NetworkAddressUnix { networkAddressUnixPath :: String }+  deriving (Show, Eq)
+ lib/Test/Sandwich/Contexts/Types/S3.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}++{-|+Helper module for working with S3 servers.+-}++module Test.Sandwich.Contexts.Types.S3 (+  TestS3Server(..)+  , HttpMode(..)++  -- * Contexts+  , testS3Server+  , HasTestS3Server++  -- * Endpoints+  , testS3ServerEndpoint+  , testS3ServerContainerEndpoint++  -- * Misc+  , s3Protocol+  ) where++import Data.String.Interpolate+import Relude+import Test.Sandwich+import Test.Sandwich.Contexts.Types.Network+++testS3Server :: Label "testS3Server" TestS3Server+testS3Server = Label++-- | A generic test S3 server. This can be used by downstream packages like sandwich-contexts-minio.+data TestS3Server = TestS3Server {+  testS3ServerAddress :: NetworkAddress+  -- | The address of the S3 server within its container, if present.+  -- Useful if you're doing container-to-container networking.+  , testS3ServerContainerAddress :: Maybe NetworkAddress+  , testS3ServerAccessKeyId :: Text+  , testS3ServerSecretAccessKey :: Text+  , testS3ServerBucket :: Maybe Text+  , testS3ServerHttpMode :: HttpMode+  } deriving (Show, Eq)++data HttpMode =+  HttpModeHttp+  | HttpModeHttps+  -- | A special mode to allow a server to run in HTTPS mode, but connect to it without HTTPS validation. Useful for tests.+  | HttpModeHttpsNoValidate+  deriving (Show, Eq)++type HasTestS3Server context = HasLabel context "testS3Server" TestS3Server++-- | Generate an S3 connection string for the given server.+testS3ServerEndpoint :: TestS3Server -> Text+testS3ServerEndpoint serv@(TestS3Server {testS3ServerAddress=(NetworkAddressTCP hostname port)}) =+  [i|#{s3Protocol serv}://#{hostname}:#{port}|]+testS3ServerEndpoint serv@(TestS3Server {testS3ServerAddress=(NetworkAddressUnix path)}) =+  [i|#{s3Protocol serv}://#{path}|]++-- | Generate an S3 connection string for the given containerized server, for the network address inside the container.+-- Returns 'Nothing' if this server isn't containerized.+testS3ServerContainerEndpoint :: TestS3Server -> Maybe Text+testS3ServerContainerEndpoint serv@(TestS3Server {testS3ServerContainerAddress=(Just (NetworkAddressTCP hostname port))}) =+  Just [i|#{s3Protocol serv}://#{hostname}:#{port}|]+testS3ServerContainerEndpoint serv@(TestS3Server {testS3ServerContainerAddress=(Just (NetworkAddressUnix path))}) =+  Just [i|#{s3Protocol serv}://#{path}|]+testS3ServerContainerEndpoint _ = Nothing++-- | Return either "http" or "https", based on the 'testS3ServerHttpMode'.+s3Protocol :: TestS3Server -> Text+s3Protocol (TestS3Server {..}) = if testS3ServerHttpMode == HttpModeHttp then "http" else "https"
+ lib/Test/Sandwich/Contexts/Util/Aeson.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}++module Test.Sandwich.Contexts.Util.Aeson where++import qualified Data.Aeson as A+import Data.Char+import qualified Data.List as L+import Data.Text hiding (toLower)+import Relude++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key             as A+import qualified Data.Aeson.KeyMap          as HM+#else+import Data.Hashable+import qualified Data.HashMap.Strict        as HM+#endif+++textKeys :: A.Object -> [Text]+#if MIN_VERSION_aeson(2,0,0)+textKeys = fmap A.toText . HM.keys+#else+textKeys = HM.keys+#endif++#if MIN_VERSION_aeson(2,0,0)+aesonLookup :: Text -> HM.KeyMap v -> Maybe v+aesonLookup = HM.lookup . A.fromText+#else+aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v+aesonLookup = HM.lookup+#endif++#if MIN_VERSION_aeson(2,0,0)+aesonInsert :: Text -> v -> HM.KeyMap v -> HM.KeyMap v+aesonInsert t = HM.insert (A.fromText t)+#else+aesonInsert :: (Eq k, Hashable k) => k -> v -> HM.HashMap k v -> HM.HashMap k v+aesonInsert = HM.insert+#endif++#if MIN_VERSION_aeson(2,0,0)+aesonDelete :: Text -> HM.KeyMap v -> HM.KeyMap v+aesonDelete t = HM.delete (A.fromText t)+#else+aesonDelete :: (Eq k, Hashable k) => k -> HM.HashMap k v -> HM.HashMap k v+aesonDelete = HM.delete+#endif++#if MIN_VERSION_aeson(2,0,0)+aesonToList :: HM.KeyMap v -> [(A.Key, v)]+aesonToList = HM.toList+#else+aesonToList :: HM.HashMap k v -> [(k, v)]+aesonToList = HM.toList+#endif+++dropNAndCamelCase :: Int -> String -> String+dropNAndCamelCase n = lowercaseFirst . L.drop n++lowercaseFirst :: [Char] -> [Char]+lowercaseFirst (x:xs) = (toLower x) : xs+lowercaseFirst [] = []
+ lib/Test/Sandwich/Contexts/Util/Nix.hs view
@@ -0,0 +1,29 @@++module Test.Sandwich.Contexts.Util.Nix (+  withWritableBinaryCache+  ) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.Logger+import Data.String.Interpolate+import Relude+import System.FilePath+import System.IO.Temp+import Test.Sandwich.Logging+import UnliftIO.Directory+import UnliftIO.Process+++withWritableBinaryCache :: (MonadIO m, MonadMask m, MonadLogger m) => Maybe FilePath -> (Maybe FilePath -> m a) -> m a+withWritableBinaryCache Nothing action = action Nothing+withWritableBinaryCache (Just readOnlyPath) action =+  withSystemTempDirectory "writable-binary-cache" $ \dir -> do+    let path = dir </> "cache"+    info [i|Putting writable binary cache at: #{path}|]+    _ <- readCreateProcess (proc "cp" ["-ra", readOnlyPath, path]) ""++    -- The cache needs a writable realisations folder+    _ <- readCreateProcess (proc "chmod" ["a+w", path]) ""+    createDirectoryIfMissing True (path </> "realisations")++    action $ Just path
+ lib/Test/Sandwich/Contexts/Util/Ports.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++{-|+Helper module for finding free ports, with various options for port ranges, retries, and excluded ports.+-}+++module Test.Sandwich.Contexts.Util.Ports (+  findFreePort++  -- * Exception-throwing versions+  , findFreePortOrException+  , findFreePortOrException'++  -- * Lower-level+  , findFreePortInRange+  , findFreePortInRange'++  -- * Lower-level+  , isPortFree+  , tryOpenAndClosePort+  , ephemeralPortRange+  ) where++import Control.Monad.Catch (MonadCatch, catch)+import Control.Retry+import Network.Socket+import Relude+import System.Random (randomRIO)+++-- | Find an unused port in the ephemeral port range.+-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers.+findFreePort :: (MonadIO m, MonadCatch m) => m (Maybe PortNumber)+findFreePort = findFreePortInRange ephemeralPortRange []++-- | Find a free port in the ephemeral range, throwing an exception if one isn't found.+findFreePortOrException :: (MonadIO m, MonadCatch m) => m PortNumber+findFreePortOrException = findFreePortOrException' (const True)++-- | Same as 'findFreePortOrException', but with a callback to test if the port is acceptable or not.+findFreePortOrException' :: (MonadIO m, MonadCatch m) => (PortNumber -> Bool) -> m PortNumber+findFreePortOrException' isAcceptable = findFreePort >>= \case+  Just port+    | isAcceptable port -> return port+    | otherwise -> findFreePortOrException' isAcceptable+  Nothing -> error "Couldn't find free port"++-- | Find an unused port in a given range, excluding certain ports.+-- If the retries time out, returns 'Nothing'.+findFreePortInRange :: (+  MonadIO m, MonadCatch m+  )+  -- | Candidate port range+  => (PortNumber, PortNumber)+  -- | Ports to exclude+  -> [PortNumber]+  -> m (Maybe PortNumber)+findFreePortInRange = findFreePortInRange' (limitRetries 50)++-- | Same as 'findFreePortInRange', but with a configurable retry policy.+findFreePortInRange' :: forall m. (+  MonadIO m, MonadCatch m+  )+  -- | Retry policy+  => RetryPolicy+  -- | Candidate port range+  -> (PortNumber, PortNumber)+  -- | Ports to exclude+  -> [PortNumber]+  -> m (Maybe PortNumber)+findFreePortInRange' retryPolicy (start, end) blacklist = retrying retryPolicy callback (const findFreePortInRange')+  where+    callback _retryStatus result = return $ isNothing result++    getAcceptableCandidate :: m PortNumber+    getAcceptableCandidate = do+      candidate <- liftIO (fromInteger <$> randomRIO (fromIntegral start, fromIntegral end))+      if | candidate `elem` blacklist -> getAcceptableCandidate+         | otherwise -> return candidate++    findFreePortInRange' :: m (Maybe PortNumber)+    findFreePortInRange' = do+      candidate <- getAcceptableCandidate+      isPortFree candidate >>= \case+        False -> return Nothing+        True -> return $ Just candidate++-- | Test if a given 'PortNumber' is currently available.+isPortFree :: (MonadIO m, MonadCatch m) => PortNumber -> m Bool+isPortFree candidate = catch (tryOpenAndClosePort candidate >> return True)+                             (\(_ :: SomeException) -> return False)++-- | Test a given 'PortNumber' availability by trying to open and close a socket on it.+-- Throws an exception on failure.+tryOpenAndClosePort :: MonadIO m => PortNumber -> m PortNumber+tryOpenAndClosePort port = liftIO $ do+  sock <- socket AF_INET Stream 0+  setSocketOption sock ReuseAddr 1+  let hints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }+  getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port) >>= \case+    ((AddrInfo {addrAddress=addr}):_) -> do+      bind sock addr+      close sock+      return $ fromIntegral port+    [] -> error "Couldn't resolve address 127.0.0.1"++-- | The ephemeral port range.+-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers.+ephemeralPortRange :: (PortNumber, PortNumber)+ephemeralPortRange = (49152, 65535)
+ lib/Test/Sandwich/Contexts/Util/SocketUtil.hs view
@@ -0,0 +1,43 @@+module Test.Sandwich.Contexts.Util.SocketUtil (+  isPortOpen+  , simpleSockAddr+  ) where++-- Taken from+-- https://stackoverflow.com/questions/39139787/i-want-to-check-whether-or-not-a-certain-port-is-open-haskell+-- https://gist.github.com/nh2/0a1442eb71ec0405a1e3ce83a467dfde#file-socketutils-hs++import Foreign.C.Error (Errno(..), eCONNREFUSED)+import GHC.IO.Exception (IOException(..))+import Network.Socket (Family(AF_INET), PortNumber, SocketType(Stream), SockAddr(SockAddrInet), socket, connect, close', tupleToHostAddress)+import Relude+import UnliftIO.Exception++-- | Checks whether @connect()@ to a given TCPv4 `SockAddr` succeeds or+-- returns `eCONNREFUSED`.+--+-- Rethrows connection exceptions in all other cases (e.g. when the host+-- is unroutable).+isPortOpen :: SockAddr -> IO Bool+isPortOpen sockAddr = do+  bracket (socket AF_INET Stream 6 {- TCP -}) close' $ \sock -> do+    res <- try $ connect sock sockAddr+    case res of+      Right () -> return True+      Left e ->+        if (Errno <$> ioe_errno e) == Just eCONNREFUSED+          then return False+          else throwIO e+++-- | Creates a `SockAttr` from host IP and port number.+--+-- Example:+-- > simpleSockAddr (127,0,0,1) 8000+simpleSockAddr :: (Word8, Word8, Word8, Word8) -> PortNumber -> SockAddr+simpleSockAddr addr port = SockAddrInet port (tupleToHostAddress addr)+++-- Example usage:+-- > isPortOpen (simpleSockAddr (127,0,0,1) 8000)+-- True
+ lib/Test/Sandwich/Contexts/Util/UUID.hs view
@@ -0,0 +1,25 @@++module Test.Sandwich.Contexts.Util.UUID (+  makeUUID+  , makeUUID'+  ) where++import qualified Data.List as L+import Data.Text as T+import Relude+import qualified System.Random as R+++makeUUID :: MonadIO m => m T.Text+makeUUID = makeUUID' 8++makeUUID' :: MonadIO m => Int -> m T.Text+makeUUID' n = toText <$> (replicateM n ((uuidLetters L.!!) <$> R.randomRIO (0, numUUIDLetters - 1)))+  where+    -- Note: for a UUID to appear in a Kubernetes name, it needs to match this regex+    -- [a-z0-9]([-a-z0-9]*[a-z0-9])?(\.[a-z0-9]([-a-z0-9]*[a-z0-9])?)*'+    uuidLetters :: [Char]+    uuidLetters = ['a'..'z'] ++ ['0'..'9']++    numUUIDLetters :: Int+    numUUIDLetters = L.length uuidLetters
+ sandwich-contexts.cabal view
@@ -0,0 +1,128 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:           sandwich-contexts+version:        0.3.0.0+synopsis:       Contexts for the Sandwich test library+description:    Please see the <https://codedownio.github.io/sandwich documentation>.+author:         Tom McLaughlin+maintainer:     tom@codedown.io+copyright:      2024 Tom McLaughlin+license:        BSD3+build-type:     Simple++library+  exposed-modules:+      Test.Sandwich.Contexts.Container+      Test.Sandwich.Contexts.FakeSmtpServer+      Test.Sandwich.Contexts.Files+      Test.Sandwich.Contexts.HttpWaits+      Test.Sandwich.Contexts.Nix+      Test.Sandwich.Contexts.PostgreSQL+      Test.Sandwich.Contexts.Types.Network+      Test.Sandwich.Contexts.Types.S3+      Test.Sandwich.Contexts.Util.Ports+  other-modules:+      Test.Sandwich.Contexts.FakeSmtpServer.Derivation+      Test.Sandwich.Contexts.Files.Types+      Test.Sandwich.Contexts.ReverseProxy.TCP+      Test.Sandwich.Contexts.Util.Aeson+      Test.Sandwich.Contexts.Util.Nix+      Test.Sandwich.Contexts.Util.SocketUtil+      Test.Sandwich.Contexts.Util.UUID+      Paths_sandwich_contexts+  hs-source-dirs:+      lib+  default-extensions:+      OverloadedStrings+      QuasiQuotes+      NamedFieldPuns+      RecordWildCards+      ScopedTypeVariables+      LambdaCase+      MultiWayIf+      ViewPatterns+      TupleSections+      FlexibleContexts+      NoImplicitPrelude+      NumericUnderscores+  ghc-options: -Wunused-packages -Wall+  build-depends:+      HTTP+    , aeson+    , base >=4.11 && <5+    , conduit+    , conduit-extra+    , containers+    , exceptions+    , filepath+    , http-client+    , http-conduit+    , http-types+    , monad-logger+    , mtl+    , network+    , process+    , random+    , relude+    , retry+    , safe+    , sandwich >=0.3.0.0+    , streaming-commons+    , string-interpolate+    , temporary+    , text+    , time+    , transformers+    , unix-compat+    , unliftio+    , unliftio-core+    , vector+  default-language: Haskell2010+  if impl(ghc >= 9.6)+    build-depends:+        crypton-connection+      , data-default+  if impl(ghc < 9.6)+    build-depends:+        connection++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Spec+      Spec.Nix+      Spec.NixContexts.PostgreSQL+      Paths_sandwich_contexts+  hs-source-dirs:+      test+  default-extensions:+      OverloadedStrings+      QuasiQuotes+      NamedFieldPuns+      RecordWildCards+      ScopedTypeVariables+      LambdaCase+      MultiWayIf+      ViewPatterns+      TupleSections+      FlexibleContexts+      NoImplicitPrelude+      NumericUnderscores+  ghc-options: -Wunused-packages -Wall -Wall -rtsopts -threaded+  build-tool-depends:+      sandwich:sandwich-discover+  build-depends:+      base >=4.11 && <5+    , filepath+    , postgresql-simple+    , relude+    , sandwich >=0.3.0.0+    , sandwich-contexts+    , string-interpolate+    , unliftio+  default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,11 @@++module Main where++import Relude+import qualified Spec+import Test.Sandwich+++main :: IO ()+main = runSandwichWithCommandLineArgs defaultOptions $+  Spec.tests
+ test/Spec.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -F -pgmF sandwich-discover #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++module Spec where++import Test.Sandwich++#insert_test_imports+++tests :: TopSpec+tests = $(getSpecFromFolder defaultGetSpecFromFolderOptions)++-- testsPooled :: PooledSpec+-- testsPooled = $(getSpecFromFolder $ defaultGetSpecFromFolderOptions {+--   getSpecCombiner = 'describeParallel+--   , getSpecIndividualSpecHooks = 'poolify+--   , getSpecWarnOnParseError = NoWarnOnParseError+--   })++-- main :: IO ()+-- main = pooledMain (return ()) testsPooled
+ test/Spec/Nix.hs view
@@ -0,0 +1,19 @@+module Spec.Nix where++import Test.Sandwich.Contexts.Nix+import Data.String.Interpolate+import Relude+import System.FilePath+import Test.Sandwich+import UnliftIO.Directory+++tests :: TopSpec+tests = describe "Nix" $ do+  introduceNixContext nixpkgsReleaseDefault $ do+    it "can build a Nix environment with some binaries" $ do+      envPath <- buildNixSymlinkJoin ["hello", "htop"]+      info [i|Got envPath: #{envPath}|]++      doesFileExist (envPath </> "bin" </> "hello") >>= (`shouldBe` True)+      doesFileExist (envPath </> "bin" </> "htop") >>= (`shouldBe` True)
+ test/Spec/NixContexts/PostgreSQL.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}++module Spec.NixContexts.PostgreSQL where++#ifdef mingw32_HOST_OS++import Relude+import Test.Sandwich++tests :: TopSpec+tests = describe "PostgreSQL Nix" $ do+  it "works" pending++#else++import Data.String.Interpolate+import Database.PostgreSQL.Simple (Only(..), connectPostgreSQL, query_)+import Relude+import Test.Sandwich+import Test.Sandwich.Contexts.Nix+import Test.Sandwich.Contexts.PostgreSQL+++tests :: TopSpec+tests = describe "PostgreSQL Nix" $ do+  introduceNixContext nixpkgsReleaseDefault $ do+    introducePostgresUnixSocketViaNix defaultPostgresNixOptions $ do+      it "should have a working postgres Unix socket" $ do+        ctx@(PostgresContext {..}) <- getContext postgres+        info [i|Got context: #{ctx}|]+        selectTwoPlusTwo (encodeUtf8 postgresConnString) >>= (`shouldBe` 4)++++selectTwoPlusTwo :: MonadIO m => ByteString -> m Int+selectTwoPlusTwo connString = liftIO $ do+  conn <- connectPostgreSQL connString+  [Only n] <- query_ conn "select 2 + 2"+  return n+#endif