diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +## 0.1.0.0 (July 26th, 2017) + +### Breaking Changes + +- The `deploy` command is renamed to `provision`. +- The environment is now passed as a positional argument instead of as an environment variable. + +### New Features + +- Added support for configuring parameters with command-line flags and hardcoded environments, in addition to environment variables. +- Parameters are now parsed from template files to determine whether or not they are optional. +- Tags `cj:application` and `cj:environment` are always added, based on the mandatory `ENV` positional argument and information in the configuration. +- The `whenEnv` and `getEnvArg` functions are provided to conditionally configure stacks based on the current environment. + +### Bugfixes and Minor Changes + +- Various improvements to CLI help text. + ## 0.0.0.0 (June 26th, 2017) - Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,101 @@ -# haskell-cloud-seeder +# cloud-seeder [![Build Status](https://travis-ci.org/cjdev/cloud-seeder.svg?branch=master)](https://travis-ci.org/cjdev/cloud-seeder) -A Haskell library for interacting with CloudFormation stacks +`cloud-seeder` is a Haskell DSL for provisioning and controlling [CloudFormation][aws-cloudformation] stacks. It provides an opinionated mechanism for provisioning a set of related stacks called a “deployment”. You write ordinary CloudFormation [templates][aws-cloudformation-templates] as YAML, and `cloud-seeder` helps to create a self-executing command-line interface to orchestrate their deployment. + +For example consider a template that provisions an S3 bucket with a configurable name, `bucket.yaml`: + +```yaml +AWSTemplateFormatVersion: '2010-09-09' + +Parameters: + BucketName: + Type: String + +Resources: + Bucket: + Type: AWS::S3::Bucket + Properties: + BucketName: !Ref BucketName + +Outputs: + Bucket: + Value: !Ref Bucket + BucketDomain: + Value: !GetAtt Bucket.DomainName +``` + +Using `cloud-seeder`, you can create a deployment script in the same directory, `config.hs`: + +```haskell +#!/usr/bin/env stack +-- stack runhaskell +{-# LANGUAGE OverloadedStrings #-} + +import Network.CloudSeeder + +main = cliIO $ deployment "cloud-seeder-example" $ do + stack "bucket" $ do + flag "BucketName" +``` + +This file contains a declarative configuration of your deployment, but it also serves as an executable command-line tool! Since it has a shebang at the top, it can be used directly to run the deployment with a pleasant interface: + +``` +$ ./config.hs provision bucket production --BucketName my-awesome-s3-bucket +``` + +The first argument to the `provision` command is the stack you want to provision, and the second argument is the name of some “environment” to provision in. This environment is used to namespace the eventual stack name, so the above command will spin up a new CloudFormation stack called `production-cloud-seeder-example-bucket`. The environment is also available in templates themselves if they specify an `Env` [parameter][aws-cloudformation-parameters]. The generated command-line interface is also robust in the face of mistakes, and it won’t do anything if a required parameter isn’t specified. + +While `cloud-seeder` *can* be used for single-stack deployments, it’s far more useful when used with multiple stacks at a time, which may possibly depend on other stacks’ [outputs][aws-cloudformation-outputs]. For example, we may now wish to serve resources out of our S3 bucket by using CloudFront. We can write a second template to do the job, `cdn.yaml`: + +```yaml +AWSTemplateFormatVersion: '2010-09-09' + +Parameters: + BucketDomainName: + Type: String + +Resources: + Distribution: + Type: AWS::CloudFront::Distribution + Properties: + DistributionConfig: + Enabled: true + Origins: + - DomainName: !Ref BucketDomainName + Id: origin + S3OriginConfig: {} + # ... +``` + +We can now add `cdn` to our deployment configuration: + +```haskell +#!/usr/bin/env stack +-- stack runhaskell +{-# LANGUAGE OverloadedStrings #-} + +import Network.CloudSeeder + +main = cliIO $ deployment "cloud-seeder-example" $ do + stack "bucket" $ do + flag "BucketName" + + stack_ "cdn" +``` + +We use `stack_` instead of `stack` to omit the configuration block, since the `cdn` stack doesn’t need any additional configuration options. When we go to provision the stack, it will work just fine: + +``` +$ ./config.hs provision cdn production +``` + +Note that we did **not** have to specify the `BucketDomainName` [parameter][aws-cloudformation-parameters] explicitly, because it was an [output][aws-cloudformation-outputs] from the `bucket` stack, so it is automatically passed downward to the `cdn` stack. This allows stacks defined lower in the configuration to build on top of resources defined in previous ones. + +For more information about all of the configuration options available, as well as some of the implementation details, see [the documentation on Hackage][cloud-seeder]. + +[aws-cloudformation]: https://aws.amazon.com/cloudformation/ +[aws-cloudformation-outputs]: http://docs.aws.amazon.com/AWSCloudFormation/latest/UserGuide/outputs-section-structure.html +[aws-cloudformation-parameters]: http://docs.aws.amazon.com/AWSCloudFormation/latest/UserGuide/parameters-section-structure.html +[aws-cloudformation-templates]: http://docs.aws.amazon.com/AWSCloudFormation/latest/UserGuide/template-guide.html +[cloud-seeder]: http://hackage.haskell.org/package/cloud-seeder diff --git a/cloud-seeder.cabal b/cloud-seeder.cabal --- a/cloud-seeder.cabal +++ b/cloud-seeder.cabal @@ -1,9 +1,9 @@ --- This file has been generated from package.yaml by hpack version 0.17.0. +-- This file has been generated from package.yaml by hpack version 0.17.1. -- -- see: https://github.com/sol/hpack name: cloud-seeder -version: 0.0.0.0 +version: 0.1.0.0 synopsis: A tool for interacting with AWS CloudFormation description: This package provides a DSL for creating deployment configurations, as well as an interpreter that reads deployment configurations in order to deploy @@ -33,40 +33,36 @@ library hs-source-dirs: library - default-extensions: ApplicativeDo ConstraintKinds DefaultSignatures DeriveGeneric ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeOperators - ghc-options: -Wall + default-extensions: ApplicativeDo ConstraintKinds DefaultSignatures DeriveGeneric ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedLists OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeOperators + ghc-options: -Wall -Wredundant-constraints build-depends: - amazonka >= 1.4.5 + aeson >= 0.11.2.0 + , amazonka >= 1.4.5 , amazonka-cloudformation >= 1.4.5 , amazonka-core >= 1.4.5 , base >= 4.9.0.0 && < 5 + , containers , deepseq >= 1.4.1.0 - , exceptions >= 0.8 && < 0.9 + , exceptions >= 0.6 , lens , monad-control >= 1.0.0.0 - , monad-logger >= 0.3.13.1 - , monad-time >= 0.2 + , monad-logger >= 0.3.11.1 , mtl - , optparse-applicative >= 0.13.0.0 + , optparse-applicative >= 0.14.0.0 , text , transformers , transformers-base + , unordered-containers + , uuid >= 1.2.6 && < 2 + , yaml >= 0.8 exposed-modules: + Network.CloudSeeder Network.CloudSeeder.CommandLine Network.CloudSeeder.DSL Network.CloudSeeder.Interfaces Network.CloudSeeder.Main - default-language: Haskell2010 - -executable cloud-seeder - main-is: Main.hs - hs-source-dirs: - executable - default-extensions: ApplicativeDo ConstraintKinds DefaultSignatures DeriveGeneric ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeOperators - ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N - build-depends: - base - , cloud-seeder + Network.CloudSeeder.Template + Network.CloudSeeder.Types default-language: Haskell2010 test-suite cloud-seeder-test-suite @@ -74,23 +70,29 @@ main-is: Main.hs hs-source-dirs: test-suite - default-extensions: ApplicativeDo ConstraintKinds DefaultSignatures DeriveGeneric ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeOperators - ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N + default-extensions: ApplicativeDo ConstraintKinds DefaultSignatures DeriveGeneric ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedLists OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeOperators + ghc-options: -Wall -Wredundant-constraints -rtsopts -threaded -with-rtsopts=-N build-depends: - amazonka-cloudformation >= 1.4 && < 1.5 - , base >= 4.9.0.0 && < 5 + amazonka-cloudformation + , base , bytestring , cloud-seeder - , deepseq >= 1.4.1.0 - , fast-logger >= 2.4.8 - , hspec >= 2.4 && < 2.5 + , containers + , deepseq + , fast-logger + , hspec , lens - , monad-logger >= 0.3 && < 0.4 + , monad-logger + , monad-mock , mtl - , text >= 1.2 && < 1.3 + , optparse-applicative + , text , transformers + , yaml other-modules: + Network.CloudSeeder.CommandLineSpec Network.CloudSeeder.DSLSpec Network.CloudSeeder.MainSpec + Network.CloudSeeder.TemplateSpec Network.CloudSeeder.Test.Stubs default-language: Haskell2010 diff --git a/executable/Main.hs b/executable/Main.hs deleted file mode 100644 --- a/executable/Main.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = return () diff --git a/library/Network/CloudSeeder.hs b/library/Network/CloudSeeder.hs new file mode 100644 --- /dev/null +++ b/library/Network/CloudSeeder.hs @@ -0,0 +1,21 @@ +module Network.CloudSeeder + ( deployment + , module Network.CloudSeeder.CommandLine + , module Network.CloudSeeder.DSL + , module Network.CloudSeeder.Interfaces + , module Control.Monad + ) where + +import qualified Network.CloudSeeder.DSL as DSL + +import Data.Text (Text) +import Control.Monad +import Control.Monad.State (StateT) + +import Network.CloudSeeder.CommandLine +import Network.CloudSeeder.DSL hiding (deployment) +import Network.CloudSeeder.Interfaces +import Network.CloudSeeder.Main + +deployment :: Text -> StateT DeploymentConfiguration AppM a -> IO () +deployment x y = cliIO $ DSL.deployment x y diff --git a/library/Network/CloudSeeder/CommandLine.hs b/library/Network/CloudSeeder/CommandLine.hs --- a/library/Network/CloudSeeder/CommandLine.hs +++ b/library/Network/CloudSeeder/CommandLine.hs @@ -1,23 +1,127 @@ +{-| +This module implements command-line parsing for cloud-seeder. The core +command-line interface, from the user’s point of view, is simple: there are a +set of subcommands (such as “provision”) that take various positional arguments +and flags. Internally, however, the parsing is a little more complex, and this +is because we want to use the user’s deployment configuration to /generate/ a +set of options that may be supplied. + +For example, if the user specifies the following configuration: + +@ +'Network.CloudSeeder.DSL.deployment' "foo" $ do + 'Network.CloudSeeder.DSL.flag' "SomeParam" +@ + +…then we want to generate a @--SomeParam=[PARAM]@ option. Not only that, we want +to make it optional or required based on whether or not there is a default value +or not. + +To accomplish this, we need to collect all the flags from the DSL, /then/ run +the command-line parser. If we do that, though, we have a new problem! The DSL +might need access to the environment, which is a positional argument. This is a +circular dependency: we need to parse the environment from the command line in +order to execute the DSL, but we need to execute the DSL in order to know which +flags to parse from the command line. + +To solve this problem, we parse arguments in two phases: first, we parse +positional arguments and accept /any/ options (and ignore them). Once we’ve used +the information in the positional arguments to evaluate the DSL, we parse the +arguments a second time, enhanced with more information. +-} module Network.CloudSeeder.CommandLine ( Command(..) - , commandParser + , ParameterSpec(..) + , parseArguments + , parseOptions ) where -import Data.Semigroup ((<>)) -import Options.Applicative (Parser, Mod, OptionFields, subparser, command, info, progDesc, strOption, long, metavar, help) +import Control.Lens ((^.)) +import Data.Monoid ((<>)) +import Options.Applicative + +import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T -data Command = DeployStack T.Text +import Network.CloudSeeder.Types + +data Command + -- | @'ProvisionStack' "stack" "env"@ + = ProvisionStack T.Text T.Text deriving (Eq, Show) -textOption :: Mod OptionFields String -> Parser T.Text -textOption = fmap T.pack . strOption +-- | A parser that corresponds to the first “parsing phase” for the @provision@ +-- subcommand, as described in the module documentation for +-- 'Network.CloudSeeder.CommandLine'. +parseArguments :: ParserInfo Command +parseArguments = program PhaseArguments -commandParser :: Parser Command -commandParser = subparser $ command "deploy" (info (DeployStack <$> stackName) (progDesc "deploy a stack")) +-- | A parser that corresponds to the second “parsing phase” for the @provision@ +-- subcommand, as described in the module documentation for +-- 'Network.CloudSeeder.CommandLine'. +parseOptions :: S.Set ParameterSpec -> ParserInfo (M.Map T.Text T.Text) +parseOptions = program . PhaseOptions + +program :: ParsingPhase r -> ParserInfo r +program phase = info (helper <*> provision phase) + (fullDesc <> progDesc "Manage stacks in CloudFormation") + +-- | Represents the current “parsing phase”, as described in the module +-- documentation for 'Network.CloudSeeder.CommandLine'. Used to parameterize +-- the 'provision' parser. +data ParsingPhase r where + PhaseArguments :: ParsingPhase Command + PhaseOptions :: S.Set ParameterSpec -> ParsingPhase (M.Map T.Text T.Text) + +-- | Parser for the 'provision' subcommand, which parses a 'ProvisionStack' +-- value if it succeeds. +-- +-- This parsers has two “phases” of parsing, as noted in the module +-- documentation for 'Network.CloudSeeder.CommandLine'. This is reflected in the +-- first argument, which also controls the result of the parser. +provision :: ParsingPhase r -> Parser r +provision phase = subparser . command "provision" $ info parser infoMod where - stackName :: Parser T.Text - stackName = textOption - ( long "stack-name" - <> metavar "STACK_NAME" - <> help "the name of the stack in the configuration") + -- When parsing arguments, we want to ignore options. Using 'forwardOptions' + -- treats them as positional arguments rather than outright ignoring them, + -- but that’s good enough for our purposes. + infoMod = progDesc "Provision a stack in an environment" <> case phase of + PhaseArguments -> forwardOptions + PhaseOptions _ -> mempty + + parser = case phase of + PhaseArguments -> commandParser <* ignoreArguments + PhaseOptions specs -> helper <*> (commandParser *> optionsParser specs) + where + ignoreArguments = many $ strArgument @String hidden + + commandParser :: Parser Command + commandParser = ProvisionStack <$> helper' stack <*> helper' env + where + stack = textArgument (metavar "STACK") + env = textArgument (metavar "ENV") + -- This is like 'helper', but slightly modified to avoid over-eagerly + -- failing. This carefully handles “deferring” showing the help text to + -- 'PhaseOptions' if both STACK and ENV are supplied. + helper' p = (abortOption ShowHelpText opts <*> empty) <|> p + where opts = long "help" <> short 'h' <> internal + + optionsParser :: S.Set ParameterSpec -> Parser (M.Map T.Text T.Text) + optionsParser specs = M.fromList <$> traverse parameter (S.toList specs) + where + parameter spec = do + let key = spec ^. parameterKey + keyStr = T.unpack key + val <- textOption (long keyStr <> metavar keyStr <> defaultMod spec) + pure (key, val) + + defaultMod (Required _) = mempty + defaultMod (Optional _ defVal) = value (T.unpack defVal) + +-- helpers -- +textArgument :: Mod ArgumentFields String -> Parser T.Text +textArgument = fmap T.pack . strArgument + +textOption :: Mod OptionFields String -> Parser T.Text +textOption = fmap T.pack . strOption diff --git a/library/Network/CloudSeeder/DSL.hs b/library/Network/CloudSeeder/DSL.hs --- a/library/Network/CloudSeeder/DSL.hs +++ b/library/Network/CloudSeeder/DSL.hs @@ -1,50 +1,74 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedLists #-} module Network.CloudSeeder.DSL ( DeploymentConfiguration(..) , StackConfiguration(..) - , environmentVariables - , name - , stacks + , HasName(..) + , HasParameterSources(..) + , HasStacks(..) + , HasTagSet(..) , deployment , environment + , flag + , tags + , param , stack_ , stack - ) - where + ) where import Control.Lens ((%=)) import Control.Monad.State (StateT, execStateT, lift) import Control.Lens.TH (makeFields) +import Data.Semigroup ((<>)) + +import qualified Data.Set as S import qualified Data.Text as T +import Network.CloudSeeder.Types + data DeploymentConfiguration = DeploymentConfiguration { _deploymentConfigurationName :: T.Text - , _deploymentConfigurationEnvironmentVariables :: [T.Text] + , _deploymentConfigurationTagSet :: S.Set (T.Text, T.Text) , _deploymentConfigurationStacks :: [StackConfiguration] + , _deploymentConfigurationParameterSources :: S.Set (T.Text, ParameterSource) } deriving (Eq, Show) data StackConfiguration = StackConfiguration { _stackConfigurationName :: T.Text - , _stackConfigurationEnvironmentVariables :: [T.Text] + , _stackConfigurationTagSet :: S.Set (T.Text, T.Text) + , _stackConfigurationParameterSources :: S.Set (T.Text, ParameterSource) } deriving (Eq, Show) makeFields ''DeploymentConfiguration makeFields ''StackConfiguration +paramSource :: (Monad m, HasParameterSources a (S.Set (T.Text, ParameterSource)) ) => T.Text -> ParameterSource -> StateT a m () +paramSource pName source = parameterSources %= S.insert (pName, source) + deployment :: Monad m => T.Text -> StateT DeploymentConfiguration m a -> m DeploymentConfiguration deployment name' x = - let config = DeploymentConfiguration name' [] [] + let config = DeploymentConfiguration name' [] [] [] in execStateT x config -environment :: (Monad m, HasEnvironmentVariables a [T.Text]) => [T.Text] -> StateT a m () -environment vars = environmentVariables %= (++ vars) +environment :: (Monad m, HasParameterSources a (S.Set (T.Text, ParameterSource))) => [T.Text] -> StateT a m () +environment = mapM_ (flip paramSource Env) +flag :: (Monad m, HasParameterSources a (S.Set (T.Text, ParameterSource))) => T.Text -> StateT a m () +flag pName = paramSource pName Flag + +tags :: (Monad m, HasTagSet a (S.Set (T.Text, T.Text))) => [(T.Text, T.Text)] -> StateT a m () +tags ts = tagSet %= (<> S.fromList ts) + +param :: (Monad m, HasParameterSources a (S.Set (T.Text, ParameterSource))) + => T.Text -> T.Text -> StateT a m () +param key val = paramSource key (Constant val) + stack_ :: Monad m => T.Text -> StateT DeploymentConfiguration m () stack_ name' = stack name' $ return () stack :: Monad m => T.Text -> StateT StackConfiguration m a -> StateT DeploymentConfiguration m () stack name' x = do - let stackConfig = StackConfiguration name' [] + let stackConfig = StackConfiguration name' [] [] stackConfig' <- lift $ execStateT x stackConfig stacks %= (++ [stackConfig']) diff --git a/library/Network/CloudSeeder/Interfaces.hs b/library/Network/CloudSeeder/Interfaces.hs --- a/library/Network/CloudSeeder/Interfaces.hs +++ b/library/Network/CloudSeeder/Interfaces.hs @@ -3,8 +3,11 @@ {-# LANGUAGE UndecidableInstances #-} module Network.CloudSeeder.Interfaces - ( MonadArguments(..) - , MonadFileSystem(..) + ( MonadCLI(..) + , getArgs' + , getOptions' + , whenEnv + , getEnvArg , MonadCloud(..) , computeChangeset' @@ -14,6 +17,7 @@ , MonadEnvironment(..) , StackName(..) + , MonadFileSystem(..) , FileSystemError(..) , readFile' , HasFileSystemError(..) @@ -26,7 +30,7 @@ import Control.DeepSeq (NFData) import Control.Lens (Traversal', (.~), (^.), (^?), (?~), _Just, only, to) import Control.Lens.TH (makeClassy, makeClassyPrisms) -import Control.Monad (void, unless) +import Control.Monad (void, unless, when) import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Error.Lens (throwing) @@ -42,20 +46,24 @@ import Data.Function ((&)) import Data.Semigroup ((<>)) import Data.String (IsString) +import Data.UUID (toText) +import Data.UUID.V4 (nextRandom) import GHC.Generics (Generic) import GHC.IO.Exception (IOException(..), IOErrorType(..)) import Network.AWS (AsError(..), ErrorMessage(..), HasEnv(..), serviceMessage) -import Network.AWS.CloudFormation.CreateChangeSet (createChangeSet, ccsChangeSetType, ccsParameters, ccsTemplateBody, ccsCapabilities, ccsrsId) +import Network.AWS.CloudFormation.CreateChangeSet (createChangeSet, ccsChangeSetType, ccsParameters, ccsTemplateBody, ccsCapabilities, ccsrsId, ccsTags) import Network.AWS.CloudFormation.DescribeChangeSet (describeChangeSet, drsExecutionStatus) import Network.AWS.CloudFormation.DescribeStacks (dStackName, dsrsStacks, describeStacks) import Network.AWS.CloudFormation.ExecuteChangeSet (executeChangeSet) -import Network.AWS.CloudFormation.Types (Capability(..), ChangeSetType(..), ExecutionStatus(..), Output, oOutputKey, oOutputValue, parameter, pParameterKey, pParameterValue, sOutputs) -import Options.Applicative (execParser, info, (<**>), helper, fullDesc, progDesc, header) -import System.Environment (lookupEnv) +import Network.AWS.CloudFormation.Types (Capability(..), ChangeSetType(..), ExecutionStatus(..), Output, oOutputKey, oOutputValue, parameter, pParameterKey, pParameterValue, sOutputs, tag, tagKey, tagValue) +import Options.Applicative (execParser) +import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Control.Exception.Lens as IO +import qualified System.Environment as IO import Network.CloudSeeder.CommandLine @@ -65,29 +73,44 @@ -------------------------------------------------------------------------------- -- | A class of monads that can access command-line arguments. -class Monad m => MonadArguments m where - -- | Returns the command-line arguments provided to the program. - getArgs :: m Command - default getArgs :: (MonadTrans t, MonadArguments m', m ~ t m') => m Command +class Monad m => MonadCLI m where + -- | Returns positional arguments provided to the program while ignoring flags -- separate from getOptions to avoid cyclical dependencies. + getArgs :: m Command + default getArgs :: (MonadTrans t, MonadCLI m', m ~ t m') => m Command getArgs = lift getArgs -instance MonadArguments m => MonadArguments (ExceptT e m) -instance MonadArguments m => MonadArguments (LoggingT m) -instance MonadArguments m => MonadArguments (ReaderT r m) -instance MonadArguments m => MonadArguments (StateT s m) -instance (Monoid s, MonadArguments m) => MonadArguments (WriterT s m) + -- | Returns flags provided to the program while ignoring positional arguments -- separate from getArgs to avoid cyclical dependencies. + getOptions :: S.Set ParameterSpec -> m (M.Map T.Text T.Text) + default getOptions :: (MonadTrans t, MonadCLI m', m ~ t m') => S.Set ParameterSpec -> m (M.Map T.Text T.Text) + getOptions = lift . getOptions -instance MonadArguments IO where - getArgs = execParser opts - where - opts = info (commandParser <**> helper) - ( fullDesc - <> progDesc "deploy stacks to the cloud" - <> header "CloudSeeder" - ) +getArgs' :: MonadBase IO m => m Command +getArgs' = liftBase $ execParser parseArguments + +getOptions' :: MonadBase IO m => S.Set ParameterSpec -> m (M.Map T.Text T.Text) +getOptions' = liftBase . execParser . parseOptions + +instance MonadCLI m => MonadCLI (ExceptT e m) +instance MonadCLI m => MonadCLI (LoggingT m) +instance MonadCLI m => MonadCLI (ReaderT r m) +instance MonadCLI m => MonadCLI (StateT s m) +instance (Monoid s, MonadCLI m) => MonadCLI (WriterT s m) + +-- DSL helpers + +getEnvArg :: MonadCLI m => m T.Text +getEnvArg = do + (ProvisionStack _ env) <- getArgs + return env + +whenEnv :: MonadCLI m => T.Text -> m () -> m () +whenEnv env x = do + envToProvision <- getEnvArg + when (envToProvision == env) x + -------------------------------------------------------------------------------- -data FileSystemError +newtype FileSystemError = FileNotFound T.Text deriving (Eq, Show) @@ -122,14 +145,14 @@ -------------------------------------------------------------------------------- -- | A class of monads that can interact with cloud deployments. class Monad m => MonadCloud m where - computeChangeset :: StackName -> T.Text -> [(T.Text, T.Text)] -> m T.Text - getStackOutputs :: StackName -> m (Maybe [(T.Text, T.Text)]) + computeChangeset :: StackName -> T.Text -> M.Map T.Text T.Text -> M.Map T.Text T.Text -> m T.Text + getStackOutputs :: StackName -> m (Maybe (M.Map T.Text T.Text)) runChangeSet :: T.Text -> m () - default computeChangeset :: (MonadTrans t, MonadCloud m', m ~ t m') => StackName -> T.Text -> [(T.Text, T.Text)] -> m T.Text - computeChangeset a b c = lift $ computeChangeset a b c + default computeChangeset :: (MonadTrans t, MonadCloud m', m ~ t m') => StackName -> T.Text -> M.Map T.Text T.Text -> M.Map T.Text T.Text -> m T.Text + computeChangeset a b c d = lift $ computeChangeset a b c d - default getStackOutputs :: (MonadTrans t, MonadCloud m', m ~ t m') => StackName -> m (Maybe [(T.Text, T.Text)]) + default getStackOutputs :: (MonadTrans t, MonadCloud m', m ~ t m') => StackName -> m (Maybe (M.Map T.Text T.Text)) getStackOutputs = lift . getStackOutputs default runChangeSet :: (MonadTrans t, MonadCloud m', m ~ t m') => T.Text -> m () @@ -141,16 +164,21 @@ _StackDoesNotExistError (StackName stackName) = _ServiceError.serviceMessage._Just.only (ErrorMessage msg) where msg = "Stack with id " <> stackName <> " does not exist" -computeChangeset' :: MonadCloudIO r m => StackName -> T.Text -> [(T.Text, T.Text)] -> m T.Text -computeChangeset' (StackName stackName) templateBody params = do +computeChangeset' :: MonadCloudIO r m => StackName -> T.Text -> M.Map T.Text T.Text -> M.Map T.Text T.Text -> m T.Text +computeChangeset' (StackName stackName) templateBody params tags = do env <- ask let stackCheckRequest = describeStacks & dStackName ?~ stackName + + uuid <- liftBase nextRandom + let changeSetName = "cs-" <> toText uuid -- change set name must begin with a letter + runResourceT . runAWST env $ do stackCheckResponse <- IO.trying_ (_StackDoesNotExistError (StackName stackName)) $ send stackCheckRequest - let changeSet = createChangeSet stackName stackName -- TODO gen UUID for changeset name - & ccsParameters .~ (awsParam <$> params) + let changeSet = createChangeSet stackName changeSetName + & ccsParameters .~ map awsParam (M.toList params) & ccsTemplateBody ?~ templateBody & ccsCapabilities .~ [CapabilityIAM] + & ccsTags .~ map awsTag (M.toList tags) request <- case stackCheckResponse ^? _Just.dsrsStacks of Nothing -> return $ changeSet & ccsChangeSetType ?~ Create Just [_] -> return $ changeSet & ccsChangeSetType ?~ Update @@ -162,8 +190,11 @@ awsParam (key, val) = parameter & pParameterKey ?~ key & pParameterValue ?~ val + awsTag (key, val) = tag + & tagKey ?~ key + & tagValue ?~ val -getStackOutputs' :: MonadCloudIO r m => StackName -> m (Maybe [(T.Text, T.Text)]) +getStackOutputs' :: MonadCloudIO r m => StackName -> m (Maybe (M.Map T.Text T.Text)) getStackOutputs' (StackName stackName) = do env <- ask let request = describeStacks & dStackName ?~ stackName @@ -171,7 +202,7 @@ response <- IO.trying_ (_StackDoesNotExistError (StackName stackName)) $ send request case response ^? _Just.dsrsStacks of Nothing -> return Nothing - Just [stack] -> Just <$> mapM outputToTuple (stack ^. sOutputs) + Just [stack] -> Just . M.fromList <$> mapM outputToTuple (stack ^. sOutputs) Just _ -> fail "getStackOutputs: describeStacks returned more than one stack" where outputToTuple :: Monad m => Output -> m (T.Text, T.Text) @@ -211,7 +242,7 @@ getEnv = lift . getEnv instance MonadEnvironment IO where - getEnv = fmap (fmap T.pack) . lookupEnv . T.unpack + getEnv = fmap (fmap T.pack) . IO.lookupEnv . T.unpack instance MonadEnvironment m => MonadEnvironment (ExceptT e m) instance MonadEnvironment m => MonadEnvironment (LoggingT m) diff --git a/library/Network/CloudSeeder/Main.hs b/library/Network/CloudSeeder/Main.hs --- a/library/Network/CloudSeeder/Main.hs +++ b/library/Network/CloudSeeder/Main.hs @@ -4,8 +4,7 @@ {-# LANGUAGE UndecidableInstances #-} module Network.CloudSeeder.Main - ( Command(..) - , StackName(..) + ( AppM , CliError(..) , HasCliError(..) , AsCliError(..) @@ -14,8 +13,8 @@ ) where import Control.Applicative.Lift (Errors, failure, runErrors) -import Control.Lens ((^.), (^..), each, has, only, to) -import Control.Lens.TH (makeClassy, makeClassyPrisms) +import Control.Lens (Getting, Prism', (^.), (^..), _1, _2, _Wrapped, anyOf, aside, each, filtered, folded, makeClassy, makeClassyPrisms, has, only, to) +import Control.Monad (unless) import Control.Monad.Base (MonadBase) import Control.Monad.Catch (MonadCatch, MonadThrow) import Control.Monad.Error.Lens (throwing) @@ -24,8 +23,11 @@ import Control.Monad.Logger (LoggingT, MonadLogger, runStderrLoggingT) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl(..)) -import Data.List (find, sort) -import Data.Semigroup ((<>)) +import Data.Function (on) +import Data.List (find, groupBy, sort) +import Data.Text.Encoding (encodeUtf8) +import Data.Semigroup (Endo, (<>)) +import Data.Yaml (decodeEither) import Network.AWS (Credentials(Discover), Env, newEnv) import System.Exit (exitFailure) @@ -33,10 +35,14 @@ import qualified Data.Text as T import qualified Data.Text.IO as T +import qualified Data.Map as M +import qualified Data.Set as S import Network.CloudSeeder.CommandLine import Network.CloudSeeder.DSL import Network.CloudSeeder.Interfaces +import Network.CloudSeeder.Template +import Network.CloudSeeder.Types -------------------------------------------------------------------------------- -- IO wiring @@ -46,6 +52,11 @@ | CliFileSystemError FileSystemError | CliStackNotConfigured T.Text | CliMissingDependencyStacks [T.Text] + | CliTemplateDecodeFail String + | CliMissingRequiredParameters (S.Set T.Text) + | CliDuplicateParameterValues (M.Map T.Text [T.Text]) + | CliDuplicateTagValues (M.Map T.Text [T.Text]) + | CliExtraParameterFlags (S.Set T.Text) deriving (Eq, Show) makeClassy ''CliError @@ -62,11 +73,29 @@ renderCliError (CliMissingDependencyStacks stackNames) = "the following dependency stacks do not exist in AWS:\n" <> T.unlines (map (" " <>) stackNames) +renderCliError (CliTemplateDecodeFail decodeFailure) + = "template YAML decoding failed: " <> T.pack decodeFailure +renderCliError (CliMissingRequiredParameters params) + = "the following required parameters were not supplied:\n" + <> T.unlines (map (" " <>) (S.toAscList params)) +renderCliError (CliDuplicateParameterValues params) + = "the following parameters were supplied more than one value:\n" + <> renderKeysToManyVals params +renderCliError (CliDuplicateTagValues ts) + = "the following tags were supplied more than one value:\n" + <> renderKeysToManyVals ts +renderCliError (CliExtraParameterFlags ts) + = "parameter flags defined in config that were not present in template:\n" + <> T.unlines (map (" " <>) (S.toAscList ts)) +renderKeysToManyVals :: M.Map T.Text [T.Text] -> T.Text +renderKeysToManyVals xs = T.unlines $ map renderKeyToManyVals (M.toAscList xs) + where renderKeyToManyVals (k, vs) = k <> ": " <> T.intercalate ", " vs + newtype AppM a = AppM (ReaderT Env (ExceptT CliError (LoggingT IO)) a) deriving ( Functor, Applicative, Monad, MonadIO, MonadBase IO , MonadCatch, MonadThrow, MonadReader Env, MonadError CliError - , MonadLogger, MonadArguments, MonadEnvironment ) + , MonadLogger, MonadEnvironment ) instance MonadBaseControl IO AppM where type StM AppM a = StM (ReaderT Env (ExceptT CliError (LoggingT IO))) a @@ -76,6 +105,10 @@ instance MonadFileSystem CliError AppM where readFile = readFile' +instance MonadCLI AppM where + getArgs = getArgs' + getOptions = getOptions' + instance MonadCloud AppM where computeChangeset = computeChangeset' getStackOutputs = getStackOutputs' @@ -93,41 +126,126 @@ instance AsFileSystemError CliError where _FileSystemError = _CliFileSystemError -cli :: (MonadCloud m, MonadFileSystem CliError m, MonadEnvironment m) => Command -> DeploymentConfiguration -> m () -cli (DeployStack nameToDeploy) config = do - let allNames = config ^.. stacks.each.name - dependencies = takeWhile (/= nameToDeploy) allNames +cli :: (MonadCLI m, MonadCloud m, MonadFileSystem CliError m, MonadEnvironment m) => m DeploymentConfiguration -> m () +cli mConfig = do + config <- mConfig + (ProvisionStack nameToProvision env) <- getArgs + + let dependencies = takeWhile (/= nameToProvision) (config ^.. stacks.each.name) appName = config ^. name - maybeStackToDeploy = config ^. stacks.to (find (has (name.only nameToDeploy))) - stackToDeploy <- maybe (throwing _CliStackNotConfigured nameToDeploy) return maybeStackToDeploy - let requiredGlobalEnvVars = "Env" : (config ^. environmentVariables) - requiredStackEnvVars = stackToDeploy ^. environmentVariables - requiredEnvVars = requiredGlobalEnvVars ++ requiredStackEnvVars + stackToProvision <- getStackToProvision config nameToProvision - maybeEnvValues <- mapM (\envVarKey -> (envVarKey,) <$> getEnv envVarKey) requiredEnvVars - let envVarsOrFailure = runErrors $ traverse (extractResult (,)) maybeEnvValues - envVars <- either (throwError . CliMissingEnvVars . sort) return envVarsOrFailure + templateBody <- readFile $ nameToProvision <> ".yaml" + template <- decodeTemplate templateBody - let env = snd $ head envVars - let mkStackName s = StackName $ env <> "-" <> appName <> "-" <> s + let paramSources = (config ^. parameterSources) <> (stackToProvision ^. parameterSources) + paramSpecs = template ^. parameterSpecs._Wrapped + allParams <- getParameters paramSources paramSpecs dependencies env appName + allTags <- getTags config stackToProvision env appName - templateBody <- readFile $ nameToDeploy <> ".yaml" + let fullStackName = mkFullStackName env appName nameToProvision + csId <- computeChangeset fullStackName templateBody allParams allTags + runChangeSet csId - maybeOutputs <- mapM (\stackName -> (stackName,) <$> getStackOutputs (mkStackName stackName)) dependencies - let outputsOrFailure = runErrors $ traverse (extractResult (flip const)) maybeOutputs - outputs <- either (throwing _CliMissingDependencyStacks) return outputsOrFailure +getStackToProvision :: (AsCliError e, MonadError e m) => DeploymentConfiguration -> T.Text -> m StackConfiguration +getStackToProvision config nameToProvision = do + let maybeStackToProvision = config ^. stacks.to (find (has (name.only nameToProvision))) + maybe (throwing _CliStackNotConfigured nameToProvision) return maybeStackToProvision - let parameters = envVars ++ concat outputs - csId <- computeChangeset (mkStackName nameToDeploy) templateBody parameters - runChangeSet csId +decodeTemplate :: (AsCliError e, MonadError e m) => T.Text -> m Template +decodeTemplate templateBody = do + let decodeOrFailure = decodeEither (encodeUtf8 templateBody) :: Either String Template + either (throwing _CliTemplateDecodeFail) return decodeOrFailure -cliIO :: IO DeploymentConfiguration -> IO () -cliIO mConfig = do - config <- mConfig - cmd <- getArgs - runAppM (cli cmd config) +mkFullStackName :: T.Text -> T.Text -> T.Text -> StackName +mkFullStackName env appName stackName = StackName $ env <> "-" <> appName <> "-" <> stackName +getTags :: (MonadError e m, AsCliError e) => DeploymentConfiguration -> StackConfiguration -> T.Text -> T.Text -> m (M.Map T.Text T.Text) +getTags config stackToProvision env appName = + assertUnique _CliDuplicateTagValues (baseTags <> globalTags <> localTags) + where + baseTags :: S.Set (T.Text, T.Text) + baseTags = [("cj:environment", env), ("cj:application", appName)] + globalTags = config ^. tagSet + localTags = stackToProvision ^. tagSet + +-- | Fetches parameter values for all param sources, handling potential errors +-- and misconfigurations. +getParameters + :: forall e m. (AsCliError e, MonadError e m, MonadCLI m, MonadEnvironment m, MonadCloud m) + => S.Set (T.Text, ParameterSource) -- ^ parameter sources to fetch values for + -> S.Set ParameterSpec -- ^ parameter specs from the template currently being deployed + -> [T.Text] -- ^ names of stack dependencies + -> T.Text -- ^ name of environment being deployed to + -> T.Text -- ^ name of application being deployed + -> m (M.Map T.Text T.Text) +getParameters paramSources paramSpecs dependencies env appName = do + let constants = paramSources ^..* folded.aside _Constant + fetchedParams <- S.unions <$> sequence [envVars, flags, outputs] + let allParams = S.insert ("Env", env) (constants <> fetchedParams) + validateParameters allParams + where + envVars :: m (S.Set (T.Text, T.Text)) + envVars = do + let requiredEnvVars = paramSources ^.. folded.filtered (has (_2._Env))._1 + maybeEnvValues <- mapM (\envVarKey -> (envVarKey,) <$> getEnv envVarKey) requiredEnvVars + let envVarsOrFailure = runErrors $ traverse (extractResult (,)) maybeEnvValues + either (throwing _CliMissingEnvVars . sort) (return . S.fromList) envVarsOrFailure + + flags :: m (S.Set (T.Text, T.Text)) + flags = do + let paramFlags = paramSources ^..* folded.filtered (has (_2._Flag))._1 + flaggedParamSpecs = paramSpecs ^..* folded.filtered (anyOf parameterKey (`elem` paramFlags)) + + paramSpecNames = paramSpecs ^..* folded.parameterKey + paramFlagsNotInTemplate = paramFlags ^..* folded.filtered (`notElem` paramSpecNames) + + unless (S.null paramFlagsNotInTemplate) $ + throwing _CliExtraParameterFlags paramFlagsNotInTemplate + S.fromList . M.toList <$> getOptions flaggedParamSpecs + + outputs :: m (S.Set (T.Text, T.Text)) + outputs = do + maybeOutputs <- mapM (\stackName -> (stackName,) <$> getStackOutputs (mkFullStackName env appName stackName)) dependencies + let outputsOrFailure = runErrors $ traverse (extractResult (flip const)) maybeOutputs + either (throwing _CliMissingDependencyStacks) (return . S.fromList . concatMap M.toList) outputsOrFailure + + validateParameters :: S.Set (T.Text, T.Text) -> m (M.Map T.Text T.Text) + validateParameters params = do + let requiredParamNames = paramSpecs ^..* folded._Required + allowedParamNames = paramSpecs ^..* folded.parameterKey + + uniqueParams <- assertUnique _CliDuplicateParameterValues params + let missingParamNames = requiredParamNames S.\\ M.keysSet uniqueParams + unless (S.null missingParamNames) $ + throwing _CliMissingRequiredParameters missingParamNames + + return $ uniqueParams `M.intersection` M.fromSet (const ()) allowedParamNames + +cliIO :: AppM DeploymentConfiguration -> IO () +cliIO mConfig = runAppM $ cli mConfig + +-- | Given a set of tuples that represent a mapping between keys and values, +-- assert the keys are all unique, and produce a map as a result. If any keys +-- are duplicated, the provided prism will be used to signal an error. +assertUnique + :: forall k v e m. (Ord k, MonadError e m) + => Prism' e (M.Map k [v]) -> S.Set (k, v) -> m (M.Map k v) +assertUnique _Err paramSet = case duplicateParams of + [] -> return $ M.fromList paramList + _ -> throwing _Err duplicateParams + where + paramList = S.toAscList paramSet + paramsGrouped = tuplesToMap paramList + duplicateParams = M.filter ((> 1) . length) paramsGrouped + + tuplesToMap :: [(k, v)] -> M.Map k [v] + tuplesToMap xs = M.fromList $ map concatGroup grouped + where + grouped = groupBy ((==) `on` fst) xs + concatGroup ys = (fst (head ys), map snd ys) + -- | Applies a function to the members of a tuple to produce a result, unless -- the tuple contains 'Nothing', in which case this logs an error in the -- 'Errors' applicative using the left side of the tuple as a label. @@ -139,4 +257,9 @@ extractResult :: (a -> b -> c) -> (a, Maybe b) -> Errors [a] c extractResult f (k, m) = do v <- maybe (failure [k]) pure m - pure $ f k v + pure (f k v) + +-- | Like '^..', but collects the result into a 'S.Set' instead of a list. +infixl 8 ^..* +(^..*) :: Ord a => s -> Getting (Endo [a]) s a -> S.Set a +x ^..* l = S.fromList (x ^.. l) diff --git a/library/Network/CloudSeeder/Template.hs b/library/Network/CloudSeeder/Template.hs new file mode 100644 --- /dev/null +++ b/library/Network/CloudSeeder/Template.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- |The `Template` module exports functions dealing with parsing YAML CloudFormation templates. +module Network.CloudSeeder.Template + ( Template(..) + , HasParameterSpecs(..) + ) where + +import Control.Lens (makeFields) +import Data.Aeson.Types (typeMismatch) +import Data.Yaml (FromJSON(..), Value(..), (.:)) + +import Network.CloudSeeder.Types + +newtype Template = Template + { _templateParameterSpecs :: ParameterSpecs + } deriving (Eq, Show) + +makeFields ''Template + +instance FromJSON Template where + parseJSON (Object v) = Template + <$> v .: "Parameters" + parseJSON invalid = typeMismatch "Template" invalid diff --git a/library/Network/CloudSeeder/Types.hs b/library/Network/CloudSeeder/Types.hs new file mode 100644 --- /dev/null +++ b/library/Network/CloudSeeder/Types.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Network.CloudSeeder.Types + ( ParameterSource(..) + , AsParameterSource(..) + + , Parameter(..) + + , ParameterSpec(..) + , AsParameterSpec(..) + , ParameterSpecs(..) + , parameterKey + + , ParameterMap(..) + ) where + +import Control.Applicative ((<|>)) +import Control.Lens (Lens', lens, makeClassyPrisms, makeWrapped) +import Data.Aeson.Types (typeMismatch) +import Data.Yaml (FromJSON(..), Parser, Value(..), (.:?)) + +import qualified Data.HashMap.Strict as H +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Set as S + +data ParameterSource + = Constant T.Text -- ^ @'Constant' "param value"@ + | Env + | Flag + | Outputs + | PreviousValue + deriving (Eq, Show, Ord) + +makeClassyPrisms ''ParameterSource + +data Parameter = Parameter ParameterSource T.Text T.Text + deriving (Eq, Show) + +data ParameterSpec + = Required T.Text + | Optional T.Text T.Text + deriving (Eq, Show, Ord) + +makeClassyPrisms ''ParameterSpec + +parameterKey :: Lens' ParameterSpec T.Text +parameterKey = lens get set + where + get (Required x) = x + get (Optional x _) = x + + set (Required _) x = Required x + set (Optional _ y) x = Optional x y + + +newtype ParameterSpecs = ParameterSpecs (S.Set ParameterSpec) + deriving (Eq, Show, Ord) + +makeWrapped ''ParameterSpecs + +instance FromJSON ParameterSpecs where + parseJSON (Object pSpecs) = + ParameterSpecs . S.fromList <$> mapM parseParamSpec (H.toList pSpecs) + where + parseParamSpec (k, Object pSpec) = do + let defParser :: FromJSON a => Parser (Maybe a) + defParser = pSpec .:? "Default" + defVal <- defParser + -- try parsing as a double if parsing fails as a string + <|> fmap (fmap (T.pack . show)) (defParser @Double) + return $ maybe (Required k) (Optional k) defVal + parseParamSpec (k, invalid) = typeMismatch (T.unpack k) invalid + parseJSON invalid = typeMismatch "Parameters" invalid + +newtype ParameterMap = ParameterMap (M.Map T.Text (ParameterSource, T.Text)) + deriving (Eq, Show) diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: cloud-seeder -version: 0.0.0.0 +version: 0.1.0.0 category: Cloud synopsis: A tool for interacting with AWS CloudFormation description: | @@ -21,7 +21,7 @@ - README.md - stack.yaml -ghc-options: -Wall +ghc-options: -Wall -Wredundant-constraints default-extensions: - ApplicativeDo - ConstraintKinds @@ -36,59 +36,57 @@ - LambdaCase - MultiParamTypeClasses - NamedFieldPuns +- OverloadedLists - OverloadedStrings - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TupleSections +- TypeApplications - TypeOperators library: dependencies: + - aeson >= 0.11.2.0 - amazonka >= 1.4.5 - amazonka-cloudformation >= 1.4.5 - amazonka-core >= 1.4.5 - base >= 4.9.0.0 && < 5 + - containers - deepseq >= 1.4.1.0 - - exceptions >= 0.8 && < 0.9 + - exceptions >= 0.6 - lens - monad-control >= 1.0.0.0 - - monad-logger >= 0.3.13.1 - - monad-time >= 0.2 + - monad-logger >= 0.3.11.1 - mtl - - optparse-applicative >= 0.13.0.0 + - optparse-applicative >= 0.14.0.0 - text - transformers - transformers-base + - unordered-containers + - uuid >= 1.2.6 && < 2 + - yaml >= 0.8 source-dirs: library -executables: - cloud-seeder: - dependencies: - - base - - cloud-seeder - ghc-options: - - -rtsopts - - -threaded - - -with-rtsopts=-N - main: Main.hs - source-dirs: executable - tests: cloud-seeder-test-suite: dependencies: - - amazonka-cloudformation >= 1.4 && < 1.5 - - base >= 4.9.0.0 && < 5 + - amazonka-cloudformation + - base - bytestring - cloud-seeder - - deepseq >= 1.4.1.0 - - fast-logger >= 2.4.8 - - hspec >= 2.4 && < 2.5 + - containers + - deepseq + - fast-logger + - hspec - lens - - monad-logger >= 0.3 && < 0.4 + - monad-logger + - monad-mock - mtl - - text >= 1.2 && < 1.3 + - optparse-applicative + - text - transformers + - yaml ghc-options: - -rtsopts - -threaded diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,66 +1,12 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# http://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" resolver: lts-8.17 -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. packages: - '.' -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: [] -# Override default flag values for local packages and extra-deps +extra-deps: +- monad-mock-0.1.1.0 +- optparse-applicative-0.14.0.0 + flags: {} -# Extra package databases containing global packages extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.3" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/test-suite/Network/CloudSeeder/CommandLineSpec.hs b/test-suite/Network/CloudSeeder/CommandLineSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Network/CloudSeeder/CommandLineSpec.hs @@ -0,0 +1,64 @@ +module Network.CloudSeeder.CommandLineSpec (spec) where + +import Options.Applicative (ParserResult(..), ParserInfo(..), execParserPure, defaultPrefs, getParseResult) +import Test.Hspec + +import Network.CloudSeeder.CommandLine + +spec :: Spec +spec = do + let runParser :: ParserInfo a -> [String] -> ParserResult a + runParser = execParserPure defaultPrefs + + describe "Command line" $ do + let command = ["provision", "stack", "env"] + describe "argument parsing" $ do + it "parses a command with no options after" $ do + let expected = ProvisionStack "stack" "env" + parsed = getParseResult $ runParser parseArguments command + parsed `shouldBe` Just expected + + it "parses a command and ignores any provided options" $ do + let expected = ProvisionStack "stack" "env" + input = command ++ ["--foo", "val"] + parsed = getParseResult $ runParser parseArguments input + parsed `shouldBe` Just expected + + it "produces help for --help if not all the arguments are supplied" $ do + let input = ["provision", "stack", "--help"] + parsed = getParseResult $ runParser parseArguments input + parsed `shouldBe` Nothing + + it "defers help for --help if all the arguments are supplied" $ do + let expected = ProvisionStack "stack" "env" + input = command ++ ["--help"] + parsed = getParseResult $ runParser parseArguments input + parsed `shouldBe` Just expected + + describe "optional parsing" $ do + it "parses an optional parameter" $ do + let flags = [Optional "foo" "defVal"] + input = command ++ ["--foo", "val"] + expected = [("foo", "val")] + parsed = getParseResult $ runParser (parseOptions flags) input + parsed `shouldBe` Just expected + + it "returns a default value if an optional parameter is not present" $ do + let flags = [Optional "bar" "defVal"] + input = command + expected = [("bar", "defVal")] + parsed = getParseResult $ runParser (parseOptions flags) input + parsed `shouldBe` Just expected + + it "parses a required parameter" $ do + let flags = [Required "flag"] + input = command ++ ["--flag", "val"] + expected = [("flag", "val")] + parsed = getParseResult $ runParser (parseOptions flags) input + parsed `shouldBe` Just expected + + it "fails if a required parameter is not present" $ do + let flags = [Required "flag"] + input = command ++ ["--notFlag", "boop"] + parsed = getParseResult $ runParser (parseOptions flags) input + parsed `shouldBe` Nothing diff --git a/test-suite/Network/CloudSeeder/DSLSpec.hs b/test-suite/Network/CloudSeeder/DSLSpec.hs --- a/test-suite/Network/CloudSeeder/DSLSpec.hs +++ b/test-suite/Network/CloudSeeder/DSLSpec.hs @@ -1,13 +1,20 @@ module Network.CloudSeeder.DSLSpec (spec) where +import qualified Data.Text as T + import Control.Lens ((^.), (^..), each) import Data.Functor.Identity (runIdentity) +import Data.Semigroup ((<>)) +import GHC.Exts (IsList(..)) import Test.Hspec import Network.CloudSeeder.DSL +import Network.CloudSeeder.Types +type TagList = forall a. (IsList a, Item a ~ (T.Text, T.Text)) => a + spec :: Spec -spec = +spec = do describe "deployment" $ do it "creates a DeploymentConfiguration with the given name" $ do let config = runIdentity $ deployment "foobar" $ return () @@ -17,13 +24,13 @@ it "adds environment variables to a DeploymentConfiguration" $ do let vars = ["foo", "bar", "baz"] config = runIdentity $ deployment "" $ environment vars - config ^. environmentVariables `shouldBe` vars + config ^. parameterSources `shouldBe` [("foo", Env), ("bar", Env), ("baz", Env)] it "adds to the environment variables that are already there" $ do let config = runIdentity $ deployment "" $ do environment ["foo"] environment ["bar"] - config ^. environmentVariables `shouldBe` ["foo", "bar"] + config ^. parameterSources `shouldBe` [("foo", Env), ("bar", Env)] describe "stack_" $ do it "registers a stack with the given name" $ do @@ -42,4 +49,27 @@ it "configures the current stack to use the given env variables" $ do let vars = ["foo", "bar", "baz"] config = runIdentity $ deployment "" $ stack "foo" (environment vars) - config ^.. stacks.each.environmentVariables `shouldBe` [["foo", "bar", "baz"]] + config ^.. stacks.each.parameterSources `shouldBe` [[("foo", Env), ("bar", Env), ("baz", Env)]] + + describe "tags" $ do + it "adds environment variables to a DeploymentConfiguration" $ do + let tagz :: TagList + tagz = [ ("tag1", "val1"), ("tag2", "val2") ] + config = runIdentity $ deployment "" $ tags tagz + config ^. tagSet `shouldBe` tagz + + it "adds to the environment variables that are already there" $ do + let tags1 :: TagList + tags1 = [("foo", "bar")] + tags2 :: TagList + tags2 = [("baz", "qux"), ("bop", "dop")] + config = runIdentity $ deployment "" $ do + tags tags1 + tags tags2 + config ^. tagSet `shouldBe` (tags1 <> tags2) + + it "tags the current stack with the provided key value pairs" $ do + let tagz :: TagList + tagz = [("foo", "bar"), ("baz", "qux")] + config = runIdentity $ deployment "" $ stack "foo" (tags tagz) + config ^.. stacks.each.tagSet `shouldBe` [tagz] diff --git a/test-suite/Network/CloudSeeder/MainSpec.hs b/test-suite/Network/CloudSeeder/MainSpec.hs --- a/test-suite/Network/CloudSeeder/MainSpec.hs +++ b/test-suite/Network/CloudSeeder/MainSpec.hs @@ -1,9 +1,16 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + module Network.CloudSeeder.MainSpec (spec) where import Control.Lens (review) import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Mock (MockT, WithResult(..), runMockT) +import Control.Monad.Mock.TH (makeAction, ts) import Data.Function ((&)) import Data.Functor.Identity (runIdentity) +import Data.Semigroup ((<>)) +import GHC.Exts (IsList(..)) import Test.Hspec import Network.CloudSeeder.DSL @@ -11,172 +18,404 @@ import Network.CloudSeeder.Main import Network.CloudSeeder.Test.Stubs +import qualified Data.Text as T + +makeAction "CloudAction" [ts| MonadCloud |] +mockCloudT :: Monad m => [WithResult CloudAction] -> MockT CloudAction m a -> m a +mockCloudT = runMockT + +type TagList = forall a. (IsList a, Item a ~ (T.Text, T.Text)) => a + spec :: Spec -spec = parallel $ do +spec = describe "cli" $ do + let rootTemplate = "Parameters:\n" + <> " Env:\n" + <> " Type: String\n" + rootExpectedTags = [("cj:application", "foo"), ("cj:environment", "test")] + rootParams = [("Env", "test")] + serverTestArgs = ["provision", "server", "test"] + baseTestArgs = ["provision", "base", "test"] + let stubExceptT :: ExceptT CliError m a -> m (Either CliError a) stubExceptT = runExceptT runSuccess x = runIdentity x `shouldBe` Right () runFailure p y x = runIdentity x `shouldBe` Left (review p y) it "fails if the template doesn't exist" $ do - let config = runIdentity $ deployment "foo" $ do + let config = deployment "foo" $ do stack_ "base" stack_ "server" - env = [("Env", "test")] - runFailure _FileNotFound "server.yaml" $ cli (DeployStack "server") config + runFailure _FileNotFound "server.yaml" $ cli config & stubFileSystemT [] + & stubEnvironmentT [] + & stubCommandLineT serverTestArgs & stubExceptT - & stubEnvironmentT env - & stubCloudT [] + & mockCloudT [] + it "fails if the template parameters can't be parsed" $ do + let config = deployment "foo" $ stack_ "base" + err = "YAML parse exception at line 0, column 8,\nwhile scanning a directive:\nfound unknown directive name" + runFailure _CliTemplateDecodeFail err $ cli config + & stubFileSystemT [("base.yaml", "%invalid")] + & stubEnvironmentT [] + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT [] + it "fails if user attempts to deploy a stack that doesn't exist in the config" $ do - let config = runIdentity $ deployment "foo" $ do - stack_ "base" - env = [("Env", "test")] - runFailure _CliStackNotConfigured "foo" $ cli (DeployStack "foo") config + let config = deployment "foo" $ stack_ "base" + fakeCliInput = ["provision", "foo", "test"] + runFailure _CliStackNotConfigured "foo" $ cli config & stubFileSystemT - [ ("base.yaml", "base.yaml contents")] + [ ("base.yaml", rootTemplate)] + & stubEnvironmentT [] + & stubCommandLineT fakeCliInput & stubExceptT - & stubEnvironmentT env - & stubCloudT [] + & mockCloudT [] + it "fails if parameters required in the template are not supplied" $ do + let baseTemplate = + rootTemplate + <> " foo:\n" + <> " Type: String\n" + <> " bar:\n" + <> " Type: String\n" + config = deployment "foo" $ do + stack_ "base" + runFailure _CliMissingRequiredParameters ["foo", "bar"] $ cli config + & stubFileSystemT [ ("base.yaml", baseTemplate) ] + & stubEnvironmentT [] + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT [] + context "the configuration does not have environment variables" $ do - let config = runIdentity $ deployment "foo" $ do + let config = deployment "foo" $ do stack_ "base" stack_ "server" stack_ "frontend" - env = [("Env", "test")] - it "applies a changeset to a stack" $ example $ do - runSuccess $ cli (DeployStack "base") config + it "applies a changeset to a stack" $ example $ + runSuccess $ cli config & stubFileSystemT - [ ("base.yaml", "base.yaml contents") ] + [ ("base.yaml", rootTemplate) ] + & stubEnvironmentT [] + & stubCommandLineT baseTestArgs & stubExceptT - & stubEnvironmentT env - & stubCloudT - [ ComputeChangeset "test-foo-base" "base.yaml contents" env :-> "csid" + & mockCloudT + [ ComputeChangeset "test-foo-base" rootTemplate rootParams rootExpectedTags :-> "csid" , RunChangeSet "csid" :-> () ] - it "passes the outputs from prior stacks" $ do - runSuccess $ cli (DeployStack "server") config + it "passes only the outputs from previous stacks that are listed in this template's Parameters" $ do + let serverTemplate = rootTemplate + <> " foo:\n" + <> " Type: String\n" + <> " bar:\n" + <> " Type: String\n" + baseOutputs = [ ("first", "output") + , ("foo", "baz") + , ("bar", "qux") + , ("last", "output") ] + + runSuccess $ cli config & stubFileSystemT - [ ("server.yaml", "server.yaml contents") ] + [ ("server.yaml", serverTemplate) ] + & stubEnvironmentT [] + & stubCommandLineT serverTestArgs & stubExceptT - & stubEnvironmentT env - & stubCloudT - [ DescribeStack "test-foo-base" :-> Just [("foo", "bar")] - , ComputeChangeset "test-foo-server" "server.yaml contents" (env ++ [("foo", "bar")]) :-> "csid" + & mockCloudT + [ GetStackOutputs "test-foo-base" :-> Just baseOutputs + , ComputeChangeset + "test-foo-server" + serverTemplate + (rootParams <> [("bar", "qux"), ("foo", "baz")]) + rootExpectedTags + :-> "csid" , RunChangeSet "csid" :-> () ] - runSuccess $ cli (DeployStack "frontend") config + + let frontendtemplate = rootTemplate + <> " foo:\n" + <> " Type: String\n" + + runSuccess $ cli config & stubFileSystemT - [ ("frontend.yaml", "frontend.yaml contents") ] + [ ("frontend.yaml", frontendtemplate) ] + & stubEnvironmentT [] + & stubCommandLineT ["provision", "frontend", "test"] & stubExceptT - & stubEnvironmentT env - & stubCloudT - [ DescribeStack "test-foo-base" :-> Just [("foo", "bar")] - , DescribeStack "test-foo-server" :-> Just [("baz", "qux")] - , ComputeChangeset "test-foo-frontend" "frontend.yaml contents" (env ++ [("foo", "bar"), ("baz", "qux")]) :-> "csid" + & mockCloudT + [ GetStackOutputs "test-foo-base" :-> Just baseOutputs + , GetStackOutputs "test-foo-server" :-> Just [] + , ComputeChangeset + "test-foo-frontend" + frontendtemplate + (rootParams <> [("foo", "baz")]) + rootExpectedTags + :-> "csid" , RunChangeSet "csid" :-> () ] it "fails if a dependency stack does not exist" $ do - runFailure _CliMissingDependencyStacks ["base"] $ cli (DeployStack "frontend") config - & stubFileSystemT - [ ("frontend.yaml", "frontend.yaml contents") ] - & stubExceptT - & stubEnvironmentT env - & stubCloudT - [ DescribeStack "test-foo-base" :-> Nothing - , DescribeStack "test-foo-server" :-> Just [] ] - - runFailure _CliMissingDependencyStacks ["server"] $ cli (DeployStack "frontend") config + runFailure _CliMissingDependencyStacks ["base"] $ cli config & stubFileSystemT - [ ("frontend.yaml", "frontend.yaml contents") ] + [ ("frontend.yaml", rootTemplate) ] + & stubEnvironmentT [] + & stubCommandLineT ["provision", "frontend", "test"] & stubExceptT - & stubEnvironmentT env - & stubCloudT - [ DescribeStack "test-foo-base" :-> Just [] - , DescribeStack "test-foo-server" :-> Nothing ] + & mockCloudT + [ GetStackOutputs "test-foo-base" :-> Nothing + , GetStackOutputs "test-foo-server" :-> Just [] ] - runFailure _CliMissingDependencyStacks ["base", "server"] $ cli (DeployStack "frontend") config + runFailure _CliMissingDependencyStacks ["server"] $ cli config & stubFileSystemT - [ ("frontend.yaml", "frontend.yaml contents") ] + [ ("frontend.yaml", rootTemplate) ] + & stubEnvironmentT [] + & stubCommandLineT ["provision", "frontend", "test"] & stubExceptT - & stubEnvironmentT env - & stubCloudT - [ DescribeStack "test-foo-base" :-> Nothing - , DescribeStack "test-foo-server" :-> Nothing ] + & mockCloudT + [ GetStackOutputs "test-foo-base" :-> Just [] + , GetStackOutputs "test-foo-server" :-> Nothing ] - it "fails when the Env environment variable is not specified" $ do - runFailure _CliMissingEnvVars ["Env"] $ cli (DeployStack "server") config + runFailure _CliMissingDependencyStacks ["base", "server"] $ cli config & stubFileSystemT - [ ("server.yaml", "server.yaml contents") ] - & stubExceptT + [ ("frontend.yaml", rootTemplate) ] & stubEnvironmentT [] - & stubCloudT [] + & stubCommandLineT ["provision", "frontend", "test"] + & stubExceptT + & mockCloudT + [ GetStackOutputs "test-foo-base" :-> Nothing + , GetStackOutputs "test-foo-server" :-> Nothing ] context "the configuration has global environment variables" $ do - let config = runIdentity $ deployment "foo" $ do + let config = deployment "foo" $ do environment ["Domain", "SecretsStore"] stack_ "base" stack_ "server" stack_ "frontend" it "passes the value in each global environment variable as a parameter" $ do - let env = [ ("Env", "test"), ("Domain", "example.com"), ("SecretsStore", "arn::aws:1234") ] - runSuccess $ cli (DeployStack "base") config + let template = rootTemplate + <> " Domain:\n" + <> " Type: String\n" + <> " SecretsStore:\n" + <> " Type: String\n" + let env = rootParams <> [ ("Domain", "example.com"), ("SecretsStore", "arn::aws:1234") ] + runSuccess $ cli config & stubFileSystemT - [ ("base.yaml", "base.yaml contents") ] - & stubExceptT + [ ("base.yaml", template) ] & stubEnvironmentT env - & stubCloudT - [ ComputeChangeset "test-foo-base" "base.yaml contents" env :-> "csid" + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT + [ ComputeChangeset "test-foo-base" template env rootExpectedTags :-> "csid" , RunChangeSet "csid" :-> () ] it "fails when a global environment variable is missing" $ do let env = [ ("Env", "test"), ("SecretsStore", "arn::aws:1234") ] - runFailure _CliMissingEnvVars ["Domain"] $ cli (DeployStack "base") config + runFailure _CliMissingEnvVars ["Domain"] $ cli config & stubFileSystemT - [ ("base.yaml", "base.yaml contents") ] - & stubExceptT + [ ("base.yaml", rootTemplate) ] & stubEnvironmentT env - & stubCloudT [] + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT [] - it "reports all missing environment variables at once in alphabetical order" $ do - runFailure _CliMissingEnvVars ["Domain", "Env", "SecretsStore"] $ cli (DeployStack "base") config + it "reports all missing environment variables at once in alphabetical order" $ + runFailure _CliMissingEnvVars ["Domain", "SecretsStore"] $ cli config & stubFileSystemT - [ ("base.yaml", "base.yaml contents") ] - & stubExceptT + [ ("base.yaml", rootTemplate) ] & stubEnvironmentT [] - & stubCloudT [] + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT [] context "the configuration has global and local environment variables" $ do - let config = runIdentity $ deployment "foo" $ do + let config = deployment "foo" $ do environment ["Domain", "SecretsStore"] stack "base" $ environment ["Base"] stack "server" $ environment ["Server1", "Server2"] stack "frontend" $ environment ["Frontend"] + let template = rootTemplate + <> " Domain:\n" + <> " Type: String\n" + <> " SecretsStore:\n" + <> " Type: String\n" it "passes the value in each local environment variable to the proper stack" $ do - let env = [ ("Env", "test"), ("Domain", "example.com"), ("SecretsStore", "arn::aws:1234") ] - baseEnv = env ++ [ ("Base", "a") ] - runSuccess $ cli (DeployStack "base") config + let env = [ ("Domain", "example.com"), ("Env", "test"), ("SecretsStore", "arn::aws:1234") ] + baseEnv = env <> [ ("Base", "a") ] + baseTemplate = template + <> " Base:\n" + <> " Type: String\n" + runSuccess $ cli config & stubFileSystemT - [ ("base.yaml", "base.yaml contents") ] - & stubExceptT + [ ("base.yaml", baseTemplate) ] & stubEnvironmentT baseEnv - & stubCloudT - [ ComputeChangeset "test-foo-base" "base.yaml contents" baseEnv :-> "csid" + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT + [ ComputeChangeset "test-foo-base" baseTemplate baseEnv rootExpectedTags :-> "csid" , RunChangeSet "csid" :-> () ] - let serverEnv = env ++ [ ("Server1", "b"), ("Server2", "c") ] - runSuccess $ cli (DeployStack "server") config + let serverEnv = env <> [ ("Server1", "b"), ("Server2", "c") ] + serverTemplate = template + <> " Server1:\n" + <> " Type: String\n" + <> " Server2:\n" + <> " Type: String\n" + runSuccess $ cli config & stubFileSystemT - [ ("server.yaml", "server.yaml contents") ] - & stubExceptT + [ ("server.yaml", serverTemplate) ] & stubEnvironmentT serverEnv - & stubCloudT - [ DescribeStack "test-foo-base" :-> Just [] - , ComputeChangeset "test-foo-server" "server.yaml contents" serverEnv :-> "csid" + & stubCommandLineT serverTestArgs + & stubExceptT + & mockCloudT + [ GetStackOutputs "test-foo-base" :-> Just [] + , ComputeChangeset "test-foo-server" serverTemplate serverEnv rootExpectedTags :-> "csid" , RunChangeSet "csid" :-> () ] + + context "the configuration has global tags" $ do + let globalTags :: TagList + globalTags = [("cj:squad", "lambda"), ("taggo", "oggat")] + config = deployment "foo" $ do + tags globalTags + stack_ "base" + stack_ "server" + stack_ "frontend" + + it "passes the value in each tag" $ do + let expectedTags = rootExpectedTags <> globalTags + runSuccess $ cli config + & stubFileSystemT + [ ("base.yaml", rootTemplate) ] + & stubEnvironmentT [] + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT + [ ComputeChangeset "test-foo-base" rootTemplate rootParams expectedTags :-> "csid" + , RunChangeSet "csid" :-> () ] + + context "the configuration has global and local tags" $ do + let globalTags :: TagList + globalTags = [("cj:squad", "lambda"), ("taggo", "oggat")] + serverTags :: TagList + serverTags = [("x", "z")] + + expectedGlobalTags = rootExpectedTags <> globalTags + expectedServerTags = expectedGlobalTags <> serverTags + + config = deployment "foo" $ do + tags globalTags + stack_ "base" + stack "server" $ tags serverTags + stack "frontend" $ tags [("frontendTag1", "ft1"), ("frontendTag2", "ft2")] + + it "passes the value in each tag to the proper stack" $ do + runSuccess $ cli config + & stubFileSystemT + [ ("base.yaml", rootTemplate) ] + & stubEnvironmentT [] + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT + [ ComputeChangeset "test-foo-base" rootTemplate rootParams expectedGlobalTags :-> "csid" + , RunChangeSet "csid" :-> () ] + + runSuccess $ cli config + & stubFileSystemT + [ ("server.yaml", rootTemplate) ] + & stubEnvironmentT [] + & stubCommandLineT serverTestArgs + & stubExceptT + & mockCloudT + [ GetStackOutputs "test-foo-base" :-> Just [] + , ComputeChangeset "test-foo-server" rootTemplate rootParams expectedServerTags :-> "csid" + , RunChangeSet "csid" :-> () ] + + context "monadic logic" $ + context "can make decisions based on the env passed in" $ do + let template = "Parameters:\n" + <> " Env:\n" + <> " Type: String\n" + <> " foo:\n" + <> " Type: String\n" + <> " baz:\n" + <> " Type: String\n" + <> " Default: prod" + let config = deployment "foo" $ do + param "foo" "bar" + whenEnv "prod" $ param "baz" "qux" + stack_ "base" + + expectedParams = [("Env", "prod"), ("baz", "qux"), ("foo", "bar")] + expectedTags = [("cj:application","foo"),("cj:environment","prod")] + expectedParamsTest = [("foo", "bar")] <> rootParams + + it "can add a param based on prod" $ + runSuccess $ cli config + & stubFileSystemT + [ ("base.yaml", template) ] + & stubEnvironmentT [] + & stubCommandLineT ["provision", "base", "prod"] + & stubExceptT + & mockCloudT + [ ComputeChangeset "prod-foo-base" template expectedParams expectedTags :-> "csid" + , RunChangeSet "csid" :-> () ] + + it "does not provide prod-only params when not in prod" $ + runSuccess $ cli config + & stubFileSystemT + [ ("base.yaml", template) ] + & stubEnvironmentT [] + & stubCommandLineT baseTestArgs + & stubExceptT + & mockCloudT + [ ComputeChangeset "test-foo-base" template expectedParamsTest rootExpectedTags :-> "csid" + , RunChangeSet "csid" :-> () ] + + context "flags" $ do + let template = "Parameters:\n" + <> " Env:\n" + <> " Type: String\n" + <> " baz:\n" + <> " Type: String\n" + <> " Default: prod" + let config = deployment "foo" $ do + flag "baz" + stack_ "base" + + it "accepts optional flags where the config calls for them" $ + runSuccess $ cli config + & stubFileSystemT + [ ("base.yaml", template) ] + & stubEnvironmentT [] + & stubCommandLineT ["provision", "base", "test", "--baz", "zab"] + & stubExceptT + & mockCloudT + [ ComputeChangeset "test-foo-base" template (rootParams <> [("baz", "zab")]) rootExpectedTags :-> "csid" + , RunChangeSet "csid" :-> () ] + + it "provides a default if an optional flag isn't provided" $ + runSuccess $ cli config + & stubFileSystemT + [ ("base.yaml", template) ] + & stubEnvironmentT [] + & stubCommandLineT ["provision", "base", "test"] + & stubExceptT + & mockCloudT + [ ComputeChangeset "test-foo-base" template (rootParams <> [("baz", "prod")]) rootExpectedTags :-> "csid" + , RunChangeSet "csid" :-> () ] + + it "raises an error if a flag is provided that does not exist in the template" $ + let config' = deployment "foo" $ do + mapM_ flag (["foo", "bar", "baz"] :: [T.Text]) + stack_ "base" + in runFailure _CliExtraParameterFlags ["foo", "bar"] $ cli config' + & stubFileSystemT + [ ("base.yaml", template) ] + & stubEnvironmentT [] + & stubCommandLineT + ["provision", "base", "test", "--foo", "oof", "--bar", "rab", "--baz", "zab"] + & stubExceptT + & mockCloudT [] diff --git a/test-suite/Network/CloudSeeder/TemplateSpec.hs b/test-suite/Network/CloudSeeder/TemplateSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Network/CloudSeeder/TemplateSpec.hs @@ -0,0 +1,45 @@ +module Network.CloudSeeder.TemplateSpec (spec) where + +import Data.ByteString.Char8 (pack) +import Data.Yaml (decode) +import Test.Hspec + +import Network.CloudSeeder.Template +import Network.CloudSeeder.Types + +spec :: Spec +spec = do + describe "template parsing" $ do + it "parses a template with required parameters" $ do + let template + = "Parameters:\n" + ++ " Env:\n" + ++ " Type: blah\n" + ++ " Foo:\n" + ++ " Type: blah\n" + expected = Template $ ParameterSpecs [Required "Env", Required "Foo"] + parsed = decode $ pack template + parsed `shouldBe` Just expected + + it "parses a template with optional parameters" $ do + let template + = "Parameters:\n" + ++ " Env:\n" + ++ " Type: boop\n" + ++ " Default: test\n" + ++ " Foo:\n" + ++ " Type: boop\n" + ++ " Default: bar\n" + expected = Template $ ParameterSpecs [Optional "Env" "test", Optional "Foo" "bar"] + parsed = decode $ pack template + parsed `shouldBe` Just expected + + it "parses default values that are numbers" $ do + let template + = "Parameters:\n" + ++ " Port:\n" + ++ " Type: Number\n" + ++ " Default: 42\n" + expected = Template $ ParameterSpecs [Optional "Port" "42.0"] + parsed = decode $ pack template + parsed `shouldBe` Just expected diff --git a/test-suite/Network/CloudSeeder/Test/Stubs.hs b/test-suite/Network/CloudSeeder/Test/Stubs.hs --- a/test-suite/Network/CloudSeeder/Test/Stubs.hs +++ b/test-suite/Network/CloudSeeder/Test/Stubs.hs @@ -8,36 +8,48 @@ import Control.Monad.Except (MonadError) import Control.Monad.Reader (ReaderT(..), ask) import Control.Monad.Writer (WriterT(..), tell) -import Control.Monad.State (StateT(..), get, put) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Logger (MonadLogger(..)) import Data.ByteString (ByteString) -import Data.Type.Equality ((:~:)(..)) +import Data.Maybe (fromJust) +import Options.Applicative (ParserInfo(..), execParserPure, defaultPrefs, getParseResult) import System.Log.FastLogger (fromLogStr, toLogStr) +import qualified Data.Map as M + import Network.CloudSeeder.CommandLine import Network.CloudSeeder.Interfaces -------------------------------------------------------------------------------- -- Arguments -newtype ArgumentsT m a = ArgumentsT (ReaderT Command m a) +newtype ArgumentsT m a = ArgumentsT (ReaderT [String] m a) deriving ( Functor, Applicative, Monad, MonadTrans, MonadError e , MonadLogger, MonadFileSystem e, MonadCloud, MonadEnvironment ) -- | Runs a computation with access to a set of command-line arguments. -runArgumentsT :: Command -> ArgumentsT m a -> m a -runArgumentsT args (ArgumentsT x) = runReaderT x args +stubCommandLineT :: [String] -> ArgumentsT m a -> m a +stubCommandLineT fake (ArgumentsT x) = runReaderT x fake -instance Monad m => MonadArguments (ArgumentsT m) where - getArgs = ArgumentsT ask +instance Monad m => MonadCLI (ArgumentsT m) where + getArgs = ArgumentsT $ do + input <- ask + return $ consume parseArguments $ take 3 input + getOptions pSpecs = ArgumentsT $ do + input <- ask + let x = execParserPure defaultPrefs (parseOptions pSpecs) input + return $ fromJust $ getParseResult x + +consume :: ParserInfo c -> [String] -> c +consume p = fromJust . getParseResult . execParserPure defaultPrefs p + -------------------------------------------------------------------------------- -- Logger newtype LoggerT m a = LoggerT (WriterT [ByteString] m a) deriving ( Functor, Applicative, Monad, MonadTrans, MonadError e - , MonadArguments, MonadFileSystem e, MonadCloud, MonadEnvironment ) + , MonadCLI, MonadFileSystem e, MonadCloud, MonadEnvironment ) -- | Runs a computation that may emit log messages, returning the result of the -- computation combined with the set of messages logged, in order. @@ -52,7 +64,7 @@ newtype FileSystemT m a = FileSystemT (ReaderT [(T.Text, T.Text)] m a) deriving ( Functor, Applicative, Monad, MonadTrans, MonadError e - , MonadArguments, MonadLogger, MonadCloud, MonadEnvironment ) + , MonadCLI, MonadLogger, MonadCloud, MonadEnvironment ) -- | Runs a computation that may interact with the file system, given a mapping -- from file paths to file contents. @@ -65,62 +77,14 @@ return (lookup path files) -------------------------------------------------------------------------------- --- Cloud - -data CloudAction r where - ComputeChangeset :: StackName -> T.Text -> [(T.Text, T.Text)] -> CloudAction T.Text - DescribeStack :: StackName -> CloudAction (Maybe [(T.Text, T.Text)]) - RunChangeSet :: T.Text -> CloudAction () -deriving instance Eq (CloudAction r) -deriving instance Show (CloudAction r) - -eqAction :: CloudAction a -> CloudAction b -> Maybe (a :~: b) -eqAction (ComputeChangeset a b c) (ComputeChangeset a' b' c') - = if a == a' && b == b' && c == c' then Just Refl else Nothing -eqAction (DescribeStack a) (DescribeStack a') - = if a == a' then Just Refl else Nothing -eqAction (RunChangeSet a) (RunChangeSet a') - = if a == a' then Just Refl else Nothing -eqAction _ _ = Nothing - -data WithResult f where - (:->) :: f r -> r -> WithResult f - -newtype CloudT m a = CloudT (StateT [WithResult CloudAction] m a) - deriving ( Functor, Applicative, Monad, MonadTrans, MonadError e - , MonadArguments, MonadFileSystem e, MonadLogger, MonadEnvironment ) - -stubCloudT :: Monad m => [WithResult CloudAction] -> CloudT m a -> m a -stubCloudT actions (CloudT x) = runStateT x actions >>= \case - (r, []) -> return r - (_, remainingActions) -> - fail $ "stubCloudT: expected the following unexecuted actions to be run:\n" - ++ unlines (map (\(action :-> _) -> " " ++ show action) remainingActions) - -stubCloudAction :: Monad m => String -> CloudAction r -> CloudT m r -stubCloudAction fnName action = CloudT $ get >>= \case - [] -> fail $ "stubCloudT: expected end of program, called " ++ fnName ++ "\n given action:\n" - ++ " " ++ show action ++ "\n" - (action' :-> r) : actions - | Just Refl <- action `eqAction` action' -> put actions >> return r - | otherwise -> fail $ "stubCloudT: argument mismatch in " ++ fnName ++ "\n" - ++ " given: " ++ show action ++ "\n" - ++ " expected: " ++ show action' ++ "\n" - -instance Monad m => MonadCloud (CloudT m) where - computeChangeset a b c = stubCloudAction "computeChangeset" (ComputeChangeset a b c) - getStackOutputs a = stubCloudAction "getStackOutputs" (DescribeStack a) - runChangeSet a = stubCloudAction "runChangeSet" (RunChangeSet a) - --------------------------------------------------------------------------------- -- Environment -newtype EnvironmentT m a = EnvironmentT (ReaderT [(T.Text, T.Text)] m a) +newtype EnvironmentT m a = EnvironmentT (ReaderT (M.Map T.Text T.Text) m a) deriving ( Functor, Applicative, Monad, MonadTrans, MonadError e - , MonadArguments, MonadLogger, MonadFileSystem e, MonadCloud ) + , MonadCLI, MonadLogger, MonadFileSystem e, MonadCloud ) -stubEnvironmentT :: [(T.Text, T.Text)] -> EnvironmentT m a -> m a +stubEnvironmentT :: M.Map T.Text T.Text -> EnvironmentT m a -> m a stubEnvironmentT fs (EnvironmentT x) = runReaderT x fs instance Monad m => MonadEnvironment (EnvironmentT m) where - getEnv x = lookup x <$> EnvironmentT ask + getEnv x = M.lookup x <$> EnvironmentT ask