Introduce HasBaseContextMonad and use it to shorten some signatures

sandwich-contexts-docker/lib/Test/Sandwich/Contexts/Docker/Registry.hs

@@ -116,7 +116,7 @@ withNewDockerRegistry action = do
 -- * Util
 
 pushContainerToRegistryTimed :: (
-  HasCallStack, MonadUnliftIO m, MonadLogger m, MonadReader context m, HasBaseContext context
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   ) => Text -> DockerRegistryContext -> m Text
 pushContainerToRegistryTimed imageName drc = timeAction [i|Pushing docker image '#{imageName}'|] $
   pushContainerToRegistry imageName drc

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/Cluster.hs

@@ -62,7 +62,7 @@ import qualified Test.Sandwich.Contexts.Kubernetes.Util as Util
 
 withForwardKubernetesService :: (
   MonadLoggerIO m, MonadMask m, MonadUnliftIO m, MonadBaseControl IO m
-  , MonadReader context m, HasBaseContext context, HasKubernetesClusterContext context
+  , HasBaseContextMonad context m, HasKubernetesClusterContext context
   ) => Text -> Text -> (URI -> m a) -> m a
 withForwardKubernetesService namespace serviceName action = do
   kcc <- getContext kubernetesCluster
@@ -70,7 +70,7 @@ withForwardKubernetesService namespace serviceName action = do
 
 withForwardKubernetesService' :: (
   MonadLoggerIO m, MonadMask m, MonadUnliftIO m, MonadBaseControl IO m
-  , MonadReader context m, HasBaseContext context
+  , HasBaseContextMonad context m
   ) => KubernetesClusterContext -> Text -> Text -> (URI -> m a) -> m a
 withForwardKubernetesService' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..})}) =
   Minikube.withForwardKubernetesService' kcc minikubeProfileName

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster.hs

@@ -57,13 +57,19 @@ import UnliftIO.Process
 
 data KindClusterOptions = KindClusterOptions {
   kindClusterNumNodes :: Int
+  -- | Extra flags to pass to kind
   , kindClusterExtraFlags :: [Text]
+  -- | Labels to apply to the created containers
   , kindClusterContainerLabels :: Map Text Text
+  -- | An extra host path that will be mounted at "/binary_cache".
+  -- TODO: make this more general, be able to pass arbitrary mounts.
   , kindClusterBinaryCache :: Maybe FilePath
+  -- | Prefix for the generated cluster name
   , kindClusterNamePrefix :: Maybe Text
+  -- | Container driver, eithe "docker" or "podman". Defaults to "docker"
   , kindClusterDriver :: Maybe Text
-  , kindClusterCpus :: Maybe Text
-  , kindClusterMemory :: Maybe Text
+  -- , kindClusterCpus :: Maybe Text
+  -- , kindClusterMemory :: Maybe Text
   }
 defaultKindClusterOptions :: KindClusterOptions
 defaultKindClusterOptions = KindClusterOptions {
@@ -73,8 +79,8 @@ defaultKindClusterOptions = KindClusterOptions {
   , kindClusterBinaryCache = Nothing
   , kindClusterNamePrefix = Nothing
   , kindClusterDriver = Nothing
-  , kindClusterCpus = Nothing
-  , kindClusterMemory = Nothing
+  -- , kindClusterCpus = Nothing
+  -- , kindClusterMemory = Nothing
   }
 
 -- * Introduce

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/Images.hs

@@ -21,7 +21,7 @@ import UnliftIO.Temporary
 
 -- | Bracket-style function to load a collection of images into a Kubernetes cluster.
 withLoadImages :: (
-  MonadUnliftIO m, MonadLogger m, MonadReader context m, HasBaseContext context, HasKubernetesClusterContext context
+  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m, HasKubernetesClusterContext context
   )
   -- | Image names
   => [Text]
@@ -36,7 +36,7 @@ withLoadImages images env action = do
 
 -- | Same as 'withLoadImages', but allows you to pass in the 'KubernetesClusterContext', rather than requiring one in context.
 withLoadImages' :: (
-  MonadUnliftIO m, MonadLogger m, MonadReader context m, HasBaseContext context
+  MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   )
   -- | Cluster context
   => KubernetesClusterContext

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KindCluster/ServiceForwardPortForward.hs

