diff --git a/aws-secrets/src/AWS/Secrets.hs b/aws-secrets/src/AWS/Secrets.hs index 2f0f1a01..b83eeeac 100644 --- a/aws-secrets/src/AWS/Secrets.hs +++ b/aws-secrets/src/AWS/Secrets.hs @@ -5,7 +5,7 @@ module AWS.Secrets , IsSecret(..) , SecretConfig(..) , arnValue - , envSpecEntries + , envSpec , externalTemplate , fetchStackSecretArn , getSecretValuePolicy @@ -29,9 +29,9 @@ import qualified Data.Text as Text import qualified MIO.Amazonka as AWS import qualified MIO.Log as Log import qualified StackDeploy.Component as StackDeploy -import qualified StackDeploy.EnvSpec -import qualified StackDeploy.Template as StackDeploy -import qualified StackDeploy.Utils +import qualified StackDeploy.EnvSpec as StackDeploy +import qualified StackDeploy.NamedTemplate as StackDeploy +import qualified StackDeploy.Stack as StackDeploy import qualified Stratosphere as CFT import qualified Stratosphere.IAM.Role as IAM.Role import qualified Stratosphere.SecretsManager.Secret as SecretsManager @@ -70,18 +70,12 @@ internalComponent = mempty externalTemplate :: forall a . IsSecret a - => StackDeploy.Template -externalTemplate = - StackDeploy.Template - { name = fromType @"secrets-external" - , .. - } + => StackDeploy.NamedTemplate +externalTemplate + = StackDeploy.mkNamedTemplate (fromType @"secrets-external") + $ (CFT.mkTemplate . CFT.Resources $ mkSecretResource <$> externalSecrets) + { CFT.outputs = pure . CFT.Outputs $ mkExternalOutput <$> externalSecrets } where - stratosphere :: CFT.Template - stratosphere = - (CFT.mkTemplate . CFT.Resources $ mkSecretResource <$> externalSecrets) - { CFT.outputs = pure . CFT.Outputs $ mkExternalOutput <$> externalSecrets } - mkExternalOutput :: a -> CFT.Output mkExternalOutput secret = (mkInternalOutput secret) { CFT.export @@ -147,13 +141,14 @@ secretNameValue namespace name fetchStackSecretArn :: IsSecret a => CF.Stack -> a -> MIO env Text fetchStackSecretArn stack - = liftIO . StackDeploy.Utils.fetchOutput stack . mkInternalOutput + = liftIO . StackDeploy.fetchStackOutput stack . mkInternalOutput readStackSecretValue :: Env env => IsSecret a => CF.Stack -> a -> MIO env Text readStackSecretValue stack secret = readSecretsManagerSecret =<< fetchStackSecretArn stack secret readEnvSecretValue :: (Env env, IsSecret a) => a -> MIO env Text -readEnvSecretValue = readSecretsManagerSecret . convert <=< Environment.getEnv . convert . envArnName +readEnvSecretValue = + readSecretsManagerSecret . convert <=< Environment.getEnv . convertVia @Text . envSpecName readSecretsManagerSecret :: Env env => Text -> MIO env Text readSecretsManagerSecret arn = do @@ -173,14 +168,14 @@ rdsGeneratePostgresqlPassword & CFT.set @"ExcludeCharacters" "/\"@" & CFT.set @"PasswordLength" (CFT.Literal 48) -envArnName :: IsSecret a => a -> Text -envArnName = (<> "_ARN") . Text.toUpper . convert . JSON.camelTo2 '_' . show +envSpecName :: IsSecret a => a -> StackDeploy.EnvSpecName +envSpecName = convertImpure . (<> "_ARN") . Text.toUpper . convert . JSON.camelTo2 '_' . show -envSpecEntries :: IsSecret a => [a] -> [StackDeploy.EnvSpec.Entry] -envSpecEntries = fmap $ \secret -> - StackDeploy.EnvSpec.Entry - { envName = envArnName secret - , envValue = StackDeploy.EnvSpec.StackOutput $ case secretConfig secret of +envSpec :: IsSecret a => [a] -> [StackDeploy.EnvSpec] +envSpec = fmap $ \secret -> + StackDeploy.EnvSpec + { name = envSpecName secret + , value = StackDeploy.EnvSpecStackOutput $ case secretConfig secret of Internal{} -> mkInternalOutput secret External{} -> mkInternalExternalOutput secret } diff --git a/aws-secrets/src/AWS/Secrets/CLI.hs b/aws-secrets/src/AWS/Secrets/CLI.hs index e6ad8710..61ca5812 100644 --- a/aws-secrets/src/AWS/Secrets/CLI.hs +++ b/aws-secrets/src/AWS/Secrets/CLI.hs @@ -13,6 +13,7 @@ import qualified Options.Applicative as CLI import qualified StackDeploy.CLI.Utils as StackDeploy.CLI import qualified StackDeploy.Stack as StackDeploy import qualified System.Exit as System +import qualified UnliftIO.Exception as UnliftIO parserInfo :: forall a env . (Env env, IsSecret a) => CLI.ParserInfo (MIO env System.ExitCode) parserInfo = CLI.info (CLI.helper <*> subcommands) CLI.idm @@ -45,12 +46,15 @@ parserInfo = CLI.info (CLI.helper <*> subcommands) CLI.idm list = traverse_ (liftIO . IO.putStrLn . snakeCase) (secrets @a) printStackSecret action = - evaluate <$> StackDeploy.CLI.instanceSpecNameOption <*> secretNameOption + evaluate <$> StackDeploy.CLI.instanceNameOption <*> secretNameOption where - evaluate instanceSpecName secret = do - stack <- StackDeploy.getExistingStack instanceSpecName - putStrLn =<< action stack secret - pure System.ExitSuccess + evaluate instanceName secret = do + maybe absent present =<< StackDeploy.readCloudFormationStack instanceName + where + absent = UnliftIO.throwString $ "Stack does not exist: " <> convertVia @Text instanceName + present stack = do + putStrLn =<< action stack secret + pure System.ExitSuccess putStrLn :: MonadIO m => Text -> m () putStrLn = liftIO . IO.putStrLn diff --git a/aws-secrets/test/Test.hs b/aws-secrets/test/Test.hs index 9f1e59dd..1bd4c3fe 100644 --- a/aws-secrets/test/Test.hs +++ b/aws-secrets/test/Test.hs @@ -6,8 +6,8 @@ import AWS.Secrets.Prelude import qualified Devtools import qualified StackDeploy.Component as StackDeploy import qualified StackDeploy.EnvSpec as StackDeploy -import qualified StackDeploy.Template as StackDeploy -import qualified StackDeploy.Utils as StackDeploy +import qualified StackDeploy.NamedTemplate as StackDeploy +import qualified StackDeploy.Stratosphere as CFT import qualified Stratosphere as CFT import qualified Stratosphere.IAM.Role as IAM import qualified Stratosphere.Lambda.Function as Lambda @@ -43,7 +43,7 @@ main = liftIO . Tasty.defaultMain . Tasty.testGroup "aws-secrets" $ [ Devtools.testTree $$(Devtools.readDependencies [Devtools.Target "aws-secrets"]) - , StackDeploy.testTree + , StackDeploy.namedTemplateTestTree $ StackDeploy.namedTemplateMapFromList [ internalTemplate , internalTemplateNoExternal , externalTemplate @TestSecret @@ -51,13 +51,13 @@ main = ] where internalTemplate - = StackDeploy.mkTemplate (fromType @"secrets-internal") + = StackDeploy.namedTemplateFromComponents (fromType @"secrets-internal") [ internalComponent @TestSecret , lambdaComponent ] internalTemplateNoExternal - = StackDeploy.mkTemplate (fromType @"secrets-internal-no-external") + = StackDeploy.namedTemplateFromComponents (fromType @"secrets-internal-no-external") [internalComponent @TestSecretNoExternal] lambdaComponent = mempty @@ -65,13 +65,13 @@ main = where lambdaFunction = CFT.resource "TestLambdaFunction" - $ Lambda.mkFunction lambdaFunctionCode (StackDeploy.getAttArn lambdaRole) + $ Lambda.mkFunction lambdaFunctionCode (CFT.getAttArn lambdaRole) & CFT.set @"Environment" - (StackDeploy.lambdaEnvironment $ envSpecEntries [TestExternal, TestInternal]) + (StackDeploy.envSpecToLambdaEnvironment $ envSpec [TestExternal, TestInternal]) lambdaRole = CFT.resource "TestLambdaRole" - $ IAM.mkRole (StackDeploy.assumeRole "lambda.amazonaws.com") + $ IAM.mkRole (CFT.assumeRole "lambda.amazonaws.com") & CFT.set @"Policies" [getSecretValuePolicy [TestExternal, TestInternal]] lambdaFunctionCode :: Lambda.CodeProperty diff --git a/aws-secrets/test/stack-9.4-dependencies.txt b/aws-secrets/test/stack-9.4-dependencies.txt index 5259bb4a..5b7d5e6b 100644 --- a/aws-secrets/test/stack-9.4-dependencies.txt +++ b/aws-secrets/test/stack-9.4-dependencies.txt @@ -163,7 +163,7 @@ socks 0.6.1 source-constraints 0.0.5 split 0.2.3.5 splitmix 0.1.0.5 -stack-deploy 0.0.9 +stack-deploy 0.1.0 stm 2.5.1.0 stratosphere 1.0.0 stratosphere-ecs 1.0.0 diff --git a/aws-temporary-ingress-rule/src/AWS/TemporaryIngressRule.hs b/aws-temporary-ingress-rule/src/AWS/TemporaryIngressRule.hs index f5f9e076..827a0fac 100644 --- a/aws-temporary-ingress-rule/src/AWS/TemporaryIngressRule.hs +++ b/aws-temporary-ingress-rule/src/AWS/TemporaryIngressRule.hs @@ -42,10 +42,10 @@ import qualified Network.IP.Addr as Network import qualified Options.Applicative as CLI import qualified StackDeploy.CLI.Utils as StackDeploy.CLI import qualified StackDeploy.Component as StackDeploy -import qualified StackDeploy.EnvSpec as EnvSpec -import qualified StackDeploy.InstanceSpec +import qualified StackDeploy.EnvSpec as StackDeploy +import qualified StackDeploy.InstanceSpec as StackDeploy import qualified StackDeploy.Stack as StackDeploy -import qualified StackDeploy.Utils +import qualified StackDeploy.Stratosphere as CFT import qualified Stratosphere as CFT import qualified Stratosphere.Events.Rule as Events import qualified Stratosphere.IAM.Role as IAM @@ -90,8 +90,8 @@ authorizeIngressRule IngressConfig{..} stack = do readRequest = do netAddr <- AWS.Checkip.readNetAddr now <- liftIO Time.getCurrentTime - groupId <- liftIO (StackDeploy.Utils.fetchOutput stack securityGroupIdOutput) - port <- read . convert <$> liftIO (StackDeploy.Utils.fetchOutput stack portOutput) + groupId <- liftIO (StackDeploy.fetchStackOutput stack securityGroupIdOutput) + port <- read . convert <$> liftIO (StackDeploy.fetchStackOutput stack portOutput) pure Request{cidr = convert @Text @String $ Network.printNetAddr netAddr, ..} revokeExpiredIngressRules :: forall env . Env env => [Text] -> MIO env () @@ -291,35 +291,39 @@ parserInfo configs = CLI.info (CLI.helper <*> subcommands) CLI.idm "show configuration" <> mkCommand "authorize-all" - (runStack authorizeAll <$> StackDeploy.CLI.instanceSpecNameOption) + (withStack authorizeAll <$> StackDeploy.CLI.instanceNameOption) "authorize all ingress configurations" <> mkCommand "revoke-expired" - (runGroupIds revokeExpiredIngressRules <$> StackDeploy.CLI.instanceSpecNameOption) + (runGroupIds revokeExpiredIngressRules <$> StackDeploy.CLI.instanceNameOption) "revoke expired ingress rules" <> mkCommand "list-expired" - (runGroupIds listExpiredIngressRules <$> StackDeploy.CLI.instanceSpecNameOption) + (runGroupIds listExpiredIngressRules <$> StackDeploy.CLI.instanceNameOption) "list expired ingress rules" printIngressConfigurations = traverse_ (liftIO . IO.putStrLn . convert . show) configs - runStack + withStack :: (CloudFormation.Stack -> MIO env ()) - -> StackDeploy.InstanceSpec.Name + -> StackDeploy.InstanceName -> MIO env System.ExitCode - runStack action instanceSpecName = do - action =<< StackDeploy.getExistingStack instanceSpecName - pure System.ExitSuccess + withStack action instanceName = do + maybe absent present =<< StackDeploy.readCloudFormationStack instanceName + where + absent = UnliftIO.throwString $ "Stack does not exist: " <> convertVia @Text instanceName + present stack = do + action stack + pure System.ExitSuccess runGroupIds :: ([Text] -> MIO env ()) - -> StackDeploy.InstanceSpec.Name + -> StackDeploy.InstanceName -> MIO env System.ExitCode runGroupIds action = - runStack $ \stack -> do + withStack $ \stack -> do groupIds <- traverse - (liftIO . StackDeploy.Utils.fetchOutput stack . (.securityGroupIdOutput)) configs + (liftIO . StackDeploy.fetchStackOutput stack . (.securityGroupIdOutput)) configs action groupIds authorizeAll :: CloudFormation.Stack -> MIO env () @@ -380,7 +384,7 @@ instance AWS.HasResourceMap Environment where bootLambdaExpire :: [IngressConfig] -> IO () bootLambdaExpire ingressConfigurations = do withEnvironment $ do - groupIds <- Text.split (== ',') <$> EnvSpec.loadEnv (groupIdsEnvSpec ingressConfigurations) + groupIds <- Text.split (== ',') <$> StackDeploy.readEnvSpecFromEnvironment (groupIdsEnvSpec ingressConfigurations) AWS.Lambda.Runtime.run (const $ revokeExpiredIngressRules groupIds $> JSON.Null) withEnvironment :: MIO Environment a -> IO a @@ -403,12 +407,11 @@ withEnvironment action = do { Amazonka.logger = logger } -groupIdsEnvSpec :: [IngressConfig] -> EnvSpec.Entry +groupIdsEnvSpec :: [IngressConfig] -> StackDeploy.EnvSpec groupIdsEnvSpec ingressConfigurations - = EnvSpec.Entry - { envName = "TEMPORARY_INGRESS_RULE_GROUP_IDS" - , envValue = EnvSpec.StackOutput $ mkGroupIdsOutput ingressConfigurations - } + = StackDeploy.EnvSpec + (fromType @"TEMPORARY_INGRESS_RULE_GROUP_IDS") + (StackDeploy.EnvSpecStackOutput $ mkGroupIdsOutput ingressConfigurations) mkGroupIdsOutput :: [IngressConfig] -> CFT.Output mkGroupIdsOutput ingressConfigurations @@ -431,8 +434,8 @@ component StackConfig{..} ingressConfigurations = mempty lambdaFunction = CFT.resource (prefix <> "LambdaFunction") - $ Lambda.mkFunction lambdaCode (StackDeploy.Utils.getAttArn lambdaRole) - & CFT.set @"Environment" (EnvSpec.lambdaEnvironment [groupIdsEnvSpec ingressConfigurations]) + $ Lambda.mkFunction lambdaCode (CFT.getAttArn lambdaRole) + & CFT.set @"Environment" (StackDeploy.envSpecToLambdaEnvironment [groupIdsEnvSpec ingressConfigurations]) & CFT.set @"FunctionName" lambdaFunctionName & CFT.set @"Handler" lambdaFunctionHandler & CFT.set @"Runtime" "provided.al2" @@ -440,28 +443,28 @@ component StackConfig{..} ingressConfigurations = mempty lambdaLogGroup = CFT.resource (prefix <> "LogGroup") - $ StackDeploy.Utils.mkLambdaLogGroup lambdaFunctionName + $ CFT.mkLambdaLogGroup lambdaFunctionName lambdaRole = CFT.resource (prefix <> "LambdaRule") - $ IAM.mkRole (StackDeploy.Utils.assumeRole "lambda.amazonaws.com") - & CFT.set @"Policies" [StackDeploy.Utils.mkLambdaLogsPolicy lambdaFunctionName, ingressRulePolicy] + $ IAM.mkRole (CFT.assumeRole "lambda.amazonaws.com") + & CFT.set @"Policies" [CFT.mkLambdaLogsPolicy lambdaFunctionName, ingressRulePolicy] lambdaFunctionName :: CFT.Value Text - lambdaFunctionName = StackDeploy.Utils.mkName $ CFT.Literal prefix + lambdaFunctionName = CFT.mkName $ CFT.Literal prefix lambdaPermission :: CFT.Resource lambdaPermission = CFT.resource (prefix <> "LambdaPermission") $ Lambda.mkPermission "lambda:InvokeFunction" (CFT.toRef lambdaFunction) "events.amazonaws.com" - & CFT.set @"SourceArn" (StackDeploy.Utils.getAttArn eventsRule) + & CFT.set @"SourceArn" (CFT.getAttArn eventsRule) eventsRule :: CFT.Resource eventsRule = CFT.resource logicalName $ Events.mkRule & CFT.set @"Description" (CFT.Literal ("Trigger rule for " <> prefix)) - & CFT.set @"Name" (StackDeploy.Utils.mkName (CFT.Literal logicalName)) + & CFT.set @"Name" (CFT.mkName (CFT.Literal logicalName)) & CFT.set @"ScheduleExpression" (CFT.Literal "rate(1 minute)") & CFT.set @"State" "ENABLED" & CFT.set @"Targets" [lambdaTarget] @@ -469,7 +472,7 @@ component StackConfig{..} ingressConfigurations = mempty logicalName = prefix <> "EventsRule" lambdaTarget = - Events.mkTargetProperty (StackDeploy.Utils.getAttArn lambdaFunction) (CFT.Literal logicalName) + Events.mkTargetProperty (CFT.getAttArn lambdaFunction) (CFT.Literal logicalName) ingressRulePolicy = IAM.mkPolicyProperty diff --git a/aws-temporary-ingress-rule/src/AWS/TemporaryIngressRule/Prelude.hs b/aws-temporary-ingress-rule/src/AWS/TemporaryIngressRule/Prelude.hs index 5da24651..2552b2ea 100644 --- a/aws-temporary-ingress-rule/src/AWS/TemporaryIngressRule/Prelude.hs +++ b/aws-temporary-ingress-rule/src/AWS/TemporaryIngressRule/Prelude.hs @@ -1,5 +1,6 @@ module AWS.TemporaryIngressRule.Prelude (module Exports) where -import Data.Conversions as Exports -import MIO.Core as Exports -import MPrelude as Exports +import Data.Conversions as Exports +import Data.Conversions.FromType as Exports +import MIO.Core as Exports +import MPrelude as Exports diff --git a/aws-temporary-ingress-rule/test/stack-9.4-dependencies.txt b/aws-temporary-ingress-rule/test/stack-9.4-dependencies.txt index 4ffc348e..876b1a19 100644 --- a/aws-temporary-ingress-rule/test/stack-9.4-dependencies.txt +++ b/aws-temporary-ingress-rule/test/stack-9.4-dependencies.txt @@ -178,7 +178,7 @@ socks 0.6.1 source-constraints 0.0.5 split 0.2.3.5 splitmix 0.1.0.5 -stack-deploy 0.0.9 +stack-deploy 0.1.0 stm 2.5.1.0 stratosphere 1.0.0 stratosphere-ecs 1.0.0 diff --git a/stack-9.4.yaml b/stack-9.4.yaml index 5c600a90..cf38c587 100644 --- a/stack-9.4.yaml +++ b/stack-9.4.yaml @@ -10,7 +10,7 @@ extra-deps: - amazonka-sts-2.0 - mprelude - github: mbj/stratosphere - commit: 7c462f2de4369a76df22d4b34b2f3a9e7754c731 + commit: d1b638820ca9fd90f7d5afba535415da47252af5 subdirs: - . - services/ecs diff --git a/stack-9.4.yaml.lock b/stack-9.4.yaml.lock index 4ab2c985..9f96d875 100644 --- a/stack-9.4.yaml.lock +++ b/stack-9.4.yaml.lock @@ -63,107 +63,107 @@ packages: - completed: name: stratosphere pantry-tree: - sha256: 5b56506ebd04c8bdf61e803e0a6049547ca0cb49fed4f6c877e01bb2725caca5 - size: 1112169 - sha256: 2f2cd065af1071679630bb4de341ad8c4c30cb130d7527a5730e4252127c9d83 - size: 2244006 + sha256: 9461aaaf7e8baccf8d129720126179caaee6420d56e34152154689f4c2d847ae + size: 1526810 + sha256: 74ab541d3bfa92fac0c8cda380f3fe2de4cb37dafd78b5c9f2506744d53f36d3 + size: 2937014 subdir: . - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz version: 1.0.0 original: subdir: . - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz - completed: name: stratosphere-ecs pantry-tree: - sha256: 6ee6b94c54497bf2603f9cb30cec6bfd4bdf3cee918274eb4e588918da063226 + sha256: 6dbadbe1590fc976c5cde85f0cb18e57e2a0bae958ff447d3e557018d099dfa8 size: 13226 - sha256: 2f2cd065af1071679630bb4de341ad8c4c30cb130d7527a5730e4252127c9d83 - size: 2244006 + sha256: 74ab541d3bfa92fac0c8cda380f3fe2de4cb37dafd78b5c9f2506744d53f36d3 + size: 2937014 subdir: services/ecs - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz version: 1.0.0 original: subdir: services/ecs - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz - completed: name: stratosphere-events pantry-tree: - sha256: c596c7457035fac103af033eda1f5169a9bd1540e57ebc3c453c4ea07de6c29b + sha256: a217cd6621badf38605e09ce7497709aa4f0a5652bf3c7f58bac329e82438fcf size: 8137 - sha256: 2f2cd065af1071679630bb4de341ad8c4c30cb130d7527a5730e4252127c9d83 - size: 2244006 + sha256: 74ab541d3bfa92fac0c8cda380f3fe2de4cb37dafd78b5c9f2506744d53f36d3 + size: 2937014 subdir: services/events - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz version: 1.0.0 original: subdir: services/events - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz - completed: name: stratosphere-iam pantry-tree: - sha256: 27abc0202f5ae4e57602f6396f6845e19c3904a5c578cad95b00c24a25000964 + sha256: da1e34b72e68f1aef0fbca8680ed1c623def45c6ed2feac25815933d17c86dcb size: 1815 - sha256: 2f2cd065af1071679630bb4de341ad8c4c30cb130d7527a5730e4252127c9d83 - size: 2244006 + sha256: 74ab541d3bfa92fac0c8cda380f3fe2de4cb37dafd78b5c9f2506744d53f36d3 + size: 2937014 subdir: services/iam - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz version: 1.0.0 original: subdir: services/iam - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz - completed: name: stratosphere-lambda pantry-tree: - sha256: f2f2a0451aec3656bc2b4571a08fd8fab156cc483bc65e44a4040e156cbc772e - size: 7795 - sha256: 2f2cd065af1071679630bb4de341ad8c4c30cb130d7527a5730e4252127c9d83 - size: 2244006 + sha256: 1e554f32ec0f522724f15185d7f1c714f39c40e72a4b533c1aae4ca6b309a7dc + size: 8043 + sha256: 74ab541d3bfa92fac0c8cda380f3fe2de4cb37dafd78b5c9f2506744d53f36d3 + size: 2937014 subdir: services/lambda - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz version: 1.0.0 original: subdir: services/lambda - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz - completed: name: stratosphere-logs pantry-tree: - sha256: 017e18db12d5296a48e069bb3c8be0b8a262d27e9e74030cccf9a02a9cfe6c2e + sha256: 9ec2b117d4ea936052e9756fcfcfcb4b804ca52cfb4ada53500b8fd2ef53f72e size: 1083 - sha256: 2f2cd065af1071679630bb4de341ad8c4c30cb130d7527a5730e4252127c9d83 - size: 2244006 + sha256: 74ab541d3bfa92fac0c8cda380f3fe2de4cb37dafd78b5c9f2506744d53f36d3 + size: 2937014 subdir: services/logs - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz version: 1.0.0 original: subdir: services/logs - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz - completed: name: stratosphere-s3 pantry-tree: - sha256: 4d1a621d3adef87f2b808a59ea318ae041927e42cbd073489b7871ca3722b200 - size: 16613 - sha256: 2f2cd065af1071679630bb4de341ad8c4c30cb130d7527a5730e4252127c9d83 - size: 2244006 + sha256: 25ea8cac5e9c4400b433f3ff8b2d26174b0ae3e78db8b03f3f9cdf24737620a7 + size: 16418 + sha256: 74ab541d3bfa92fac0c8cda380f3fe2de4cb37dafd78b5c9f2506744d53f36d3 + size: 2937014 subdir: services/s3 - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz version: 1.0.0 original: subdir: services/s3 - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz - completed: name: stratosphere-secretsmanager pantry-tree: - sha256: ca004cb2d9876f121873baab2f45b1eb77abe0eb2968bab8b28de6810cc63cfb + sha256: 2fee0eb9db2c3d6b02bf0eada7ed492f28c1bde89ad4383af3ccd2292f7e6e6d size: 1408 - sha256: 2f2cd065af1071679630bb4de341ad8c4c30cb130d7527a5730e4252127c9d83 - size: 2244006 + sha256: 74ab541d3bfa92fac0c8cda380f3fe2de4cb37dafd78b5c9f2506744d53f36d3 + size: 2937014 subdir: services/secretsmanager - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz version: 1.0.0 original: subdir: services/secretsmanager - url: https://github.com/mbj/stratosphere/archive/7c462f2de4369a76df22d4b34b2f3a9e7754c731.tar.gz + url: https://github.com/mbj/stratosphere/archive/d1b638820ca9fd90f7d5afba535415da47252af5.tar.gz snapshots: - completed: sha256: abcc4a65c15c7c2313f1a87f01bfd4d910516e1930b99653eef1d2d006515916 diff --git a/stack-9.6.yaml b/stack-9.6.yaml index fac853b7..bf5d8de9 100644 --- a/stack-9.6.yaml +++ b/stack-9.6.yaml @@ -12,7 +12,7 @@ extra-deps: - github: ndmitchell/hlint commit: 505a4d57b972f3ba605ad7a59721cef1f3d98a84 - github: mbj/stratosphere - commit: 7c462f2de4369a76df22d4b34b2f3a9e7754c731 + commit: d1b638820ca9fd90f7d5afba535415da47252af5 subdirs: - . - services/ecs diff --git a/stack-deploy/package.yaml b/stack-deploy/package.yaml index 774f3cb0..0075503e 100644 --- a/stack-deploy/package.yaml +++ b/stack-deploy/package.yaml @@ -1,7 +1,7 @@ _common/package: !include "../common/package.yaml" name: stack-deploy -version: 0.0.9 +version: 0.1.0 synopsis: Utilities around cloudformation templates license: BSD3 @@ -50,3 +50,14 @@ dependencies: tests: test: <<: *test + other-modules: [] + doctest: + dependencies: + - doctest-parallel + main: DocTest.hs + other-modules: [] + source-dirs: test + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N diff --git a/stack-deploy/src/StackDeploy/AWS.hs b/stack-deploy/src/StackDeploy/AWS.hs index 4b0524c9..c5ba7a32 100644 --- a/stack-deploy/src/StackDeploy/AWS.hs +++ b/stack-deploy/src/StackDeploy/AWS.hs @@ -1,16 +1,16 @@ -module StackDeploy.AWS (listResource) where +module StackDeploy.AWS (nestedResourceC) where import Data.Conduit (ConduitT, (.|)) import Data.Conduit.Combinators (concatMap) --- import Network.AWS.Types as Exports import StackDeploy.Prelude import qualified Amazonka import qualified MIO.Amazonka as AWS -listResource +-- | Convert paginator with a nested list item into a paginator of that item +nestedResourceC :: (AWS.Env env, Amazonka.AWSPager a, AWS.Transaction a) => a -> (Amazonka.AWSResponse a -> [b]) -> ConduitT () b (MIO env) () -listResource action map = AWS.paginate action .| concatMap map +nestedResourceC action map = AWS.paginate action .| concatMap map diff --git a/stack-deploy/src/StackDeploy/CLI.hs b/stack-deploy/src/StackDeploy/CLI.hs index 468ab2f2..f5256ec3 100644 --- a/stack-deploy/src/StackDeploy/CLI.hs +++ b/stack-deploy/src/StackDeploy/CLI.hs @@ -1,18 +1,16 @@ module StackDeploy.CLI (parserInfo) where import CLI.Utils +import Control.Applicative (many) import Control.Lens ((.~)) import Data.Conduit ((.|), runConduit) -import Options.Applicative hiding (value) import StackDeploy.CLI.Utils import StackDeploy.Events import StackDeploy.IO import StackDeploy.Parameters import StackDeploy.Prelude -import StackDeploy.Stack import StackDeploy.Types import StackDeploy.Wait -import System.Exit (ExitCode(..)) import qualified Amazonka.CloudFormation.CancelUpdateStack as CF import qualified Amazonka.CloudFormation.DescribeStackEvents as CF @@ -21,159 +19,193 @@ import qualified Data.Attoparsec.Text as Text import qualified Data.ByteString.Lazy as LBS import qualified Data.Char as Char import qualified Data.Conduit.Combinators as Conduit +import qualified Data.Map.Strict as Map import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as Text import qualified MIO.Amazonka as AWS +import qualified Options.Applicative as CLI import qualified StackDeploy.AWS as AWS import qualified StackDeploy.Env as StackDeploy -import qualified StackDeploy.InstanceSpec as InstanceSpec -import qualified StackDeploy.Template as Template +import qualified StackDeploy.InstanceSpec as StackDeploy +import qualified StackDeploy.NamedTemplate as StackDeploy +import qualified StackDeploy.Operation as StackDeploy +import qualified StackDeploy.Stack as StackDeploy +import qualified Stratosphere as CFT +import qualified System.Exit as System parserInfo :: forall env . (AWS.Env env, StackDeploy.Env env) - => InstanceSpec.Provider env - -> ParserInfo (MIO env ExitCode) -parserInfo instanceSpecProvider = wrapHelper commands "stack commands" + => StackDeploy.InstanceSpecMap env + -> CLI.ParserInfo (MIO env System.ExitCode) +parserInfo instanceSpecMap = wrapHelper commands "stack commands" where - commands :: Parser (MIO env ExitCode) - commands = hsubparser + commands :: CLI.Parser (MIO env System.ExitCode) + commands = CLI.hsubparser $ mkCommand "instance" instanceCommands "instance commands" <> mkCommand "spec" specCommands "instance spec commands" <> mkCommand "token" (pure printNewToken) "print a new stack token" <> mkCommand "template" templateCommands "template commands" - instanceCommands :: Parser (MIO env ExitCode) - instanceCommands = hsubparser - $ mkCommand "cancel" (cancel <$> instanceSpecNameOption) "cancel stack update" - <> mkCommand "create" (create <$> instanceSpecNameOption <*> parameters) "create stack" - <> mkCommand "delete" (delete <$> instanceSpecNameOption) "delete stack" - <> mkCommand "events" (events <$> instanceSpecNameOption) "list stack events" - <> mkCommand "list" (pure list) "list stack instances" - <> mkCommand "outputs" (outputs <$> instanceSpecNameOption) "list stack outputs" - <> mkCommand "sync" (sync <$> instanceSpecNameOption <*> parameters) "sync stack with spec" - <> mkCommand "update" (update <$> instanceSpecNameOption <*> parameters) "update existing stack" - <> mkCommand "wait" (wait <$> instanceSpecNameOption <*> tokenParser) "wait for stack operation" - <> mkCommand "watch" (watch <$> instanceSpecNameOption) "watch stack events" - - templateCommands :: Parser (MIO env ExitCode) - templateCommands = hsubparser + instanceCommands :: CLI.Parser (MIO env System.ExitCode) + instanceCommands = CLI.hsubparser + $ mkCommand "cancel" (cancel <$> instanceNameOption) "cancel stack update" + <> mkCommand "create" (create <$> instanceNameOption <*> parameters) "create stack" + <> mkCommand "delete" (delete <$> instanceNameOption) "delete stack" + <> mkCommand "events" (events <$> instanceNameOption) "list stack events" + <> mkCommand "outputs" (outputs <$> instanceNameOption) "list stack outputs" + <> mkCommand "sync" (sync <$> instanceNameOption <*> parameters) "sync stack with spec" + <> mkCommand "update" (update <$> instanceNameOption <*> parameters) "update existing stack" + <> mkCommand "wait" (wait <$> instanceNameOption <*> tokenParser) "wait for stack operation" + <> mkCommand "watch" (watch <$> instanceNameOption) "watch stack events" + + templateCommands :: CLI.Parser (MIO env System.ExitCode) + templateCommands = CLI.hsubparser $ mkCommand "list" (pure listTemplates) "list templates" <> mkCommand "render" (render <$> templateNameOption) "render template" - specCommands :: Parser (MIO env ExitCode) - specCommands = hsubparser + specCommands :: CLI.Parser (MIO env System.ExitCode) + specCommands = CLI.hsubparser $ mkCommand "list" (pure listSpecs) "list stack specifications" - tokenParser :: Parser Token - tokenParser = Token <$> argument str (metavar "TOKEN") + tokenParser :: CLI.Parser Token + tokenParser = Token <$> CLI.argument CLI.str (CLI.metavar "TOKEN") - cancel :: InstanceSpec.Name -> MIO env ExitCode + cancel :: StackDeploy.InstanceName -> MIO env System.ExitCode cancel name = do void . AWS.send . CF.newCancelUpdateStack $ toText name success - create :: InstanceSpec.Name -> Parameters -> MIO env ExitCode - create name params = do - spec <- InstanceSpec.get instanceSpecProvider name params - exitCode =<< perform (OpCreate spec) - - update :: InstanceSpec.Name -> Parameters -> MIO env ExitCode - update name params = do - spec <- InstanceSpec.get instanceSpecProvider name params - stackId <- getExistingStackId name - - exitCode =<< perform (OpUpdate stackId spec) - - sync :: InstanceSpec.Name -> Parameters -> MIO env ExitCode - sync name params = do - spec <- InstanceSpec.get instanceSpecProvider name params - - exitCode - =<< perform . maybe (OpCreate spec) (`OpUpdate` spec) - =<< getStackId name - - wait :: InstanceSpec.Name -> Token -> MIO env ExitCode - wait name token = maybe success (waitForOperation token) =<< getStackId name - - outputs :: InstanceSpec.Name -> MIO env ExitCode - outputs name = do - traverse_ printOutput . fromMaybe [] . (.outputs) =<< getExistingStack name + create :: StackDeploy.InstanceName -> ParameterMap -> MIO env System.ExitCode + create name userParameterMap = do + withInstanceSpec name $ \instanceSpec -> + exitCode =<< StackDeploy.performOperation (OpCreate instanceSpec userParameterMap) + + update :: StackDeploy.InstanceName -> ParameterMap -> MIO env System.ExitCode + update name userParameterMap = do + withInstanceSpec name $ \instanceSpec -> + withExistingStack name $ \existingStack -> + exitCode =<< StackDeploy.performOperation (OpUpdate existingStack instanceSpec userParameterMap) + + sync :: StackDeploy.InstanceName -> ParameterMap -> MIO env System.ExitCode + sync name userParameterMap = do + withInstanceSpec name $ \instanceSpec -> do + exitCode + =<< StackDeploy.performOperation . maybe + (OpCreate instanceSpec userParameterMap) + (\existingStack -> OpUpdate existingStack instanceSpec userParameterMap) + =<< StackDeploy.readExistingStack name + + wait :: StackDeploy.InstanceName -> Token -> MIO env System.ExitCode + wait name token + = withExistingStack name + $ waitForOperation token . (.stackId) + + outputs :: StackDeploy.InstanceName -> MIO env System.ExitCode + outputs name = withExistingStack name $ \existingStack -> do + traverse_ printOutput existingStack.outputs success where printOutput :: CF.Output -> MIO env () printOutput = liftIO . Text.putStrLn . convertText . show - delete :: InstanceSpec.Name -> MIO env ExitCode - delete = maybe success (exitCode <=< perform . OpDelete) <=< getStackId - - list :: MIO env ExitCode - list = do - runConduit $ stackNames .| Conduit.mapM_ say - success + delete :: StackDeploy.InstanceName -> MIO env System.ExitCode + delete name = withExistingStack name $ exitCode <=< StackDeploy.performOperation . OpDelete - listTemplates :: MIO env ExitCode + listTemplates :: MIO env System.ExitCode listTemplates = do - traverse_ - (liftIO . Text.putStrLn . toText . (.name)) - (toList templateProvider) + printList $ Map.keys namedTemplateMap success - listSpecs :: MIO env ExitCode + listSpecs :: MIO env System.ExitCode listSpecs = do - traverse_ - (liftIO . Text.putStrLn . toText . (.name)) - (toList instanceSpecProvider) + printList $ Map.keys instanceSpecMap success - events :: InstanceSpec.Name -> MIO env ExitCode + events :: StackDeploy.InstanceName -> MIO env System.ExitCode events name = do - runConduit $ AWS.listResource req (fromMaybe [] . (.stackEvents)) .| Conduit.mapM_ printEvent + runConduit $ AWS.nestedResourceC req (fromMaybe [] . (.stackEvents)) .| Conduit.mapM_ StackDeploy.printEvent success where req = CF.newDescribeStackEvents & CF.describeStackEvents_stackName .~ pure (toText name) - watch :: InstanceSpec.Name -> MIO env ExitCode - watch name = do - stackId <- getExistingStackId name - void $ pollEvents (defaultPoll stackId) printEvent + watch :: StackDeploy.InstanceName -> MIO env System.ExitCode + watch name = withExistingStack name $ \existingStack -> do + void $ pollEvents (defaultPoll existingStack.stackId) StackDeploy.printEvent success - waitForOperation :: Token -> Id -> MIO env ExitCode + waitForOperation :: Token -> StackId -> MIO env System.ExitCode waitForOperation token stackId = - exitCode =<< waitForAccept RemoteOperation{..} printEvent + exitCode =<< waitForAccept RemoteOperation{..} StackDeploy.printEvent - printNewToken :: MIO env ExitCode + printNewToken :: MIO env System.ExitCode printNewToken = do say =<< newToken success - render :: Template.Name -> MIO env ExitCode - render name = do - template <- Template.get templateProvider name - say . Text.decodeUtf8 . LBS.toStrict $ Template.encode template - success - - success :: MIO env ExitCode - success = pure ExitSuccess + render :: StackDeploy.TemplateName -> MIO env System.ExitCode + render templateName = + maybe + (failure $ "Template not found: " <> convert templateName) + printPretty + (Map.lookup templateName namedTemplateMap) + where + printPretty :: CFT.Template -> MIO env System.ExitCode + printPretty template = do + say + . Text.decodeUtf8 + . LBS.toStrict + $ StackDeploy.stratosphereTemplateEncodePretty template + pure System.ExitSuccess + + success :: MIO env System.ExitCode + success = pure System.ExitSuccess + + failure :: Text -> MIO env System.ExitCode + failure message = do + say message + pure $ System.ExitFailure 1 exitCode = \case RemoteOperationSuccess -> success - RemoteOperationFailure -> pure $ ExitFailure 1 - - templateProvider = InstanceSpec.templateProvider instanceSpecProvider - -parameter :: Parser Parameter -parameter = option - parameterReader - (long "parameter" <> help "Set stack parameter") - -parameterReader :: ReadM Parameter -parameterReader = eitherReader (Text.parseOnly parser . convertText) + RemoteOperationFailure -> failure "Stack operation failed" + + namedTemplateMap = StackDeploy.instanceNamedTemplateMap instanceSpecMap + + withExistingStack + :: StackDeploy.InstanceName + -> (ExistingStack -> MIO env System.ExitCode) + -> MIO env System.ExitCode + withExistingStack instanceName action = + StackDeploy.readExistingStack instanceName >>= + maybe + (failure $ "Stack does not exist: " <> convert instanceName) + action + + withInstanceSpec + :: StackDeploy.InstanceName + -> (StackDeploy.InstanceSpec env -> MIO env System.ExitCode) + -> MIO env System.ExitCode + withInstanceSpec instanceName action = + maybe + (failure $ "Instance spec does not exist: " <> convert instanceName) + action + (Map.lookup instanceName instanceSpecMap) + + + printList :: Conversion Text a => [a] -> MIO env () + printList = traverse_ say + +parameter :: CLI.Parser Parameter +parameter = CLI.option + reader + (CLI.long "parameter" <> CLI.help "Set stack parameter") where + reader = CLI.eitherReader (Text.parseOnly parser . convertText) + parser = do - name <- ParameterName . convertText <$> Text.many1 (Text.satisfy allowChar) + name <- convertFail =<< Text.many1 (Text.satisfy allowChar) Text.skip (== ':') - value <- ParameterValue . convertText <$> Text.many' Text.anyChar + value <- convertFail =<< Text.many' Text.anyChar void Text.endOfInput pure $ Parameter name value @@ -182,5 +214,5 @@ parameterReader = eitherReader (Text.parseOnly parser . convertText) '-' -> True char -> Char.isDigit char || Char.isAlpha char -parameters :: Parser Parameters -parameters = fromList <$> many parameter +parameters :: CLI.Parser ParameterMap +parameters = fromList . fmap (\Parameter{..} -> (name, value)) <$> many parameter diff --git a/stack-deploy/src/StackDeploy/CLI/Utils.hs b/stack-deploy/src/StackDeploy/CLI/Utils.hs index 69bfa95c..38b88c8f 100644 --- a/stack-deploy/src/StackDeploy/CLI/Utils.hs +++ b/stack-deploy/src/StackDeploy/CLI/Utils.hs @@ -1,5 +1,5 @@ module StackDeploy.CLI.Utils - ( instanceSpecNameOption + ( instanceNameOption , templateNameOption ) where @@ -8,20 +8,20 @@ import GHC.TypeLits (KnownSymbol) import Options.Applicative import StackDeploy.Prelude -import qualified StackDeploy.InstanceSpec as InstanceSpec -import qualified StackDeploy.Template as Template +import qualified StackDeploy.InstanceSpec as StackDeploy +import qualified StackDeploy.NamedTemplate as StackDeploy -instanceSpecNameOption :: Parser InstanceSpec.Name -instanceSpecNameOption = +instanceNameOption :: Parser StackDeploy.InstanceName +instanceNameOption = option reader (long "instance" <> metavar "INSTANCE" <> help "Stack instance name") -templateNameOption :: Parser Template.Name +templateNameOption :: Parser StackDeploy.TemplateName templateNameOption = option reader - (long "template" <> metavar "TEMPLATE" <> help "Template name") + (long "template" <> metavar "TEMPLATE_NAME" <> help "Template name") reader :: KnownSymbol a => ReadM (BoundText a) reader = maybeReader (convertMaybe . convert @Text) diff --git a/stack-deploy/src/StackDeploy/Component.hs b/stack-deploy/src/StackDeploy/Component.hs index 45afbab5..9767c8d9 100644 --- a/stack-deploy/src/StackDeploy/Component.hs +++ b/stack-deploy/src/StackDeploy/Component.hs @@ -1,20 +1,28 @@ -module StackDeploy.Component (Component(..), Mappings, mkTemplate) where +module StackDeploy.Component + ( Component(..) + , Mappings + , namedTemplateFromComponents +) where import Data.Foldable (fold) -import Data.Map.Strict (Map) import StackDeploy.Prelude -import qualified Data.Aeson as JSON -import qualified StackDeploy.Template as Template -import qualified Stratosphere +import qualified Data.Aeson as JSON +import qualified StackDeploy.NamedTemplate as StackDeploy +import qualified Stratosphere as CFT type Mappings = Map Text (Map Text JSON.Object) +-- | Template component that can be merged with other components to forma a full template +-- +-- This is intentionally close but not quite a full stratosphere template. +-- Primary use case is to merge together many components, usually defined in separate modules +-- to a full template. data Component = Component { conditions :: JSON.Object - , outputs :: Stratosphere.Outputs - , parameters :: Stratosphere.Parameters - , resources :: Stratosphere.Resources + , outputs :: CFT.Outputs + , parameters :: CFT.Parameters + , resources :: CFT.Resources , mappings :: Map Text (Map Text JSON.Object) } deriving stock (Eq, Show) @@ -37,13 +45,24 @@ instance Monoid Component where , resources = [] } -mkTemplate :: Template.Name -> [Component] -> Template.Template -mkTemplate name components - = Template.mk name - $ (Stratosphere.mkTemplate merged.resources) - & Stratosphere.set @"Conditions" merged.conditions - & Stratosphere.set @"Mappings" merged.mappings - & Stratosphere.set @"Outputs" merged.outputs - & Stratosphere.set @"Parameters" merged.parameters +-- | Construct named template from components +-- >>> import StackDeploy.Prelude +-- >>> import qualified StackDeploy.Component as StackDeploy +-- >>> import qualified Stratosphere as CFT +-- >>> let componentA = mempty { StackDeploy.outputs = [CFT.mkOutput "OutputA" "Value-A"] } +-- >>> let componentB = mempty { StackDeploy.outputs = [CFT.mkOutput "OutputB" "Value-B"] } +-- >>> StackDeploy.namedTemplateFromComponents (fromType @"test") [componentA, componentB] +-- NamedTemplate {name = BoundText "test", template = Template {conditions = Just (fromList []), description = Nothing, formatVersion = Nothing, mappings = Just (fromList []), metadata = Nothing, outputs = Just (Outputs {outputs = [Output {name = "OutputA", condition = Nothing, description = Nothing, value = Literal "Value-A", export = Nothing},Output {name = "OutputB", condition = Nothing, description = Nothing, value = Literal "Value-B", export = Nothing}]}), parameters = Just (Parameters {parameterList = []}), resources = Resources {resourceList = []}}} +namedTemplateFromComponents + :: StackDeploy.TemplateName + -> [Component] + -> StackDeploy.NamedTemplate +namedTemplateFromComponents name components + = StackDeploy.mkNamedTemplate name + $ (CFT.mkTemplate merged.resources) + & CFT.set @"Conditions" merged.conditions + & CFT.set @"Mappings" merged.mappings + & CFT.set @"Outputs" merged.outputs + & CFT.set @"Parameters" merged.parameters where merged = fold components diff --git a/stack-deploy/src/StackDeploy/Env.hs b/stack-deploy/src/StackDeploy/Env.hs index a6270257..456e5316 100644 --- a/stack-deploy/src/StackDeploy/Env.hs +++ b/stack-deploy/src/StackDeploy/Env.hs @@ -5,12 +5,13 @@ import StackDeploy.Prelude import qualified Amazonka.S3.Types as S3 newtype Config env = Config - { getTemplateBucketName :: Maybe (MIO env S3.BucketName) + { readTemplateBucketName :: Maybe (MIO env S3.BucketName) } type Env env = HasField "stackDeployConfig" env (Config env) +-- | Config that does not provide a template bucket name defaultConfig :: Config env defaultConfig = Config - { getTemplateBucketName = empty + { readTemplateBucketName = empty } diff --git a/stack-deploy/src/StackDeploy/EnvSpec.hs b/stack-deploy/src/StackDeploy/EnvSpec.hs index c5f133b3..a982b06e 100644 --- a/stack-deploy/src/StackDeploy/EnvSpec.hs +++ b/stack-deploy/src/StackDeploy/EnvSpec.hs @@ -1,113 +1,194 @@ module StackDeploy.EnvSpec - ( Entry(..) - , Value(..) - , ecsTaskDefinitionEnvironment - , lambdaEnvironment - , loadEnv - , loadStack - , posixEnv + ( EnvSpec(..) + , EnvSpecName + , EnvSpecValue(..) + , envSpecToEcsTaskDefinitionEnvironment + , envSpecToLambdaEnvironment + , envSpecToPosixEnvironment + , readEnvSpecFromEnvironment + , readEnvSpecFromStack ) where -import Data.Map.Strict (Map) import StackDeploy.Prelude -import StackDeploy.Utils import qualified Amazonka.CloudFormation.Types as CF import qualified Data.Foldable as Foldable import qualified Data.List as List +import qualified StackDeploy.Stack as StackDeploy +import qualified StackDeploy.Stratosphere as CFT import qualified Stratosphere as CFT import qualified Stratosphere.ECS.TaskDefinition as ECS.TaskDefinition import qualified Stratosphere.Lambda.Function as Lambda.Function import qualified UnliftIO.Environment as Environment -data Value - = StackId - | StackName - | StackOutput CFT.Output - | StackParameter CFT.Parameter - | StackPrefix Text - | Static Text - -data Entry = Entry - { envName :: Text - , envValue :: Value +-- $setup +-- >>> import StackDeploy.Prelude +-- >>> import qualified Data.Time.Clock as Time +-- >>> import qualified Data.Time.Clock.POSIX as Time +-- >>> import qualified Amazonka.CloudFormation.Types as CF +-- >>> import qualified StackDeploy.EnvSpec as StackDeploy + +-- | Specification of an environment variable that can be evaluated inside and outside of cloudformation defined resources. +-- +-- Primary use case is to be able to run local operations CLI tooling in the same +-- environment stack defined resources are running into. +-- As long the stack defined resources are being defined via this data type its +-- guaranteed an execution on a developers/operators machine can reproduc the same +-- environment. +-- +-- General useage is to export env spec values from components for subsystems, +-- like modules that define lambas and ecs containers. Than for local ops tooling that +-- needs the same environment run load these env spec values directly via functions like +-- `readenvSpecFromStack` outside of AWS execution resources. +data EnvSpec = EnvSpec + { name :: EnvSpecName + , value :: EnvSpecValue } -ecsTaskDefinitionEnvironment :: [Entry] -> [ECS.TaskDefinition.KeyValuePairProperty] -ecsTaskDefinitionEnvironment entries = render <$> List.sortOn (.envName) entries +type EnvSpecName = BoundText "StackDeploy.EnvSpec.Name" + +data EnvSpecValue + = EnvSpecStackId + -- ^ Stack id env spec + -- CloudFormation: Expression that resolves to the stack id. + -- CLI: Reflects stack id + | EnvSpecStackName + -- ^ Stack name env spec + -- CloudFormation: Expression that resolves to the stack name. + -- CLI: Reflects stack name + | EnvSpecStackOutput CFT.Output + -- ^ Output value env spec + -- CloudFormation: Expression that resolves to the output value. + -- CLI: Reflects output value from stack + | EnvSpecStackParameter CFT.Parameter + -- ^ Parameter value env spec + -- CloudFormation: Expression that resolves to the parameter value. + -- CLI: Reflects parameter value from stack + | EnvSpecStackPrefix Text + -- ^ Static aws stack name prefixing env spec + -- CloudFormation: Expression that prefixes a string literal with the stack name. + -- CLI: Reflects stack name. + | EnvSpecStatic Text + -- ^ Static env spec. + -- CloudFormation: String literal + -- CLI: Constant return + +-- | Construct a ECS task definition environment key value property +-- >>> let envSpecA = StackDeploy.EnvSpec (fromType @"Env-A") (StackDeploy.EnvSpecStatic "Value-A") +-- >>> let envSpecB = StackDeploy.EnvSpec (fromType @"Env-B") StackDeploy.EnvSpecStackName +-- >>> StackDeploy.envSpecToEcsTaskDefinitionEnvironment [envSpecB, envSpecA] +-- [KeyValuePairProperty {name = Just (Literal "Env-A"), value = Just (Literal "Value-A")},KeyValuePairProperty {name = Just (Literal "Env-B"), value = Just (Ref "AWS::StackName")}] +envSpecToEcsTaskDefinitionEnvironment :: [EnvSpec] -> [ECS.TaskDefinition.KeyValuePairProperty] +envSpecToEcsTaskDefinitionEnvironment entries = render <$> List.sortOn (.name) entries where - render (Entry key value) = mkPair key $ renderValue value + render (EnvSpec key value) = mkPair key $ renderValue value - mkPair :: Text -> CFT.Value Text -> ECS.TaskDefinition.KeyValuePairProperty + mkPair :: EnvSpecName -> CFT.Value Text -> ECS.TaskDefinition.KeyValuePairProperty mkPair key value = ECS.TaskDefinition.KeyValuePairProperty - { name = pure (CFT.Literal key) + { name = pure (CFT.Literal $ convert key) , value = pure value } -lambdaEnvironment :: [Entry] -> Lambda.Function.EnvironmentProperty -lambdaEnvironment entries +-- | Construct a lambda environment +-- >>> let envSpecA = StackDeploy.EnvSpec (fromType @"Env-A") (StackDeploy.EnvSpecStatic "Value-A") +-- >>> let envSpecB = StackDeploy.EnvSpec (fromType @"Env-B") StackDeploy.EnvSpecStackName +-- >>> StackDeploy.envSpecToLambdaEnvironment [envSpecB, envSpecA] +-- EnvironmentProperty {variables = Just (fromList [("Env-A",Literal "Value-A"),("Env-B",Ref "AWS::StackName")])} +envSpecToLambdaEnvironment :: [EnvSpec] -> Lambda.Function.EnvironmentProperty +envSpecToLambdaEnvironment entries = Lambda.Function.mkEnvironmentProperty { Lambda.Function.variables = pure variables } where variables :: Map Text (CFT.Value Text) - variables = fromList $ render <$> List.sortOn (.envName) entries + variables = fromList $ render <$> List.sortOn (.name) entries - render (Entry key value) = (key, renderValue value) + render (EnvSpec key value) = (convert @Text key, renderValue value) -posixEnv :: CF.Stack -> [Entry] -> MIO env [(String, String)] -posixEnv stack = traverse render . List.sortOn (.envName) +-- | Construct a posix environment list +-- +-- Only intent for running 3rd party binaries via exporting that environment list before +-- spawning a new process. +-- +-- If its planned to re-use an environment in the same HS process juse `readEnvSpecFromStack` to read the values as the CF stack would define them. +-- +-- >>> let envSpecA = StackDeploy.EnvSpec (fromType @"Env-A") (StackDeploy.EnvSpecStatic "Value-A") +-- >>> let envSpecB = StackDeploy.EnvSpec (fromType @"Env-B") StackDeploy.EnvSpecStackName +-- >>> let epochTime = Time.posixSecondsToUTCTime 0 +-- >>> let stack = CF.newStack "test-stack" epochTime CF.StackStatus_UPDATE_COMPLETE +-- >>> envSpec <- StackDeploy.envSpecToPosixEnvironment stack [envSpecB, envSpecA] +-- >>> envSpec +-- [("Env-A","Value-A"),("Env-B","test-stack")] +envSpecToPosixEnvironment + :: forall m . MonadIO m + => CF.Stack + -> [EnvSpec] + -> m [(String, String)] +envSpecToPosixEnvironment stack = traverse render . List.sortOn (.name) where - render :: Entry -> MIO env (String, String) - render entry@Entry{..} = do - (convert envName,) . convert <$> loadStack stack entry - -loadStack :: CF.Stack -> Entry -> MIO env Text -loadStack stack Entry{..} = case envValue of - StackOutput output' -> liftIO $ fetchOutput stack output' - StackParameter param -> fetchParam stack param - StackPrefix text -> pure $ stack.stackName <> "-" <> text - StackId -> maybe failAbsentStackId pure stack.stackId - StackName -> pure $ stack.stackName - Static text -> pure text + render :: EnvSpec -> m (String, String) + render entry@EnvSpec{..} = (convertVia @Text name,) . convert <$> readEnvSpecFromStack stack entry + +-- | Read an env spec value as AWS resources would do +-- +-- Primary use case is to initialize operations CLI to the same state an equivalent AWS resource would have. +-- +-- >>> let envSpec = StackDeploy.EnvSpec (fromType @"STACK_NAME") StackDeploy.EnvSpecStackName +-- >>> let epochTime = Time.posixSecondsToUTCTime 0 +-- >>> let stack = CF.newStack "test-stack" epochTime CF.StackStatus_UPDATE_COMPLETE +-- >>> value <- StackDeploy.readEnvSpecFromStack stack envSpec +-- >>> value +-- "test-stack" +readEnvSpecFromStack :: forall m . MonadIO m => CF.Stack -> EnvSpec -> m Text +readEnvSpecFromStack stack EnvSpec{..} = case value of + EnvSpecStackId -> maybe failAbsentStackId pure stack.stackId + EnvSpecStackName -> pure stack.stackName + EnvSpecStackOutput output -> liftIO $ StackDeploy.fetchStackOutput stack output + EnvSpecStackParameter parameter -> fetchParameter stack parameter + EnvSpecStackPrefix text -> pure $ stack.stackName <> "-" <> text + EnvSpecStatic text -> pure text where - failAbsentStackId :: MIO env a + failAbsentStackId :: m a failAbsentStackId = throwString $ "Missing stack id: " <> show stack -loadEnv :: Entry -> MIO env Text -loadEnv Entry{..} = convert <$> Environment.getEnv (convert envName) +-- | Read an env spec value from the environment +-- +-- This function is intend to be run within lambda or ECS tasks reading the env value the cloud formation resource defined. For operations CLI use `readEnvSpecFromStack` instead. +readEnvSpecFromEnvironment :: EnvSpec -> MIO env Text +readEnvSpecFromEnvironment EnvSpec{..} = convert <$> Environment.getEnv (convertVia @Text name) -renderValue :: Value -> CFT.Value Text +renderValue :: EnvSpecValue -> CFT.Value Text renderValue = \case - StackId -> CFT.awsStackId - StackName -> CFT.awsStackName - StackOutput output' -> (output'.value) - StackParameter param -> CFT.toRef param - StackPrefix value -> mkName (CFT.Literal value) - Static text -> CFT.Literal text - -fetchParam - :: CF.Stack + EnvSpecStackId -> CFT.awsStackId + EnvSpecStackName -> CFT.awsStackName + EnvSpecStackOutput output -> output.value + EnvSpecStackParameter parameter -> CFT.toRef parameter + EnvSpecStackPrefix value -> CFT.mkName (CFT.Literal value) + EnvSpecStatic text -> CFT.Literal text + +fetchParameter + :: forall m . MonadIO m + => CF.Stack -> CFT.Parameter - -> MIO env Text -fetchParam stack stratosphereParameter = + -> m Text +fetchParameter stack stratosphereParameter = maybe - (failOutputKey "missing") - (maybe (failOutputKey "has no value") pure . (.parameterValue)) + (failParamemterKey "missing") + (maybe (failParamemterKey "has no value") pure . (.parameterValue)) $ Foldable.find ((==) (pure key) . (.parameterKey)) (fromMaybe [] stack.parameters) where key = stratosphereParameter.name - failOutputKey :: Text -> MIO env a - failOutputKey message + failParamemterKey :: Text -> m a + failParamemterKey message = failStack $ "Parameter " <> convertText key <> " " <> message - failStack :: Text -> MIO env a + failStack :: Text -> m a failStack message = throwString . convertText diff --git a/stack-deploy/src/StackDeploy/Events.hs b/stack-deploy/src/StackDeploy/Events.hs index fc18fa0e..640079fe 100644 --- a/stack-deploy/src/StackDeploy/Events.hs +++ b/stack-deploy/src/StackDeploy/Events.hs @@ -7,7 +7,6 @@ import Data.Conduit (ConduitT, (.|), await, runConduit, yield) import Data.Conduit.Combinators (find, iterM, takeWhile, yieldMany) import Data.Conduit.List (consume) import Data.Function (on) -import StackDeploy.AWS import StackDeploy.Prelude import StackDeploy.Types @@ -16,16 +15,17 @@ import qualified Amazonka.CloudFormation.Types as CF import qualified Data.Foldable as Foldable import qualified Data.List as List import qualified MIO.Amazonka as AWS +import qualified StackDeploy.AWS as AWS data Poll = Poll { delay :: forall m . MonadIO m => m () , eventFilter :: CF.StackEvent -> Bool - , stackId :: Id + , stackId :: StackId , startCondition :: CF.StackEvent -> Bool , stopCondition :: CF.StackEvent -> Bool } -defaultPoll :: Id -> Poll +defaultPoll :: StackId -> Poll defaultPoll stackId = Poll { delay = liftIO $ threadDelay 1_000_000 -- 1 second , eventFilter = const True -- accept all events @@ -96,9 +96,9 @@ allEvents Poll{..} = stackEvents :: AWS.Env env - => Id + => StackId -> ConduitT () CF.StackEvent (MIO env) () -stackEvents stackId = listResource request (fromMaybe [] . (.stackEvents)) +stackEvents stackId = AWS.nestedResourceC request (fromMaybe [] . (.stackEvents)) where request = CF.newDescribeStackEvents & CF.describeStackEvents_stackName ?~ toText stackId diff --git a/stack-deploy/src/StackDeploy/InstanceSpec.hs b/stack-deploy/src/StackDeploy/InstanceSpec.hs index 6eca50c8..4519e968 100644 --- a/stack-deploy/src/StackDeploy/InstanceSpec.hs +++ b/stack-deploy/src/StackDeploy/InstanceSpec.hs @@ -1,128 +1,134 @@ module StackDeploy.InstanceSpec - ( InstanceSpec(..) - , Name - , Provider - , RoleARN(..) + ( InstanceName + , InstanceSpec(..) + , InstanceSpecMap + , RoleARN , addTags - , get - , mk - , templateProvider + , instanceNamedTemplateMap + , instanceSpecMapFromList + , mkInstanceSpec + , setInstanceSpecParameter ) where import Data.MonoTraversable (omap) import Prelude (error) -import StackDeploy.Parameters (Parameters) import StackDeploy.Prelude -import StackDeploy.Template (Template) import qualified Amazonka.CloudFormation.Types as CF import qualified Data.Aeson as JSON import qualified Data.Aeson.KeyMap as KeyMap -import qualified StackDeploy.Parameters as Parameters -import qualified StackDeploy.Provider as Provider -import qualified StackDeploy.Template as Template -import qualified Stratosphere +import qualified Data.Map.Strict as Map +import qualified StackDeploy.NamedTemplate as StackDeploy +import qualified StackDeploy.Parameters as StackDeploy +import qualified Stratosphere as CFT -newtype RoleARN = RoleARN Text - deriving (Conversion Text) via Text - deriving stock Eq +-- $setup +-- >>> import StackDeploy.Prelude +-- >>> import qualified StackDeploy.InstanceSpec as StackDeploy +-- >>> import qualified StackDeploy.NamedTemplate as StackDeploy +-- >>> import qualified Stratosphere as CFT -type Name = BoundText "StackDeploy.InstanceSpec.Name" - -type Provider env = Provider.Provider (InstanceSpec env) +type RoleARN = BoundText "StackDeploy.InstanceSpec.RoleARN" +type InstanceName = BoundText "StackDeploy.InstanceSpec.Name" +type InstanceSpecMap env = Map InstanceName (InstanceSpec env) data InstanceSpec env = InstanceSpec { capabilities :: [CF.Capability] - , envParameters :: MIO env Parameters - , envRoleARN :: Maybe (MIO env RoleARN) - , name :: Name + , name :: InstanceName + , namedTemplate :: StackDeploy.NamedTemplate + , onLoad :: InstanceSpec env -> MIO env (InstanceSpec env) , onSuccess :: MIO env () - , parameters :: Parameters - , roleARN :: Maybe RoleARN - , template :: Template + , parameterMap :: StackDeploy.ParameterMap + , roleArn :: Maybe RoleARN } -instance Provider.HasItemName (InstanceSpec env) where - type ItemName (InstanceSpec env) = Name - name = (.name) - -get - :: Provider env - -> Name - -> Parameters - -> MIO env (InstanceSpec env) -get provider targetName userParameters = do - instanceSpec <- Provider.get "instance-spec" provider targetName - env <- instanceSpec.envParameters - roleARN <- tryEnvRole instanceSpec - - pure $ instanceSpec - { parameters - = expandedParameters instanceSpec - `union` env - `union` userParameters - , roleARN = roleARN - } - - where - expandedParameters :: InstanceSpec env -> Parameters - expandedParameters InstanceSpec{..} = - Parameters.expandTemplate parameters template - - tryEnvRole :: InstanceSpec env -> MIO env (Maybe RoleARN) - tryEnvRole InstanceSpec{..} = maybe (pure roleARN) (pure <$>) envRoleARN - - union = Parameters.union +-- | Set instance spec parameter +setInstanceSpecParameter :: StackDeploy.Parameter -> InstanceSpec env -> InstanceSpec env +setInstanceSpecParameter parameter instanceSpec@InstanceSpec{..} + = instanceSpec + { parameterMap = Map.insert parameter.name parameter.value parameterMap + } -mk :: Name -> Template -> InstanceSpec env -mk name template = InstanceSpec +-- | Construct instance spec map from list +-- >>> let namedTemplate = StackDeploy.mkNamedTemplate (fromType @"test") (CFT.mkTemplate []) +-- >>> let instanceSpec = StackDeploy.mkInstanceSpec (fromType @"test") namedTemplate +-- >>> let instanceSpecMap = StackDeploy.instanceSpecMapFromList [instanceSpec] +instanceSpecMapFromList :: [InstanceSpec env] -> InstanceSpecMap env +instanceSpecMapFromList = Map.fromList . fmap (\instanceSpec -> (instanceSpec.name, instanceSpec)) + +-- | Construct minimal instance spec +-- >>> let namedTemplate = StackDeploy.mkNamedTemplate (fromType @"test") (CFT.mkTemplate []) +-- >>> let instanceSpec = StackDeploy.mkInstanceSpec (fromType @"test") namedTemplate +-- >>> instanceSpec.capabilities +-- [] +-- >>> instanceSpec.name +-- BoundText "test" +-- >>> instanceSpec.parameterMap +-- fromList [] +-- >>> instanceSpec.roleArn +-- Nothing +mkInstanceSpec :: InstanceName -> StackDeploy.NamedTemplate -> InstanceSpec env +mkInstanceSpec name namedTemplate = InstanceSpec { capabilities = empty - , envParameters = pure Parameters.empty - , envRoleARN = empty + , onLoad = pure , onSuccess = pure () - , parameters = Parameters.empty - , roleARN = empty + , parameterMap = [] + , roleArn = empty , .. } -templateProvider :: Provider env -> Template.Provider -templateProvider provider = fromList $ (.template) <$> toList provider - -addTags :: [Stratosphere.Tag] -> InstanceSpec env -> InstanceSpec env +-- | Construct template map from instance spec map +-- >>> let namedTemplate = StackDeploy.mkNamedTemplate (fromType @"test") (CFT.mkTemplate []) +-- >>> let instanceSpec = StackDeploy.mkInstanceSpec (fromType @"test") namedTemplate +-- >>> StackDeploy.instanceNamedTemplateMap [((fromType @"test"), instanceSpec)] +-- fromList [(BoundText "test",Template {conditions = Nothing, description = Nothing, formatVersion = Nothing, mappings = Nothing, metadata = Nothing, outputs = Nothing, parameters = Nothing, resources = Resources {resourceList = []}})] +instanceNamedTemplateMap :: InstanceSpecMap env -> StackDeploy.NamedTemplateMap +instanceNamedTemplateMap map + = Map.fromList + $ (\InstanceSpec{..} -> (namedTemplate.name, namedTemplate.template)) <$> Map.elems map + +-- | Add static tags to instance spec +addTags :: [CFT.Tag] -> InstanceSpec env -> InstanceSpec env addTags tags InstanceSpec{..} = InstanceSpec - { template = addTemplateTags tags template + { namedTemplate = addNamedTemplateTags tags namedTemplate , .. } -addTemplateTags :: [Stratosphere.Tag] -> Template.Template -> Template.Template -addTemplateTags tags Template.Template{..} - = Template.Template - { stratosphere = addStratosphereTags tags stratosphere +-- | Add static tags to named template tags +addNamedTemplateTags :: [CFT.Tag] -> StackDeploy.NamedTemplate -> StackDeploy.NamedTemplate +addNamedTemplateTags tags StackDeploy.NamedTemplate{..} + = StackDeploy.NamedTemplate + { template = addStratosphereTags tags template , .. } -addStratosphereTags :: [Stratosphere.Tag] -> Stratosphere.Template -> Stratosphere.Template -addStratosphereTags tags Stratosphere.Template{..} - = Stratosphere.Template +-- | Add static tags to stratosphere template +addStratosphereTags :: [CFT.Tag] -> CFT.Template -> CFT.Template +addStratosphereTags tags CFT.Template{..} + = CFT.Template { resources = omap (addResourceTags tags) resources , .. } -addResourceTags :: [Stratosphere.Tag] -> Stratosphere.Resource -> Stratosphere.Resource -addResourceTags tags Stratosphere.Resource{..} - = Stratosphere.Resource +-- | Add static tags to stratosphere resource +addResourceTags :: [CFT.Tag] -> CFT.Resource -> CFT.Resource +addResourceTags tags CFT.Resource{..} + = CFT.Resource { properties = addResourcePropertiesTags tags properties , .. } +-- | Add static tags to stratosphere resource properties +-- +-- This function will honor the special logic for aws auto scaling group and set tags to be propagated on launch. addResourcePropertiesTags - :: [Stratosphere.Tag] - -> Stratosphere.ResourceProperties - -> Stratosphere.ResourceProperties -addResourcePropertiesTags tags Stratosphere.ResourceProperties{..} - = Stratosphere.ResourceProperties + :: [CFT.Tag] + -> CFT.ResourceProperties + -> CFT.ResourceProperties +addResourcePropertiesTags tags CFT.ResourceProperties{..} + = CFT.ResourceProperties { properties = newProperties , .. } diff --git a/stack-deploy/src/StackDeploy/NamedTemplate.hs b/stack-deploy/src/StackDeploy/NamedTemplate.hs new file mode 100644 index 00000000..3ef91270 --- /dev/null +++ b/stack-deploy/src/StackDeploy/NamedTemplate.hs @@ -0,0 +1,76 @@ +module StackDeploy.NamedTemplate + ( NamedTemplate(..) + , NamedTemplateMap + , TemplateName + , mkNamedTemplate + , namedTemplateMapFromList + , namedTemplateTestTree + , stratosphereTemplateEncodePretty + ) +where + +import Data.Ord (compare) +import StackDeploy.Prelude +import System.FilePath ((<.>), ()) + +import qualified Data.Aeson.Encode.Pretty as JSON +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map +import qualified Data.Text.Encoding as Text +import qualified Stratosphere as CFT +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.MGolden as Tasty + +-- $setup +-- >>> import StackDeploy.Prelude +-- >>> import qualified Stratosphere as CFT +-- >>> import qualified StackDeploy.NamedTemplate as StackDeploy + +type TemplateName = BoundText "StackDeploy.Template.Name" + +data NamedTemplate = NamedTemplate + { name :: TemplateName + , template :: CFT.Template + } + deriving stock (Eq, Show) + +type NamedTemplateMap = Map TemplateName CFT.Template + +-- | Pretty print a template using aeson-pretty. +-- >>> StackDeploy.stratosphereTemplateEncodePretty $ CFT.mkTemplate [] +-- "{\n \"Resources\": {}\n}" +stratosphereTemplateEncodePretty :: CFT.Template -> LBS.ByteString +stratosphereTemplateEncodePretty = JSON.encodePretty' config + where + config + = JSON.defConfig + { JSON.confIndent = JSON.Spaces 2 + , JSON.confCompare = compare + } + +-- | Construct named template +-- >>> StackDeploy.mkNamedTemplate (fromType @"test") (CFT.mkTemplate []) +-- NamedTemplate {name = BoundText "test", template = Template {conditions = Nothing, description = Nothing, formatVersion = Nothing, mappings = Nothing, metadata = Nothing, outputs = Nothing, parameters = Nothing, resources = Resources {resourceList = []}}} +mkNamedTemplate :: TemplateName -> CFT.Template -> NamedTemplate +mkNamedTemplate = NamedTemplate + +-- | Construct template map from named templates +-- >>> let test = StackDeploy.mkNamedTemplate (fromType @"test") (CFT.mkTemplate []) +-- >>> StackDeploy.namedTemplateMapFromList [test] +-- fromList [(BoundText "test",Template {conditions = Nothing, description = Nothing, formatVersion = Nothing, mappings = Nothing, metadata = Nothing, outputs = Nothing, parameters = Nothing, resources = Resources {resourceList = []}})] +namedTemplateMapFromList :: [NamedTemplate] -> NamedTemplateMap +namedTemplateMapFromList = Map.fromList . fmap mkPair + where + mkPair NamedTemplate{..} = (name, template) + +namedTemplateTestTree :: NamedTemplateMap -> Tasty.TestTree +namedTemplateTestTree map = Tasty.testGroup "template" (templateTest <$> Map.toList map) + where + templateTest :: (TemplateName, CFT.Template) -> Tasty.TestTree + templateTest (name, template) = + Tasty.goldenTest + (convertText name) + expectedPath + (pure . Text.decodeUtf8 . LBS.toStrict $ stratosphereTemplateEncodePretty template) + where + expectedPath = "test" "template" convertText name <.> ".json" diff --git a/stack-deploy/src/StackDeploy/Operation.hs b/stack-deploy/src/StackDeploy/Operation.hs new file mode 100644 index 00000000..84f0decf --- /dev/null +++ b/stack-deploy/src/StackDeploy/Operation.hs @@ -0,0 +1,271 @@ +module StackDeploy.Operation + ( performOperation + , printEvent + ) +where + +import Control.Lens (Lens', set, view) +import Data.Int (Int) +import Data.Time.Format (defaultTimeLocale, formatTime) +import StackDeploy.IO +import StackDeploy.InstanceSpec (InstanceSpec(..)) +import StackDeploy.Parameters +import StackDeploy.Prelude +import StackDeploy.Types +import StackDeploy.Wait + +import qualified Amazonka +import qualified Amazonka.CloudFormation.CreateStack as CF +import qualified Amazonka.CloudFormation.DeleteStack as CF +import qualified Amazonka.CloudFormation.Types as CF +import qualified Amazonka.CloudFormation.UpdateStack as CF +import qualified Amazonka.S3.Types as S3 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.IO as Text +import qualified MIO.Amazonka as AWS +import qualified StackDeploy.Env as StackDeploy +import qualified StackDeploy.NamedTemplate as StackDeploy +import qualified StackDeploy.S3 +import qualified StackDeploy.Stack as StackDeploy + +data OperationFields a = OperationFields + { capabilitiesField :: Lens' a (Maybe [CF.Capability]) + , parameterExpand :: ParameterExpand + , parametersField :: Lens' a (Maybe [CF.Parameter]) + , roleARNField :: Lens' a (Maybe Text) + , templateBodyField :: Lens' a (Maybe Text) + , templateURLField :: Lens' a (Maybe Text) + , tokenField :: Lens' a (Maybe Text) + } + +performOperation + :: forall env . (AWS.Env env, StackDeploy.Env env) + => Operation env + -> MIO env RemoteOperationResult +performOperation = \case + (OpCreate instanceSpec userParameterMap) -> do + effectiveInstanceSpec <- loadEffectiveInstanceSpec instanceSpec + successCallback instanceSpec =<< create effectiveInstanceSpec userParameterMap + (OpDelete existingStack) -> + runStackId existingStack.stackId delete + (OpUpdate existingStack instanceSpec userParameterMap) -> do + effectiveInstanceSpec <- loadEffectiveInstanceSpec instanceSpec + successCallback effectiveInstanceSpec =<< + runStackId + existingStack.stackId + (update effectiveInstanceSpec existingStack.parameters userParameterMap) + where + loadEffectiveInstanceSpec :: InstanceSpec env -> MIO env (InstanceSpec env) + loadEffectiveInstanceSpec instanceSpec = instanceSpec.onLoad instanceSpec + + runStackId + :: StackId + -> (RemoteOperation -> MIO env RemoteOperationResult) + -> MIO env RemoteOperationResult + runStackId stackId action = do + token <- newToken + action RemoteOperation{..} + + create + :: InstanceSpec env + -> ParameterMap + -> MIO env RemoteOperationResult + create instanceSpec@InstanceSpec{..} userParameterMap = do + token <- newToken + stackId <- StackDeploy.readStackIdField CF.createStackResponse_stackId =<< doCreate token + waitFor RemoteOperation{..} + where + doCreate :: Token -> MIO env (Amazonka.AWSResponse CF.CreateStack) + doCreate token = + prepareOperation + operationFields + instanceSpec + userParameterMap + token + (CF.newCreateStack $ convert name) + >>= AWS.send + + operationFields = OperationFields + { capabilitiesField = CF.createStack_capabilities + , parameterExpand = ParameterExpandCreate + , parametersField = CF.createStack_parameters + , roleARNField = CF.createStack_roleARN + , templateBodyField = CF.createStack_templateBody + , templateURLField = CF.createStack_templateURL + , tokenField = CF.createStack_clientRequestToken + } + + delete :: RemoteOperation -> MIO env RemoteOperationResult + delete remoteOperation@RemoteOperation{..} = + doDelete >> waitFor remoteOperation + where + doDelete :: MIO env () + doDelete + = void + . AWS.send + . setText CF.deleteStack_clientRequestToken token + . CF.newDeleteStack + $ convert stackId + + update + :: InstanceSpec env + -> [CF.Parameter] + -> ParameterMap + -> RemoteOperation + -> MIO env RemoteOperationResult + update instanceSpec previousParameters userParameterMap remoteOperation@RemoteOperation{..} + = either handleNoUpdateError (const $ waitFor remoteOperation) =<< doUpdate + where + doUpdate :: MIO env (Either Amazonka.Error CF.UpdateStackResponse) + doUpdate = + prepareOperation + operationFields + instanceSpec + userParameterMap + token + (CF.newUpdateStack $ convert stackId) + >>= AWS.sendEither + + handleNoUpdateError :: Amazonka.Error -> MIO env RemoteOperationResult + handleNoUpdateError = \case + ( Amazonka.ServiceError + Amazonka.ServiceError' + { code = Amazonka.ErrorCode "ValidationError" + , message = Just (Amazonka.ErrorMessage "No updates are to be performed.") + }) -> pure RemoteOperationSuccess + other -> throwIO other + + operationFields = OperationFields + { capabilitiesField = CF.updateStack_capabilities + , parameterExpand = ParameterExpandUpdate previousParameters + , parametersField = CF.updateStack_parameters + , roleARNField = CF.updateStack_roleARN + , templateBodyField = CF.updateStack_templateBody + , templateURLField = CF.updateStack_templateURL + , tokenField = CF.updateStack_clientRequestToken + } + + waitFor :: RemoteOperation -> MIO env RemoteOperationResult + waitFor remoteOperation = waitForAccept remoteOperation printEvent + + successCallback + :: InstanceSpec env + -> RemoteOperationResult + -> MIO env RemoteOperationResult + successCallback InstanceSpec{..} result = case result of + RemoteOperationSuccess -> onSuccess >> pure result + _ -> pure result + +printEvent :: CF.StackEvent -> MIO env () +printEvent event = do + say $ Text.unwords + [ timestamp + , physicalResourceId + , logicalResourceId + , resourceType + , resourceStatus + ] + sayReason event.resourceStatusReason + where + logicalResourceId = + fromMaybe + "[unknown-logical-resource-id]" + (event.logicalResourceId) + + physicalResourceId = + fromMaybe + "[unknown-physical-resource-id]" + (event.physicalResourceId) + + resourceType = + fromMaybe + "[unknown-resource-type]" + event.resourceType + + resourceStatus :: Text + resourceStatus = + maybe + "[unknown-resource-type]" + CF.fromResourceStatus + event.resourceStatus + + timeFormat :: String + timeFormat = "%Y-%m-%dT%H:%M:%S" + + timestamp :: Text + timestamp + = convertText + . formatTime defaultTimeLocale timeFormat + $ view CF.stackEvent_timestamp event + + sayReason :: Maybe Text -> MIO env () + sayReason = maybe (pure ()) (say . ("- " <>)) + +prepareOperation + :: forall env a . (AWS.Env env, StackDeploy.Env env) + => OperationFields a + -> InstanceSpec env + -> ParameterMap + -> Token + -> a + -> MIO env a +prepareOperation + OperationFields{..} + InstanceSpec{..} + userParameterMap + token + operation = do + effectiveParameters <- either (throwString . show) pure $ + parameterMapTemplateExpand parameterExpand mergedParameterMap namedTemplate.template + setTemplateBody + . set capabilitiesField (pure capabilities) + . set parametersField (pure effectiveParameters) + . set roleARNField (convert <$> roleArn) + . setText tokenField token + $ operation + where + mergedParameterMap = Map.union parameterMap userParameterMap + + setTemplateBody :: a -> MIO env a + setTemplateBody request = + if BS.length templateBodyBS <= maxBytes + then pure $ setText templateBodyField templateBody request + else s3Template request + + s3Template :: a -> MIO env a + s3Template request = do + ask >>= + (maybe failMissingTemplateBucket (doUpload request =<<) . (.readTemplateBucketName)) . (.stackDeployConfig) + + doUpload :: a -> S3.BucketName -> MIO env a + doUpload request bucketName@(S3.BucketName bucketNameText) = do + StackDeploy.S3.syncTarget targetObject + pure $ setText templateURLField s3URL request + where + s3URL = "https://" <> bucketNameText <> ".s3.amazonaws.com/" <> StackDeploy.S3.targetObjectKeyText targetObject + + targetObject = + (StackDeploy.S3.hashedTargetObject bucketName (convert name) "json" templateBodyBS) + { StackDeploy.S3.uploadCallback = liftIO . Text.putStrLn . ("Uploading template: " <>) + } + + failMissingTemplateBucket :: MIO env a + failMissingTemplateBucket + = liftIO + $ fail + $ "Template is bigger than " + <> show maxBytes + <> " cloudformation requires to read the template via an S3 object but the environment specifies none" + + maxBytes :: Int + maxBytes = 51200 + + templateBody = Text.decodeUtf8 templateBodyBS + templateBodyBS = LBS.toStrict $ StackDeploy.stratosphereTemplateEncodePretty namedTemplate.template + +setText :: (Applicative f, ToText b) => Lens' a (f Text) -> b -> a -> a +setText field value = set field (pure $ convert value) diff --git a/stack-deploy/src/StackDeploy/Parameters.hs b/stack-deploy/src/StackDeploy/Parameters.hs index 509bc4a4..21221f7a 100644 --- a/stack-deploy/src/StackDeploy/Parameters.hs +++ b/stack-deploy/src/StackDeploy/Parameters.hs @@ -1,118 +1,132 @@ +{-# OPTIONS -Wwarn #-} + module StackDeploy.Parameters ( Parameter(..) - , ParameterName(..) - , ParameterValue(..) - , Parameters - , cfParameters - , empty - , expandTemplate - , fromStratosphereParameter - , union + , ParameterExpand(..) + , ParameterMap + , ParameterName + , ParameterValue + , parameterFromStratosphere + , parameterMapFromList + , parameterMapTemplateExpand ) where import Control.Lens ((?~)) -import Data.Map.Strict (Map) -import Data.Set (Set) -import StackDeploy.Prelude hiding (empty) -import StackDeploy.Template +import StackDeploy.Prelude import qualified Amazonka.CloudFormation.Types as CF -import qualified Control.Applicative as Alternative import qualified Data.Foldable as Foldable -import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import qualified Stratosphere - -newtype ParameterName = ParameterName Text - deriving (Conversion Text) via Text - deriving stock (Eq, Ord) - -newtype ParameterValue = ParameterValue Text - deriving (Conversion Text) via Text - deriving stock Eq - -data Parameter - = Parameter ParameterName ParameterValue - | ParameterUsePrevious ParameterName - -newtype Parameters = Parameters (Map ParameterName Parameter) - -parameterName :: Parameter -> ParameterName -parameterName = \case - (Parameter name _value) -> name - (ParameterUsePrevious name) -> name - -empty :: Parameters -empty = Parameters [] - -fromStratosphereParameter - :: Stratosphere.Parameter +import qualified Data.Text as Text +import qualified Stratosphere as CFT + +-- $setup +-- >>> :{ +-- import Control.Lens ((?~)) +-- import StackDeploy.Prelude +-- import qualified Amazonka.CloudFormation.Types as CF +-- import qualified StackDeploy.Parameters as StackDeploy +-- import qualified Stratosphere as CFT +-- :} + +type ParameterName = BoundText "StackDeploy.Parameter.Name" +type ParameterValue = BoundText "StackDeploy.Parameter.Value" + +data Parameter = Parameter + { name :: ParameterName + , value :: ParameterValue + } + deriving stock (Eq, Show) + +type ParameterMap = Map ParameterName ParameterValue + +-- | Create parameter from stratosphere +-- >>> StackDeploy.parameterFromStratosphere (CFT.mkParameter "A" "String") (fromType @"A-Value") +-- Parameter {name = BoundText "A", value = BoundText "A-Value"} +parameterFromStratosphere + :: CFT.Parameter -> ParameterValue -> Parameter -fromStratosphereParameter = Parameter . ParameterName . (.name) - -instance IsList Parameters where - type Item Parameters = Parameter - - fromList parameters = - Parameters . Map.fromList $ pairs - where - pairs :: [(ParameterName, Parameter)] - pairs = mkPair <$> parameters - - mkPair :: Parameter -> (ParameterName, Parameter) - mkPair parameter = (parameterName parameter, parameter) - - toList (Parameters map) = List.sortOn parameterName $ Map.elems map - -cfParameters :: Parameters -> [CF.Parameter] -cfParameters parameters = mkCFParameter <$> toList parameters - -mkCFParameter :: Parameter -> CF.Parameter -mkCFParameter = \case - Parameter name value -> - CF.newParameter - & CF.parameter_parameterKey ?~ toText name - & CF.parameter_parameterValue ?~ toText value - ParameterUsePrevious name -> - CF.newParameter - & CF.parameter_parameterKey ?~ toText name - & CF.parameter_usePreviousValue ?~ True - -union :: Parameters -> Parameters -> Parameters -union (Parameters left) (Parameters right) = - Parameters $ Map.union right left - -expandTemplate :: Parameters -> Template -> Parameters -expandTemplate parameters@(Parameters hash) template - = parameters `union` usePreviousParameters +parameterFromStratosphere = Parameter . convertImpure . (.name) + +parameterMapFromList :: [Parameter] -> ParameterMap +parameterMapFromList = Map.fromList . fmap (\Parameter{..} -> (name, value)) + +data ParameterExpand + = ParameterExpandCreate + | ParameterExpandUpdate [CF.Parameter] + +-- | Expand parameter map to amazonka cloudformation parameters against a stratosphere template +-- | +-- | Explansion fails if unknown parameters are provided. +-- | Missing parameters will not be detected. These are to be detected by the cloudformation API. +-- >>> let cfParameterA = CF.newParameter & CF.parameter_parameterKey ?~ "A" +-- >>> let cfParameterB = CF.newParameter & CF.parameter_parameterKey ?~ "B" +-- >>> let cftParameterA = CFT.mkParameter "A" "String" & CFT.set @"Default" "A-Default" +-- >>> let cftParameterB = CFT.mkParameter "B" "String" +-- >>> let cftTemplate = CFT.mkTemplate [] & CFT.set @"Parameters" [cftParameterA, cftParameterB] +-- >>> let pairA = (fromType @"A", fromType @"A-Value") +-- >>> let pairB = (fromType @"B", fromType @"B-Value") +-- >>> let pairC = (fromType @"C", fromType @"C-Value") +-- >>> StackDeploy.parameterMapTemplateExpand StackDeploy.ParameterExpandCreate [pairC] cftTemplate +-- Left "Unknown parameters: C" +-- >>> StackDeploy.parameterMapTemplateExpand StackDeploy.ParameterExpandCreate [pairA] cftTemplate +-- Right [Parameter' {parameterKey = Just "A", parameterValue = Just "A-Value", resolvedValue = Nothing, usePreviousValue = Nothing}] +-- >>> StackDeploy.parameterMapTemplateExpand (StackDeploy.ParameterExpandUpdate [cfParameterA, cfParameterB]) [pairA] cftTemplate +-- Right [Parameter' {parameterKey = Just "A", parameterValue = Just "A-Value", resolvedValue = Nothing, usePreviousValue = Nothing},Parameter' {parameterKey = Just "B", parameterValue = Nothing, resolvedValue = Nothing, usePreviousValue = Just True}] +-- >>> StackDeploy.parameterMapTemplateExpand (StackDeploy.ParameterExpandUpdate [cfParameterA, cfParameterB]) [pairB] cftTemplate +-- Right [Parameter' {parameterKey = Just "A", parameterValue = Nothing, resolvedValue = Nothing, usePreviousValue = Just True},Parameter' {parameterKey = Just "B", parameterValue = Just "B-Value", resolvedValue = Nothing, usePreviousValue = Nothing}] +-- >>> StackDeploy.parameterMapTemplateExpand (StackDeploy.ParameterExpandUpdate [cfParameterB]) [pairB] cftTemplate +-- Right [Parameter' {parameterKey = Just "B", parameterValue = Just "B-Value", resolvedValue = Nothing, usePreviousValue = Nothing}] +parameterMapTemplateExpand + :: ParameterExpand + -> ParameterMap + -> CFT.Template + -> Either String [CF.Parameter] +parameterMapTemplateExpand operation parameterMap template + = if not $ Set.null unknownParameterNames + then Left $ "Unknown parameters: " <> join unknownParameterNames + else pure $ Foldable.foldMap process $ Set.toList templateParameterNames where - usePreviousParameters :: Parameters - usePreviousParameters - = Parameters - . Map.fromList - $ mkPair - <$> Foldable.toList missingParameterNames - - mkPair name = (name, ParameterUsePrevious name) - - missingParameterNames :: Set ParameterName - missingParameterNames = - Set.difference - templateParameterNames - givenParameterNames + process :: ParameterName -> [CF.Parameter] + process parameterName = + maybe absent (pure . mkParameterValue) (Map.lookup parameterName parameterMap) + where + absent = case operation of + ParameterExpandCreate -> [] + ParameterExpandUpdate{} -> [mkUsePrevious | Set.member parameterName previousParameterNames] + + parameterNameText = convert parameterName + + mkParameterValue :: ParameterValue -> CF.Parameter + mkParameterValue parameterValue + = CF.newParameter + & CF.parameter_parameterKey ?~ parameterNameText + & CF.parameter_parameterValue ?~ convert parameterValue + + mkUsePrevious :: CF.Parameter + mkUsePrevious + = CF.newParameter + & CF.parameter_parameterKey ?~ parameterNameText + & CF.parameter_usePreviousValue ?~ True + + unknownParameterNames :: Set ParameterName + unknownParameterNames = Set.difference givenParameterNames templateParameterNames givenParameterNames :: Set ParameterName - givenParameterNames = Set.fromList $ Map.keys hash + givenParameterNames = Map.keysSet parameterMap - templateParameterNames :: Set ParameterName templateParameterNames = Set.fromList - $ ParameterName . (.name) <$> templateParameters + $ convertImpure . (.name) <$> maybe [] (.parameterList) template.parameters + + previousParameterNames = case operation of + ParameterExpandCreate -> + [] + (ParameterExpandUpdate cfPreviousParameters) -> + Set.fromList $ Foldable.foldMap (maybe [] (pure . convertImpure) . (.parameterKey)) cfPreviousParameters - templateParameters :: [Stratosphere.Parameter] - templateParameters - = maybe Alternative.empty (.parameterList) - $ template.stratosphere.parameters + join :: Set ParameterName -> String + join = convert . Text.intercalate "," . fmap convert . Set.toList diff --git a/stack-deploy/src/StackDeploy/Prelude.hs b/stack-deploy/src/StackDeploy/Prelude.hs index cdd5603f..8c2bd948 100644 --- a/stack-deploy/src/StackDeploy/Prelude.hs +++ b/stack-deploy/src/StackDeploy/Prelude.hs @@ -5,7 +5,9 @@ import Control.Monad.Reader as Exports (ask) import Data.Bounded.Text as Exports import Data.Conversions as Exports import Data.Conversions.FromType as Exports +import Data.Map.Strict as Exports (Map) +import Data.Set as Exports (Set) import GHC.Exts as Exports (IsList, Item, fromList, toList) import MIO.Core as Exports import MPrelude as Exports -import UnliftIO.Exception as Exports (catchJust, throwIO, throwString) +import UnliftIO.Exception as Exports (throwIO, throwString) diff --git a/stack-deploy/src/StackDeploy/Provider.hs b/stack-deploy/src/StackDeploy/Provider.hs deleted file mode 100644 index 07d52843..00000000 --- a/stack-deploy/src/StackDeploy/Provider.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - -module StackDeploy.Provider (Get, HasItemName(..), Provider, get) where - -import Control.Exception.Base (Exception) -import Data.Kind (Type) -import Data.Map.Strict (Map) -import Data.MonoTraversable (Element, MonoFunctor) -import StackDeploy.Prelude - -import qualified Data.List as List -import qualified Data.Map.Strict as Map - -type instance Element (Provider a) = a - -newtype Provider a = Provider (Map (ItemName a) a) - deriving newtype MonoFunctor - -deriving newtype instance (Eq a, Eq (ItemName a)) => Eq (Provider a) -deriving newtype instance (Show a, Show (ItemName a)) => Show (Provider a) - -class HasItemName a where - type ItemName a :: Type - name :: a -> ItemName a - -instance (HasItemName a, Ord (ItemName a)) => IsList (Provider a) where - type Item (Provider a) = a - - fromList items = Provider $ Map.fromList (mkPair <$> items) - where - mkPair :: a -> (ItemName a, a) - mkPair item = (name item, item) - - toList (Provider map) = List.sortOn name $ Map.elems map - -type Get a b = forall m . MonadThrow m => Provider a -> b -> m a - -newtype MissingProviderItem = MissingProviderItem Text - deriving stock Show - -instance Exception MissingProviderItem - -get - :: forall a m . (MonadThrow m, Ord (ItemName a), ToText (ItemName a)) - => Text - -> Provider a - -> ItemName a - -> m a -get subject (Provider map) targetName - = maybe failMissing pure $ Map.lookup targetName map - where - failMissing :: m a - failMissing - = throwM - . MissingProviderItem - $ "Unknown " <> subject <> ": " <> toText targetName - diff --git a/stack-deploy/src/StackDeploy/Stack.hs b/stack-deploy/src/StackDeploy/Stack.hs index 034218b6..a952c757 100644 --- a/stack-deploy/src/StackDeploy/Stack.hs +++ b/stack-deploy/src/StackDeploy/Stack.hs @@ -1,334 +1,107 @@ module StackDeploy.Stack - ( finalMessage - , getExistingStack - , getExistingStackId - , getOutput - , getStackId - , perform - , printEvent - , stackNames + ( fetchStackOutput + , readCloudFormationStack + , readCloudFormationStackPresent + , readExistingStack + , readIdFromStack + , readStackIdField + , readStackOutput ) where import Control.Lens (Lens', set, view) -import Data.Conduit (ConduitT, (.|), runConduit) -import Data.Conduit.Combinators (find, map) -import Data.Int (Int) -import Data.Time.Format (defaultTimeLocale, formatTime) -import StackDeploy.IO -import StackDeploy.InstanceSpec (InstanceSpec(..)) +import Data.Conduit ((.|)) import StackDeploy.Prelude import StackDeploy.Types -import StackDeploy.Wait -import qualified Amazonka -import qualified Amazonka.CloudFormation.CreateStack as CF -import qualified Amazonka.CloudFormation.DeleteStack as CF import qualified Amazonka.CloudFormation.DescribeStacks as CF import qualified Amazonka.CloudFormation.Types as CF -import qualified Amazonka.CloudFormation.UpdateStack as CF -import qualified Amazonka.S3.Types as S3 -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS +import qualified Data.Conduit as Conduit +import qualified Data.Conduit.Combinators as Conduit import qualified Data.Foldable as Foldable -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Text.IO as Text import qualified MIO.Amazonka as AWS import qualified StackDeploy.AWS as AWS -import qualified StackDeploy.Env as StackDeploy -import qualified StackDeploy.InstanceSpec as InstanceSpec -import qualified StackDeploy.Parameters as Parameters -import qualified StackDeploy.S3 as S3 -import qualified StackDeploy.Template as Template - -data OperationFields a = OperationFields - { tokenField :: Lens' a (Maybe Text) - , capabilitiesField :: Lens' a (Maybe [CF.Capability]) - , parametersField :: Lens' a (Maybe [CF.Parameter]) - , roleARNField :: Lens' a (Maybe Text) - , templateBodyField :: Lens' a (Maybe Text) - , templateURLField :: Lens' a (Maybe Text) - } - -perform - :: forall env . (AWS.Env env, StackDeploy.Env env) - => Operation env - -> MIO env RemoteOperationResult -perform = \case - (OpCreate instanceSpec) -> - successCallback instanceSpec =<< create instanceSpec - (OpDelete stackId) -> - runStackId stackId delete - (OpUpdate stackId instanceSpec) -> - successCallback instanceSpec =<< - runStackId stackId (update instanceSpec) - where - runStackId - :: Id - -> (RemoteOperation -> MIO env RemoteOperationResult) - -> MIO env RemoteOperationResult - runStackId stackId action = do - token <- newToken - action RemoteOperation{..} - - create :: InstanceSpec env -> MIO env RemoteOperationResult - create instanceSpec@InstanceSpec{..} = do - token <- newToken - stackId <- accessStackId CF.createStackResponse_stackId =<< doCreate token - waitFor RemoteOperation{..} - where - doCreate :: Token -> MIO env (Amazonka.AWSResponse CF.CreateStack) - doCreate token = - prepareOperation operationFields instanceSpec token (CF.newCreateStack $ toText name) - >>= AWS.send - - operationFields = OperationFields - { capabilitiesField = CF.createStack_capabilities - , parametersField = CF.createStack_parameters - , roleARNField = CF.createStack_roleARN - , templateBodyField = CF.createStack_templateBody - , templateURLField = CF.createStack_templateURL - , tokenField = CF.createStack_clientRequestToken - } - - delete :: RemoteOperation -> MIO env RemoteOperationResult - delete remoteOperation@RemoteOperation{..} = - doDelete >> waitFor remoteOperation - where - doDelete :: MIO env () - doDelete - = void - . AWS.send - . setText CF.deleteStack_clientRequestToken token - . CF.newDeleteStack $ toText stackId - - update - :: InstanceSpec env - -> RemoteOperation - -> MIO env RemoteOperationResult - update - instanceSpec - remoteOperation@RemoteOperation{..} = - catchJust handleNoUpdateError - (doUpdate >> waitFor remoteOperation) - pure - where - doUpdate :: MIO env () - doUpdate = - prepareOperation operationFields instanceSpec token (CF.newUpdateStack $ toText stackId) - >>= void . AWS.send - - handleNoUpdateError :: Amazonka.Error -> Maybe RemoteOperationResult - handleNoUpdateError - ( Amazonka.ServiceError - Amazonka.ServiceError' - { code = Amazonka.ErrorCode "ValidationError" - , message = Just (Amazonka.ErrorMessage "No updates are to be performed.") - } - ) = pure RemoteOperationSuccess - handleNoUpdateError _error = empty - - operationFields = OperationFields - { capabilitiesField = CF.updateStack_capabilities - , parametersField = CF.updateStack_parameters - , roleARNField = CF.updateStack_roleARN - , templateBodyField = CF.updateStack_templateBody - , templateURLField = CF.updateStack_templateURL - , tokenField = CF.updateStack_clientRequestToken - } - - waitFor :: RemoteOperation -> MIO env RemoteOperationResult - waitFor remoteOperation = waitForAccept remoteOperation printEvent - - successCallback - :: InstanceSpec env - -> RemoteOperationResult - -> MIO env RemoteOperationResult - successCallback InstanceSpec{..} result = case result of - RemoteOperationSuccess -> onSuccess >> pure result - _ -> pure result - -printEvent :: CF.StackEvent -> MIO env () -printEvent event = do - say $ Text.unwords - [ timestamp - , physicalResourceId - , logicalResourceId - , resourceType - , resourceStatus - ] - sayReason event.resourceStatusReason +import qualified StackDeploy.InstanceSpec as StackDeploy +import qualified Stratosphere as CFT + +fetchStackOutput + :: forall m . MonadIO m + => CF.Stack + -> CFT.Output + -> m Text +fetchStackOutput stack cftOutput = + maybe + (failOutputKey "missing") + (maybe (failOutputKey "has no value") pure . (.outputValue)) + $ Foldable.find + ((==) (pure key) . (.outputKey)) + (fromMaybe [] stack.outputs) where - logicalResourceId = - fromMaybe - "[unknown-logical-resource-id]" - (event.logicalResourceId) - - physicalResourceId = - fromMaybe - "[unknown-physical-resource-id]" - (event.physicalResourceId) - - resourceType = - fromMaybe - "[unknown-resource-type]" - event.resourceType + key :: Text + key = cftOutput.name - resourceStatus :: Text - resourceStatus = - maybe - "[unknown-resource-type]" - CF.fromResourceStatus - event.resourceStatus + failOutputKey :: Text -> m a + failOutputKey message + = failStack + $ "Output: " <> convertText key <> " " <> message - timeFormat :: String - timeFormat = "%Y-%m-%dT%H:%M:%S" - - timestamp :: Text - timestamp - = convertText - . formatTime defaultTimeLocale timeFormat - $ view CF.stackEvent_timestamp event - - sayReason :: Maybe Text -> MIO env () - sayReason = maybe (pure ()) (say . ("- " <>)) + failStack :: Text -> m a + failStack message + = throwString + . convertText + $ "Stack: " <> stack.stackName <> " " <> message -getStack :: AWS.Env env => InstanceSpec.Name -> MIO env (Maybe CF.Stack) -getStack name = - catchJust handleNotFoundError (pure <$> getExistingStack name) pure +readStackOutput + :: AWS.Env env + => StackDeploy.InstanceName + -> CFT.Output + -> MIO env Text +readStackOutput instanceName cftOutput = do + stack <- readCloudFormationStackPresent instanceName + fetchStackOutput stack cftOutput + +readExistingStack + :: AWS.Env env + => StackDeploy.InstanceName + -> MIO env (Maybe ExistingStack) +readExistingStack name = + traverse present =<< readCloudFormationStack name where - handleNotFoundError :: Amazonka.Error -> Maybe (Maybe CF.Stack) - handleNotFoundError - (Amazonka.ServiceError - Amazonka.ServiceError' - { code = Amazonka.ErrorCode "ValidationError" - , message = Just actualMessage + present :: CF.Stack -> MIO env ExistingStack + present stack = do + stackId <- readIdFromStack stack + pure ExistingStack + { stackId = stackId + , outputs = fromMaybe [] stack.outputs + , parameters = fromMaybe [] stack.parameters } - ) - = if actualMessage == expectedMessage - then pure empty - else empty - handleNotFoundError _error = empty - expectedMessage :: Amazonka.ErrorMessage - expectedMessage = - Amazonka.ErrorMessage $ "Stack with id " <> toText name <> " does not exist" - -getStackId :: AWS.Env env => InstanceSpec.Name -> MIO env (Maybe Id) -getStackId = getId <=< getStack - where - getId :: Maybe CF.Stack -> MIO env (Maybe Id) - getId = maybe (pure empty) ((pure <$>) . idFromStack) - -getExistingStack +readCloudFormationStack :: forall env . AWS.Env env - => InstanceSpec.Name - -> MIO env CF.Stack -getExistingStack name = maybe failMissingRequested pure =<< doRequest + => StackDeploy.InstanceName + -> MIO env (Maybe CF.Stack) +readCloudFormationStack name + = Conduit.runConduit + $ AWS.nestedResourceC describeSpecificStack (fromMaybe [] . (.stacks)) + .| Conduit.find ((convert name ==) . (.stackName)) where - doRequest :: MIO env (Maybe CF.Stack) - doRequest = runConduit - $ AWS.listResource describeSpecificStack (fromMaybe [] . (.stacks)) - .| find ((toText name ==) . (.stackName)) - - failMissingRequested :: MIO env a - failMissingRequested - = throwString - $ "Successful request to stack " <> convertText name <> " did not return the stack" - describeSpecificStack :: CF.DescribeStacks - describeSpecificStack = set CF.describeStacks_stackName (pure $ toText name) CF.newDescribeStacks - -getExistingStackId - :: AWS.Env env - => InstanceSpec.Name - -> MIO env Id -getExistingStackId = idFromStack <=< getExistingStack - -getOutput :: AWS.Env env => InstanceSpec.Name -> Text -> MIO env Text -getOutput name key = do - stack <- getExistingStack name - - maybe - (failStack $ "Output " <> convertText key <> " missing") - (maybe (failStack $ "Output " <> convertText key <> " has no value") pure . (.outputValue)) - (Foldable.find ((==) (pure key) . (.outputKey)) (fromMaybe [] $ stack.outputs)) - where - failStack :: Text -> MIO env a - failStack message - = throwString . convertText $ "Stack: " <> convertText name <> " " <> message - -stackNames :: AWS.Env env => ConduitT () InstanceSpec.Name (MIO env) () -stackNames - = AWS.listResource CF.newDescribeStacks (fromMaybe [] . (.stacks)) - .| map (convertImpure . (.stackName)) + describeSpecificStack = + set CF.describeStacks_stackName (pure $ convert name) CF.newDescribeStacks -prepareOperation - :: forall env a . (AWS.Env env, StackDeploy.Env env) - => OperationFields a - -> InstanceSpec env - -> Token - -> a - -> MIO env a -prepareOperation OperationFields{..} InstanceSpec{..} token - = setTemplateBody - . set capabilitiesField (pure capabilities) - . set parametersField (pure $ Parameters.cfParameters parameters) - . set roleARNField (toText <$> roleARN) - . setText tokenField token +readCloudFormationStackPresent + :: forall env . AWS.Env env + => StackDeploy.InstanceName + -> MIO env CF.Stack +readCloudFormationStackPresent instanceName = + maybe absent pure =<< readCloudFormationStack instanceName where - setTemplateBody :: a -> MIO env a - setTemplateBody request = - if BS.length templateBodyBS <= maxBytes - then pure $ setText templateBodyField templateBody request - else s3Template request - - s3Template :: a -> MIO env a - s3Template request = do - ask >>= - (maybe failMissingTemplateBucket (doUpload request =<<) . (.getTemplateBucketName)) . (.stackDeployConfig) - - doUpload :: a -> S3.BucketName -> MIO env a - doUpload request bucketName@(S3.BucketName bucketNameText) = do - S3.syncTarget targetObject - pure $ setText templateURLField s3URL request - where - s3URL = "https://" <> bucketNameText <> ".s3.amazonaws.com/" <> S3.targetObjectKeyText targetObject - - targetObject = - (S3.hashedTargetObject bucketName (toText name) "json" templateBodyBS) - { S3.uploadCallback = liftIO . Text.putStrLn . ("Uploading template: " <>) - } - - failMissingTemplateBucket :: MIO env a - failMissingTemplateBucket - = liftIO - $ fail - $ "Template is bigger than " - <> show maxBytes - <> " cloudformation requires to read the template via an S3 object but the environment specifies none" - - maxBytes :: Int - maxBytes = 51200 - - templateBody = Text.decodeUtf8 templateBodyBS - templateBodyBS = LBS.toStrict $ Template.encode template - -setText :: (Applicative f, ToText b) => Lens' a (f Text) -> b -> a -> a -setText field value = set field (pure $ toText value) + absent = throwString $ "Stack does not exist: " <> convertVia @Text instanceName -finalMessage :: RemoteOperationResult -> Text -finalMessage = \case - RemoteOperationFailure -> "failure" - RemoteOperationSuccess -> "succcess" -idFromStack :: CF.Stack -> MIO env Id -idFromStack = accessStackId CF.stack_stackId +readIdFromStack :: CF.Stack -> MIO env StackId +readIdFromStack = readStackIdField CF.stack_stackId -accessStackId :: Lens' a (Maybe Text) -> a -> MIO env Id -accessStackId lens - = maybe - (throwString "Remote stack without stack id") - (pure . Id) - . view lens +readStackIdField :: Lens' a (Maybe Text) -> a -> MIO env StackId +readStackIdField lens + = maybe (throwString "stack without stack id") convertThrow . view lens diff --git a/stack-deploy/src/StackDeploy/Utils.hs b/stack-deploy/src/StackDeploy/Stratosphere.hs similarity index 71% rename from stack-deploy/src/StackDeploy/Utils.hs rename to stack-deploy/src/StackDeploy/Stratosphere.hs index c7164815..9fd93dbb 100644 --- a/stack-deploy/src/StackDeploy/Utils.hs +++ b/stack-deploy/src/StackDeploy/Stratosphere.hs @@ -1,15 +1,13 @@ -module StackDeploy.Utils where +module StackDeploy.Stratosphere where import StackDeploy.Prelude -import qualified Amazonka.CloudFormation.Types as CF -import qualified Data.Aeson as JSON -import qualified Data.Foldable as Foldable -import qualified Data.Vector as Vector -import qualified Stratosphere as CFT -import qualified Stratosphere.IAM.Role as IAM -import qualified Stratosphere.Logs.LogGroup as Logs -import qualified Stratosphere.S3.Bucket as S3.Bucket +import qualified Data.Aeson as JSON +import qualified Data.Vector as Vector +import qualified Stratosphere as CFT +import qualified Stratosphere.IAM.Role as IAM +import qualified Stratosphere.Logs.LogGroup as Logs +import qualified Stratosphere.S3.Bucket as S3.Bucket mkName :: CFT.Value Text -> CFT.Value Text mkName name = CFT.Join "-" [CFT.awsStackName, name] @@ -62,33 +60,6 @@ dependencies :: [CFT.Resource] -> CFT.Resource -> CFT.Resource dependencies deps resource = resource { CFT.dependsOn = pure (CFT.itemName <$> deps) } -fetchOutput - :: forall m . MonadFail m - => CF.Stack - -> CFT.Output - -> m Text -fetchOutput stack stratosphereOutput = - maybe - (failOutputKey "missing") - (maybe (failOutputKey "has no value") pure . (.outputValue)) - $ Foldable.find - ((==) (pure key) . (.outputKey)) - (fromMaybe [] stack.outputs) - where - key :: Text - key = stratosphereOutput.name - - failOutputKey :: Text -> m a - failOutputKey message - = failStack - $ "Output " <> convertText key <> " " <> message - - failStack :: Text -> m a - failStack message - = fail - . convertText - $ "Stack: " <> stack.stackName <> " " <> message - resolveSecretsmanagerSecret :: CFT.Value Text -> CFT.Value Text resolveSecretsmanagerSecret arn = wrap $ CFT.Join ":" ["resolve", "secretsmanager", arn] where diff --git a/stack-deploy/src/StackDeploy/Template.hs b/stack-deploy/src/StackDeploy/Template.hs deleted file mode 100644 index 4b8abcd2..00000000 --- a/stack-deploy/src/StackDeploy/Template.hs +++ /dev/null @@ -1,64 +0,0 @@ -module StackDeploy.Template - ( Name - , Provider - , Template(..) - , encode - , get - , mk - , testTree - ) -where - -import Data.Ord (compare) -import StackDeploy.Prelude -import System.FilePath ((<.>), ()) - -import qualified Data.Aeson.Encode.Pretty as Pretty -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text.Encoding as Text -import qualified StackDeploy.Provider as Provider -import qualified Stratosphere -import qualified Test.Tasty as Tasty -import qualified Test.Tasty.MGolden as Tasty - -type Name = BoundText "StackDeploy.Template.Name" - -data Template = Template - { name :: Name - , stratosphere :: Stratosphere.Template - } - deriving stock (Eq, Show) - -instance Provider.HasItemName Template where - type ItemName Template = Name - name = (.name) - -type Provider = Provider.Provider Template - --- | Pretty print a template using aeson-pretty. -encode :: Template -> LBS.ByteString -encode = Pretty.encodePretty' config . (.stratosphere) - where - config = Pretty.defConfig - { Pretty.confIndent = Pretty.Spaces 2 - , Pretty.confCompare = compare - } - -get :: MonadThrow m => Provider -> Name -> m Template -get = Provider.get "template" - -mk :: Name -> Stratosphere.Template -> Template -mk = Template - -testTree :: Provider -> Tasty.TestTree -testTree provider - = Tasty.testGroup "template" (templateTest <$> toList provider) - -templateTest :: Template -> Tasty.TestTree -templateTest template@Template{..} = - Tasty.goldenTest - (convertText name) - expectedPath - (pure . Text.decodeUtf8 . LBS.toStrict $ encode template) - where - expectedPath = "test" "template" convertText name <.> ".json" diff --git a/stack-deploy/src/StackDeploy/Template/Code.hs b/stack-deploy/src/StackDeploy/Template/Code.hs index a35e5d1e..51489411 100644 --- a/stack-deploy/src/StackDeploy/Template/Code.hs +++ b/stack-deploy/src/StackDeploy/Template/Code.hs @@ -1,26 +1,26 @@ -module StackDeploy.Template.Code (template) where +module StackDeploy.Template.Code (namedTemplate) where +import StackDeploy.NamedTemplate import StackDeploy.Prelude -import StackDeploy.Template -import StackDeploy.Utils -import Stratosphere hiding (Template) +import StackDeploy.Stratosphere +import qualified Stratosphere as CFT import qualified Stratosphere.S3.Bucket as S3 -template :: Template -template - = mk (fromType @"code") - $ Stratosphere.mkTemplate [codeBucket] - & set @"Outputs" outputs +namedTemplate :: NamedTemplate +namedTemplate + = mkNamedTemplate (fromType @"code") + $ CFT.mkTemplate [codeBucket] + & CFT.set @"Outputs" outputs where outputs - = Outputs - [ mkOutput "CodeBucketName" (toRef codeBucket) - & set @"Export" (OutputExport "CodeBucketName") + = CFT.Outputs + [ CFT.mkOutput "CodeBucketName" (CFT.toRef codeBucket) + & CFT.set @"Export" (CFT.OutputExport "CodeBucketName") ] -codeBucket :: Resource +codeBucket :: CFT.Resource codeBucket - = resource "CodeBucket" + = CFT.resource "CodeBucket" $ S3.mkBucket - & set @"PublicAccessBlockConfiguration" s3BucketBlockPublicAccess + & CFT.set @"PublicAccessBlockConfiguration" s3BucketBlockPublicAccess diff --git a/stack-deploy/src/StackDeploy/Types.hs b/stack-deploy/src/StackDeploy/Types.hs index 5ce2c179..6a5d2055 100644 --- a/stack-deploy/src/StackDeploy/Types.hs +++ b/stack-deploy/src/StackDeploy/Types.hs @@ -2,24 +2,31 @@ module StackDeploy.Types where import Data.Word (Word32) import StackDeploy.InstanceSpec +import StackDeploy.Parameters import StackDeploy.Prelude -import qualified Data.ByteString.Builder as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text.Encoding as Text -import qualified System.Random as Random +import qualified Amazonka.CloudFormation.Types as CF +import qualified Data.ByteString.Builder as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Encoding as Text +import qualified System.Random as Random -newtype Id = Id Text - deriving (Conversion Text) via Text +type StackId = BoundText "StackDeploy.StackId" + +data ExistingStack = ExistingStack + { outputs :: [CF.Output] + , parameters :: [CF.Parameter] + , stackId :: StackId + } data Operation env - = OpCreate (InstanceSpec env) - | OpDelete Id - | OpUpdate Id (InstanceSpec env) + = OpCreate (InstanceSpec env) ParameterMap + | OpDelete ExistingStack + | OpUpdate ExistingStack (InstanceSpec env) ParameterMap data RemoteOperation = RemoteOperation - { stackId :: Id - , token :: Token + { stackId :: StackId + , token :: Token } data RemoteOperationResult = RemoteOperationFailure | RemoteOperationSuccess @@ -29,9 +36,9 @@ newtype Token = Token Text verb :: Operation env -> Text verb = \case - (OpCreate _instanceSpec) -> "create" - (OpDelete _id ) -> "delete" - (OpUpdate _id _instanceSpec) -> "update" + OpCreate{} -> "create" + OpDelete{} -> "delete" + OpUpdate{} -> "update" newToken :: forall m . MonadIO m => m Token newToken = Token . text <$> bytes diff --git a/stack-deploy/src/StackDeploy/Wait.hs b/stack-deploy/src/StackDeploy/Wait.hs index f83dec7f..f07db033 100644 --- a/stack-deploy/src/StackDeploy/Wait.hs +++ b/stack-deploy/src/StackDeploy/Wait.hs @@ -1,6 +1,5 @@ module StackDeploy.Wait (waitForAccept) where -import Data.Set (Set) import StackDeploy.Events import StackDeploy.Prelude import StackDeploy.Types diff --git a/stack-deploy/stack-deploy.cabal b/stack-deploy/stack-deploy.cabal index 56f8dcbe..f8a92d74 100644 --- a/stack-deploy/stack-deploy.cabal +++ b/stack-deploy/stack-deploy.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: stack-deploy -version: 0.0.9 +version: 0.1.0 synopsis: Utilities around cloudformation templates homepage: https://github.com/mbj/mhs#readme bug-reports: https://github.com/mbj/mhs/issues @@ -39,15 +39,15 @@ library StackDeploy.Events StackDeploy.InstanceSpec StackDeploy.IO + StackDeploy.NamedTemplate + StackDeploy.Operation StackDeploy.Parameters StackDeploy.Prelude - StackDeploy.Provider StackDeploy.S3 StackDeploy.Stack - StackDeploy.Template + StackDeploy.Stratosphere StackDeploy.Template.Code StackDeploy.Types - StackDeploy.Utils StackDeploy.Wait other-modules: Paths_stack_deploy @@ -131,11 +131,93 @@ library build-depends: source-constraints +test-suite doctest + type: exitcode-stdio-1.0 + main-is: DocTest.hs + hs-source-dirs: + test + default-extensions: + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NoFieldSelectors + NoImplicitPrelude + NumericUnderscores + OverloadedLists + OverloadedRecordDot + OverloadedStrings + RankNTypes + RecordWildCards + ScopedTypeVariables + Strict + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + ViewPatterns + ghc-options: -Wall -Wcompat -Werror -Widentities -Wimplicit-prelude -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wmissing-local-signatures -Wmissing-signatures -Wmonomorphism-restriction -Wno-ambiguous-fields -Wredundant-constraints -fhide-source-paths -funbox-strict-fields -optP-Wno-nonportable-include-path -rtsopts -threaded -with-rtsopts=-N + build-depends: + aeson >=1.4 + , aeson-pretty >=0.8 + , amazonka >=2.0 + , amazonka-cloudformation >=2.0 + , amazonka-core >=2.0 + , amazonka-s3 >=2.0 + , attoparsec >=0.13 + , base + , bounded + , bytestring + , cli-utils + , conduit >=1.3 + , containers >=0.6 + , conversions + , doctest-parallel + , exceptions >=0.10 + , filepath >=1.4 + , http-types >=0.12 + , lens + , mio-amazonka + , mio-core + , mono-traversable + , mprelude + , mtl + , optparse-applicative >=0.14 + , random >=1.1 + , source-constraints >=0.0.1 + , stratosphere >=1.0 + , stratosphere-ecs >=1.0 + , stratosphere-iam >=1.0 + , stratosphere-lambda >=1.0 + , stratosphere-logs >=1.0 + , stratosphere-s3 >=1.0 + , tasty >=1.3 + , tasty-mgolden >=0.0.1 + , text + , time + , unliftio >=0.2 + , vector >=0.12 + default-language: Haskell2010 + if flag(development) + ghc-options: -Werror + else + ghc-options: -Wwarn + if impl(ghc < 9.5) + ghc-options: -fplugin=SourceConstraints + build-depends: + source-constraints + test-suite test type: exitcode-stdio-1.0 main-is: Test.hs - other-modules: - Paths_stack_deploy hs-source-dirs: test default-extensions: diff --git a/stack-deploy/test/DocTest.hs b/stack-deploy/test/DocTest.hs new file mode 100644 index 00000000..2049f3de --- /dev/null +++ b/stack-deploy/test/DocTest.hs @@ -0,0 +1,8 @@ +module Main where + +import MPrelude + +import qualified Test.DocTest + +main :: IO () +main = Test.DocTest.mainFromCabal "stack-deploy" ["--no-implicit-module-import"] diff --git a/stack-deploy/test/stack-9.4-dependencies.txt b/stack-deploy/test/stack-9.4-dependencies.txt index fcfeaf7d..ba4af04b 100644 --- a/stack-deploy/test/stack-9.4-dependencies.txt +++ b/stack-deploy/test/stack-9.4-dependencies.txt @@ -1,6 +1,7 @@ Cabal 3.8.1.0 Cabal-syntax 3.8.1.0 Diff 0.4.1 +Glob 0.10.2 OneTuple 0.4.1.1 QuickCheck 2.14.3 StateVar 1.2.2 @@ -48,6 +49,7 @@ cereal 0.5.8.3 cli-utils 0.0.1 clock 0.8.4 cmdargs 0.10.22 +code-page 0.2.1 colour 2.3.6 comonad 5.0.8 concurrent-output 1.10.20 @@ -76,6 +78,7 @@ devtools 0.2.0 directory 1.3.7.1 distributive 0.6.2.1 dlist 1.0 +doctest-parallel 0.3.1 entropy 0.4.1.10 erf 2.0.0.0 exceptions 0.10.5 @@ -93,6 +96,7 @@ ghc-boot-th 9.4.8 ghc-heap 9.4.8 ghc-lib-parser 9.4.8.20231111 ghc-lib-parser-ex 9.4.0.0 +ghc-paths 0.1.0.12 ghc-prim 0.9.1 ghci 9.4.8 happy 1.20.1.1 @@ -160,7 +164,7 @@ socks 0.6.1 source-constraints 0.0.5 split 0.2.3.5 splitmix 0.1.0.5 -stack-deploy 0.0.9 +stack-deploy 0.1.0 stm 2.5.1.0 stratosphere 1.0.0 stratosphere-ecs 1.0.0