mirror of
https://github.com/codedownio/sandwich.git
synced 2024-09-19 07:37:25 +03:00
contexts: initial commit
This commit is contained in:
parent
8cdb56f612
commit
81f06c7e2a
8
sandwich-contexts/.dir-locals.el
Normal file
8
sandwich-contexts/.dir-locals.el
Normal file
@ -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"
|
||||
))
|
||||
)))
|
@ -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
|
131
sandwich-contexts/lib/Sandwich/Contexts/Container/PostgreSQL.hs
Normal file
131
sandwich-contexts/lib/Sandwich/Contexts/Container/PostgreSQL.hs
Normal file
@ -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
|
139
sandwich-contexts/lib/Sandwich/Contexts/FakeSmtpServer.hs
Normal file
139
sandwich-contexts/lib/Sandwich/Contexts/FakeSmtpServer.hs
Normal file
@ -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
|
143
sandwich-contexts/lib/Sandwich/Contexts/Nix.hs
Normal file
143
sandwich-contexts/lib/Sandwich/Contexts/Nix.hs
Normal file
@ -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}]; }
|
||||
|]
|
@ -0,0 +1,3 @@
|
||||
-- |
|
||||
|
||||
module Sandwich.Contexts.Nix.CaddyProxy where
|
45
sandwich-contexts/lib/Sandwich/Contexts/Nix/MinIO.hs
Normal file
45
sandwich-contexts/lib/Sandwich/Contexts/Nix/MinIO.hs
Normal file
@ -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
|
185
sandwich-contexts/lib/Sandwich/Contexts/Nix/PostgreSQL.hs
Normal file
185
sandwich-contexts/lib/Sandwich/Contexts/Nix/PostgreSQL.hs
Normal file
@ -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)
|
65
sandwich-contexts/lib/Sandwich/Contexts/Util/Aeson.hs
Normal file
65
sandwich-contexts/lib/Sandwich/Contexts/Util/Aeson.hs
Normal file
@ -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 [] = []
|
125
sandwich-contexts/lib/Sandwich/Contexts/Util/Container.hs
Normal file
125
sandwich-contexts/lib/Sandwich/Contexts/Util/Container.hs
Normal file
@ -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 _ = []
|
13
sandwich-contexts/lib/Sandwich/Contexts/Util/Exception.hs
Normal file
13
sandwich-contexts/lib/Sandwich/Contexts/Util/Exception.hs
Normal file
@ -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
|
29
sandwich-contexts/lib/Sandwich/Contexts/Util/Nix.hs
Normal file
29
sandwich-contexts/lib/Sandwich/Contexts/Util/Nix.hs
Normal file
@ -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
|
70
sandwich-contexts/lib/Sandwich/Contexts/Util/Ports.hs
Normal file
70
sandwich-contexts/lib/Sandwich/Contexts/Util/Ports.hs
Normal file
@ -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)
|
43
sandwich-contexts/lib/Sandwich/Contexts/Util/SocketUtil.hs
Normal file
43
sandwich-contexts/lib/Sandwich/Contexts/Util/SocketUtil.hs
Normal file
@ -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
|
22
sandwich-contexts/lib/Sandwich/Contexts/Util/UUID.hs
Normal file
22
sandwich-contexts/lib/Sandwich/Contexts/Util/UUID.hs
Normal file
@ -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)))
|
137
sandwich-contexts/lib/Sandwich/Contexts/Waits.hs
Normal file
137
sandwich-contexts/lib/Sandwich/Contexts/Waits.hs
Normal file
@ -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
|
86
sandwich-contexts/package.yaml
Normal file
86
sandwich-contexts/package.yaml
Normal file
@ -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
|
119
sandwich-contexts/sandwich-contexts.cabal
Normal file
119
sandwich-contexts/sandwich-contexts.cabal
Normal file
@ -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
|
11
sandwich-contexts/test/Main.hs
Normal file
11
sandwich-contexts/test/Main.hs
Normal file
@ -0,0 +1,11 @@
|
||||
|
||||
module Main where
|
||||
|
||||
import Relude
|
||||
import qualified Spec
|
||||
import Test.Sandwich
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = runSandwichWithCommandLineArgs defaultOptions $
|
||||
Spec.tests
|
25
sandwich-contexts/test/Spec.hs
Normal file
25
sandwich-contexts/test/Spec.hs
Normal file
@ -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
|
19
sandwich-contexts/test/Spec/Nix.hs
Normal file
19
sandwich-contexts/test/Spec/Nix.hs
Normal file
@ -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)
|
27
sandwich-contexts/test/Spec/NixContexts/PostgreSQL.hs
Normal file
27
sandwich-contexts/test/Spec/NixContexts/PostgreSQL.hs
Normal file
@ -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
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user