@@ -24,7 +24,7 @@ import UnliftIO.Process
 
 withForwardKubernetesService' :: (
   MonadUnliftIO m, MonadCatch m, MonadBaseControl IO m, MonadLoggerIO m
-  , MonadReader context m, HasBaseContext context
+  , HasBaseContextMonad context m
   ) => KubernetesClusterContext -> Text -> Text -> (URI -> m a) -> m a
 withForwardKubernetesService' (KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterKind {..}), ..}) namespace service action = do
   baseEnv <- maybe getEnvironment return kindClusterEnvironment

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlLogs.hs

@@ -27,7 +27,7 @@ data KubectlLogsContext = KubectlLogsContext
 -- | Note that this will stop working if the pod you're talking to goes away (even if you do it against a service)
 -- If this happens, a rerun of the command is needed to resume forwarding
 withKubectlLogs :: (
-  HasBaseContext ctx, MonadReader ctx m, MonadLogger m, MonadFail m, MonadUnliftIO m
+  HasBaseContextMonad ctx m, MonadLogger m, MonadFail m, MonadUnliftIO m
   ) => FilePath -> Text -> Text -> Maybe Text -> Bool -> (KubectlLogsContext -> m a) -> m a
 withKubectlLogs kubeConfigFile namespace target maybeContainer interruptWhenDone action = do
   let args = ["logs", toString target

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/KubectlPortForward.hs

@@ -37,14 +37,14 @@ newtype KubectlPortForwardContext = KubectlPortForwardContext {
 -- * Implementation
 
 withKubectlPortForward :: (
-  HasCallStack, HasBaseContext ctx, MonadReader ctx m, MonadCatch m, MonadLogger m, MonadUnliftIO m
+  HasCallStack, HasBaseContextMonad ctx m, MonadCatch m, MonadLogger m, MonadUnliftIO m
   ) => FilePath -> Text -> Text -> PortNumber -> (KubectlPortForwardContext -> m a) -> m a
 withKubectlPortForward kubeConfigFile namespace = withKubectlPortForward' kubeConfigFile namespace (const True) Nothing
 
 -- | Note that this will stop working if the pod you're talking to goes away (even if you do it against a service)
 -- If this happens, a rerun of the command is needed to resume forwarding
 withKubectlPortForward' :: (
-  HasCallStack, HasBaseContext ctx, MonadReader ctx m, MonadCatch m, MonadLogger m, MonadUnliftIO m
+  HasCallStack, HasBaseContextMonad ctx m, MonadCatch m, MonadLogger m, MonadUnliftIO m
   ) => FilePath -> Text -> (PortNumber -> Bool) -> Maybe PortNumber -> Text -> PortNumber -> (KubectlPortForwardContext -> m a) -> m a
 withKubectlPortForward' kubeConfigFile namespace isAcceptablePort maybeHostPort targetName targetPort action = do
   port <- maybe (findFreePortOrException' isAcceptablePort) return maybeHostPort

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster.hs

@@ -102,7 +102,7 @@ introduceMinikubeCluster' minikubeBinary minikubeClusterOptions spec =
 -- * Implementation
 
 withMinikubeCluster :: (
-  MonadReader context m, HasBaseContext context, HasFile context "minikube"
+  HasBaseContextMonad context m, HasFile context "minikube"
   , MonadLoggerIO m, MonadUnliftIO m, MonadFail m
   ) => MinikubeClusterOptions -> (KubernetesClusterContext -> m a) -> m a
 withMinikubeCluster options action = do
@@ -110,7 +110,7 @@ withMinikubeCluster options action = do
   withMinikubeCluster' minikubeBinary options action
 
 withMinikubeCluster' :: (
-  MonadReader context m, HasBaseContext context
+  HasBaseContextMonad context m
   , MonadLoggerIO m, MonadUnliftIO m, MonadFail m
   ) => FilePath -> MinikubeClusterOptions -> (KubernetesClusterContext -> m a) -> m a
 withMinikubeCluster' minikubeBinary options@(MinikubeClusterOptions {..}) action = do
@@ -120,7 +120,7 @@ withMinikubeCluster' minikubeBinary options@(MinikubeClusterOptions {..}) action
   withNewMinikubeCluster minikubeBinary clusterName options action
 
 withNewMinikubeCluster :: (
-  MonadReader context m, HasBaseContext context
+  HasBaseContextMonad context m
   , MonadLoggerIO m, MonadUnliftIO m, MonadFail m
   ) => FilePath -> String -> MinikubeClusterOptions -> (KubernetesClusterContext -> m a) -> m a
 withNewMinikubeCluster minikubeBinary clusterName options@(MinikubeClusterOptions {..}) action = do

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinikubeCluster/Images.hs

@@ -30,7 +30,7 @@ introduceImages images = introduceWith "introduce minikube cluster images" kuber
 
 withLoadImages :: (
   MonadUnliftIO m, MonadLogger m
-  , MonadReader context m, HasBaseContext context, HasKubernetesClusterContext context
+  , HasBaseContextMonad context m, HasKubernetesClusterContext context
   ) => [Text] -> ([Text] -> m a) -> m a
 withLoadImages images action = do
   kcc <- getContext kubernetesCluster
@@ -38,7 +38,7 @@ withLoadImages images action = do
 
 withLoadImages' :: (
   MonadUnliftIO m, MonadLogger m
-  , MonadReader context m, HasBaseContext context
+  , HasBaseContextMonad context m
   ) => KubernetesClusterContext -> [Text] -> ([Text] -> m a) -> m a
 withLoadImages' kcc@(KubernetesClusterContext {kubernetesClusterType=(KubernetesClusterMinikube {..})}) images action = do
   let tweak image = "docker.io/" <> image

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/MinioS3Server.hs

