diff --git a/lib/Test/Sandwich/Contexts/Container.hs b/lib/Test/Sandwich/Contexts/Container.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Container.hs @@ -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}'.|] diff --git a/lib/Test/Sandwich/Contexts/FakeSmtpServer.hs b/lib/Test/Sandwich/Contexts/FakeSmtpServer.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/FakeSmtpServer.hs @@ -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 diff --git a/lib/Test/Sandwich/Contexts/FakeSmtpServer/Derivation.hs b/lib/Test/Sandwich/Contexts/FakeSmtpServer/Derivation.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/FakeSmtpServer/Derivation.hs @@ -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 +|] diff --git a/lib/Test/Sandwich/Contexts/Files.hs b/lib/Test/Sandwich/Contexts/Files.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Files.hs @@ -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) diff --git a/lib/Test/Sandwich/Contexts/Files/Types.hs b/lib/Test/Sandwich/Contexts/Files/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Files/Types.hs @@ -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) diff --git a/lib/Test/Sandwich/Contexts/HttpWaits.hs b/lib/Test/Sandwich/Contexts/HttpWaits.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/HttpWaits.hs @@ -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 diff --git a/lib/Test/Sandwich/Contexts/Nix.hs b/lib/Test/Sandwich/Contexts/Nix.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Nix.hs @@ -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 {}) = "" + +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 "\\/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 "\\/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 channel to bootstrap +with { + inherit (import () {}) + 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 channel to bootstrap +with { + inherit (import () {}) + fetchgit fetchFromGitHub; +}; + +let + nixpkgs = fetchFromGitHub { + owner = "#{nixpkgsDerivationOwner}"; + repo = "#{nixpkgsDerivationRepo}"; + rev = "#{nixpkgsDerivationRev}"; + sha256 = "#{nixpkgsDerivationSha256}"; + }; + + pkgs = import nixpkgs {}; +in + +pkgs.callPackage #{show derivationPath :: String} {} +|] diff --git a/lib/Test/Sandwich/Contexts/PostgreSQL.hs b/lib/Test/Sandwich/Contexts/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/PostgreSQL.hs @@ -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 @\\/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 diff --git a/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs b/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/ReverseProxy/TCP.hs @@ -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 diff --git a/lib/Test/Sandwich/Contexts/Types/Network.hs b/lib/Test/Sandwich/Contexts/Types/Network.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Types/Network.hs @@ -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) diff --git a/lib/Test/Sandwich/Contexts/Types/S3.hs b/lib/Test/Sandwich/Contexts/Types/S3.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Types/S3.hs @@ -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" diff --git a/lib/Test/Sandwich/Contexts/Util/Aeson.hs b/lib/Test/Sandwich/Contexts/Util/Aeson.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Util/Aeson.hs @@ -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 [] = [] diff --git a/lib/Test/Sandwich/Contexts/Util/Nix.hs b/lib/Test/Sandwich/Contexts/Util/Nix.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Util/Nix.hs @@ -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 diff --git a/lib/Test/Sandwich/Contexts/Util/Ports.hs b/lib/Test/Sandwich/Contexts/Util/Ports.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Util/Ports.hs @@ -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) diff --git a/lib/Test/Sandwich/Contexts/Util/SocketUtil.hs b/lib/Test/Sandwich/Contexts/Util/SocketUtil.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Util/SocketUtil.hs @@ -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 diff --git a/lib/Test/Sandwich/Contexts/Util/UUID.hs b/lib/Test/Sandwich/Contexts/Util/UUID.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Sandwich/Contexts/Util/UUID.hs @@ -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 diff --git a/sandwich-contexts.cabal b/sandwich-contexts.cabal new file mode 100644 --- /dev/null +++ b/sandwich-contexts.cabal @@ -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 . +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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,11 @@ + +module Main where + +import Relude +import qualified Spec +import Test.Sandwich + + +main :: IO () +main = runSandwichWithCommandLineArgs defaultOptions $ + Spec.tests diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/Spec/Nix.hs b/test/Spec/Nix.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Nix.hs @@ -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) diff --git a/test/Spec/NixContexts/PostgreSQL.hs b/test/Spec/NixContexts/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/test/Spec/NixContexts/PostgreSQL.hs @@ -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