cloud-seeder (empty) → 0.0.0.0
raw patch · 16 files changed
+1076/−0 lines, 16 filesdep +amazonkadep +amazonka-cloudformationdep +amazonka-coresetup-changed
Dependencies added: amazonka, amazonka-cloudformation, amazonka-core, base, bytestring, cloud-seeder, deepseq, exceptions, fast-logger, hspec, lens, monad-control, monad-logger, monad-time, mtl, optparse-applicative, text, transformers, transformers-base
Files
- CHANGELOG.md +3/−0
- LICENSE +13/−0
- README.md +3/−0
- Setup.hs +7/−0
- cloud-seeder.cabal +96/−0
- executable/Main.hs +2/−0
- library/Network/CloudSeeder/CommandLine.hs +23/−0
- library/Network/CloudSeeder/DSL.hs +50/−0
- library/Network/CloudSeeder/Interfaces.hs +220/−0
- library/Network/CloudSeeder/Main.hs +142/−0
- package.yaml +97/−0
- stack.yaml +66/−0
- test-suite/Main.hs +1/−0
- test-suite/Network/CloudSeeder/DSLSpec.hs +45/−0
- test-suite/Network/CloudSeeder/MainSpec.hs +182/−0
- test-suite/Network/CloudSeeder/Test/Stubs.hs +126/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+## 0.0.0.0 (June 26th, 2017)++- Initial release
+ LICENSE view
@@ -0,0 +1,13 @@+Copyright 2017 CJ Affiliate by Conversant++Permission to use, copy, modify, and/or distribute this software for any purpose+with or without fee is hereby granted, provided that the above copyright notice+and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF+THIS SOFTWARE.
+ README.md view
@@ -0,0 +1,3 @@+# haskell-cloud-seeder++A Haskell library for interacting with CloudFormation stacks
+ Setup.hs view
@@ -0,0 +1,7 @@+-- This script is used to build and install your package. Typically you don't+-- need to change it. The Cabal documentation has more information about this+-- file: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain
+ cloud-seeder.cabal view
@@ -0,0 +1,96 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name: cloud-seeder+version: 0.0.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+ application stacks to AWS CloudFormation using Amazonka.+category: Cloud+homepage: https://github.com/cjdev/cloud-seeder#readme+bug-reports: https://github.com/cjdev/cloud-seeder/issues+author: Alexis King <lexi.lambda@gmail.com>, Michael Arnold <michaelaarnold@gmail.com>+maintainer: Alexis King <lexi.lambda@gmail.com>, Michael Arnold <michaelaarnold@gmail.com>+copyright: 2017 CJ Affiliate by Conversant+license: ISC+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ CHANGELOG.md+ LICENSE+ package.yaml+ README.md+ stack.yaml++source-repository head+ type: git+ location: https://github.com/cjdev/cloud-seeder++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+ build-depends:+ amazonka >= 1.4.5+ , amazonka-cloudformation >= 1.4.5+ , amazonka-core >= 1.4.5+ , base >= 4.9.0.0 && < 5+ , deepseq >= 1.4.1.0+ , exceptions >= 0.8 && < 0.9+ , lens+ , monad-control >= 1.0.0.0+ , monad-logger >= 0.3.13.1+ , monad-time >= 0.2+ , mtl+ , optparse-applicative >= 0.13.0.0+ , text+ , transformers+ , transformers-base+ exposed-modules:+ 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+ default-language: Haskell2010++test-suite cloud-seeder-test-suite+ type: exitcode-stdio-1.0+ 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+ build-depends:+ amazonka-cloudformation >= 1.4 && < 1.5+ , base >= 4.9.0.0 && < 5+ , bytestring+ , cloud-seeder+ , deepseq >= 1.4.1.0+ , fast-logger >= 2.4.8+ , hspec >= 2.4 && < 2.5+ , lens+ , monad-logger >= 0.3 && < 0.4+ , mtl+ , text >= 1.2 && < 1.3+ , transformers+ other-modules:+ Network.CloudSeeder.DSLSpec+ Network.CloudSeeder.MainSpec+ Network.CloudSeeder.Test.Stubs+ default-language: Haskell2010
+ executable/Main.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = return ()
+ library/Network/CloudSeeder/CommandLine.hs view
@@ -0,0 +1,23 @@+module Network.CloudSeeder.CommandLine+ ( Command(..)+ , commandParser+ ) where++import Data.Semigroup ((<>))+import Options.Applicative (Parser, Mod, OptionFields, subparser, command, info, progDesc, strOption, long, metavar, help)+import qualified Data.Text as T++data Command = DeployStack T.Text+ deriving (Eq, Show)++textOption :: Mod OptionFields String -> Parser T.Text+textOption = fmap T.pack . strOption++commandParser :: Parser Command+commandParser = subparser $ command "deploy" (info (DeployStack <$> stackName) (progDesc "deploy a stack"))+ where+ stackName :: Parser T.Text+ stackName = textOption+ ( long "stack-name"+ <> metavar "STACK_NAME"+ <> help "the name of the stack in the configuration")
+ library/Network/CloudSeeder/DSL.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell #-}++module Network.CloudSeeder.DSL+ ( DeploymentConfiguration(..)+ , StackConfiguration(..)+ , environmentVariables+ , name+ , stacks+ , deployment+ , environment+ , stack_+ , stack+ )+ where++import Control.Lens ((%=))+import Control.Monad.State (StateT, execStateT, lift)+import Control.Lens.TH (makeFields)+import qualified Data.Text as T++data DeploymentConfiguration = DeploymentConfiguration+ { _deploymentConfigurationName :: T.Text+ , _deploymentConfigurationEnvironmentVariables :: [T.Text]+ , _deploymentConfigurationStacks :: [StackConfiguration]+ } deriving (Eq, Show)++data StackConfiguration = StackConfiguration+ { _stackConfigurationName :: T.Text+ , _stackConfigurationEnvironmentVariables :: [T.Text]+ } deriving (Eq, Show)++makeFields ''DeploymentConfiguration+makeFields ''StackConfiguration++deployment :: Monad m => T.Text -> StateT DeploymentConfiguration m a -> m DeploymentConfiguration+deployment name' x =+ let config = DeploymentConfiguration name' [] []+ in execStateT x config++environment :: (Monad m, HasEnvironmentVariables a [T.Text]) => [T.Text] -> StateT a m ()+environment vars = environmentVariables %= (++ vars)++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' []+ stackConfig' <- lift $ execStateT x stackConfig+ stacks %= (++ [stackConfig'])
+ library/Network/CloudSeeder/Interfaces.hs view
@@ -0,0 +1,220 @@+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Network.CloudSeeder.Interfaces+ ( MonadArguments(..)+ , MonadFileSystem(..)++ , MonadCloud(..)+ , computeChangeset'+ , getStackOutputs'+ , runChangeSet'++ , MonadEnvironment(..)+ , StackName(..)++ , FileSystemError(..)+ , readFile'+ , HasFileSystemError(..)+ , AsFileSystemError(..)+ ) where++import Prelude hiding (readFile)++import Control.Concurrent (threadDelay)+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.Base (MonadBase, liftBase)+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.Error.Lens (throwing)+import Control.Monad.Except (ExceptT, MonadError)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Logger (LoggingT)+import Control.Monad.Reader (MonadReader, ReaderT, ask)+import Control.Monad.State (StateT)+import Control.Monad.Trans (MonadTrans, lift)+import Control.Monad.Trans.AWS (runResourceT, runAWST, send)+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Writer (WriterT)+import Data.Function ((&))+import Data.Semigroup ((<>))+import Data.String (IsString)+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.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 qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Control.Exception.Lens as IO++import Network.CloudSeeder.CommandLine++newtype StackName = StackName T.Text+ deriving (Eq, Show, Generic, IsString)+instance NFData StackName++--------------------------------------------------------------------------------+-- | 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+ 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)++instance MonadArguments IO where+ getArgs = execParser opts+ where+ opts = info (commandParser <**> helper)+ ( fullDesc+ <> progDesc "deploy stacks to the cloud"+ <> header "CloudSeeder"+ )+--------------------------------------------------------------------------------+data FileSystemError+ = FileNotFound T.Text+ deriving (Eq, Show)++makeClassy ''FileSystemError+makeClassyPrisms ''FileSystemError++-- | A class of monads that can interact with the filesystem.+class (AsFileSystemError e, MonadError e m) => MonadFileSystem e m | m -> e where+ -- | Reads a file at the given path and returns its contents. If the file does+ -- not exist, is not accessible, or is improperly encoded, this method throws+ -- an exception.+ readFile :: T.Text -> m T.Text++ default readFile :: (MonadTrans t, MonadFileSystem e m', m ~ t m') => T.Text -> m T.Text+ readFile = lift . readFile++readFile' :: (AsFileSystemError e, MonadError e m, MonadBase IO m) => T.Text -> m T.Text+readFile' p = do+ let _IOException_NoSuchThing = IO._IOException . to isNoSuchThingIOError+ x <- liftBase $ IO.catching_ _IOException_NoSuchThing (Just <$> T.readFile (T.unpack p)) (return Nothing)+ maybe (throwing _FileNotFound p) return x+ where+ isNoSuchThingIOError IOError { ioe_type = NoSuchThing } = True+ isNoSuchThingIOError _ = False++instance MonadFileSystem e m => MonadFileSystem e (ExceptT e m)+instance MonadFileSystem e m => MonadFileSystem e (LoggingT m)+instance MonadFileSystem e m => MonadFileSystem e (ReaderT r m)+instance MonadFileSystem e m => MonadFileSystem e (StateT s m)+instance (MonadFileSystem e m, Monoid w) => MonadFileSystem e (WriterT w m)++--------------------------------------------------------------------------------+-- | 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)])+ 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 getStackOutputs :: (MonadTrans t, MonadCloud m', m ~ t m') => StackName -> m (Maybe [(T.Text, T.Text)])+ getStackOutputs = lift . getStackOutputs++ default runChangeSet :: (MonadTrans t, MonadCloud m', m ~ t m') => T.Text -> m ()+ runChangeSet = lift . runChangeSet++type MonadCloudIO r m = (HasEnv r, MonadReader r m, MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)++_StackDoesNotExistError :: AsError a => StackName -> Traversal' a ()+_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+ env <- ask+ let stackCheckRequest = describeStacks & dStackName ?~ stackName+ 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)+ & ccsTemplateBody ?~ templateBody+ & ccsCapabilities .~ [CapabilityIAM]+ request <- case stackCheckResponse ^? _Just.dsrsStacks of+ Nothing -> return $ changeSet & ccsChangeSetType ?~ Create+ Just [_] -> return $ changeSet & ccsChangeSetType ?~ Update+ Just _ -> fail "computeChangeset: describeStacks returned more than one stack"+ response <- send request+ maybe (fail "computeChangeset: createChangeSet did not return a change set id")+ return (response ^. ccsrsId)+ where+ awsParam (key, val) = parameter+ & pParameterKey ?~ key+ & pParameterValue ?~ val++getStackOutputs' :: MonadCloudIO r m => StackName -> m (Maybe [(T.Text, T.Text)])+getStackOutputs' (StackName stackName) = do+ env <- ask+ let request = describeStacks & dStackName ?~ stackName+ runResourceT . runAWST env $ do+ response <- IO.trying_ (_StackDoesNotExistError (StackName stackName)) $ send request+ case response ^? _Just.dsrsStacks of+ Nothing -> return Nothing+ Just [stack] -> Just <$> mapM outputToTuple (stack ^. sOutputs)+ Just _ -> fail "getStackOutputs: describeStacks returned more than one stack"+ where+ outputToTuple :: Monad m => Output -> m (T.Text, T.Text)+ outputToTuple x = case (x ^. oOutputKey, x ^. oOutputValue) of+ (Just k, Just v) -> return (k, v)+ (Nothing, _) -> fail "getStackOutputs: stack output key was missing"+ (_, Nothing) -> fail "getStackOutputs: stack output value was missing"++runChangeSet' :: MonadCloudIO r m => T.Text -> m ()+runChangeSet' csId = do+ env <- ask+ waitUntilChangeSetReady env+ runResourceT . runAWST env $+ void $ send (executeChangeSet csId)+ where+ waitUntilChangeSetReady env = do+ liftBase $ threadDelay 1000000+ cs <- runResourceT . runAWST env $+ send (describeChangeSet csId)+ execStatus <- case cs ^. drsExecutionStatus of+ Just x -> return x+ Nothing -> fail "runChangeSet: change set lacks execution status"+ unless (execStatus == Available) $ void $ waitUntilChangeSetReady env++instance MonadCloud m => MonadCloud (ExceptT e m)+instance MonadCloud m => MonadCloud (LoggingT m)+instance MonadCloud m => MonadCloud (ReaderT r m)+instance MonadCloud m => MonadCloud (StateT s m)+instance (MonadCloud m, Monoid w) => MonadCloud (WriterT w m)++--------------------------------------------------------------------------------+-- | A class of monads that can access environment variables+class Monad m => MonadEnvironment m where+ getEnv :: T.Text -> m (Maybe T.Text)++ default getEnv :: (MonadTrans t, MonadEnvironment m', m ~ t m') => T.Text -> m (Maybe T.Text)+ getEnv = lift . getEnv++instance MonadEnvironment IO where+ getEnv = fmap (fmap T.pack) . lookupEnv . T.unpack++instance MonadEnvironment m => MonadEnvironment (ExceptT e m)+instance MonadEnvironment m => MonadEnvironment (LoggingT m)+instance MonadEnvironment m => MonadEnvironment (ReaderT r m)+instance MonadEnvironment m => MonadEnvironment (StateT s m)+instance (MonadEnvironment m, Monoid w) => MonadEnvironment (WriterT w m)
+ library/Network/CloudSeeder/Main.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Network.CloudSeeder.Main+ ( Command(..)+ , StackName(..)+ , CliError(..)+ , HasCliError(..)+ , AsCliError(..)+ , cli+ , cliIO+ ) where++import Control.Applicative.Lift (Errors, failure, runErrors)+import Control.Lens ((^.), (^..), each, has, only, to)+import Control.Lens.TH (makeClassy, makeClassyPrisms)+import Control.Monad.Base (MonadBase)+import Control.Monad.Catch (MonadCatch, MonadThrow)+import Control.Monad.Error.Lens (throwing)+import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)+import Control.Monad.IO.Class (MonadIO)+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 Network.AWS (Credentials(Discover), Env, newEnv)+import System.Exit (exitFailure)++import Prelude hiding (readFile)++import qualified Data.Text as T+import qualified Data.Text.IO as T++import Network.CloudSeeder.CommandLine+import Network.CloudSeeder.DSL+import Network.CloudSeeder.Interfaces++--------------------------------------------------------------------------------+-- IO wiring++data CliError+ = CliMissingEnvVars [T.Text]+ | CliFileSystemError FileSystemError+ | CliStackNotConfigured T.Text+ | CliMissingDependencyStacks [T.Text]+ deriving (Eq, Show)++makeClassy ''CliError+makeClassyPrisms ''CliError++renderCliError :: CliError -> T.Text+renderCliError (CliMissingEnvVars vars)+ = "the following required environment variables were not set:\n"+ <> T.unlines (map (" " <>) vars)+renderCliError (CliFileSystemError (FileNotFound path))+ = "file not found: ‘" <> path <> "’\n"+renderCliError (CliStackNotConfigured stackName)+ = "stack name not present in configuration: ‘" <> stackName <> "’\n"+renderCliError (CliMissingDependencyStacks stackNames)+ = "the following dependency stacks do not exist in AWS:\n"+ <> T.unlines (map (" " <>) stackNames)++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 )++instance MonadBaseControl IO AppM where+ type StM AppM a = StM (ReaderT Env (ExceptT CliError (LoggingT IO))) a+ liftBaseWith f = AppM (liftBaseWith (\g -> f (\(AppM x) -> g x)))+ restoreM = AppM . restoreM++instance MonadFileSystem CliError AppM where+ readFile = readFile'++instance MonadCloud AppM where+ computeChangeset = computeChangeset'+ getStackOutputs = getStackOutputs'+ runChangeSet = runChangeSet'++runAppM :: AppM a -> IO a+runAppM (AppM x) = do+ env <- newEnv Discover+ result <- runStderrLoggingT . runExceptT $ runReaderT x env+ either (\err -> T.putStr (renderCliError err) >> exitFailure) return result++--------------------------------------------------------------------------------+-- Logic++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+ 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++ maybeEnvValues <- mapM (\envVarKey -> (envVarKey,) <$> getEnv envVarKey) requiredEnvVars+ let envVarsOrFailure = runErrors $ traverse (extractResult (,)) maybeEnvValues+ envVars <- either (throwError . CliMissingEnvVars . sort) return envVarsOrFailure++ let env = snd $ head envVars+ let mkStackName s = StackName $ env <> "-" <> appName <> "-" <> s++ templateBody <- readFile $ nameToDeploy <> ".yaml"++ maybeOutputs <- mapM (\stackName -> (stackName,) <$> getStackOutputs (mkStackName stackName)) dependencies+ let outputsOrFailure = runErrors $ traverse (extractResult (flip const)) maybeOutputs+ outputs <- either (throwing _CliMissingDependencyStacks) return outputsOrFailure++ let parameters = envVars ++ concat outputs+ csId <- computeChangeset (mkStackName nameToDeploy) templateBody parameters+ runChangeSet csId++cliIO :: IO DeploymentConfiguration -> IO ()+cliIO mConfig = do+ config <- mConfig+ cmd <- getArgs+ runAppM (cli cmd config)++-- | 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.+--+-- >>> runErrors $ extractResult (,) ("foo", Just True)+-- Right ("foo", True)+-- >>> runErrors $ extractResult (,) ("foo", Nothing)+-- Left ["foo"]+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
+ package.yaml view
@@ -0,0 +1,97 @@+name: cloud-seeder+version: 0.0.0.0+category: Cloud+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+ application stacks to AWS CloudFormation using Amazonka.++copyright: 2017 CJ Affiliate by Conversant+license: ISC+license-file: LICENSE+author: Alexis King <lexi.lambda@gmail.com>, Michael Arnold <michaelaarnold@gmail.com>+maintainer: Alexis King <lexi.lambda@gmail.com>, Michael Arnold <michaelaarnold@gmail.com>+github: cjdev/cloud-seeder++extra-source-files:+- CHANGELOG.md+- LICENSE+- package.yaml+- README.md+- stack.yaml++ghc-options: -Wall+default-extensions:+- ApplicativeDo+- ConstraintKinds+- DefaultSignatures+- DeriveGeneric+- ExistentialQuantification+- FlexibleContexts+- FlexibleInstances+- FunctionalDependencies+- GADTs+- GeneralizedNewtypeDeriving+- LambdaCase+- MultiParamTypeClasses+- NamedFieldPuns+- OverloadedStrings+- RankNTypes+- ScopedTypeVariables+- StandaloneDeriving+- TupleSections+- TypeOperators++library:+ dependencies:+ - amazonka >= 1.4.5+ - amazonka-cloudformation >= 1.4.5+ - amazonka-core >= 1.4.5+ - base >= 4.9.0.0 && < 5+ - deepseq >= 1.4.1.0+ - exceptions >= 0.8 && < 0.9+ - lens+ - monad-control >= 1.0.0.0+ - monad-logger >= 0.3.13.1+ - monad-time >= 0.2+ - mtl+ - optparse-applicative >= 0.13.0.0+ - text+ - transformers+ - transformers-base+ 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+ - bytestring+ - cloud-seeder+ - deepseq >= 1.4.1.0+ - fast-logger >= 2.4.8+ - hspec >= 2.4 && < 2.5+ - lens+ - monad-logger >= 0.3 && < 0.4+ - mtl+ - text >= 1.2 && < 1.3+ - transformers+ ghc-options:+ - -rtsopts+ - -threaded+ - -with-rtsopts=-N+ main: Main.hs+ source-dirs: test-suite
+ stack.yaml view
@@ -0,0 +1,66 @@+# 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+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
+ test-suite/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test-suite/Network/CloudSeeder/DSLSpec.hs view
@@ -0,0 +1,45 @@+module Network.CloudSeeder.DSLSpec (spec) where++import Control.Lens ((^.), (^..), each)+import Data.Functor.Identity (runIdentity)+import Test.Hspec++import Network.CloudSeeder.DSL++spec :: Spec+spec =+ describe "deployment" $ do+ it "creates a DeploymentConfiguration with the given name" $ do+ let config = runIdentity $ deployment "foobar" $ return ()+ config ^. name `shouldBe` "foobar"++ describe "environment" $ do+ it "adds environment variables to a DeploymentConfiguration" $ do+ let vars = ["foo", "bar", "baz"]+ config = runIdentity $ deployment "" $ environment vars+ config ^. environmentVariables `shouldBe` vars++ 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"]++ describe "stack_" $ do+ it "registers a stack with the given name" $ do+ let config = runIdentity $ deployment "" $ stack_ "foo"+ config ^.. stacks.each.name `shouldBe` ["foo"]++ it "adds multiple stacks to the DeploymentConfiguration" $ do+ let config = runIdentity $ deployment "" $ do+ stack_ "foo"+ stack_ "bar"+ stack_ "baz"+ config ^.. stacks.each.name `shouldBe` ["foo", "bar", "baz"]++ describe "stack" $ do+ describe "environment" $ do+ 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"]]
+ test-suite/Network/CloudSeeder/MainSpec.hs view
@@ -0,0 +1,182 @@+module Network.CloudSeeder.MainSpec (spec) where++import Control.Lens (review)+import Control.Monad.Except (ExceptT, runExceptT)+import Data.Function ((&))+import Data.Functor.Identity (runIdentity)+import Test.Hspec++import Network.CloudSeeder.DSL+import Network.CloudSeeder.Interfaces+import Network.CloudSeeder.Main+import Network.CloudSeeder.Test.Stubs++spec :: Spec+spec = parallel $ do+ describe "cli" $ do+ 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+ stack_ "base"+ stack_ "server"+ env = [("Env", "test")]+ runFailure _FileNotFound "server.yaml" $ cli (DeployStack "server") config+ & stubFileSystemT []+ & stubExceptT+ & stubEnvironmentT env+ & stubCloudT []++ 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+ & stubFileSystemT+ [ ("base.yaml", "base.yaml contents")]+ & stubExceptT+ & stubEnvironmentT env+ & stubCloudT []++ context "the configuration does not have environment variables" $ do+ let config = runIdentity $ 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+ & stubFileSystemT+ [ ("base.yaml", "base.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT env+ & stubCloudT+ [ ComputeChangeset "test-foo-base" "base.yaml contents" env :-> "csid"+ , RunChangeSet "csid" :-> () ]++ it "passes the outputs from prior stacks" $ do+ runSuccess $ cli (DeployStack "server") config+ & stubFileSystemT+ [ ("server.yaml", "server.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT env+ & stubCloudT+ [ DescribeStack "test-foo-base" :-> Just [("foo", "bar")]+ , ComputeChangeset "test-foo-server" "server.yaml contents" (env ++ [("foo", "bar")]) :-> "csid"+ , RunChangeSet "csid" :-> () ]++ runSuccess $ cli (DeployStack "frontend") config+ & stubFileSystemT+ [ ("frontend.yaml", "frontend.yaml contents") ]+ & 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"+ , 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+ & stubFileSystemT+ [ ("frontend.yaml", "frontend.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT env+ & stubCloudT+ [ DescribeStack "test-foo-base" :-> Just []+ , DescribeStack "test-foo-server" :-> Nothing ]++ runFailure _CliMissingDependencyStacks ["base", "server"] $ cli (DeployStack "frontend") config+ & stubFileSystemT+ [ ("frontend.yaml", "frontend.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT env+ & stubCloudT+ [ DescribeStack "test-foo-base" :-> Nothing+ , DescribeStack "test-foo-server" :-> Nothing ]++ it "fails when the Env environment variable is not specified" $ do+ runFailure _CliMissingEnvVars ["Env"] $ cli (DeployStack "server") config+ & stubFileSystemT+ [ ("server.yaml", "server.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT []+ & stubCloudT []++ context "the configuration has global environment variables" $ do+ let config = runIdentity $ 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+ & stubFileSystemT+ [ ("base.yaml", "base.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT env+ & stubCloudT+ [ ComputeChangeset "test-foo-base" "base.yaml contents" env :-> "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+ & stubFileSystemT+ [ ("base.yaml", "base.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT env+ & stubCloudT []++ it "reports all missing environment variables at once in alphabetical order" $ do+ runFailure _CliMissingEnvVars ["Domain", "Env", "SecretsStore"] $ cli (DeployStack "base") config+ & stubFileSystemT+ [ ("base.yaml", "base.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT []+ & stubCloudT []++ context "the configuration has global and local environment variables" $ do+ let config = runIdentity $ deployment "foo" $ do+ environment ["Domain", "SecretsStore"]+ stack "base" $ environment ["Base"]+ stack "server" $ environment ["Server1", "Server2"]+ stack "frontend" $ environment ["Frontend"]++ 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+ & stubFileSystemT+ [ ("base.yaml", "base.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT baseEnv+ & stubCloudT+ [ ComputeChangeset "test-foo-base" "base.yaml contents" baseEnv :-> "csid"+ , RunChangeSet "csid" :-> () ]++ let serverEnv = env ++ [ ("Server1", "b"), ("Server2", "c") ]+ runSuccess $ cli (DeployStack "server") config+ & stubFileSystemT+ [ ("server.yaml", "server.yaml contents") ]+ & stubExceptT+ & stubEnvironmentT serverEnv+ & stubCloudT+ [ DescribeStack "test-foo-base" :-> Just []+ , ComputeChangeset "test-foo-server" "server.yaml contents" serverEnv :-> "csid"+ , RunChangeSet "csid" :-> () ]
+ test-suite/Network/CloudSeeder/Test/Stubs.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE UndecidableInstances #-}++module Network.CloudSeeder.Test.Stubs where++import qualified Data.Text as T++import Control.Monad.Error.Lens (throwing)+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 System.Log.FastLogger (fromLogStr, toLogStr)++import Network.CloudSeeder.CommandLine+import Network.CloudSeeder.Interfaces++--------------------------------------------------------------------------------+-- Arguments++newtype ArgumentsT m a = ArgumentsT (ReaderT Command 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++instance Monad m => MonadArguments (ArgumentsT m) where+ getArgs = ArgumentsT ask++--------------------------------------------------------------------------------+-- Logger++newtype LoggerT m a = LoggerT (WriterT [ByteString] m a)+ deriving ( Functor, Applicative, Monad, MonadTrans, MonadError e+ , MonadArguments, 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.+runLoggerT :: LoggerT m a -> m (a, [ByteString])+runLoggerT (LoggerT x) = runWriterT x++instance Monad m => MonadLogger (LoggerT m) where+ monadLoggerLog _ _ _ str = LoggerT $ tell [fromLogStr (toLogStr str)]++--------------------------------------------------------------------------------+-- File System++newtype FileSystemT m a = FileSystemT (ReaderT [(T.Text, T.Text)] m a)+ deriving ( Functor, Applicative, Monad, MonadTrans, MonadError e+ , MonadArguments, MonadLogger, MonadCloud, MonadEnvironment )++-- | Runs a computation that may interact with the file system, given a mapping+-- from file paths to file contents.+stubFileSystemT :: [(T.Text, T.Text)] -> FileSystemT m a -> m a+stubFileSystemT fs (FileSystemT x) = runReaderT x fs++instance (AsFileSystemError e, MonadError e m) => MonadFileSystem e (FileSystemT m) where+ readFile path = FileSystemT $ ask >>= \files ->+ maybe (throwing _FileNotFound path)+ 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)+ deriving ( Functor, Applicative, Monad, MonadTrans, MonadError e+ , MonadArguments, MonadLogger, MonadFileSystem e, MonadCloud )++stubEnvironmentT :: [(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