@@ -41,7 +41,7 @@ introduceK8SMinioS3Server kubernetesClusterContext namespace =
 
 withK8SMinioS3Server :: (
   MonadLoggerIO m, MonadMask m, MonadBaseControl IO m, MonadUnliftIO m, MonadFail m
-  , HasBaseContext context, MonadReader context m
+  , HasBaseContextMonad context m
   ) => KubernetesClusterContext -> MinioOperatorContext -> Text -> (TestS3Server -> m [Result]) -> m ()
 withK8SMinioS3Server (KubernetesClusterContext {..}) MinioOperatorContext namespace action = do
   baseEnv <- getEnvironment

sandwich-contexts-kubernetes/lib/Test/Sandwich/Contexts/Kubernetes/SeaweedFS.hs

@@ -47,14 +47,14 @@ introduceSeaweedFSCluster :: (
 introduceSeaweedFSCluster namespace options = introduceWith "introduce SeaweedFS" seaweedFs (void . withSeaweedFS namespace options)
 
 withSeaweedFS :: forall context m a. (
-  HasCallStack, MonadFail m, MonadLoggerIO m, MonadReader context m, MonadUnliftIO m, HasBaseContext context, HasKubernetesClusterContext context
+  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m, HasKubernetesClusterContext context
   ) => Text -> SeaweedFSOptions -> (SeaweedFSContext -> m a) -> m a
 withSeaweedFS namespace options action = do
   kcc <- getContext kubernetesCluster
   withSeaweedFS' kcc namespace options action
 
 withSeaweedFS' :: forall context m a. (
-  HasCallStack, MonadFail m, MonadLoggerIO m, MonadReader context m, MonadUnliftIO m, HasBaseContext context
+  HasCallStack, MonadFail m, MonadLoggerIO m, MonadUnliftIO m, HasBaseContextMonad context m
   ) => KubernetesClusterContext -> Text -> SeaweedFSOptions -> (SeaweedFSContext -> m a) -> m a
 withSeaweedFS' kcc@(KubernetesClusterContext {kubernetesClusterKubeConfigPath}) namespace options action = do
   baseEnv <- getEnvironment

sandwich-contexts-minio/lib/Test/Sandwich/Contexts/MinIO.hs

@@ -97,7 +97,7 @@ introduceMinIOViaNix options = introduceBinaryViaNixPackage @"minio" "minio" .
   introduceWith "MinIO S3 server (via Nix binary)" testS3Server (withMinIOViaBinary options)
 
 withMinIOViaBinary :: (
-  MonadReader context m, HasBaseContext context, HasFile context "minio"
+  HasBaseContextMonad context m, HasFile context "minio"
   , MonadLoggerIO m, MonadMask m, MonadUnliftIO m
   ) => MinIOContextOptions -> (TestS3Server -> m [Result]) -> m ()
 withMinIOViaBinary options action = do
