contexts: initial commit

sandwich-contexts/.dir-locals.el

@@ -0,0 +1,8 @@
+((haskell-mode
+  . (
+     (haskell-process-args-stack-ghci . ("--ghci-options=-ferror-spans" "--no-build" "--no-load"
+                                         "--stack-yaml" "/home/tom/codedown/stack.yaml"
+                                         "codedown-core:lib"
+                                         "codedown-test-contexts:lib"
+                                         ))
+     )))

sandwich-contexts/lib/Sandwich/Contexts/Container/MinioS3Server.hs

@@ -0,0 +1,199 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Sandwich.Contexts.Container.MinioS3Server (
+  introduceContainerMinioS3Server
+  , withContainerMinioS3Server
+  , MinioContextOptions (..)
+  , defaultMinioContextOptions
+
+  , fakeS3Server
+  , FakeS3Server(..)
+  , HasFakeS3Server
+  , HttpMode(..)
+
+  , fakeS3ServerEndpoint
+  , fakeS3TestEndpoint
+  , fakeS3ConnectionInfo
+  ) where
+
+import Control.Monad
+import Control.Monad.Catch (MonadMask)
+import qualified Control.Monad.Catch as MC
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Retry
+import qualified Data.Map as M
+import Data.String.Interpolate
+import Network.HostName
+import Network.Minio
+import Network.Socket (PortNumber)
+import Relude
+import Safe
+import Sandwich.Contexts.Util.Container
+import Sandwich.Contexts.Util.UUID
+import Sandwich.Contexts.Waits
+import System.Exit
+import System.FilePath
+import Test.Sandwich
+import UnliftIO.Directory
+import UnliftIO.Exception
+import UnliftIO.Process
+
+
+-- * Types
+
+fakeS3Server :: Label "fakeS3Server" FakeS3Server
+fakeS3Server = Label
+
+data FakeS3Server = FakeS3Server {
+  fakeS3ServerHostname :: HostName
+  , fakeS3ServerPort :: PortNumber
+  , fakeS3ServerAccessKeyId :: Text
+  , fakeS3ServerSecretAccessKey :: Text
+  , fakeS3Bucket :: Text
+  , fakeS3TestHostname :: HostName
+  , fakeS3TestPort :: PortNumber
+  , fakeS3HttpMode :: HttpMode
+  } deriving (Show, Eq)
+
+data HttpMode = HttpModeHttp | HttpModeHttps | HttpModeHttpsNoValidate
+  deriving (Show, Eq)
+
+type HasFakeS3Server context = HasLabel context "fakeS3Server" FakeS3Server
+
+fakeS3ServerEndpoint :: FakeS3Server -> Text
+fakeS3ServerEndpoint (FakeS3Server {..}) = [i|#{protocol}://#{fakeS3ServerHostname}:#{fakeS3ServerPort}|]
+  where protocol :: Text = if fakeS3HttpMode == HttpModeHttp then "http" else "https"
+
+fakeS3TestEndpoint :: FakeS3Server -> Text
+fakeS3TestEndpoint (FakeS3Server {..}) = [i|#{protocol}://#{fakeS3TestHostname}:#{fakeS3TestPort}|]
+  where protocol :: Text = if fakeS3HttpMode == HttpModeHttp then "http" else "https"
+
+fakeS3ConnectionInfo :: FakeS3Server -> ConnectInfo
+fakeS3ConnectionInfo fakeServ@(FakeS3Server {..}) =
+  fromString (toString (fakeS3TestEndpoint fakeServ))
+  & setCreds (CredentialValue (AccessKey fakeS3ServerAccessKeyId) (SecretKey (fromString (toString fakeS3ServerSecretAccessKey))) Nothing)
+  & (if fakeS3HttpMode == HttpModeHttpsNoValidate then disableTLSCertValidation else id)
+
+data MinioContextOptions = MinioContextOptions {
+  minioContextLabels :: Map Text Text
+  , minioContextContainerName :: Maybe Text
+  , minioContextContainerSystem :: ContainerSystem
+  } deriving (Show, Eq)
+defaultMinioContextOptions :: MinioContextOptions
+defaultMinioContextOptions = MinioContextOptions {
+  minioContextLabels = mempty
+  , minioContextContainerName = Nothing
+  , minioContextContainerSystem = ContainerSystemPodman
+  }
+
+-- * Functions
+
+introduceContainerMinioS3Server :: (
+  HasBaseContext context, MonadMask m, MonadBaseControl IO m, MonadUnliftIO m
+  ) => MinioContextOptions -> SpecFree (LabelValue "fakeS3Server" FakeS3Server :> context) m () -> SpecFree context m ()
+introduceContainerMinioS3Server options = introduceWith "minio S3 server" fakeS3Server $ \action -> do
+  withContainerMinioS3Server options action
+
+withContainerMinioS3Server :: (
+  MonadLoggerIO m, MonadMask m, HasBaseContext context, MonadReader context m, MonadBaseControl IO m, MonadUnliftIO m
+  ) => MinioContextOptions -> (FakeS3Server -> m [Result]) -> m ()
+withContainerMinioS3Server (MinioContextOptions {..}) action = do
+  folder <- getCurrentFolder >>= \case
+    Nothing -> expectationFailure "withContainerMinioS3Server must be run with a run root"
+    Just x -> return x
+
+  let mockDir = folder </> "mock_root"
+  createDirectoryIfMissing True mockDir
+  liftIO $ void $ readCreateProcess (proc "chmod" ["777", mockDir]) "" -- Fix permission problems on GitHub Runners
+
+  let bucket = "bucket1"
+
+  let innerPort = 9000 :: PortNumber
+
+  uuid <- makeUUID
+  let containerName = fromMaybe ("test-s3-" <> uuid) minioContextContainerName
+
+  let labelArgs = case minioContextLabels of
+        x | M.null x -> []
+        xs -> "--label" : [[i|#{k}=#{v}|] | (k, v) <- M.toList xs]
+
+  bracket (do
+              uid <- liftIO getCurrentUID
+
+              let cp = proc (show minioContextContainerSystem) $ [
+                    "run"
+                    , "-d"
+                    , "-p", [i|#{innerPort}|]
+                    , "-v", [i|#{mockDir}:/data|]
+                    , "-u", [i|#{uid}|]
+                    , "--name", toString containerName
+                    ]
+                    <> labelArgs
+                    <> [
+                        "minio/minio:RELEASE.2022-09-25T15-44-53Z"
+                        , "server", "/data", "--console-address", ":9001"
+                    ]
+
+              info [i|Got command: #{cp}"|]
+
+              createProcessWithLogging cp
+          )
+          (\_ -> do
+              void $ liftIO $ readCreateProcess (shell [i|#{minioContextContainerSystem} rm -f --volumes #{containerName}|]) ""
+          )
+          (\p -> do
+              waitForProcess p >>= \case
+                ExitSuccess -> return ()
+                ExitFailure n -> expectationFailure [i|Failed to start Minio container (exit code #{n})|]
+
+              localPort <- containerPortToHostPort minioContextContainerSystem containerName innerPort
+
+              let server@FakeS3Server {..} = FakeS3Server {
+                    fakeS3ServerHostname = "127.0.0.1"
+                    , fakeS3ServerPort = localPort -- TODO: this needs to be innerPort if ever accessed from another container
+                    , fakeS3ServerAccessKeyId = "minioadmin"
+                    , fakeS3ServerSecretAccessKey = "minioadmin"
+                    , fakeS3Bucket = bucket
+                    , fakeS3TestHostname = "127.0.0.1"
+                    , fakeS3TestPort = localPort
+                    , fakeS3HttpMode = HttpModeHttp
+                    }
+
+              -- The minio image seems not to have a healthcheck?
+              -- waitForHealth containerName
+              waitUntilStatusCodeWithTimeout' (1_000_000 * 60 * 5) (2, 0, 0) NoVerify [i|http://#{fakeS3TestHostname}:#{fakeS3TestPort}/minio/health/live|]
+
+              let connInfo :: ConnectInfo = setCreds (CredentialValue "minioadmin" "minioadmin" Nothing) [i|http://#{fakeS3TestHostname}:#{fakeS3TestPort}|]
+              -- Make the test bucket, retrying on ServiceErr
+              let policy = limitRetriesByCumulativeDelay (1_000_000 * 60 * 5) $ capDelay 1_000_000 $ exponentialBackoff 50_000
+              let handlers = [\_ -> MC.Handler (\case (ServiceErr {}) -> return True; _ -> return False)
+                             , \_ -> MC.Handler (\case (MErrService (ServiceErr {})) -> return True; _ -> return False)]
+              debug [i|Starting to try to make bucket at http://#{fakeS3TestHostname}:#{fakeS3TestPort}|]
+              recovering policy handlers $ \retryStatus@(RetryStatus {}) -> do
+                info [i|About to try making S3 bucket with retry status: #{retryStatus}|]
+                liftIO $ doMakeBucket connInfo fakeS3Bucket
+              debug [i|Got Minio S3 server: #{server}|]
+
+              void $ action server
+          )
+
+
+doMakeBucket :: ConnectInfo -> Bucket -> IO ()
+doMakeBucket connInfo bucket = do
+  result <- runMinio connInfo $ do
+    try (makeBucket bucket Nothing) >>= \case
+      Left BucketAlreadyOwnedByYou -> return ()
+      Left e -> throwIO e
+      Right _ -> return ()
+
+  whenLeft_ result throwIO
+
+getCurrentUID :: (HasCallStack, MonadIO m) => m Int
+getCurrentUID = (readMay <$> (readCreateProcess (proc "id" ["-u"]) "")) >>= \case
+  Nothing -> expectationFailure [i|Couldn't parse UID|]
+  Just x -> return x

sandwich-contexts/lib/Sandwich/Contexts/Container/PostgreSQL.hs

@@ -0,0 +1,131 @@
+{-# LANGUAGE GADTs #-}
+
+module Sandwich.Contexts.Container.PostgreSQL (
+  PostgresDatabaseTestContext (..)
+  , withPostgresContainer
+
+  , PostgresContextOptions (..)
+  , defaultPostgresContextOptions
+
+  , createPostgresDatabase
+  , waitForPostgresDatabase
+  ) where
+
+import Control.Monad
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control (MonadBaseControl)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.String.Interpolate
+import qualified Data.Text as T
+import Network.Socket (PortNumber)
+import Relude
+import Sandwich.Contexts.Util.Container
+import Sandwich.Contexts.Util.UUID
+import System.Exit
+import Test.Sandwich
+import UnliftIO.Exception
+import UnliftIO.Process
+
+
+-- * Types
+
+data PostgresContextOptions = PostgresContextOptions {
+  postgresContextUser :: Text
+  , postgresContextPassword :: Text
+  , postgresContextLabels :: Map Text Text
+  , postgresContextContainerName :: Maybe Text
+  , postgresContextContainerSystem :: ContainerSystem
+  , postgresContextImage :: Text
+  } deriving (Show, Eq)
+defaultPostgresContextOptions :: PostgresContextOptions
+defaultPostgresContextOptions = PostgresContextOptions {
+  postgresContextUser = "postgres"
+  , postgresContextPassword = "password"
+  , postgresContextLabels = mempty
+  , postgresContextContainerName = Nothing
+  , postgresContextContainerSystem = ContainerSystemPodman
+  , postgresContextImage = "docker.io/postgres:15"
+  }
+
+data PostgresDatabaseTestContext = PostgresDatabaseTestContext {
+  postgresDatabaseLocalHostname :: Text
+  , postgresDatabaseLocalPort :: PortNumber
+  , postgresDatabaseUsername :: Text
+  , postgresDatabasePassword :: Text
+  , postgresDatabaseDatabase :: Text
+  , postgresDatabaseContainerPort :: PortNumber
+  , postgresDatabaseContainerName :: Text
+  } deriving (Show, Eq)
+
+-- * Functions
+
+withPostgresContainer :: (
+  HasCallStack, MonadUnliftIO m, MonadBaseControl IO m, MonadLoggerIO m, MonadMask m, MonadReader context m, HasBaseContext context
+  ) => PostgresContextOptions -> (PostgresDatabaseTestContext -> m a) -> m a
+withPostgresContainer options action = do
+  bracket (createPostgresDatabase options)
+          (\(containerName, _p) -> timeAction "cleanup Postgres database" $ do
+              info [i|Doing #{postgresContextContainerSystem options} rm -f --volumes #{containerName}|]
+              (exitCode, sout, serr) <-  liftIO $ readCreateProcessWithExitCode (shell [i|#{postgresContextContainerSystem 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, MonadReader context m, HasBaseContext context
+  ) => PostgresContextOptions -> m (Text, ProcessHandle)
+createPostgresDatabase (PostgresContextOptions {..}) = timeAction "create Postgres database" $ do
+  containerName <- maybe (("postgres-" <>) <$> makeUUID) return postgresContextContainerName
+
+  let containerSystem = postgresContextContainerSystem
+  let labelArgs = mconcat [["-l", [i|#{k}=#{v}|]] | (k, v) <- M.toList postgresContextLabels]
+  let args = ["run"
+             , "-d"
+             , "-e", [i|POSTGRES_USER=#{postgresContextUser}|]
+             , "-e", [i|POSTGRES_PASSWORD=#{postgresContextPassword}|]
+             , "-p", "5432"
+             , "--health-cmd", [i|pg_isready -U #{postgresContextUser}|]
+             , "--health-interval=100ms"
+             , "--name", containerName
+             ]
+             <> labelArgs
+             <> [postgresContextImage]
+
+  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
+  ) => PostgresContextOptions -> (Text, ProcessHandle) -> m PostgresDatabaseTestContext
+waitForPostgresDatabase (PostgresContextOptions {..}) (containerName, p) = do
+  containerID <- waitForProcess p >>= \case
+    ExitSuccess -> containerNameToContainerId postgresContextContainerSystem containerName
+    _ -> expectationFailure [i|Failed to start Postgres container.|]
+
+  debug [i|Postgres container ID: #{containerID}|]
+
+  localPort <- containerPortToHostPort postgresContextContainerSystem containerName 5432
+
+  waitForHealth postgresContextContainerSystem containerID
+
+  let pdtc = PostgresDatabaseTestContext {
+        postgresDatabaseLocalHostname = "127.0.0.1"
+        , postgresDatabaseLocalPort = localPort
+        , postgresDatabaseUsername = postgresContextUser
+        , postgresDatabasePassword = postgresContextPassword
+        , postgresDatabaseDatabase = postgresContextUser
+        , postgresDatabaseContainerPort = 5432
+        , postgresDatabaseContainerName = containerName
+        }
+
+  -- TODO: might be a good idea to do this here, rather than wrap a retry around the initial migrate later on
+  -- waitForSimpleQuery pdtc
+
+  return pdtc

sandwich-contexts/lib/Sandwich/Contexts/FakeSmtpServer.hs

@@ -0,0 +1,139 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Sandwich.Contexts.FakeSmtpServer (
+  introduceFakeSmtpServer
+  , withFakeSMTPServer
+  , fakeSmtpServer
+  , FakeSmtpServer(..)
+  , EmailInfo(..)
+
+  , getEmails
+  , authUsername
+  , authPassword
+  ) where
+
+import Sandwich.Contexts.Util.Aeson
+import Sandwich.Contexts.Waits
+import Control.Monad
+import Control.Monad.Catch (MonadMask, MonadThrow)
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Retry
+import qualified Data.Aeson as A
+import qualified Data.Aeson.TH as A
+import Data.String.Interpolate
+import Network.HTTP.Client
+import Network.Socket (PortNumber)
+import Relude
+import System.FilePath
+import System.IO
+import System.Process
+import Test.Sandwich
+import UnliftIO.Directory
+import UnliftIO.Exception
+
+
+-- * Types
+
+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 {
+  fakeSmtpServerSmtpPort :: PortNumber
+  , fakeSmtpServerGetEmails :: forall m. (MonadLoggerIO m, MonadUnliftIO m, MonadThrow m) => m [EmailInfo]
+  }
+
+fakeSmtpServer :: Label "fakeSmtpServer" FakeSmtpServer
+fakeSmtpServer = Label
+
+-- * Functions
+
+introduceFakeSmtpServer :: (
+  HasBaseContext context, MonadMask m, MonadBaseControl IO m, MonadUnliftIO m
+  ) => Bool -> Bool -> SpecFree (LabelValue "fakeSmtpServer" FakeSmtpServer :> context) m () -> SpecFree context m ()
+introduceFakeSmtpServer auth allowInsecureLogin = introduceWith "fake SMTP server" fakeSmtpServer (withFakeSMTPServer auth allowInsecureLogin)
+
+authUsername, authPassword :: Text
+authUsername = "user"
+authPassword = "pass"
+
+withFakeSMTPServer :: (
+  HasBaseContext context, MonadReader context m, MonadLoggerIO m, MonadThrow m, MonadBaseControl IO m, MonadUnliftIO m
+  ) => Bool -> Bool -> (FakeSmtpServer -> m [Result]) -> m ()
+withFakeSMTPServer auth allowInsecureLogin 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"
+
+  bracket (do
+              let authFlag = if auth then ["--auth",  [i|#{authUsername}:#{authPassword}|]] else []
+              let insecureLoginFlag = if allowInsecureLogin then "--allow-insecure-login" else ""
+              createProcessWithLogging ((proc "fake-smtp-server" ([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 auth of
+                    True -> [i|#{authUsername}:#{authPassword}@|] :: Text
+                    False -> ""
+
+              waitUntil200WithTimeout' (1_000_000 * 60 * 2) [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

sandwich-contexts/lib/Sandwich/Contexts/Nix.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Sandwich.Contexts.Nix (
+  -- * Nix contexts
+  introduceNixContext
+  , nixContext
+  , NixContext(..)
+  , HasNixContext
+
+  -- * Nix environments
+  , introduceNixEnvironment
+  , buildNixEnvironment
+  , nixEnvironment
+  , HasNixEnvironment
+
+  -- * Nixpkgs releases
+  , nixpkgsRelease2311
+  , nixpkgsReleaseDefault
+  -- TODO: export smart constructors for this
+  , NixpkgsDerivation(..)
+  ) where
+
+import Control.Monad.Catch (MonadThrow)
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger
+import Data.Aeson as A
+import Data.String.Interpolate
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Relude
+import Sandwich.Contexts.Util.Aeson
+import System.FilePath
+import System.IO.Temp
+import Test.Sandwich
+import UnliftIO.Directory
+import UnliftIO.Process
+
+-- * Types
+
+nixContext :: Label "nixContext" NixContext
+nixContext = Label
+
+data NixContext = NixContext {
+  nixContextNixBinary :: FilePath
+  , nixContextNixpkgsDerivations :: NixpkgsDerivation
+  } deriving (Show, Eq)
+
+type HasNixContext context = HasLabel context "nixContext" NixContext
+
+nixEnvironment :: Label "nixEnvironment" FilePath
+nixEnvironment = Label
+
+type HasNixEnvironment context = HasLabel context "nixEnvironment" FilePath
+
+
+data NixpkgsDerivation =
+  NixpkgsDerivationFetchFromGitHub {
+    nixpkgsDerivationOwner :: Text
+    , nixpkgsDerivationRepo :: Text
+    , nixpkgsDerivationRev :: Text
+    , nixpkgsDerivationSha256 :: Text
+    } deriving (Show, Eq)
+
+-- | 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="
+  }
+
+nixpkgsReleaseDefault :: NixpkgsDerivation
+nixpkgsReleaseDefault = nixpkgsRelease2311
+
+introduceNixContext :: (
+  MonadUnliftIO m, MonadThrow m
+  ) => NixpkgsDerivation -> SpecFree (LabelValue "nixContext" NixContext :> context) m () -> SpecFree context m ()
+introduceNixContext nixpkgsDerivation = introduce "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
+        pure (NixContext p nixpkgsDerivation)
+
+introduceNixEnvironment :: (
+  MonadReader context m, HasBaseContext context, HasNixContext context
+  , MonadUnliftIO m
+  ) => [Text] -> SpecFree (LabelValue "nixEnvironment" FilePath :> context) m () -> SpecFree context m ()
+introduceNixEnvironment packageNames = introduce "Introduce Nix environment" nixEnvironment (buildNixEnvironment packageNames) (const $ return ())
+
+-- | 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".
+buildNixEnvironment :: (
+  MonadReader context m, HasBaseContext context, HasNixContext context
+  , MonadUnliftIO m, MonadLogger m, MonadFail m
+  ) => [Text] -> m FilePath
+buildNixEnvironment packageNames = do
+  Just dir <- getCurrentFolder
+  gcrootDir <- liftIO $ createTempDirectory dir "nix-environment"
+
+  NixContext {..} <- getContext nixContext
+  output <- readCreateProcessWithLogging (
+    proc "nix" ["build"
+               , "--impure"
+               , "--expr", renderNixEnvironment nixContextNixpkgsDerivations packageNames
+               , "-o", gcrootDir </> "gcroot"
+               , "--json"
+               ]
+    ) ""
+
+  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)
+    x -> expectationFailure [i|Couldn't parse Nix build JSON output: #{x} (output was #{output})|]
+
+
+renderNixEnvironment :: NixpkgsDerivation -> [Text] -> String
+renderNixEnvironment (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}]; }
+|]

sandwich-contexts/lib/Sandwich/Contexts/Nix/CaddyProxy.hs

@@ -0,0 +1,3 @@
+-- |
+
+module Sandwich.Contexts.Nix.CaddyProxy where

sandwich-contexts/lib/Sandwich/Contexts/Nix/MinIO.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Sandwich.Contexts.Nix.MinIO (
+  minio
+  , introduceMinio
+
+  , MinioNixOptions
+  , defaultMinioNixOptions
+
+  , MinioContext(..)
+  ) where
+
+import Sandwich.Contexts.Nix
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.IO.Unlift
+import Relude hiding (withFile)
+import Test.Sandwich
+
+-- * Labels
+
+minio :: Label "minio" MinioContext
+minio = Label
+
+-- * Types
+
+data MinioNixOptions = MinioNixOptions {
+
+  }
+defaultMinioNixOptions :: MinioNixOptions
+defaultMinioNixOptions = MinioNixOptions {
+  }
+
+-- TODO: use the same context here as the container version
+data MinioContext = MinioContext {
+  } deriving (Show)
+
+
+introduceMinio :: (
+  HasBaseContext context, HasNixContext context
+  , MonadUnliftIO m, MonadMask m
+  ) => MinioNixOptions -> SpecFree (LabelValue "minio" MinioContext :> context) m () -> SpecFree context m ()
+introduceMinio (MinioNixOptions {}) = introduceWith "Minio via Nix" minio $ \_action -> do
+  undefined

sandwich-contexts/lib/Sandwich/Contexts/Nix/PostgreSQL.hs

@@ -0,0 +1,185 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Sandwich.Contexts.Nix.PostgreSQL (
+  postgres
+  , introducePostgres
+
+  , postgresUnixSocket
+  , introducePostgresUnixSocket
+
+  , PostgresNixOptions
+  , postgresNixPostgres
+  , defaultPostgresNixOptions
+
+  , PostgresContext(..)
+  ) where
+
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger
+import Data.String.Interpolate
+import qualified Data.Text.IO as T
+import Relude hiding (withFile)
+import Sandwich.Contexts.Nix
+import System.Exit
+import System.FilePath
+import System.IO.Temp
+import System.Posix.Files
+import Test.Sandwich
+import UnliftIO.Directory
+import UnliftIO.Environment
+import UnliftIO.Exception
+import UnliftIO.IO (hClose, withFile)
+import UnliftIO.Process
+
+-- * Labels
+
+postgres :: Label "postgres" PostgresContext
+postgres = Label
+
+postgresUnixSocket :: Label "postgresUnixSocket" PostgresContext
+postgresUnixSocket = 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"
+  }
+
+-- TODO: use the same context here as the container version
+data PostgresContext = PostgresContext {
+  postgresUsername :: Text
+  , postgresPassword :: Text
+  , postgresConnString :: Text
+  , postgresDatabase :: Text
+  } deriving (Show)
+
+
+-- 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
+
+introducePostgres :: (
+  HasBaseContext context, HasNixContext context
+  , MonadUnliftIO m, MonadMask m
+  ) => PostgresNixOptions -> SpecFree (LabelValue "postgres" PostgresContext :> context) m () -> SpecFree context m ()
+introducePostgres opts@(PostgresNixOptions {..}) = introduceWith "PostgreSQL via Nix" postgres $ \action -> do
+  nixEnv <- buildNixEnvironment [postgresNixPostgres]
+
+  withPostgresUnixSocket opts nixEnv $ \unixSocket -> do
+    debug [i|Got unix socket: #{unixSocket}|]
+    -- TODO: set up proxy
+    void $ action $ PostgresContext {
+      postgresUsername = postgresNixUsername
+      , postgresPassword = postgresNixPostgres
+      , postgresConnString = [i|postgresql://#{postgresNixUsername}:#{postgresNixPassword}@/#{postgresNixDatabase}?host=#{takeDirectory unixSocket}|]
+      , postgresDatabase = postgresNixDatabase
+      }
+
+introducePostgresUnixSocket :: (
+  HasBaseContext context, HasNixContext context
+  , MonadUnliftIO m, MonadMask m
+  ) => PostgresNixOptions -> SpecFree (LabelValue "postgresUnixSocket" PostgresContext :> context) m () -> SpecFree context m ()
+introducePostgresUnixSocket opts@(PostgresNixOptions {..}) = introduceWith "PostgreSQL via Nix" postgresUnixSocket $ \action -> do
+  nixEnv <- buildNixEnvironment [postgresNixPostgres]
+  withPostgresUnixSocket opts nixEnv $ \unixSocket -> do
+    void $ action $ PostgresContext {
+      postgresUsername = postgresNixUsername
+      , postgresPassword = postgresNixPostgres
+      , postgresConnString = [i|postgresql://#{postgresNixUsername}:#{postgresNixPassword}@/#{postgresNixDatabase}?host=#{takeDirectory unixSocket}|]
+      , postgresDatabase = postgresNixDatabase
+      }
+
+withPostgresUnixSocket :: (
+  MonadReader context m, HasBaseContext context
+  , MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m
+  ) => PostgresNixOptions -> FilePath -> (FilePath -> m a) -> m a
+withPostgresUnixSocket (PostgresNixOptions {..}) nixEnv 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 postgresNixPassword
+            hClose h
+            createProcessWithLogging ((proc (nixEnv </> "bin" </> "initdb") [dbDirName
+                                                                            , "--username", toString postgresNixUsername
+                                                                            , "-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 (nixEnv </> "bin" </> "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 (nixEnv </> "bin" </> "psql") [
+                                        -- "-h", unixSockDir
+                                        -- , "--username", toString postgresNixUsername
+                                        [i|postgresql://#{postgresNixUsername}:#{postgresNixPassword}@/?host=#{unixSockDir}|]
+                                        , "-c", [i|CREATE DATABASE #{postgresNixDatabase};|]
+                                        ]) { 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 (nixEnv </> "bin" </> "pg_ctl") [
+                                                   "-D", dbDirName
+                                                   , "-l", logfileName
+                                                   , "stop" , "--wait"
+                                                   ]) { cwd = Just dir }) ""
+      )
+      (\socketPath -> action socketPath)

sandwich-contexts/lib/Sandwich/Contexts/Util/Aeson.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE CPP #-}
+
+module 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 [] = []

sandwich-contexts/lib/Sandwich/Contexts/Util/Container.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Sandwich.Contexts.Util.Container (
+  ContainerSystem (..)
+
+  , isInContainer
+
+  , containerPortToHostPort
+
+  , containerNameToContainerId
+
+  , readUncompressedImageName
+
+  , waitForHealth
+  ) 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.ByteString.Lazy as BL
+import qualified Data.List as L
+import qualified Data.Map as M
+import Data.String.Interpolate
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Network.Socket (PortNumber)
+import Relude
+import Safe
+import Sandwich.Contexts.Util.Aeson
+import System.Exit
+import System.FilePath
+import Test.Sandwich
+import qualified Text.Show
+import UnliftIO.Process
+
+
+data ContainerSystem = ContainerSystemDocker | ContainerSystemPodman
+  deriving (Eq)
+
+instance Show ContainerSystem where
+  show ContainerSystemDocker = "docker"
+  show ContainerSystemPodman = "podman"
+
+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)
+
+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
+
+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}'|]
+
+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}'.|]
+
+readUncompressedImageName :: (HasCallStack, MonadIO m) => FilePath -> m Text
+readUncompressedImageName path = do
+  contents <- liftIO $ BL.readFile (path </> "manifest.json")
+
+  case A.eitherDecode contents of
+    Left err -> expectationFailure [i|Couldn't decode manifest.json: #{err}|]
+    Right (A.Array entries) -> case concatMap getRepoTags entries of
+      (x:_) -> pure x
+      [] -> expectationFailure [i|Didn't find a repo tag for image at #{path}|]
+    Right x -> expectationFailure [i|Unexpected manifest.json format: #{x}|]
+
+  where
+    getRepoTags :: A.Value -> [Text]
+    getRepoTags (A.Object (aesonLookup "RepoTags" -> Just (A.Array repoItems))) = [t | A.String t <- V.toList repoItems]
+    getRepoTags _ = []

sandwich-contexts/lib/Sandwich/Contexts/Util/Exception.hs

@@ -0,0 +1,13 @@
+
+module Sandwich.Contexts.Util.Exception where
+
+import Control.Monad.IO.Unlift
+import Relude
+import Test.Sandwich.Misc
+import UnliftIO.Exception
+
+
+leftOnException :: (MonadUnliftIO m) => m (Either Text a) -> m (Either Text a)
+leftOnException = handleAny $ \e -> return $ Left $ case fromException e of
+  Just (Reason _ msg) -> toText msg
+  _ -> show e

sandwich-contexts/lib/Sandwich/Contexts/Util/Nix.hs

@@ -0,0 +1,29 @@
+
+module 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

sandwich-contexts/lib/Sandwich/Contexts/Util/Ports.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE RankNTypes #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Sandwich.Contexts.Util.Ports where
+
+import Control.Monad.Catch (MonadCatch, catch)
+import Control.Retry
+import Network.Socket
+import Relude
+import System.Random (randomRIO)
+
+
+-- | Find an unused port in a given range
+findFreePortInRange' :: forall m. (
+  MonadIO m, MonadCatch m
+  ) => RetryPolicy -> (PortNumber, PortNumber) -> [PortNumber] -> m (Maybe PortNumber)
+findFreePortInRange' retryPolicy (start, end) blacklist = retrying retryPolicy (\_retryStatus result -> return $ isNothing result) (const findFreePortInRange')
+  where 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
+
+isPortFree :: (MonadIO m, MonadCatch m) => PortNumber -> m Bool
+isPortFree candidate = catch (tryOpenAndClosePort candidate >> return True)
+                             (\(_ :: SomeException) -> return False)
+
+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"
+
+findFreePortInRange :: (
+  MonadIO m, MonadCatch m
+  ) => (PortNumber, PortNumber) -> [PortNumber] -> m (Maybe PortNumber)
+findFreePortInRange = findFreePortInRange' (limitRetries 50)
+
+-- | Find an unused port in the ephemeral port range.
+-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers
+-- This works without a timeout since there should always be a port in there somewhere;
+-- it might be advisable to wrap in a timeout anyway.
+findFreePort :: (MonadIO m, MonadCatch m) => m (Maybe PortNumber)
+findFreePort = findFreePortInRange (49152, 65535) []
+
+findFreePortOrException :: (MonadIO m, MonadCatch m) => m PortNumber
+findFreePortOrException = findFreePortOrException' (const True)
+
+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"
+
+findFreePortNotIn :: (MonadIO m, MonadCatch m) => [PortNumber] -> m (Maybe PortNumber)
+findFreePortNotIn = findFreePortInRange (49152, 65535)

sandwich-contexts/lib/Sandwich/Contexts/Util/SocketUtil.hs

@@ -0,0 +1,43 @@
+module 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

sandwich-contexts/lib/Sandwich/Contexts/Util/UUID.hs

@@ -0,0 +1,22 @@
+
+module Sandwich.Contexts.Util.UUID where
+
+import qualified Data.List as L
+import Data.Text as T
+import Relude
+import qualified System.Random as R
+
+
+-- 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
+
+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)))

sandwich-contexts/lib/Sandwich/Contexts/Waits.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Sandwich.Contexts.Waits where
+
+import Control.Concurrent
+import qualified Control.Exception.Lifted as EL
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Retry
+import Data.Maybe
+import Data.String.Interpolate
+import Data.Time
+import Data.Typeable
+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 System.Timeout (Timeout)
+import qualified System.Timeout.Lifted as ST
+import Test.Sandwich
+import UnliftIO.Exception
+import UnliftIO.Timeout
+
+
+timePerRequest :: Int
+timePerRequest = 10000000
+
+type WaitConstraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadThrow m)
+
+data VerifyCerts = YesVerify | NoVerify
+  deriving (Eq)
+
+tlsNoVerifySettings :: ManagerSettings
+tlsNoVerifySettings = mkManagerSettings tlsSettings Nothing
+  where
+    tlsSettings = TLSSettingsSimple {
+      settingDisableCertificateValidation = True
+      , settingDisableSession = False
+      , settingUseServerName = False
+      }
+
+-- | Send HTTP requests to 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)
+  ST.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 = EL.handle (\(e :: EL.SomeException) -> return $ Left $ ErrorMisc [i|Exception in waitUntilStatusCode: #{e}|])
+    statusToInt (x, y, z) = 100 * x + 10 * y + z
+
+waitUntil200 :: (WaitConstraints m) => String -> m ()
+waitUntil200 = waitUntilStatusCode (2, 0, 0) YesVerify
+
+-- | Same as waitUntil200, but with a fixed timeout
+waitUntil200WithTimeout :: (WaitConstraints m) => String -> m ()
+waitUntil200WithTimeout = waitUntil200WithTimeout' 30_000_000
+
+-- | Same as waitUntil200WithTimeout, but with a customizable timeout
+waitUntil200WithTimeout' :: (WaitConstraints m) => Int -> String -> m ()
+waitUntil200WithTimeout' timeInMicroseconds url = do
+  maybeSuccess <- ST.timeout timeInMicroseconds $ waitUntil200 url
+  when (isNothing maybeSuccess) $
+    expectationFailure [i|Failed to connect to URL "#{url}" in waitUntil200WithTimeout'...|]
+
+waitUntilStatusCodeWithTimeout :: (WaitConstraints m) => (Int, Int, Int) -> String -> m ()
+waitUntilStatusCodeWithTimeout code = waitUntilStatusCodeWithTimeout' 30000000 code YesVerify
+
+-- | Same as waitUntilStatusCodeWithTimeout, but with a customizable timeout
+waitUntilStatusCodeWithTimeout' :: (WaitConstraints m) => Int -> (Int, Int, Int) -> VerifyCerts -> String -> m ()
+waitUntilStatusCodeWithTimeout' timeInMicroseconds code verifyCerts url = do
+  maybeSuccess <- ST.timeout timeInMicroseconds $ waitUntilStatusCode code verifyCerts url
+  when (isNothing maybeSuccess) $
+    expectationFailure [i|Failed to connect to URL "#{url}" in waitUntilStatusCodeWithTimeout'...|]
+
+
+-- | Keep trying an action up to a timeout while it
+-- a) fails with a FailureReason in the MonadError monad
+waitUntil :: forall m a. (HasCallStack, MonadMask m, MonadUnliftIO m) => Double -> m a -> m a
+waitUntil timeInSeconds action = do
+  startTime <- liftIO getCurrentTime
+
+  recoveringDynamic policy [handleFailureReasonException startTime] $ \_status ->
+    rethrowTimeoutExceptionWithCallStack $
+      timeout (round (timeInSeconds * 1_000_000)) action >>= \case
+        Nothing -> expectationFailure [i|Action timed out in waitUntil|]
+        Just x -> return x
+
+  where
+    policy = capDelay 1_000_000 $ exponentialBackoff 1_000
+
+    handleFailureReasonException startTime _status = Handler $ \(_ :: FailureReason) ->
+      retryUnlessTimedOut startTime
+
+    retryUnlessTimedOut :: UTCTime -> m RetryAction
+    retryUnlessTimedOut startTime = do
+      now <- liftIO getCurrentTime
+      let thresh = secondsToNominalDiffTime (realToFrac timeInSeconds)
+      if | (diffUTCTime now startTime) > thresh -> return DontRetry
+         | otherwise -> return ConsultPolicy
+
+    rethrowTimeoutExceptionWithCallStack :: (HasCallStack) => m a -> m a
+    rethrowTimeoutExceptionWithCallStack = handleSyncOrAsync $ \(e@(SomeException inner)) ->
+      if | Just (_ :: Timeout) <- fromExceptionUnwrap e -> do
+             throwIO $ Reason (Just (popCallStack callStack)) "Timeout in waitUntil"
+         | Just (SyncExceptionWrapper (cast -> Just (SomeException (cast -> Just (SomeAsyncException (cast -> Just (_ :: Timeout))))))) <- cast inner -> do
+             throwIO $ Reason (Just (popCallStack callStack)) "Timeout in waitUntil"
+         | otherwise -> do
+             throwIO e
+
+#if !MIN_VERSION_time(1,9,1)
+secondsToNominalDiffTime :: Pico -> NominalDiffTime
+secondsToNominalDiffTime = realToFrac
+
+nominalDiffTimeToSeconds :: NominalDiffTime -> Pico
+nominalDiffTimeToSeconds = realToFrac
+#endif

sandwich-contexts/package.yaml

@@ -0,0 +1,86 @@
+name: sandwich-contexts
+version: 0.1.0.0
+synopsis: Sandwich test contexts
+description: Please see README.md
+author: Tom McLaughlin
+maintainer: tom@codedown.io
+copyright: 2023 Tom McLaughlin
+dependencies:
+- base
+- sandwich
+- unliftio
+
+default-extensions:
+- OverloadedStrings
+- QuasiQuotes
+- NamedFieldPuns
+- RecordWildCards
+- ScopedTypeVariables
+- LambdaCase
+- MultiWayIf
+- ViewPatterns
+- TupleSections
+- FlexibleContexts
+- NoImplicitPrelude
+- NumericUnderscores
+
+ghc-options:
+- -Wunused-packages # For GHC 8.10.1 and above
+- -Wall
+# - -Wpartial-fields
+# - -Wredundant-constraints # Reports HasCallStack, so keep it off normally
+
+library:
+  source-dirs: lib
+  exposed-modules:
+  - Sandwich.Contexts.FakeSmtpServer
+  - Sandwich.Contexts.Container.MinioS3Server
+  - Sandwich.Contexts.Container.PostgreSQL
+  - Sandwich.Contexts.Nix
+  - Sandwich.Contexts.Nix.PostgreSQL
+  - Sandwich.Contexts.Waits
+  dependencies:
+  - aeson
+  - bytestring
+  - containers
+  - crypton-connection
+  - exceptions
+  - filepath
+  - hostname
+  - http-client
+  - http-conduit
+  - http-types
+  - HTTP
+  - lifted-base
+  - minio-hs
+  - monad-control
+  - monad-logger
+  - mtl
+  - network
+  - process
+  - random
+  - relude
+  - retry
+  - safe
+  - string-interpolate
+  - temporary
+  - text
+  - time
+  - unix
+  - unliftio-core
+  - vector
+
+tests:
+  tests:
+    main: Main.hs
+    source-dirs: test
+    ghc-options:
+    - -Wall
+    - -rtsopts
+    - -threaded
+    dependencies:
+    - filepath
+    - postgresql-simple
+    - relude
+    - sandwich-contexts
+    - string-interpolate

sandwich-contexts/sandwich-contexts.cabal

@@ -0,0 +1,119 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.36.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           sandwich-contexts
+version:        0.1.0.0
+synopsis:       Sandwich test contexts
+description:    Please see README.md
+author:         Tom McLaughlin
+maintainer:     tom@codedown.io
+copyright:      2023 Tom McLaughlin
+build-type:     Simple
+
+library
+  exposed-modules:
+      Sandwich.Contexts.FakeSmtpServer
+      Sandwich.Contexts.Container.MinioS3Server
+      Sandwich.Contexts.Container.PostgreSQL
+      Sandwich.Contexts.Nix
+      Sandwich.Contexts.Nix.PostgreSQL
+      Sandwich.Contexts.Waits
+  other-modules:
+      Sandwich.Contexts.Nix.CaddyProxy
+      Sandwich.Contexts.Nix.MinIO
+      Sandwich.Contexts.Util.Aeson
+      Sandwich.Contexts.Util.Container
+      Sandwich.Contexts.Util.Exception
+      Sandwich.Contexts.Util.Nix
+      Sandwich.Contexts.Util.Ports
+      Sandwich.Contexts.Util.SocketUtil
+      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
+    , bytestring
+    , containers
+    , crypton-connection
+    , exceptions
+    , filepath
+    , hostname
+    , http-client
+    , http-conduit
+    , http-types
+    , lifted-base
+    , minio-hs
+    , monad-control
+    , monad-logger
+    , mtl
+    , network
+    , process
+    , random
+    , relude
+    , retry
+    , safe
+    , sandwich
+    , string-interpolate
+    , temporary
+    , text
+    , time
+    , unix
+    , unliftio
+    , unliftio-core
+    , vector
+  default-language: Haskell2010
+
+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-depends:
+      base
+    , filepath
+    , postgresql-simple
+    , relude
+    , sandwich
+    , sandwich-contexts
+    , string-interpolate
+    , unliftio
+  default-language: Haskell2010

sandwich-contexts/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

sandwich-contexts/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

sandwich-contexts/test/Spec/Nix.hs

@@ -0,0 +1,19 @@
+module Spec.Nix where
+
+import 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 <- buildNixEnvironment ["hello", "htop"]
+      info [i|Got envPath: #{envPath}|]
+
+      doesFileExist (envPath </> "bin" </> "hello") >>= (`shouldBe` True)
+      doesFileExist (envPath </> "bin" </> "htop") >>= (`shouldBe` True)

sandwich-contexts/test/Spec/NixContexts/PostgreSQL.hs

@@ -0,0 +1,27 @@
+
+module Spec.NixContexts.PostgreSQL where
+
+import Sandwich.Contexts.Nix
+import Sandwich.Contexts.Nix.PostgreSQL
+import Data.String.Interpolate
+import Database.PostgreSQL.Simple
+import Relude
+import Test.Sandwich
+
+
+tests :: TopSpec
+tests = describe "PostgreSQL Nix" $ do
+  introduceNixContext nixpkgsReleaseDefault $ do
+    introducePostgresUnixSocket defaultPostgresNixOptions $ do
+      it "should have a working postgres Unix socket" $ do
+        ctx@(PostgresContext {..}) <- getContext postgresUnixSocket
+        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

stack.yaml

@@ -16,6 +16,7 @@ nix:
 
 packages:
 - ./sandwich
+- ./sandwich-contexts
 - ./sandwich-hedgehog
 - ./sandwich-quickcheck
 - ./sandwich-slack
@@ -54,3 +55,7 @@ extra-deps:
 - vty-crossplatform-0.4.0.0
 - vty-unix-0.2.0.0
 - vty-windows-0.2.0.0
+
+# For sandwich-contexts
+- git: https://github.com/codedownio/minio-hs
+  commit: 768665c90321d118fdd3cde2c6ac6c01310d76a0

stack.yaml.lock

@@ -39,6 +39,17 @@ packages:
       size: 2160
   original:
     hackage: vty-windows-0.2.0.0
+- completed:
+    commit: 768665c90321d118fdd3cde2c6ac6c01310d76a0
+    git: https://github.com/codedownio/minio-hs
+    name: minio-hs
+    pantry-tree:
+      sha256: 63fecbf5146f8704eba62c12ba86494f7bc477d8d882e74846ea0d1dfce03a1a
+      size: 4744
+    version: 1.7.0
+  original:
+    commit: 768665c90321d118fdd3cde2c6ac6c01310d76a0
+    git: https://github.com/codedownio/minio-hs
 snapshots:
 - completed:
     sha256: c2e1f24aaacdb9b102211cc79a46de9e906be677d9702ac3aa102bfb8e1fb1c9