@@ -105,7 +105,7 @@ withMinIOViaBinary options action = do
   withMinIO minioPath options action
 
 withMinIO :: (
-  MonadReader context m, HasBaseContext context
+  HasBaseContextMonad context m
   , MonadLoggerIO m, MonadMask m, MonadUnliftIO m
   ) => FilePath -> MinIOContextOptions -> (TestS3Server -> m [Result]) -> m ()
 withMinIO minioPath (MinIOContextOptions {..}) action = do
@@ -182,7 +182,7 @@ introduceMinIOViaContainer options = introduceWith "MinIO S3 server (via contain
   withMinIOContainer options action
 
 withMinIOContainer :: (
-  MonadReader context m, HasBaseContext context
+  HasBaseContextMonad context m
   , MonadLoggerIO m, MonadMask m, MonadUnliftIO m
   ) => MinIOContextOptions -> (TestS3Server -> m [Result]) -> m ()
 withMinIOContainer (MinIOContextOptions {..}) action = do

sandwich-contexts/lib/Test/Sandwich/Contexts/Files.hs

@@ -164,7 +164,7 @@ introduceBinaryViaNixPackage' proxy packageName = introduce [i|#{symbolVal proxy
 
 -- | Bracket-style version of 'introduceBinaryViaNixPackage'.
 withBinaryViaNixPackage :: forall a b context m. (
-  MonadReader context m, HasBaseContext context, HasNixContext context
+  HasBaseContextMonad context m, HasNixContext context
   , MonadUnliftIO m, MonadLoggerIO m, MonadFail m, KnownSymbol a
   ) =>
     -- | Nix package name which contains the desired binary.

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

@@ -113,7 +113,7 @@ introduceNixContext nixpkgsDerivation = introduce "Introduce Nix context" nixCon
 -- These packages are mashed together using the Nix "symlinkJoin" function. Their binaries will generally
 -- be found in "\<environment path\>\/bin".
 introduceNixEnvironment :: (
-  MonadReader context m, HasBaseContext context, HasNixContext context
+  HasBaseContextMonad context m, HasNixContext context
   , MonadUnliftIO m
   )
   -- | List of package names to include in the Nix environment
@@ -124,7 +124,7 @@ introduceNixEnvironment packageNames = introduce "Introduce Nix environment" nix
 
 -- | Build a Nix environment, as in 'introduceNixEnvironment'.
 buildNixSymlinkJoin :: (
-  MonadReader context m, HasBaseContext context, HasNixContext context
+  HasBaseContextMonad context m, HasNixContext context
   , MonadUnliftIO m, MonadLogger m, MonadFail m
   )
   -- | Package names
@@ -137,7 +137,7 @@ buildNixSymlinkJoin packageNames = do
 -- Nix "callPackage" design pattern. I.e.
 -- "{ git, gcc, stdenv, ... }: stdenv.mkDerivation {...}"
 buildNixCallPackageDerivation :: (
-  MonadReader context m, HasBaseContext context, HasNixContext context
+  HasBaseContextMonad context m, HasNixContext context
   , MonadUnliftIO m, MonadLogger m, MonadFail m
   )
   -- | Nix derivation
@@ -165,7 +165,7 @@ buildNixCallPackageDerivation derivation = do
 -- These packages are mashed together using the Nix "symlinkJoin" function. Their binaries will generally
 -- be found in "\<environment path\>\/bin".
 buildNixExpression :: (
-  MonadReader context m, HasBaseContext context, HasNixContext context
+  HasBaseContextMonad context m, HasNixContext context
   , MonadUnliftIO m, MonadLogger m, MonadFail m
   )
   -- | Nix expression

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

@@ -115,7 +115,7 @@ introducePostgresViaNix opts = introduceWith "PostgreSQL via Nix" postgres $ \ac
 
 -- | Bracket-style variant of 'introducePostgresViaNix'.
 withPostgresViaNix :: (
-  MonadReader context m, HasBaseContext context, HasNixContext context
+  HasBaseContextMonad context m, HasNixContext context
   , MonadUnliftIO m, MonadMask m, MonadFail m, MonadLogger m
   )
   -- | Options
@@ -156,7 +156,7 @@ introducePostgresUnixSocketViaNix opts@(PostgresNixOptions {..}) = introduceWith
 
 -- | Bracket-style variant of 'introducePostgresUnixSocketViaNix'.
 withPostgresUnixSocketViaNix :: (
-  MonadReader context m, HasBaseContext context, HasNixContext context
+  HasBaseContextMonad context m, HasNixContext context
   , MonadUnliftIO m, MonadFail m, MonadMask m, MonadLogger m
   )
   -- | Options
@@ -268,7 +268,7 @@ introducePostgresViaContainer opts = introduceWith "PostgreSQL via container" po
 
 -- | Bracket-style variant of 'introducePostgresViaContainer'.
 withPostgresContainer :: (
-  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadMask m, MonadReader context m, HasBaseContext context
+  HasCallStack, MonadUnliftIO m, MonadLoggerIO m, MonadMask m, HasBaseContextMonad context m
   )
   -- | Options
   => PostgresContainerOptions
@@ -285,7 +285,7 @@ withPostgresContainer options action = do
           (waitForPostgresDatabase options >=> action)
 
 createPostgresDatabase :: (
-  HasCallStack, MonadUnliftIO m, MonadLogger m, MonadReader context m, HasBaseContext context
+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m
   ) => PostgresContainerOptions -> m (Text, ProcessHandle)
 createPostgresDatabase (PostgresContainerOptions {..}) = timeAction "create Postgres database" $ do
   containerName <- maybe (("postgres-" <>) <$> makeUUID) return postgresContainerContainerName

sandwich/src/Test/Sandwich/Contexts.hs

@@ -23,13 +23,13 @@ getContextMaybe = asks . getLabelValueMaybe
 
 -- | Get the root folder of the on-disk test tree for the current run.
 -- Will be 'Nothing' if the run isn't configured to use the disk.
-getRunRoot :: (HasBaseContext context, MonadReader context m) => m (Maybe FilePath)
+getRunRoot :: (HasBaseContextMonad context m) => m (Maybe FilePath)
 getRunRoot = asks (baseContextRunRoot . getBaseContext)
 
 -- | Get the on-disk folder corresponding to the current node.
 -- Will be 'Nothing' if the run isn't configured to use the disk, or if the current node is configured
 -- not to create a folder.
-getCurrentFolder :: (HasBaseContext context, MonadReader context m) => m (Maybe FilePath)
+getCurrentFolder :: (HasBaseContextMonad context m) => m (Maybe FilePath)
 getCurrentFolder = asks (baseContextPath . getBaseContext)
 
 -- | Get the command line options, if configured.

sandwich/src/Test/Sandwich/Interpreters/StartTree.hs

@@ -11,7 +11,6 @@ module Test.Sandwich.Interpreters.StartTree (
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
 import Control.Concurrent.STM
-import UnliftIO.Exception
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger
@@ -41,6 +40,7 @@ import Test.Sandwich.Types.RunTree
 import Test.Sandwich.Types.Spec
 import Test.Sandwich.Types.TestTimer
 import Test.Sandwich.Util
+import UnliftIO.Exception
 
 
 baseContextFromCommon :: RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext

sandwich/src/Test/Sandwich/Misc.hs

@@ -35,6 +35,7 @@ module Test.Sandwich.Misc (
   -- * Context classes
   , BaseContext
   , HasBaseContext
+  , HasBaseContextMonad
   , HasCommandLineOptions
 
   -- * Result types

sandwich/src/Test/Sandwich/TestTimer.hs

@@ -35,7 +35,7 @@ type ProfileName = T.Text
 -- * User functions
 
 -- | Time a given action with a given event name. This name will be the "stack frame" of the given action in the profiling results. This function will use the current timing profile name.
-timeAction :: (MonadUnliftIO m, MonadReader context m, HasBaseContext context, HasTestTimer context) => EventName -> m a -> m a
+timeAction :: (MonadUnliftIO m, HasBaseContextMonad context m, HasTestTimer context) => EventName -> m a -> m a
 timeAction eventName action = do
   tt <- asks getTestTimer
   BaseContext {baseContextTestTimerProfile} <- asks getBaseContext

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

@@ -15,6 +15,7 @@ import Control.Monad.Catch
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
+import Control.Monad.Reader
 import qualified Data.ByteString.Char8 as BS8
 import Data.Sequence hiding ((:>))
 import qualified Data.Set as S
@@ -159,6 +160,8 @@ type CoreSpec = Spec BaseContext IO
 
 type TopSpec = forall context. (HasBaseContext context, Typeable context) => SpecFree context IO ()
 
+type HasBaseContextMonad context m = (HasBaseContext context, MonadReader context m)
+
 -- * Specs with command line options provided
 
 commandLineOptions :: Label "commandLineOptions" (CommandLineOptions a)