stackctl 1.4.2.1 → 1.4.2.2
raw patch · 47 files changed
+1045/−889 lines, 47 filesdep −unliftio-coredep ~Blammodep ~amazonkadep ~amazonka-cloudformation
Dependencies removed: unliftio-core
Dependency ranges changed: Blammo, amazonka, amazonka-cloudformation, amazonka-core, amazonka-ec2, amazonka-lambda, amazonka-sso, amazonka-sts, unliftio
Files
- CHANGELOG.md +7/−1
- README.md +1/−0
- src/Stackctl/AWS/CloudFormation.hs +81/−85
- src/Stackctl/AWS/Core.hs +88/−35
- src/Stackctl/AWS/EC2.hs +1/−1
- src/Stackctl/AWS/Lambda.hs +41/−30
- src/Stackctl/AWS/Orphans.hs +45/−25
- src/Stackctl/AWS/Scope.hs +23/−23
- src/Stackctl/Action.hs +14/−13
- src/Stackctl/AutoSSO.hs +13/−10
- src/Stackctl/CLI.hs +15/−13
- src/Stackctl/ColorOption.hs +8/−6
- src/Stackctl/Colors.hs +1/−27
- src/Stackctl/Commands.hs +42/−36
- src/Stackctl/Config.hs +26/−22
- src/Stackctl/Config/RequiredVersion.hs +11/−7
- src/Stackctl/DirectoryOption.hs +17/−14
- src/Stackctl/FilterOption.hs +19/−15
- src/Stackctl/Options.hs +22/−19
- src/Stackctl/ParameterOption.hs +10/−7
- src/Stackctl/Prelude.hs +8/−3
- src/Stackctl/RemovedStack.hs +1/−1
- src/Stackctl/Spec/Capture.hs +63/−47
- src/Stackctl/Spec/Cat.hs +51/−41
- src/Stackctl/Spec/Changes.hs +19/−16
- src/Stackctl/Spec/Changes/Format.hs +48/−40
- src/Stackctl/Spec/Deploy.hs +58/−46
- src/Stackctl/Spec/Discover.hs +4/−4
- src/Stackctl/Spec/Generate.hs +27/−26
- src/Stackctl/Spec/List.hs +2/−2
- src/Stackctl/StackDescription.hs +9/−7
- src/Stackctl/StackSpec.hs +19/−17
- src/Stackctl/StackSpecPath.hs +23/−20
- src/Stackctl/StackSpecYaml.hs +11/−12
- src/Stackctl/Subcommand.hs +12/−7
- src/Stackctl/TagOption.hs +10/−7
- src/Stackctl/VerboseOption.hs +10/−6
- src/UnliftIO/Exception/Lens.hs +0/−33
- stackctl.cabal +10/−12
- test/Spec.hs +1/−1
- test/Stackctl/AWS/ScopeSpec.hs +6/−6
- test/Stackctl/Config/RequiredVersionSpec.hs +2/−2
- test/Stackctl/ConfigSpec.hs +22/−20
- test/Stackctl/FilterOptionSpec.hs +22/−18
- test/Stackctl/StackDescriptionSpec.hs +4/−4
- test/Stackctl/StackSpecSpec.hs +25/−23
- test/Stackctl/StackSpecYamlSpec.hs +93/−79
CHANGELOG.md view
@@ -1,4 +1,10 @@-## [_Unreleased_](https://github.com/freckle/stackctl/compare/v1.4.2.1...main)+## [_Unreleased_](https://github.com/freckle/stackctl/compare/v1.4.2.2...main)++## [v1.4.2.2](https://github.com/freckle/stackctl/compare/v1.4.2.1...v1.4.2.2)++- Use `amazonka-2.0` :tada:+- Finalize update to `UnliftIO.Exception.Lens`+- Re-export upstreamed `Blammo.Logging.Colors` ## [v1.4.2.1](https://github.com/freckle/stackctl/compare/v1.4.2.0...v1.4.2.1)
README.md view
@@ -24,6 +24,7 @@ - Have `~/.local/bin` on your `$PATH` - Have `~/.local/share/man` on your `$MANPATH` (for documentation) - If on OSX, `brew install coreutils` (i.e. have `ginstall` available)+- If on OSX, `brew install jq` ### Scripted
src/Stackctl/AWS/CloudFormation.hs view
@@ -1,23 +1,23 @@ module Stackctl.AWS.CloudFormation- ( Stack(..)+ ( Stack (..) , stack_stackName , stackDescription , stackStatusRequiresDeletion- , StackId(..)- , StackName(..)- , StackDescription(..)- , StackStatus(..)- , StackEvent(..)- , ResourceStatus(..)+ , StackId (..)+ , StackName (..)+ , StackDescription (..)+ , StackStatus (..)+ , StackEvent (..)+ , ResourceStatus (..) , stackEvent_eventId , stackEvent_logicalResourceId , stackEvent_resourceStatus , stackEvent_resourceStatusReason , stackEvent_timestamp- , StackTemplate(..)- , StackDeployResult(..)+ , StackTemplate (..)+ , StackDeployResult (..) , prettyStackDeployResult- , StackDeleteResult(..)+ , StackDeleteResult (..) , prettyStackDeleteResult , Parameter , parameter_parameterKey@@ -25,7 +25,7 @@ , newParameter , makeParameter , readParameter- , Capability(..)+ , Capability (..) , Tag , newTag , tag_key@@ -43,20 +43,20 @@ , awsCloudFormationWait , awsCloudFormationGetTemplate - -- * ChangeSets- , ChangeSet(..)+ -- * ChangeSets+ , ChangeSet (..) , changeSetJSON- , ChangeSetId(..)- , ChangeSetName(..)- , Change(..)- , ResourceChange(..)- , Replacement(..)- , ChangeAction(..)- , ResourceAttribute(..)- , ResourceChangeDetail(..)- , ChangeSource(..)- , ResourceTargetDefinition(..)- , RequiresRecreation(..)+ , ChangeSetId (..)+ , ChangeSetName (..)+ , Change (..)+ , ResourceChange (..)+ , Replacement (..)+ , ChangeAction (..)+ , ResourceAttribute (..)+ , ResourceChangeDetail (..)+ , ChangeSource (..)+ , ResourceTargetDefinition (..)+ , RequiresRecreation (..) , awsCloudFormationCreateChangeSet , awsCloudFormationExecuteChangeSet , awsCloudFormationDeleteAllChangeSets@@ -80,13 +80,11 @@ import Amazonka.Core ( AsError , ServiceError+ , hasStatus , _MatchServiceError , _ServiceError- , hasStatus- , serviceCode- , serviceMessage )-import Amazonka.Waiter (Accept(..))+import Amazonka.Waiter (Accept (..)) import Conduit import Control.Lens ((?~)) import Data.Aeson@@ -127,14 +125,14 @@ | StackCreateFailure Bool | StackUpdateSuccess | StackUpdateFailure Bool- deriving stock Show+ deriving stock (Show) prettyStackDeployResult :: StackDeployResult -> Text prettyStackDeployResult = \case StackCreateSuccess -> "Created Stack successfully"- StackCreateFailure{} -> "Failed to create Stack"+ StackCreateFailure {} -> "Failed to create Stack" StackUpdateSuccess -> "Updated Stack successfully"- StackUpdateFailure{} -> "Failed to update Stack"+ StackUpdateFailure {} -> "Failed to update Stack" stackCreateResult :: Accept -> StackDeployResult stackCreateResult = \case@@ -155,7 +153,7 @@ prettyStackDeleteResult :: StackDeleteResult -> Text prettyStackDeleteResult = \case StackDeleteSuccess -> "Deleted Stack successfully"- StackDeleteFailure{} -> "Failed to delete Stack"+ StackDeleteFailure {} -> "Failed to delete Stack" stackDeleteResult :: Accept -> StackDeleteResult stackDeleteResult = \case@@ -174,8 +172,7 @@ awsCloudFormationDescribeStack :: (MonadResource m, MonadReader env m, HasAwsEnv env) => StackName -> m Stack awsCloudFormationDescribeStack stackName = do- let- req = newDescribeStacks & describeStacks_stackName ?~ unStackName stackName+ let req = newDescribeStacks & describeStacks_stackName ?~ unStackName stackName awsSimple "DescribeStack" req $ \resp -> do stacks <- resp ^. describeStacksResponse_stacks@@ -202,14 +199,14 @@ awsCloudFormationDescribeStackEvents :: (MonadResource m, MonadReader env m, HasAwsEnv env) => StackName- -> Maybe Text -- ^ Last-seen Id+ -> Maybe Text+ -- ^ Last-seen Id -> m [StackEvent] awsCloudFormationDescribeStackEvents stackName mLastId = do- let- req =- newDescribeStackEvents- & describeStackEvents_stackName- ?~ unStackName stackName+ let req =+ newDescribeStackEvents+ & describeStackEvents_stackName+ ?~ unStackName stackName runConduit $ awsPaginate req@@ -277,9 +274,10 @@ => StackName -> m StackDeployResult awsCloudFormationWait stackName = do- either stackCreateResult stackUpdateResult <$> race- (awsAwait newStackCreateComplete req)- (awsAwait newStackUpdateComplete req)+ either stackCreateResult stackUpdateResult+ <$> race+ (awsAwait newStackCreateComplete req)+ (awsAwait newStackUpdateComplete req) where req = newDescribeStacks & describeStacks_stackName ?~ unStackName stackName @@ -359,27 +357,27 @@ -> [Capability] -> [Tag] -> m (Either Text (Maybe ChangeSet))-awsCloudFormationCreateChangeSet stackName mStackDescription stackTemplate parameters capabilities tags- = fmap (first formatServiceError)+awsCloudFormationCreateChangeSet stackName mStackDescription stackTemplate parameters capabilities tags =+ fmap (first formatServiceError) $ trying (_ServiceError . hasStatus 400) $ do- name <- newChangeSetName+ name <- newChangeSetName - logDebug $ "Reading Template" :# ["path" .= stackTemplate]- templateBody <- addStackDescription mStackDescription+ logDebug $ "Reading Template" :# ["path" .= stackTemplate]+ templateBody <-+ addStackDescription mStackDescription <$> readFileUtf8 (unStackTemplate stackTemplate) - mStack <- awsCloudFormationDescribeStackMaybe stackName+ mStack <- awsCloudFormationDescribeStackMaybe stackName - let- changeSetType = fromMaybe ChangeSetType_CREATE $ do+ let changeSetType = fromMaybe ChangeSetType_CREATE $ do stack <- mStack- pure $ if stackIsAbandonedCreate stack- then ChangeSetType_CREATE- else ChangeSetType_UPDATE+ pure+ $ if stackIsAbandonedCreate stack+ then ChangeSetType_CREATE+ else ChangeSetType_UPDATE - let- req =+ let req = newCreateChangeSet (unStackName stackName) (unChangeSetName name) & (createChangeSet_changeSetType ?~ changeSetType) . (createChangeSet_templateBody ?~ templateBody)@@ -387,17 +385,17 @@ . (createChangeSet_capabilities ?~ capabilities) . (createChangeSet_tags ?~ tags) - logInfo- $ "Creating changeset..."- :# ["name" .= name, "type" .= changeSetType]- csId <- awsSimple "CreateChangeSet" req (^. createChangeSetResponse_id)+ logInfo+ $ "Creating changeset..."+ :# ["name" .= name, "type" .= changeSetType]+ csId <- awsSimple "CreateChangeSet" req (^. createChangeSetResponse_id) - logDebug "Awaiting CREATE_COMPLETE"- void $ awsAwait newChangeSetCreateComplete $ newDescribeChangeSet csId+ logDebug "Awaiting CREATE_COMPLETE"+ void $ awsAwait newChangeSetCreateComplete $ newDescribeChangeSet csId - logInfo "Retrieving changeset..."- cs <- awsCloudFormationDescribeChangeSet $ ChangeSetId csId- pure $ cs <$ guard (not $ changeSetFailed cs)+ logInfo "Retrieving changeset..."+ cs <- awsCloudFormationDescribeChangeSet $ ChangeSetId csId+ pure $ cs <$ guard (not $ changeSetFailed cs) awsCloudFormationDescribeChangeSet :: (MonadResource m, MonadReader env m, HasAwsEnv env)@@ -452,15 +450,15 @@ runConduit $ awsPaginate (newListChangeSets $ unStackName stackName) .| concatMapC- (\resp -> fromMaybe [] $ do- ss <- resp ^. listChangeSetsResponse_summaries- pure $ mapMaybe Summary.changeSetId ss- )+ ( \resp -> fromMaybe [] $ do+ ss <- resp ^. listChangeSetsResponse_summaries+ pure $ mapMaybe Summary.changeSetId ss+ ) .| mapM_C- (\csId -> do- logInfo $ "Enqueing delete" :# ["changeSetId" .= csId]- void $ awsSend $ newDeleteChangeSet csId- )+ ( \csId -> do+ logInfo $ "Enqueing delete" :# ["changeSetId" .= csId]+ void $ awsSend $ newDeleteChangeSet csId+ ) -- | Did we abandoned this Stack's first ever ChangeSet? --@@ -474,16 +472,20 @@ -- Our hueristic for finding these is under review but with no previous -- updates (no lastUpdatedTime), presumably meaning it's still in its /first/ -- review.--- stackIsAbandonedCreate :: Stack -> Bool stackIsAbandonedCreate stack =- stack ^. stack_stackStatus == StackStatus_REVIEW_IN_PROGRESS && isNothing- (stack ^. stack_lastUpdatedTime)+ stack+ ^. stack_stackStatus+ == StackStatus_REVIEW_IN_PROGRESS+ && isNothing+ (stack ^. stack_lastUpdatedTime) stackStatusRequiresDeletion :: Stack -> Maybe StackStatus-stackStatusRequiresDeletion stack = status- <$ guard (status `elem` requiresDeletionStatuses)- where status = stack ^. stack_stackStatus+stackStatusRequiresDeletion stack =+ status+ <$ guard (status `elem` requiresDeletionStatuses)+ where+ status = stack ^. stack_stackStatus requiresDeletionStatuses :: [StackStatus] requiresDeletionStatuses =@@ -499,9 +501,3 @@ _ValidationError :: AsError a => Getting (First ServiceError) a ServiceError _ValidationError = _MatchServiceError defaultService "ValidationError" . hasStatus 400--formatServiceError :: ServiceError -> Text-formatServiceError e = mconcat- [ toText $ e ^. serviceCode- , maybe "" ((": " <>) . toText) $ e ^. serviceMessage- ]
src/Stackctl/AWS/Core.hs view
@@ -1,6 +1,6 @@ module Stackctl.AWS.Core ( AwsEnv- , HasAwsEnv(..)+ , HasAwsEnv (..) , awsEnvDiscover , awsSimple , awsSend@@ -8,25 +8,31 @@ , awsAwait , awsAssumeRole - -- * Modifiers on 'AwsEnv'+ -- * Modifiers on 'AwsEnv' , awsWithin , awsTimeout - -- * 'Amazonka' extensions- , AccountId(..)+ -- * 'Amazonka' extensions+ , AccountId (..) - -- * 'Amazonka'/'ResourceT' re-exports- , Region(..)- , FromText(..)- , ToText(..)+ -- * Error-handling+ , handlingServiceError+ , formatServiceError++ -- * 'Amazonka'/'ResourceT' re-exports+ , Region (..)+ , FromText (..)+ , ToText (..) , MonadResource ) where import Stackctl.Prelude hiding (timeout) -import Amazonka hiding (LogLevel(..))+import Amazonka hiding (LogLevel (..)) import qualified Amazonka as AWS import Amazonka.Auth.Keys (fromSession)+import Amazonka.Data.Text (FromText (..), ToText (..))+import Amazonka.Env (env_logger, env_region) import Amazonka.STS.AssumeRole import Conduit (ConduitM) import Control.Monad.Logger (defaultLoc, toLogStr)@@ -38,7 +44,7 @@ } unL :: Lens' AwsEnv Env-unL = lens unAwsEnv $ \x y -> x { unAwsEnv = y }+unL = lens unAwsEnv $ \x y -> x {unAwsEnv = y} awsEnvDiscover :: MonadLoggerIO m => m AwsEnv awsEnvDiscover = do@@ -48,20 +54,20 @@ configureLogging :: MonadLoggerIO m => Env -> m Env configureLogging env = do loggerIO <- askLoggerIO- pure $ env- { AWS.envLogger = \level msg -> do- loggerIO- defaultLoc -- TODO: there may be a way to get a CallStack/Loc- "Amazonka"- (case level of- AWS.Info -> LevelInfo- AWS.Error -> LevelError- AWS.Debug -> LevelDebug- AWS.Trace -> LevelOther "trace"- )- (toLogStr msg)- } + let logger level = do+ loggerIO+ defaultLoc -- TODO: there may be a way to get a CallStack/Loc+ "Amazonka"+ ( case level of+ AWS.Info -> LevelInfo+ AWS.Error -> LevelError+ AWS.Debug -> LevelDebug+ AWS.Trace -> LevelOther "trace"+ )+ . toLogStr+ pure $ env & env_logger .~ logger+ class HasAwsEnv env where awsEnvL :: Lens' env AwsEnv @@ -69,7 +75,13 @@ awsEnvL = id awsSimple- :: (MonadResource m, MonadReader env m, HasAwsEnv env, AWSRequest a)+ :: ( MonadResource m+ , MonadReader env m+ , HasAwsEnv env+ , AWSRequest a+ , Typeable a+ , Typeable (AWSResponse a)+ ) => Text -> a -> (AWSResponse a -> Maybe b)@@ -77,10 +89,17 @@ awsSimple name req post = do resp <- awsSend req maybe (throwString err) pure $ post resp- where err = unpack name <> " successful, but processing the response failed"+ where+ err = unpack name <> " successful, but processing the response failed" awsSend- :: (MonadResource m, MonadReader env m, HasAwsEnv env, AWSRequest a)+ :: ( MonadResource m+ , MonadReader env m+ , HasAwsEnv env+ , AWSRequest a+ , Typeable a+ , Typeable (AWSResponse a)+ ) => a -> m (AWSResponse a) awsSend req = do@@ -88,7 +107,13 @@ send env req awsPaginate- :: (MonadResource m, MonadReader env m, HasAwsEnv env, AWSPager a)+ :: ( MonadResource m+ , MonadReader env m+ , HasAwsEnv env+ , AWSPager a+ , Typeable a+ , Typeable (AWSResponse a)+ ) => a -> ConduitM () (AWSResponse a) m () awsPaginate req = do@@ -99,7 +124,12 @@ hoistEither = either (liftIO . throwIO) pure awsAwait- :: (MonadResource m, MonadReader env m, HasAwsEnv env, AWSRequest a)+ :: ( MonadResource m+ , MonadReader env m+ , HasAwsEnv env+ , AWSRequest a+ , Typeable a+ ) => Wait a -> a -> m Accept@@ -120,24 +150,47 @@ let req = newAssumeRole role sessionName assumeEnv <- awsSimple "sts:AssumeRole" req $ \resp -> do- creds <- resp ^. assumeRoleResponse_credentials- token <- creds ^. authSessionToken+ let creds = resp ^. assumeRoleResponse_credentials+ token <- creds ^. authEnv_sessionToken let- accessKeyId = creds ^. authAccessKeyId- secretAccessKey = creds ^. authSecretAccessKey+ accessKeyId = creds ^. authEnv_accessKeyId+ secretAccessKey = creds ^. authEnv_secretAccessKey . _Sensitive - pure $ fromSession accessKeyId secretAccessKey token+ pure $ fromSession accessKeyId secretAccessKey $ token ^. _Sensitive local (awsEnvL . unL %~ assumeEnv) f awsWithin :: (MonadReader env m, HasAwsEnv env) => Region -> m a -> m a-awsWithin r = local $ over (awsEnvL . unL) (within r)+awsWithin r = local $ awsEnvL . unL . env_region .~ r awsTimeout :: (MonadReader env m, HasAwsEnv env) => Seconds -> m a -> m a-awsTimeout t = local $ over (awsEnvL . unL) (timeout t)+awsTimeout t = local $ over (awsEnvL . unL) (globalTimeout t) newtype AccountId = AccountId { unAccountId :: Text } deriving newtype (Eq, Ord, Show, ToJSON)++-- | Handle 'ServiceError', log it and 'exitFailure'+--+-- This is useful at the top-level of the app, where we'd be crashing anyway. It+-- makes things more readable and easier to debug.+handlingServiceError :: (MonadUnliftIO m, MonadLogger m) => m a -> m a+handlingServiceError =+ handleJust @_ @SomeException (^? _ServiceError) $ \e -> do+ logError+ $ "Exiting due to AWS Service error"+ :# [ "code" .= toText (e ^. serviceError_code)+ , "message" .= fmap toText (e ^. serviceError_message)+ , "requestId" .= fmap toText (e ^. serviceError_requestId)+ ]+ exitFailure++formatServiceError :: ServiceError -> Text+formatServiceError e =+ mconcat+ [ toText $ e ^. serviceError_code+ , maybe "" ((": " <>) . toText) $ e ^. serviceError_message+ , maybe "" (("\nRequest Id: " <>) . toText) $ e ^. serviceError_requestId+ ]
src/Stackctl/AWS/EC2.hs view
@@ -5,7 +5,7 @@ import Stackctl.Prelude import Amazonka.EC2.DescribeAvailabilityZones-import Amazonka.EC2.Types (AvailabilityZone(..))+import Amazonka.EC2.Types (AvailabilityZone (..)) import Stackctl.AWS.Core awsEc2DescribeFirstAvailabilityZoneRegionName
src/Stackctl/AWS/Lambda.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE MultiWayIf #-} module Stackctl.AWS.Lambda- ( LambdaInvokeResult(..)- , LambdaError(..)+ ( LambdaInvokeResult (..)+ , LambdaError (..) , logLambdaInvocationResult , isLambdaInvocationSuccess , awsLambdaInvoke@@ -19,36 +19,40 @@ = LambdaInvokeSuccess ByteString | LambdaInvokeError LambdaError (Maybe Text) | LambdaInvokeFailure Int (Maybe Text)- deriving stock Show+ deriving stock (Show) logLambdaInvocationResult :: MonadLogger m => LambdaInvokeResult -> m () logLambdaInvocationResult = \case LambdaInvokeSuccess bs -> do- let- meta = case decode @Value $ BSL.fromStrict bs of- Nothing -> ["response" .= decodeUtf8 bs]- Just response -> ["response" .= response]+ let meta = case decode @Value $ BSL.fromStrict bs of+ Nothing -> ["response" .= decodeUtf8 bs]+ Just response -> ["response" .= response] logInfo $ "LambdaInvokeSuccess" :# meta LambdaInvokeError LambdaError {..} mFunctionError ->- logError $ (:# []) $ mconcat- [ "LambdaInvokeError"- , "\n errorType: " <> errorType- , "\n errorMessage: " <> errorMessage- , "\n trace: "- , mconcat $ map ("\n " <>) trace- , "\n FunctionError: " <> fromMaybe "none" mFunctionError- ]- LambdaInvokeFailure status mFunctionError -> logError $ (:# []) $ mconcat- [ "LambdaInvokeFailure"- , "\n StatusCode: " <> pack (show status)- , "\n FunctionError: " <> fromMaybe "none" mFunctionError- ]+ logError+ $ (:# [])+ $ mconcat+ [ "LambdaInvokeError"+ , "\n errorType: " <> errorType+ , "\n errorMessage: " <> errorMessage+ , "\n trace: "+ , mconcat $ map ("\n " <>) trace+ , "\n FunctionError: " <> fromMaybe "none" mFunctionError+ ]+ LambdaInvokeFailure status mFunctionError ->+ logError+ $ (:# [])+ $ mconcat+ [ "LambdaInvokeFailure"+ , "\n StatusCode: " <> pack (show status)+ , "\n FunctionError: " <> fromMaybe "none" mFunctionError+ ] isLambdaInvocationSuccess :: LambdaInvokeResult -> Bool isLambdaInvocationSuccess = \case- LambdaInvokeSuccess{} -> True- LambdaInvokeError{} -> False- LambdaInvokeFailure{} -> False+ LambdaInvokeSuccess {} -> True+ LambdaInvokeError {} -> False+ LambdaInvokeFailure {} -> False data LambdaError = LambdaError { errorType :: Text@@ -66,14 +70,20 @@ , ToJSON a ) => Text- -> a -- ^ Payload+ -> a+ -- ^ Payload -> m LambdaInvokeResult awsLambdaInvoke name payload = do logDebug $ "Invoking function" :# ["name" .= name] -- Match Lambda's own limit (15 minutes) and add some buffer- resp <- awsTimeout 905 $ awsSend $ newInvoke name $ BSL.toStrict $ encode- payload+ resp <-+ awsTimeout 905+ $ awsSend+ $ newInvoke name+ $ BSL.toStrict+ $ encode+ payload let status = resp ^. invokeResponse_statusCode@@ -89,10 +99,11 @@ , "functionError" .= mFunctionError ] - pure $ if- | statusIsUnsuccessful status -> LambdaInvokeFailure status mFunctionError- | Just e <- mError -> LambdaInvokeError e mFunctionError- | otherwise -> LambdaInvokeSuccess response+ pure+ $ if+ | statusIsUnsuccessful status -> LambdaInvokeFailure status mFunctionError+ | Just e <- mError -> LambdaInvokeError e mFunctionError+ | otherwise -> LambdaInvokeSuccess response statusIsUnsuccessful :: Int -> Bool statusIsUnsuccessful s = s < 200 || s >= 300
src/Stackctl/AWS/Orphans.hs view
@@ -5,9 +5,7 @@ -- -- Orphans so we can get @'ToJSON' 'ChangeSet'@ without hand-writing a massive, -- incomplete, and doomed-to-drift instance ourselves.----module Stackctl.AWS.Orphans- () where+module Stackctl.AWS.Orphans () where import Stackctl.Prelude @@ -17,32 +15,54 @@ import GHC.Generics (Rep) -- Makes it syntactally easier to do a bunch of these-newtype Generically a = Generically { unGenerically :: a }+newtype Generically a = Generically {unGenerically :: a} instance ( Generic a , GToJSON' Value Zero (Rep a) , GToJSON' Encoding Zero (Rep a)- ) => ToJSON (Generically a) where+ )+ => ToJSON (Generically a)+ where toJSON = genericToJSON defaultOptions . unGenerically toEncoding = genericToEncoding defaultOptions . unGenerically -deriving via (Generically DescribeChangeSetResponse)- instance ToJSON DescribeChangeSetResponse-deriving via (Generically Tag)- instance ToJSON Tag-deriving via (Generically Parameter)- instance ToJSON Parameter-deriving via (Generically RollbackConfiguration)- instance ToJSON RollbackConfiguration-deriving via (Generically RollbackTrigger)- instance ToJSON RollbackTrigger-deriving via (Generically Change)- instance ToJSON Change-deriving via (Generically ResourceChange)- instance ToJSON ResourceChange-deriving via (Generically ModuleInfo)- instance ToJSON ModuleInfo-deriving via (Generically ResourceChangeDetail)- instance ToJSON ResourceChangeDetail-deriving via (Generically ResourceTargetDefinition)- instance ToJSON ResourceTargetDefinition+deriving via+ (Generically DescribeChangeSetResponse)+ instance+ ToJSON DescribeChangeSetResponse+deriving via+ (Generically Tag)+ instance+ ToJSON Tag+deriving via+ (Generically Parameter)+ instance+ ToJSON Parameter+deriving via+ (Generically RollbackConfiguration)+ instance+ ToJSON RollbackConfiguration+deriving via+ (Generically RollbackTrigger)+ instance+ ToJSON RollbackTrigger+deriving via+ (Generically Change)+ instance+ ToJSON Change+deriving via+ (Generically ResourceChange)+ instance+ ToJSON ResourceChange+deriving via+ (Generically ModuleInfo)+ instance+ ToJSON ModuleInfo+deriving via+ (Generically ResourceChangeDetail)+ instance+ ToJSON ResourceChangeDetail+deriving via+ (Generically ResourceTargetDefinition)+ instance+ ToJSON ResourceTargetDefinition
src/Stackctl/AWS/Scope.hs view
@@ -1,8 +1,8 @@ module Stackctl.AWS.Scope- ( AwsScope(..)+ ( AwsScope (..) , awsScopeSpecPatterns , awsScopeSpecStackName- , HasAwsScope(..)+ , HasAwsScope (..) , fetchAwsScope ) where @@ -20,26 +20,26 @@ , awsRegion :: Region } deriving stock (Eq, Show, Generic)- deriving anyclass ToJSON+ deriving anyclass (ToJSON) awsScopeSpecPatterns :: AwsScope -> [Pattern] awsScopeSpecPatterns AwsScope {..} = [ compile- $ "stacks"- </> unpack (unAccountId awsAccountId)- <> ".*"- </> unpack (fromRegion awsRegion)- <> "**"- </> "*"- <.> "yaml"+ $ "stacks"+ </> unpack (unAccountId awsAccountId)+ <> ".*"+ </> unpack (fromRegion awsRegion)+ <> "**"+ </> "*"+ <.> "yaml" , compile- $ "stacks"- </> "*."- <> unpack (unAccountId awsAccountId)- </> unpack (fromRegion awsRegion)- <> "**"- </> "*"- <.> "yaml"+ $ "stacks"+ </> "*."+ <> unpack (unAccountId awsAccountId)+ </> unpack (fromRegion awsRegion)+ <> "**"+ </> "*"+ <.> "yaml" ] awsScopeSpecStackName :: AwsScope -> FilePath -> Maybe StackName@@ -49,13 +49,13 @@ -- once we've guarded that the path matches our scope patterns, we can play it -- pretty fast and loose with the "parsing" step pure- $ path -- stacks/account/region/x/y.yaml- & splitPath -- [stacks/, account/, region/, x/, y.yaml]- & drop 3 -- [x, y.yaml]- & joinPath -- x/y.yaml- & dropExtension -- x/y+ $ path -- stacks/account/region/x/y.yaml+ & splitPath -- [stacks/, account/, region/, x/, y.yaml]+ & drop 3 -- [x, y.yaml]+ & joinPath -- x/y.yaml+ & dropExtension -- x/y & pack- & T.replace "/" "-" -- x-y+ & T.replace "/" "-" -- x-y & StackName class HasAwsScope env where
src/Stackctl/Action.hs view
@@ -11,12 +11,11 @@ -- run: -- InvokeLambdaByStackOutput: OnDeployFunction -- @--- module Stackctl.Action ( Action , newAction- , ActionOn(..)- , ActionRun(..)+ , ActionOn (..)+ , ActionRun (..) , runActions ) where @@ -63,18 +62,20 @@ <|> (InvokeLambdaByName <$> o .: "InvokeLambdaByName") instance ToJSON ActionRun where- toJSON = object . \case- InvokeLambdaByStackOutput name -> ["InvokeLambdaByStackOutput" .= name]- InvokeLambdaByName name -> ["InvokeLambdaByName" .= name]- toEncoding = pairs . \case- InvokeLambdaByStackOutput name -> "InvokeLambdaByStackOutput" .= name- InvokeLambdaByName name -> "InvokeLambdaByName" .= name+ toJSON =+ object . \case+ InvokeLambdaByStackOutput name -> ["InvokeLambdaByStackOutput" .= name]+ InvokeLambdaByName name -> ["InvokeLambdaByName" .= name]+ toEncoding =+ pairs . \case+ InvokeLambdaByStackOutput name -> "InvokeLambdaByStackOutput" .= name+ InvokeLambdaByName name -> "InvokeLambdaByName" .= name data ActionFailure = NoSuchOutput | InvokeLambdaFailure- deriving stock Show- deriving anyclass Exception+ deriving stock (Show)+ deriving anyclass (Exception) runActions :: (MonadResource m, MonadLogger m, MonadReader env m, HasAwsEnv env)@@ -86,14 +87,14 @@ traverse_ (runAction stackName) . filter (`shouldRunOn` on) shouldRunOn :: Action -> ActionOn -> Bool-shouldRunOn Action { on } on' = on == on'+shouldRunOn Action {on} on' = on == on' runAction :: (MonadResource m, MonadLogger m, MonadReader env m, HasAwsEnv env) => StackName -> Action -> m ()-runAction stackName Action { on, run } = do+runAction stackName Action {on, run} = do logInfo $ "Running action" :# ["on" .= on, "run" .= run] case run of
src/Stackctl/AutoSSO.hs view
@@ -1,7 +1,7 @@ module Stackctl.AutoSSO ( AutoSSOOption , defaultAutoSSOOption- , HasAutoSSOOption(..)+ , HasAutoSSOOption (..) , autoSSOOption , envAutoSSOOption , handleAutoSSO@@ -10,18 +10,19 @@ import Stackctl.Prelude import Amazonka.SSO (_UnauthorizedException)-import Amazonka.Types (Error, ErrorMessage(..), serviceMessage)-import Data.Semigroup (Last(..))+import Data.Semigroup (Last (..)) import qualified Env import Options.Applicative+import Stackctl.AWS.Core (formatServiceError) import Stackctl.Prompt import System.Process.Typed+import UnliftIO.Exception.Lens (catching) data AutoSSOOption = AutoSSOAlways | AutoSSOAsk | AutoSSONever- deriving Semigroup via Last AutoSSOOption+ deriving (Semigroup) via Last AutoSSOOption defaultAutoSSOOption :: AutoSSOOption defaultAutoSSOOption = AutoSSOAsk@@ -38,12 +39,14 @@ autoSSOOptionL :: Lens' env AutoSSOOption autoSSOOption :: Parser AutoSSOOption-autoSSOOption = option (eitherReader readAutoSSO)- $ mconcat [long "auto-sso", help autoSSOHelp, metavar "WHEN"]+autoSSOOption =+ option (eitherReader readAutoSSO)+ $ mconcat [long "auto-sso", help autoSSOHelp, metavar "WHEN"] envAutoSSOOption :: Env.Parser Env.Error AutoSSOOption-envAutoSSOOption = Env.var (first Env.UnreadError . readAutoSSO) "AUTO_SSO"- $ Env.help autoSSOHelp+envAutoSSOOption =+ Env.var (first Env.UnreadError . readAutoSSO) "AUTO_SSO"+ $ Env.help autoSSOHelp autoSSOHelp :: IsString a => a autoSSOHelp = "Automatically run aws-sso-login if necessary?"@@ -59,7 +62,7 @@ -> m a -> m a handleAutoSSO options f = do- catchJust (preview (_UnauthorizedException @Error)) f $ \ex -> do+ catching _UnauthorizedException f $ \ex -> do case options ^. autoSSOOptionL of AutoSSOAlways -> do logWarn $ ssoErrorMessage ex@@ -76,6 +79,6 @@ where ssoErrorMessage ex = "AWS SSO authorization error"- :# [ "message" .= fmap fromErrorMessage (ex ^. serviceMessage)+ :# [ "message" .= formatServiceError ex , "hint" .= ("Run `aws sso login' and try again" :: Text) ]
src/Stackctl/CLI.hs view
@@ -10,9 +10,9 @@ import qualified Blammo.Logging.LogSettings.Env as LoggingEnv import Control.Monad.Catch (MonadCatch) import Control.Monad.Trans.Resource (ResourceT, runResourceT)-import Stackctl.AutoSSO import Stackctl.AWS import Stackctl.AWS.Scope+import Stackctl.AutoSSO import Stackctl.ColorOption import Stackctl.Config import Stackctl.DirectoryOption@@ -28,19 +28,19 @@ } optionsL :: Lens' (App options) options-optionsL = lens appOptions $ \x y -> x { appOptions = y }+optionsL = lens appOptions $ \x y -> x {appOptions = y} instance HasLogger (App options) where- loggerL = lens appLogger $ \x y -> x { appLogger = y }+ loggerL = lens appLogger $ \x y -> x {appLogger = y} instance HasConfig (App options) where- configL = lens appConfig $ \x y -> x { appConfig = y }+ configL = lens appConfig $ \x y -> x {appConfig = y} instance HasAwsScope (App options) where- awsScopeL = lens appAwsScope $ \x y -> x { appAwsScope = y }+ awsScopeL = lens appAwsScope $ \x y -> x {appAwsScope = y} instance HasAwsEnv (App options) where- awsEnvL = lens appAwsEnv $ \x y -> x { appAwsEnv = y }+ awsEnvL = lens appAwsEnv $ \x y -> x {appAwsEnv = y} instance HasDirectoryOption options => HasDirectoryOption (App options) where directoryOptionL = optionsL . directoryOptionL@@ -87,14 +87,16 @@ runAppT options f = do envLogSettings <- liftIO- . LoggingEnv.parseWith- . setLogSettingsConcurrency (Just 1)- $ defaultLogSettings+ . LoggingEnv.parseWith+ . setLogSettingsConcurrency (Just 1)+ $ defaultLogSettings - logger <- newLogger $ adjustLogSettings- (options ^. colorOptionL)- (options ^. verboseOptionL)- envLogSettings+ logger <-+ newLogger+ $ adjustLogSettings+ (options ^. colorOptionL)+ (options ^. verboseOptionL)+ envLogSettings app <- runResourceT $ runLoggerLoggingT logger $ do aws <- runReaderT (handleAutoSSO options awsEnvDiscover) logger
src/Stackctl/ColorOption.hs view
@@ -1,23 +1,25 @@ module Stackctl.ColorOption- ( ColorOption(..)- , HasColorOption(..)+ ( ColorOption (..)+ , HasColorOption (..) , colorOption ) where import Stackctl.Prelude import Blammo.Logging.LogSettings-import Data.Semigroup (Last(..))+import Data.Semigroup (Last (..)) import Options.Applicative newtype ColorOption = ColorOption { unColorOption :: LogColor }- deriving Semigroup via Last ColorOption+ deriving (Semigroup) via Last ColorOption class HasColorOption env where colorOptionL :: Lens' env (Maybe ColorOption) colorOption :: Parser ColorOption-colorOption = option (eitherReader $ fmap ColorOption . readLogColor) $ mconcat- [long "color", help "When to colorize output", metavar "auto|always|never"]+colorOption =+ option (eitherReader $ fmap ColorOption . readLogColor)+ $ mconcat+ [long "color", help "When to colorize output", metavar "auto|always|never"]
src/Stackctl/Colors.hs view
@@ -1,31 +1,5 @@--- | Facilities for colorizing output module Stackctl.Colors- ( Colors(..)- , getColorsStdout- , getColorsLogger- , noColors+ ( module Blammo.Logging.Colors ) where -import Stackctl.Prelude- import Blammo.Logging.Colors-import Blammo.Logging.Logger-import Blammo.Logging.LogSettings (shouldColorHandle)---- | Return 'Colors' based on options and 'stdout'-getColorsStdout :: (MonadIO m, MonadReader env m, HasLogger env) => m Colors-getColorsStdout = getColorsHandle stdout---- | Return 'Colors' based on options given 'Handle'-getColorsHandle- :: (MonadIO m, MonadReader env m, HasLogger env) => Handle -> m Colors-getColorsHandle h = do- ls <- view $ loggerL . to getLoggerLogSettings- getColors <$> shouldColorHandle ls h---- | Return 'Colors' consistent with the ambient 'Logger'-getColorsLogger :: (MonadReader env m, HasLogger env) => m Colors-getColorsLogger = view $ loggerL . to (getColors . getLoggerShouldColor)--noColors :: Colors-noColors = getColors False
src/Stackctl/Commands.hs view
@@ -25,12 +25,13 @@ , HasAutoSSOOption options ) => Subcommand options CatOptions-cat = Subcommand- { name = "cat"- , description = "Pretty-print specifications"- , parse = parseCatOptions- , run = runAppSubcommand runCat- }+cat =+ Subcommand+ { name = "cat"+ , description = "Pretty-print specifications"+ , parse = parseCatOptions+ , run = runAppSubcommand runCat+ } capture :: ( HasColorOption options@@ -39,12 +40,13 @@ , HasAutoSSOOption options ) => Subcommand options CaptureOptions-capture = Subcommand- { name = "capture"- , description = "Capture deployed Stacks as specifications"- , parse = parseCaptureOptions- , run = runAppSubcommand runCapture- }+capture =+ Subcommand+ { name = "capture"+ , description = "Capture deployed Stacks as specifications"+ , parse = parseCaptureOptions+ , run = runAppSubcommand runCapture+ } changes :: ( HasColorOption options@@ -54,12 +56,13 @@ , HasAutoSSOOption options ) => Subcommand options ChangesOptions-changes = Subcommand- { name = "changes"- , description = "Review changes between specification and deployed state"- , parse = parseChangesOptions- , run = runAppSubcommand runChanges- }+changes =+ Subcommand+ { name = "changes"+ , description = "Review changes between specification and deployed state"+ , parse = parseChangesOptions+ , run = runAppSubcommand runChanges+ } deploy :: ( HasColorOption options@@ -69,12 +72,13 @@ , HasAutoSSOOption options ) => Subcommand options DeployOptions-deploy = Subcommand- { name = "deploy"- , description = "Deploy specifications"- , parse = parseDeployOptions- , run = runAppSubcommand runDeploy- }+deploy =+ Subcommand+ { name = "deploy"+ , description = "Deploy specifications"+ , parse = parseDeployOptions+ , run = runAppSubcommand runDeploy+ } list :: ( HasColorOption options@@ -84,17 +88,19 @@ , HasAutoSSOOption options ) => Subcommand options ListOptions-list = Subcommand- { name = "ls"- , description = "List specifications"- , parse = parseListOptions- , run = runAppSubcommand runList- }+list =+ Subcommand+ { name = "ls"+ , description = "List specifications"+ , parse = parseListOptions+ , run = runAppSubcommand runList+ } version :: Subcommand options ()-version = Subcommand- { name = "version"- , description = "Output the version"- , parse = pure ()- , run = \() _ -> logVersion- }+version =+ Subcommand+ { name = "version"+ , description = "Output the version"+ , parse = pure ()+ , run = \() _ -> logVersion+ }
src/Stackctl/Config.hs view
@@ -1,10 +1,10 @@ module Stackctl.Config- ( Config(..)+ ( Config (..) , configParameters , configTags , emptyConfig- , HasConfig(..)- , ConfigError(..)+ , HasConfig (..)+ , ConfigError (..) , loadConfigOrExit , loadConfigFromBytes , applyConfig@@ -25,8 +25,8 @@ { required_version :: Maybe RequiredVersion , defaults :: Maybe Defaults }- deriving stock Generic- deriving anyclass FromJSON+ deriving stock (Generic)+ deriving anyclass (FromJSON) configParameters :: Config -> Maybe ParametersYaml configParameters = parameters <=< defaults@@ -41,8 +41,8 @@ { parameters :: Maybe ParametersYaml , tags :: Maybe TagsYaml }- deriving stock Generic- deriving anyclass FromJSON+ deriving stock (Generic)+ deriving anyclass (FromJSON) class HasConfig env where configL :: Lens' env Config@@ -54,7 +54,7 @@ = ConfigInvalidYaml Yaml.ParseException | ConfigInvalid (NonEmpty Text) | ConfigVersionNotSatisfied RequiredVersion Version- deriving stock Show+ deriving stock (Show) configErrorMessage :: ConfigError -> Message configErrorMessage = \case@@ -73,9 +73,10 @@ exitFailure loadConfig :: MonadIO m => m (Either ConfigError Config)-loadConfig = runExceptT $ getConfigFile >>= \case- Nothing -> pure emptyConfig- Just cf -> loadConfigFrom cf+loadConfig =+ runExceptT $ getConfigFile >>= \case+ Nothing -> pure emptyConfig+ Just cf -> loadConfigFrom cf loadConfigFrom :: (MonadIO m, MonadError ConfigError m) => FilePath -> m Config loadConfigFrom path = loadConfigFromBytes =<< liftIO (readFileBinary path)@@ -91,16 +92,19 @@ $ ConfigVersionNotSatisfied rv Paths.version applyConfig :: Config -> StackSpecYaml -> StackSpecYaml-applyConfig config ss@StackSpecYaml {..} = ss- { ssyParameters = configParameters config <> ssyParameters- , ssyTags = configTags config <> ssyTags- }+applyConfig config ss@StackSpecYaml {..} =+ ss+ { ssyParameters = configParameters config <> ssyParameters+ , ssyTags = configTags config <> ssyTags+ } getConfigFile :: MonadIO m => m (Maybe FilePath)-getConfigFile = listToMaybe <$> filterM- doesFileExist- [ ".stackctl" </> "config" <.> "yaml"- , ".stackctl" </> "config" <.> "yml"- , ".stackctl" <.> "yaml"- , ".stackctl" <.> "yml"- ]+getConfigFile =+ listToMaybe+ <$> filterM+ doesFileExist+ [ ".stackctl" </> "config" <.> "yaml"+ , ".stackctl" </> "config" <.> "yml"+ , ".stackctl" <.> "yaml"+ , ".stackctl" <.> "yml"+ ]
src/Stackctl/Config/RequiredVersion.hs view
@@ -1,11 +1,11 @@ module Stackctl.Config.RequiredVersion- ( RequiredVersion(..)- , RequiredVersionOp(..)+ ( RequiredVersion (..)+ , RequiredVersionOp (..) , requiredVersionToText , requiredVersionFromText , isRequiredVersionSatisfied - -- * Exported for testing+ -- * Exported for testing , (=~) ) where @@ -39,8 +39,10 @@ requiredVersionToText :: RequiredVersion -> Text requiredVersionToText RequiredVersion {..} =- requiredVersionOpToText requiredVersionOp <> " " <> pack- (showVersion requiredVersionCompareWith)+ requiredVersionOpToText requiredVersionOp+ <> " "+ <> pack+ (showVersion requiredVersionCompareWith) requiredVersionFromText :: Text -> Either String RequiredVersion requiredVersionFromText = fromWords . T.words@@ -78,12 +80,14 @@ $ note ("Failed to parse as a version " <> s) $ NE.nonEmpty $ readP_to_S Version.parseVersion s- where s = unpack t+ where+ s = unpack t isRequiredVersionSatisfied :: RequiredVersion -> Version -> Bool isRequiredVersionSatisfied RequiredVersion {..} = (`requiredVersionCompare` requiredVersionCompareWith)- where requiredVersionCompare = requiredVersionOpCompare requiredVersionOp+ where+ requiredVersionCompare = requiredVersionOpCompare requiredVersionOp data RequiredVersionOp = RequiredVersionEQ
src/Stackctl/DirectoryOption.hs view
@@ -1,22 +1,22 @@ module Stackctl.DirectoryOption- ( DirectoryOption(..)+ ( DirectoryOption (..) , defaultDirectoryOption- , HasDirectoryOption(..)+ , HasDirectoryOption (..) , envDirectoryOption , directoryOption ) where import Stackctl.Prelude -import Data.Semigroup (Last(..))+import Data.Semigroup (Last (..)) import qualified Env import Options.Applicative newtype DirectoryOption = DirectoryOption { unDirectoryOption :: FilePath }- deriving newtype IsString- deriving Semigroup via Last DirectoryOption+ deriving newtype (IsString)+ deriving (Semigroup) via Last DirectoryOption defaultDirectoryOption :: DirectoryOption defaultDirectoryOption = "."@@ -28,14 +28,17 @@ directoryOptionL = id envDirectoryOption :: Env.Parser Env.Error DirectoryOption-envDirectoryOption = Env.var (Env.str <=< Env.nonempty) "DIRECTORY"- $ Env.help "Operate on specifications in this directory"+envDirectoryOption =+ Env.var (Env.str <=< Env.nonempty) "DIRECTORY"+ $ Env.help "Operate on specifications in this directory" directoryOption :: Parser DirectoryOption-directoryOption = option str $ mconcat- [ short 'd'- , long "directory"- , metavar "PATH"- , help "Operate on specifications in PATH"- , action "directory"- ]+directoryOption =+ option str+ $ mconcat+ [ short 'd'+ , long "directory"+ , metavar "PATH"+ , help "Operate on specifications in PATH"+ , action "directory"+ ]
src/Stackctl/FilterOption.hs view
@@ -1,7 +1,7 @@ module Stackctl.FilterOption ( FilterOption , defaultFilterOption- , HasFilterOption(..)+ , HasFilterOption (..) , envFilterOption , filterOption , filterOptionFromPaths@@ -13,11 +13,11 @@ import Stackctl.Prelude import qualified Data.List.NonEmpty as NE-import Data.Semigroup (Last(..))+import Data.Semigroup (Last (..)) import qualified Data.Text as T import qualified Env import Options.Applicative-import Stackctl.AWS.CloudFormation (StackName(..))+import Stackctl.AWS.CloudFormation (StackName (..)) import Stackctl.StackSpec import System.FilePath (hasExtension) import System.FilePath.Glob@@ -25,7 +25,7 @@ newtype FilterOption = FilterOption { unFilterOption :: NonEmpty Pattern }- deriving Semigroup via Last FilterOption+ deriving (Semigroup) via Last FilterOption instance ToJSON FilterOption where toJSON = toJSON . showFilterOption@@ -48,11 +48,13 @@ <> " by patterns" filterOption :: String -> Parser FilterOption-filterOption items = option (eitherReader readFilterOption) $ mconcat- [ long "filter"- , metavar "PATTERN[,PATTERN]"- , help $ "Filter " <> items <> " to match PATTERN(s)"- ]+filterOption items =+ option (eitherReader readFilterOption)+ $ mconcat+ [ long "filter"+ , metavar "PATTERN[,PATTERN]"+ , help $ "Filter " <> items <> " to match PATTERN(s)"+ ] filterOptionFromPaths :: NonEmpty FilePath -> FilterOption filterOptionFromPaths = FilterOption . fmap compile@@ -83,7 +85,8 @@ readFilterOption :: String -> Either String FilterOption readFilterOption = note err . filterOptionFromText . pack- where err = "Must be non-empty, comma-separated list of non-empty patterns"+ where+ err = "Must be non-empty, comma-separated list of non-empty patterns" showFilterOption :: FilterOption -> String showFilterOption =@@ -104,8 +107,9 @@ filter $ \spec -> any (`matchStackSpec` spec) $ unFilterOption fo matchStackSpec :: Pattern -> StackSpec -> Bool-matchStackSpec p spec = or- [ match p $ unpack $ unStackName $ stackSpecStackName spec- , match p $ stackSpecStackFile spec- , match p $ stackSpecTemplateFile spec- ]+matchStackSpec p spec =+ or+ [ match p $ unpack $ unStackName $ stackSpecStackName spec+ , match p $ stackSpecStackFile spec+ , match p $ stackSpecTemplateFile spec+ ]
src/Stackctl/Options.hs view
@@ -22,17 +22,17 @@ , oVerbose :: Verbosity , oAutoSSO :: Maybe AutoSSOOption }- deriving stock Generic- deriving Semigroup via GenericSemigroupMonoid Options+ deriving stock (Generic)+ deriving (Semigroup) via GenericSemigroupMonoid Options directoryL :: Lens' Options (Maybe DirectoryOption)-directoryL = lens oDirectory $ \x y -> x { oDirectory = y }+directoryL = lens oDirectory $ \x y -> x {oDirectory = y} filterL :: Lens' Options (Maybe FilterOption)-filterL = lens oFilter $ \x y -> x { oFilter = y }+filterL = lens oFilter $ \x y -> x {oFilter = y} autoSSOL :: Lens' Options (Maybe AutoSSOOption)-autoSSOL = lens oAutoSSO $ \x y -> x { oAutoSSO = y }+autoSSOL = lens oAutoSSO $ \x y -> x {oAutoSSO = y} instance HasDirectoryOption Options where directoryOptionL = directoryL . maybeLens defaultDirectoryOption@@ -41,10 +41,10 @@ filterOptionL = filterL . maybeLens defaultFilterOption instance HasColorOption Options where- colorOptionL = lens oColor $ \x y -> x { oColor = y }+ colorOptionL = lens oColor $ \x y -> x {oColor = y} instance HasVerboseOption Options where- verboseOptionL = lens oVerbose $ \x y -> x { oVerbose = y }+ verboseOptionL = lens oVerbose $ \x y -> x {oVerbose = y} instance HasAutoSSOOption Options where autoSSOOptionL = autoSSOL . maybeLens defaultAutoSSOOption@@ -52,19 +52,22 @@ -- brittany-disable-next-binding envParser :: Env.Parser Env.Error Options-envParser = Env.prefixed "STACKCTL_" $ Options- <$> optional envDirectoryOption- <*> optional (envFilterOption "specifications")- <*> pure mempty -- use LOG_COLOR- <*> pure mempty -- use LOG_LEVEL- <*> optional envAutoSSOOption+envParser =+ Env.prefixed "STACKCTL_"+ $ Options+ <$> optional envDirectoryOption+ <*> optional (envFilterOption "specifications")+ <*> pure mempty -- use LOG_COLOR+ <*> pure mempty -- use LOG_LEVEL+ <*> optional envAutoSSOOption -- brittany-disable-next-binding optionsParser :: Parser Options-optionsParser = Options- <$> optional directoryOption- <*> optional (filterOption "specifications")- <*> optional colorOption- <*> verboseOption- <*> optional autoSSOOption+optionsParser =+ Options+ <$> optional directoryOption+ <*> optional (filterOption "specifications")+ <*> optional colorOption+ <*> verboseOption+ <*> optional autoSSOOption
src/Stackctl/ParameterOption.hs view
@@ -9,12 +9,14 @@ import Stackctl.AWS.CloudFormation (Parameter, makeParameter) parameterOption :: Parser Parameter-parameterOption = option (eitherReader readParameter) $ mconcat- [ short 'p'- , long "parameter"- , metavar "KEY=[VALUE]"- , help "Override the given Parameter for this operation"- ]+parameterOption =+ option (eitherReader readParameter)+ $ mconcat+ [ short 'p'+ , long "parameter"+ , metavar "KEY=[VALUE]"+ , help "Override the given Parameter for this operation"+ ] readParameter :: String -> Either String Parameter readParameter s = case T.breakOn "=" t of@@ -22,4 +24,5 @@ (k, _) | T.null k -> Left $ "Empty key (" <> s <> ")" (k, "=") -> Right $ makeParameter k $ Just "" (k, v) -> Right $ makeParameter k $ Just $ T.drop 1 v- where t = pack s+ where+ t = pack s
src/Stackctl/Prelude.hs view
@@ -5,7 +5,7 @@ ) where import RIO as X hiding- ( LogLevel(..)+ ( LogLevel (..) , LogSource , logDebug , logDebugS@@ -21,10 +21,15 @@ import Blammo.Logging as X import Control.Error.Util as X (hush, note)-import Data.Aeson as X (ToJSON(..), object)+import Data.Aeson as X (ToJSON (..), object) import Data.Text as X (pack, unpack) import System.FilePath as X- (dropExtension, takeBaseName, takeDirectory, (<.>), (</>))+ ( dropExtension+ , takeBaseName+ , takeDirectory+ , (<.>)+ , (</>)+ ) import UnliftIO.Directory as X (withCurrentDirectory) {-# ANN module ("HLint: ignore Avoid restricted alias" :: String) #-}
src/Stackctl/RemovedStack.hs view
@@ -5,7 +5,7 @@ import Stackctl.Prelude import Control.Error.Util (hoistMaybe)-import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Stackctl.AWS.CloudFormation import Stackctl.AWS.Core import Stackctl.AWS.Scope
src/Stackctl/Spec/Capture.hs view
@@ -1,5 +1,5 @@ module Stackctl.Spec.Capture- ( CaptureOptions(..)+ ( CaptureOptions (..) , parseCaptureOptions , runCapture ) where@@ -27,37 +27,51 @@ -- brittany-disable-next-binding parseCaptureOptions :: Parser CaptureOptions-parseCaptureOptions = CaptureOptions- <$> optional (strOption- ( short 'n'- <> long "account-name"- <> metavar "NAME"- <> help "Account name to use in generated files"- ))- <*> optional (strOption- ( short 't'- <> long "template-path"- <> metavar "PATH"- <> help "Write Template to PATH. Default is based on STACK"- ))- <*> optional (strOption- ( short 'p'- <> long "path"- <> metavar "PATH"- <> help "Write specification to PATH. Default is based on STACK"- ))- <*> optional (some (StackName <$> strOption- ( long "depend"- <> metavar "STACK"- <> help "Add a dependency on STACK"- )))- <*> flag TemplateFormatYaml TemplateFormatJson- ( long "no-flip"- <> help "Don't flip JSON templates to Yaml"+parseCaptureOptions =+ CaptureOptions+ <$> optional+ ( strOption+ ( short 'n'+ <> long "account-name"+ <> metavar "NAME"+ <> help "Account name to use in generated files"+ ) )+ <*> optional+ ( strOption+ ( short 't'+ <> long "template-path"+ <> metavar "PATH"+ <> help "Write Template to PATH. Default is based on STACK"+ )+ )+ <*> optional+ ( strOption+ ( short 'p'+ <> long "path"+ <> metavar "PATH"+ <> help "Write specification to PATH. Default is based on STACK"+ )+ )+ <*> optional+ ( some+ ( StackName+ <$> strOption+ ( long "depend"+ <> metavar "STACK"+ <> help "Add a dependency on STACK"+ )+ )+ )+ <*> flag+ TemplateFormatYaml+ TemplateFormatJson+ ( long "no-flip"+ <> help "Don't flip JSON templates to Yaml"+ ) <*> strArgument- ( metavar "STACK"- <> help "Name of deployed Stack to capture"+ ( metavar "STACK"+ <> help "Name of deployed Stack to capture" ) runCapture@@ -76,28 +90,31 @@ runCapture CaptureOptions {..} = do let setScopeName scope =- maybe scope (\name -> scope { awsAccountName = name }) scoAccountName+ maybe scope (\name -> scope {awsAccountName = name}) scoAccountName generate' stack template path templatePath = do let stackName = StackName $ stack ^. stack_stackName templateBody = templateBodyFromValue template - void $ local (awsScopeL %~ setScopeName) $ generate Generate- { gDescription = stackDescription stack- , gDepends = scoDepends- , gActions = Nothing- , gParameters = parameters stack- , gCapabilities = capabilities stack- , gTags = tags stack- , gSpec = case path of- Nothing -> GenerateSpec stackName- Just sp -> GenerateSpecTo stackName sp- , gTemplate = case templatePath of- Nothing -> GenerateTemplate templateBody scoTemplateFormat- Just tp -> GenerateTemplateTo templateBody tp- , gOverwrite = False- }+ void+ $ local (awsScopeL %~ setScopeName)+ $ generate+ Generate+ { gDescription = stackDescription stack+ , gDepends = scoDepends+ , gActions = Nothing+ , gParameters = parameters stack+ , gCapabilities = capabilities stack+ , gTags = tags stack+ , gSpec = case path of+ Nothing -> GenerateSpec stackName+ Just sp -> GenerateSpecTo stackName sp+ , gTemplate = case templatePath of+ Nothing -> GenerateTemplate templateBody scoTemplateFormat+ Just tp -> GenerateTemplateTo templateBody tp+ , gOverwrite = False+ } results <- awsCloudFormationGetStackNamesMatching scoStackName @@ -108,7 +125,6 @@ <> pack (decompile scoStackName) :# [] exitFailure- [stackName] -> do stack <- awsCloudFormationDescribeStack stackName template <- awsCloudFormationGetTemplate stackName
src/Stackctl/Spec/Cat.hs view
@@ -1,5 +1,5 @@ module Stackctl.Spec.Cat- ( CatOptions(..)+ ( CatOptions (..) , parseCatOptions , runCat ) where@@ -21,7 +21,7 @@ import Stackctl.AWS.Scope import Stackctl.Colors import Stackctl.Config (HasConfig)-import Stackctl.DirectoryOption (HasDirectoryOption(..), unDirectoryOption)+import Stackctl.DirectoryOption (HasDirectoryOption (..), unDirectoryOption) import Stackctl.FilterOption (HasFilterOption) import Stackctl.Spec.Discover import Stackctl.StackSpec@@ -37,20 +37,21 @@ -- brittany-disable-next-binding parseCatOptions :: Parser CatOptions-parseCatOptions = CatOptions- <$> switch- ( long "no-stacks"- <> help "Only show templates/"- )- <*> switch- ( long "no-templates"- <> help "Only show stacks/"- )- <*> switch- ( short 'b'- <> long "brief"- <> help "Don't show file contents, only paths"- )+parseCatOptions =+ CatOptions+ <$> switch+ ( long "no-stacks"+ <> help "Only show templates/"+ )+ <*> switch+ ( long "no-templates"+ <> help "Only show stacks/"+ )+ <*> switch+ ( short 'b'+ <> long "brief"+ <> help "Don't show file contents, only paths"+ ) runCat :: ( MonadMask m@@ -114,21 +115,23 @@ groupRegion = groupTo (stackSpecPathRegion . stackSpecSpecPath) groupAccount :: [StackSpec] -> [((AccountId, Text), [StackSpec])]- groupAccount = groupTo- ((stackSpecPathAccountId &&& stackSpecPathAccountName) . stackSpecSpecPath)+ groupAccount =+ groupTo+ ((stackSpecPathAccountId &&& stackSpecPathAccountName) . stackSpecSpecPath) groupTo :: Ord b => (a -> b) -> [a] -> [(b, [a])] groupTo f = map (f . NE.head &&& NE.toList) . NE.groupAllWith f prettyPrintStackSpecYaml :: Colors -> StackName -> StackSpecYaml -> [Text]-prettyPrintStackSpecYaml Colors {..} name StackSpecYaml {..} = concat- [ [cyan "Name" <> ": " <> green (unStackName name)]- , maybe [] ppDescription ssyDescription- , [cyan "Template" <> ": " <> green (pack ssyTemplate)]- , ppObject "Parameters" parametersYamlKVs ssyParameters- , ppList "Capabilities" ppCapabilities ssyCapabilities- , ppObject "Tags" tagsYamlKVs ssyTags- ]+prettyPrintStackSpecYaml Colors {..} name StackSpecYaml {..} =+ concat+ [ [cyan "Name" <> ": " <> green (unStackName name)]+ , maybe [] ppDescription ssyDescription+ , [cyan "Template" <> ": " <> green (pack ssyTemplate)]+ , ppObject "Parameters" parametersYamlKVs ssyParameters+ , ppList "Capabilities" ppCapabilities ssyCapabilities+ , ppObject "Tags" tagsYamlKVs ssyTags+ ] where ppObject :: Text -> (a -> [(Text, Maybe Text)]) -> Maybe a -> [Text] ppObject label f mA = fromMaybe [] $ do@@ -136,10 +139,10 @@ pure $ [cyan label <> ":"] <> map- (\(k, mV) ->- " " <> cyan k <> ":" <> maybe "" (\v -> " " <> green v) mV- )- kvs+ ( \(k, mV) ->+ " " <> cyan k <> ":" <> maybe "" (\v -> " " <> green v) mV+ )+ kvs ppList :: Text -> (a -> [Text]) -> Maybe a -> [Text] ppList label f = maybe [] (((cyan label <> ":") :) . f)@@ -152,9 +155,13 @@ parametersYamlKVs = mapMaybe parameterYamlKV . unParametersYaml parameterYamlKV :: ParameterYaml -> Maybe (Text, Maybe Text)-parameterYamlKV py = (,) <$> (p ^. parameter_parameterKey) <*> pure- (p ^. parameter_parameterValue)- where p = unParameterYaml py+parameterYamlKV py =+ (,)+ <$> (p ^. parameter_parameterKey)+ <*> pure+ (p ^. parameter_parameterValue)+ where+ p = unParameterYaml py tagsYamlKVs :: TagsYaml -> [(Text, Maybe Text)] tagsYamlKVs = map (tagKV . unTagYaml) . unTagsYaml@@ -163,12 +170,13 @@ tagKV tg = (tg ^. tag_key, tg ^. tag_value . to Just) prettyPrintTemplate :: Colors -> Value -> [Text]-prettyPrintTemplate Colors {..} val = concat- [ displayTextProperty "Description"- , displayObjectProperty "Parameters"- , displayObjectProperty "Resources"- , displayObjectProperty "Outputs"- ]+prettyPrintTemplate Colors {..} val =+ concat+ [ displayTextProperty "Description"+ , displayObjectProperty "Parameters"+ , displayObjectProperty "Resources"+ , displayObjectProperty "Outputs"+ ] where displayTextProperty :: Text -> [Text] displayTextProperty = displayPropertyWith@@ -184,7 +192,8 @@ displayPropertyWith :: (FromJSON a, ToJSON a) => (a -> [Text]) -> Text -> [Text] displayPropertyWith f k = cyan k <> ": " : fromMaybe [] displayValue- where displayValue = val ^? key (Key.fromText k) . _JSON . to f+ where+ displayValue = val ^? key (Key.fromText k) . _JSON . to f putBoxed :: MonadIO m => Int -> [Text] -> m () putBoxed n xs = do@@ -194,4 +203,5 @@ put :: MonadIO m => Int -> Text -> m () put n = liftIO . T.putStrLn . (indent <>)- where indent = mconcat $ replicate n " "+ where+ indent = mconcat $ replicate n " "
src/Stackctl/Spec/Changes.hs view
@@ -1,5 +1,5 @@ module Stackctl.Spec.Changes- ( ChangesOptions(..)+ ( ChangesOptions (..) , parseChangesOptions , runChanges ) where@@ -34,16 +34,20 @@ -- brittany-disable-next-binding parseChangesOptions :: Parser ChangesOptions-parseChangesOptions = ChangesOptions- <$> formatOption- <*> omitFullOption- <*> many parameterOption- <*> many tagOption- <*> optional (argument str- ( metavar "PATH"- <> help "Write changes summary to PATH"- <> action "file"- ))+parseChangesOptions =+ ChangesOptions+ <$> formatOption+ <*> omitFullOption+ <*> many parameterOption+ <*> many tagOption+ <*> optional+ ( argument+ str+ ( metavar "PATH"+ <> help "Write changes summary to PATH"+ <> action "file"+ )+ ) runChanges :: ( MonadMask m@@ -66,12 +70,11 @@ colors <- case scoOutput of Nothing -> getColorsLogger- Just{} -> pure noColors+ Just {} -> pure noColors - let- write formatted = case scoOutput of- Nothing -> pushLoggerLn formatted- Just p -> liftIO $ T.appendFile p $ formatted <> "\n"+ let write formatted = case scoOutput of+ Nothing -> pushLoggerLn formatted+ Just p -> liftIO $ T.appendFile p $ formatted <> "\n" specs <- discoverSpecs
src/Stackctl/Spec/Changes/Format.hs view
@@ -1,7 +1,7 @@ module Stackctl.Spec.Changes.Format- ( Format(..)+ ( Format (..) , formatOption- , OmitFull(..)+ , OmitFull (..) , omitFullOption , formatChangeSet , formatRemovedStack@@ -25,13 +25,15 @@ | IncludeFull formatOption :: Parser Format-formatOption = option (eitherReader readFormat) $ mconcat- [ short 'f'- , long "format"- , help "Format to output changes in"- , value FormatTTY- , showDefaultWith showFormat- ]+formatOption =+ option (eitherReader readFormat)+ $ mconcat+ [ short 'f'+ , long "format"+ , help "Format to output changes in"+ , value FormatTTY+ , showDefaultWith showFormat+ ] readFormat :: String -> Either String Format readFormat = \case@@ -47,10 +49,13 @@ -- brittany-disable-next-binding omitFullOption :: Parser OmitFull-omitFullOption = flag IncludeFull OmitFull- ( long "no-include-full"- <> help "Don't include full ChangeSet JSON details"- )+omitFullOption =+ flag+ IncludeFull+ OmitFull+ ( long "no-include-full"+ <> help "Don't include full ChangeSet JSON details"+ ) formatChangeSet :: Colors -> OmitFull -> Text -> Format -> Maybe ChangeSet -> Text@@ -62,16 +67,18 @@ formatRemovedStack Colors {..} format stack = case format of FormatTTY -> red "DELETE" <> " stack " <> cyan name FormatPullRequest -> ":x: This PR will **delete** the stack `" <> name <> "`"- where name = stack ^. stack_stackName+ where+ name = stack ^. stack_stackName formatTTY :: Colors -> Text -> Maybe ChangeSet -> Text formatTTY colors@Colors {..} name mChangeSet = case (mChangeSet, rChanges) of (Nothing, _) -> "No changes for " <> name (_, Nothing) -> "Metadata only changes (e.g. Tags or Outputs)" (_, Just rcs) ->- ("\n" <>) $ (<> "\n") $ mconcat $ ("Changes for " <> cyan name <> ":") : map- (("\n " <>) . formatResourceChange)- (NE.toList rcs)+ ("\n" <>) $ (<> "\n") $ mconcat $ ("Changes for " <> cyan name <> ":")+ : map+ (("\n " <>) . formatResourceChange)+ (NE.toList rcs) where rChanges = do cs <- mChangeSet@@ -143,31 +150,32 @@ ] <> map commentTableRow (NE.toList rcs) <> case omitFull of- OmitFull -> []- IncludeFull ->- [ "\n"- , "\n<details>"- , "\n<summary>Full changes</summary>"- , "\n"- , "\n```json"- , "\n" <> changeSetJSON cs- , "\n```"- , "\n"- , "\n</details>"- ]+ OmitFull -> []+ IncludeFull ->+ [ "\n"+ , "\n<details>"+ , "\n<summary>Full changes</summary>"+ , "\n"+ , "\n```json"+ , "\n" <> changeSetJSON cs+ , "\n```"+ , "\n"+ , "\n</details>"+ ] commentTableRow :: ResourceChange -> Text-commentTableRow ResourceChange' {..} = mconcat- [ "\n"- , "| " <> maybe "" toText action <> " "- , "| " <> maybe "" toText logicalResourceId <> " "- , "| " <> maybe "" toText physicalResourceId <> " "- , "| " <> maybe "" toText resourceType <> " "- , "| " <> maybe "" toText replacement <> " "- , "| " <> maybe "" (T.intercalate ", " . map toText) scope <> " "- , "| " <> maybe "" (mdList . mapMaybe (formatDetail noColors)) details <> " "- , "|"- ]+commentTableRow ResourceChange' {..} =+ mconcat+ [ "\n"+ , "| " <> maybe "" toText action <> " "+ , "| " <> maybe "" toText logicalResourceId <> " "+ , "| " <> maybe "" toText physicalResourceId <> " "+ , "| " <> maybe "" toText resourceType <> " "+ , "| " <> maybe "" toText replacement <> " "+ , "| " <> maybe "" (T.intercalate ", " . map toText) scope <> " "+ , "| " <> maybe "" (mdList . mapMaybe (formatDetail noColors)) details <> " "+ , "|"+ ] mdList :: [Text] -> Text mdList xs =
src/Stackctl/Spec/Deploy.hs view
@@ -1,6 +1,6 @@ module Stackctl.Spec.Deploy- ( DeployOptions(..)- , DeployConfirmation(..)+ ( DeployOptions (..)+ , DeployConfirmation (..) , parseDeployOptions , runDeploy ) where@@ -11,9 +11,9 @@ import qualified Data.Text as T import Data.Time (defaultTimeLocale, formatTime, utcToLocalZonedTime) import Options.Applicative-import Stackctl.Action import Stackctl.AWS hiding (action) import Stackctl.AWS.Scope+import Stackctl.Action import Stackctl.Colors import Stackctl.Config (HasConfig) import Stackctl.DirectoryOption (HasDirectoryOption)@@ -39,27 +39,34 @@ -- brittany-disable-next-binding parseDeployOptions :: Parser DeployOptions-parseDeployOptions = DeployOptions- <$> many parameterOption- <*> many tagOption- <*> optional (strOption- ( long "save-change-sets"- <> metavar "DIRECTORY"- <> help "Save executed changesets to DIRECTORY"- <> action "directory"- ))- <*> flag DeployWithConfirmation DeployWithoutConfirmation- ( long "no-confirm"- <> help "Don't confirm changes before executing"- )- <*> (not <$> switch- ( long "no-remove"- <> help "Don't delete removed Stacks"- ))- <*> switch- ( long "clean"- <> help "Remove all changesets from Stack after deploy"- )+parseDeployOptions =+ DeployOptions+ <$> many parameterOption+ <*> many tagOption+ <*> optional+ ( strOption+ ( long "save-change-sets"+ <> metavar "DIRECTORY"+ <> help "Save executed changesets to DIRECTORY"+ <> action "directory"+ )+ )+ <*> flag+ DeployWithConfirmation+ DeployWithoutConfirmation+ ( long "no-confirm"+ <> help "Don't confirm changes before executing"+ )+ <*> ( not+ <$> switch+ ( long "no-remove"+ <> help "Don't delete removed Stacks"+ )+ )+ <*> switch+ ( long "clean"+ <> help "Remove all changesets from Stack after deploy"+ ) runDeploy :: ( MonadMask m@@ -77,6 +84,10 @@ => DeployOptions -> m () runDeploy DeployOptions {..} = do+ when sdoRemovals $ do+ removed <- inferRemovedStacks+ traverse_ (deleteRemovedStack sdoDeployConfirmation) removed+ specs <- discoverSpecs for_ specs $ \spec -> do@@ -104,10 +115,6 @@ runActions stackName PostDeploy $ stackSpecActions spec when sdoClean $ awsCloudFormationDeleteAllChangeSets stackName - when sdoRemovals $ do- removed <- inferRemovedStacks- traverse_ (deleteRemovedStack sdoDeployConfirmation) removed- deleteRemovedStack :: ( MonadMask m , MonadResource m@@ -131,12 +138,13 @@ DeployWithoutConfirmation -> pure () deleteStack stackName- where stackName = StackName $ stack ^. stack_stackName+ where+ stackName = StackName $ stack ^. stack_stackName data DeployConfirmation = DeployWithConfirmation | DeployWithoutConfirmation- deriving stock Eq+ deriving stock (Eq) checkIfStackRequiresDeletion :: ( MonadUnliftIO m@@ -156,7 +164,7 @@ logWarn $ "Stack must be deleted before proceeding" :# ["status" .= status] when (status == StackStatus_ROLLBACK_FAILED) $ logWarn- "Stack is in ROLLBACK_FAILED. This may require elevated permissions for the delete to succeed"+ "Stack is in ROLLBACK_FAILED. This may require elevated permissions for the delete to succeed" case confirmation of DeployWithConfirmation -> promptContinue@@ -176,7 +184,7 @@ case result of StackDeleteSuccess -> logInfo $ prettyStackDeleteResult result :# []- StackDeleteFailure{} -> logWarn $ prettyStackDeleteResult result :# []+ StackDeleteFailure {} -> logWarn $ prettyStackDeleteResult result :# [] deployChangeSet :: ( MonadUnliftIO m@@ -218,9 +226,9 @@ case result of StackCreateSuccess -> onSuccess- StackCreateFailure{} -> onFailure+ StackCreateFailure {} -> onFailure StackUpdateSuccess -> onSuccess- StackUpdateFailure{} -> onFailure+ StackUpdateFailure {} -> onFailure where stackName = csStackName changeSet changeSetId = csChangeSetId changeSet@@ -233,7 +241,8 @@ , HasAwsEnv env ) => StackName- -> Maybe Text -- ^ StackEventId+ -> Maybe Text+ -- ^ StackEventId -> m a tailStackEventsSince stackName mLastId = do colors <- getColorsLogger@@ -251,18 +260,21 @@ formatStackEvent :: MonadIO m => Colors -> StackEvent -> m Text formatStackEvent Colors {..} e = do timestamp <-- liftIO $ formatTime defaultTimeLocale "%F %T %Z" <$> utcToLocalZonedTime- (e ^. stackEvent_timestamp)+ liftIO+ $ formatTime defaultTimeLocale "%F %T %Z"+ <$> utcToLocalZonedTime+ (e ^. stackEvent_timestamp) - pure $ mconcat- [ fromString timestamp- , " | "- , maybe "" colorStatus $ e ^. stackEvent_resourceStatus- , maybe "" (magenta . (" " <>)) $ e ^. stackEvent_logicalResourceId- , maybe "" ((\x -> " (" <> x <> ")") . T.strip)- $ e- ^. stackEvent_resourceStatusReason- ]+ pure+ $ mconcat+ [ fromString timestamp+ , " | "+ , maybe "" colorStatus $ e ^. stackEvent_resourceStatus+ , maybe "" (magenta . (" " <>)) $ e ^. stackEvent_logicalResourceId+ , maybe "" ((\x -> " (" <> x <> ")") . T.strip)+ $ e+ ^. stackEvent_resourceStatusReason+ ] where colorStatus = \case ResourceStatus' x
src/Stackctl/Spec/Discover.hs view
@@ -10,8 +10,8 @@ import Stackctl.AWS import Stackctl.AWS.Scope import Stackctl.Config (HasConfig)-import Stackctl.DirectoryOption (HasDirectoryOption(..), unDirectoryOption)-import Stackctl.FilterOption (HasFilterOption(..), filterStackSpecs)+import Stackctl.DirectoryOption (HasDirectoryOption (..), unDirectoryOption)+import Stackctl.FilterOption (HasFilterOption (..), filterStackSpecs) import Stackctl.StackSpec import Stackctl.StackSpecPath import System.FilePath (isPathSeparator)@@ -51,8 +51,8 @@ specs <- sortStackSpecs- . filterStackSpecs filterOption- <$> traverse (readStackSpec dir) specPaths+ . filterStackSpecs filterOption+ <$> traverse (readStackSpec dir) specPaths when (null specs) $ logWarn "No specs found" specs <$ logDebug ("Discovered specs" :# ["matched" .= length specs])
src/Stackctl/Spec/Generate.hs view
@@ -1,16 +1,16 @@ module Stackctl.Spec.Generate- ( Generate(..)- , GenerateSpec(..)- , GenerateTemplate(..)+ ( Generate (..)+ , GenerateSpec (..)+ , GenerateTemplate (..) , generate- , TemplateFormat(..)+ , TemplateFormat (..) ) where import Stackctl.Prelude -import Stackctl.Action import Stackctl.AWS import Stackctl.AWS.Scope+import Stackctl.Action import Stackctl.Config (HasConfig) import Stackctl.DirectoryOption import Stackctl.Spec.Discover (buildSpecPath)@@ -31,18 +31,18 @@ } data GenerateSpec- = GenerateSpec StackName- -- ^ Generate at an inferred name- | GenerateSpecTo StackName FilePath- -- ^ Generate to a given path+ = -- | Generate at an inferred name+ GenerateSpec StackName+ | -- | Generate to a given path+ GenerateSpecTo StackName FilePath data GenerateTemplate- = GenerateTemplate TemplateBody TemplateFormat- -- ^ Generate at an inferred name- | GenerateTemplateTo TemplateBody FilePath- -- ^ Generate to the given path- | UseExistingTemplate FilePath- -- ^ Assume template exists+ = -- | Generate at an inferred name+ GenerateTemplate TemplateBody TemplateFormat+ | -- | Generate to the given path+ GenerateTemplateTo TemplateBody FilePath+ | -- | Assume template exists+ UseExistingTemplate FilePath data TemplateFormat = TemplateFormatYaml@@ -69,21 +69,22 @@ GenerateTemplate body format -> ( Just body , case format of- TemplateFormatYaml -> unpack (unStackName stackName) <> ".yaml"- TemplateFormatJson -> unpack (unStackName stackName) <> ".json"+ TemplateFormatYaml -> unpack (unStackName stackName) <> ".yaml"+ TemplateFormatJson -> unpack (unStackName stackName) <> ".json" ) GenerateTemplateTo body path -> (Just body, path) UseExistingTemplate path -> (Nothing, path) - specYaml = StackSpecYaml- { ssyDescription = gDescription- , ssyTemplate = templatePath- , ssyDepends = gDepends- , ssyActions = gActions- , ssyParameters = parametersYaml . mapMaybe parameterYaml <$> gParameters- , ssyCapabilities = gCapabilities- , ssyTags = tagsYaml . map TagYaml <$> gTags- }+ specYaml =+ StackSpecYaml+ { ssyDescription = gDescription+ , ssyTemplate = templatePath+ , ssyDepends = gDepends+ , ssyActions = gActions+ , ssyParameters = parametersYaml . mapMaybe parameterYaml <$> gParameters+ , ssyCapabilities = gCapabilities+ , ssyTags = tagsYaml . map TagYaml <$> gTags+ } dir <- view $ directoryOptionL . to unDirectoryOption specPath <- buildSpecPath stackName stackPath
src/Stackctl/Spec/List.hs view
@@ -1,5 +1,5 @@ module Stackctl.Spec.List- ( ListOptions(..)+ ( ListOptions (..) , parseListOptions , runList ) where@@ -12,7 +12,7 @@ import Stackctl.AWS.Scope import Stackctl.Colors import Stackctl.Config (HasConfig)-import Stackctl.DirectoryOption (HasDirectoryOption(..))+import Stackctl.DirectoryOption (HasDirectoryOption (..)) import Stackctl.FilterOption (HasFilterOption) import Stackctl.Spec.Discover import Stackctl.StackSpec
src/Stackctl/StackDescription.hs view
@@ -1,12 +1,12 @@ module Stackctl.StackDescription- ( StackDescription(..)+ ( StackDescription (..) , addStackDescription ) where import Stackctl.Prelude import Control.Lens ((?~))-import Data.Aeson (FromJSON, Value(..))+import Data.Aeson (FromJSON, Value (..)) import qualified Data.Aeson as JSON import Data.Aeson.Lens import Data.ByteString.Char8 as BS8@@ -28,13 +28,15 @@ decodeUtf8 <$> case bc of BodyContentJSON v -> updateJSON d bs <$ guard (not $ hasDescription v) BodyContentYaml v -> updateYaml d bs <$ guard (not $ hasDescription v)- where bs = encodeUtf8 body+ where+ bs = encodeUtf8 body getBodyContent :: ByteString -> Maybe BodyContent-getBodyContent body = asum- [ BodyContentJSON . Object <$> JSON.decodeStrict body- , hush $ BodyContentYaml . Object <$> Yaml.decodeEither' body- ]+getBodyContent body =+ asum+ [ BodyContentJSON . Object <$> JSON.decodeStrict body+ , hush $ BodyContentYaml . Object <$> Yaml.decodeEither' body+ ] -- Inserting a key is easy to do in Yaml without the parsing round-trip that -- would strip formatting and comments. But updating a key is hard. To avoid
src/Stackctl/StackSpec.hs view
@@ -27,14 +27,14 @@ import qualified Data.ByteString.Lazy as BSL import Data.List.Extra (nubOrdOn) import qualified Data.Yaml as Yaml-import Stackctl.Action import Stackctl.AWS-import Stackctl.Config (HasConfig(..), applyConfig)+import Stackctl.Action+import Stackctl.Config (HasConfig (..), applyConfig) import Stackctl.Sort import Stackctl.StackSpecPath import Stackctl.StackSpecYaml-import qualified System.FilePath as FilePath import System.FilePath (takeExtension)+import qualified System.FilePath as FilePath import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist) data StackSpec = StackSpec@@ -101,11 +101,12 @@ -> m StackSpec buildStackSpec dir specPath specBody = do config <- view configL- pure StackSpec- { ssSpecRoot = dir- , ssSpecPath = specPath- , ssSpecBody = applyConfig config specBody- }+ pure+ StackSpec+ { ssSpecRoot = dir+ , ssSpecPath = specPath+ , ssSpecBody = applyConfig config specBody+ } data TemplateBody = TemplateText Text@@ -114,7 +115,7 @@ newtype UnexpectedTemplateJson = UnexpectedTemplateJson { _unexpectedTemplateJsonExtension :: String }- deriving stock Show+ deriving stock (Show) instance Exception UnexpectedTemplateJson where displayException (UnexpectedTemplateJson ext) =@@ -192,14 +193,15 @@ -> [Parameter] -> [Tag] -> m (Either Text (Maybe ChangeSet))-createChangeSet spec parameters tags = awsCloudFormationCreateChangeSet- (stackSpecStackName spec)- (stackSpecStackDescription spec)- (stackSpecTemplate spec)- (nubOrdOn (^. parameter_parameterKey) $ parameters <> stackSpecParameters spec- )- (stackSpecCapabilities spec)- (nubOrdOn (^. tag_key) $ tags <> stackSpecTags spec)+createChangeSet spec parameters tags =+ awsCloudFormationCreateChangeSet+ (stackSpecStackName spec)+ (stackSpecStackDescription spec)+ (stackSpecTemplate spec)+ ( nubOrdOn (^. parameter_parameterKey) $ parameters <> stackSpecParameters spec+ )+ (stackSpecCapabilities spec)+ (nubOrdOn (^. tag_key) $ tags <> stackSpecTags spec) sortStackSpecs :: [StackSpec] -> [StackSpec] sortStackSpecs = sortByDependencies stackSpecStackName stackSpecDepends
src/Stackctl/StackSpecPath.hs view
@@ -3,7 +3,7 @@ module Stackctl.StackSpecPath ( StackSpecPath - -- * Fields+ -- * Fields , stackSpecPathAccountId , stackSpecPathAccountName , stackSpecPathRegion@@ -11,7 +11,7 @@ , stackSpecPathBasePath , stackSpecPathFilePath - -- * Construction+ -- * Construction , stackSpecPath , stackSpecPathFromFilePath ) where@@ -33,12 +33,13 @@ deriving stock (Eq, Show) stackSpecPath :: AwsScope -> StackName -> FilePath -> StackSpecPath-stackSpecPath sspAwsScope@AwsScope {..} sspStackName sspPath = StackSpecPath- { sspAwsScope- , sspAccountPathPart- , sspStackName- , sspPath- }+stackSpecPath sspAwsScope@AwsScope {..} sspStackName sspPath =+ StackSpecPath+ { sspAwsScope+ , sspAccountPathPart+ , sspStackName+ , sspPath+ } where sspAccountPathPart = unpack $ unAccountId awsAccountId <> "." <> awsAccountName@@ -71,7 +72,8 @@ stackSpecPathFromFilePath :: AwsScope- -> FilePath -- ^ Must be relative, @stacks/@+ -> FilePath+ -- ^ Must be relative, @stacks/@ -> Either String StackSpecPath stackSpecPathFromFilePath awsScope@AwsScope {..} path = case splitDirectories path of@@ -94,17 +96,17 @@ stackName <- maybe (Left "Must end in .yaml") (Right . StackName)- $ T.stripSuffix ".yaml"- $ T.intercalate "-"- $ map pack rest-- Right $ StackSpecPath- { sspAwsScope = awsScope { awsAccountName = accountName }- , sspAccountPathPart = pathAccount- , sspStackName = stackName- , sspPath = joinPath rest- }+ $ T.stripSuffix ".yaml"+ $ T.intercalate "-"+ $ map pack rest + Right+ $ StackSpecPath+ { sspAwsScope = awsScope {awsAccountName = accountName}+ , sspAccountPathPart = pathAccount+ , sspStackName = stackName+ , sspPath = joinPath rest+ } _ -> Left $ "Path is not stacks/././.: " <> path -- | Handle @{account-name}.{account-id}@ or @{account-id}.{account-name}@@@ -116,4 +118,5 @@ Left $ "Path matches neither {account-id}.{account-name}, nor {account-name}.{account-id}: " <> path- where isAccountId x = T.length x == 12 && T.all isDigit x+ where+ isAccountId x = T.length x == 12 && T.all isDigit x
src/Stackctl/StackSpecYaml.hs view
@@ -17,9 +17,8 @@ -- - Key: <string> -- Value: <string> -- @--- module Stackctl.StackSpecYaml- ( StackSpecYaml(..)+ ( StackSpecYaml (..) , ParametersYaml , parametersYaml , unParametersYaml@@ -29,7 +28,7 @@ , TagsYaml , tagsYaml , unTagsYaml- , TagYaml(..)+ , TagYaml (..) ) where import Stackctl.Prelude@@ -40,10 +39,10 @@ import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (typeMismatch) import qualified Data.HashMap.Strict as HashMap-import Data.Monoid (Last(..))+import Data.Monoid (Last (..)) import qualified Data.Text as T-import Stackctl.Action import Stackctl.AWS+import Stackctl.Action data StackSpecYaml = StackSpecYaml { ssyDescription :: Maybe StackDescription@@ -86,7 +85,7 @@ -- error messages will include "Parameters.{k}". See specs for an example. let parseKey k = ParameterYaml k <$> o .: k ParametersYaml <$> traverse parseKey (KeyMap.keys o)- v@Array{} -> ParametersYaml <$> parseJSON v+ v@Array {} -> ParametersYaml <$> parseJSON v v -> typeMismatch err v where err =@@ -164,14 +163,14 @@ instance FromJSON TagsYaml where parseJSON = \case Object o -> do- let- parseKey k = do- t <- newTag (Key.toText k) <$> o .: k- pure $ TagYaml t+ let parseKey k = do+ t <- newTag (Key.toText k) <$> o .: k+ pure $ TagYaml t TagsYaml <$> traverse parseKey (KeyMap.keys o)- v@Array{} -> TagsYaml <$> parseJSON v+ v@Array {} -> TagsYaml <$> parseJSON v v -> typeMismatch err v- where err = "Object or list of {Key, Value} Objects"+ where+ err = "Object or list of {Key, Value} Objects" instance ToJSON TagsYaml where toJSON = object . tagsYamlPairs
src/Stackctl/Subcommand.hs view
@@ -1,5 +1,5 @@ module Stackctl.Subcommand- ( Subcommand(..)+ ( Subcommand (..) , subcommand , runSubcommand , runSubcommand'@@ -10,6 +10,7 @@ import qualified Env import Options.Applicative+import Stackctl.AWS (handlingServiceError) import Stackctl.AutoSSO import Stackctl.CLI import Stackctl.ColorOption@@ -42,12 +43,14 @@ -> Mod CommandFields (options -> IO a) -> IO a runSubcommand' title parseEnv parseCLI sp = do- (options, act) <- applyEnv- <$> Env.parse (Env.header $ unpack title) parseEnv- <*> execParser (withInfo title $ (,) <$> parseCLI <*> subparser sp)+ (options, act) <-+ applyEnv+ <$> Env.parse (Env.header $ unpack title) parseEnv+ <*> execParser (withInfo title $ (,) <$> parseCLI <*> subparser sp) act options- where applyEnv env = first (env <>)+ where+ applyEnv env = first (env <>) -- | Use this in the 'run' member of a 'Subcommand' that wants 'AppT' --@@ -60,7 +63,6 @@ -- runFoo :: (MonadReader env m, HasAws env) => FooOptions -> m () -- runFoo = undefined -- @--- runAppSubcommand :: ( HasColorOption options , HasVerboseOption options@@ -70,7 +72,10 @@ -> subOptions -> options -> IO a-runAppSubcommand f subOptions options = runAppT options $ f subOptions+runAppSubcommand f subOptions options =+ runAppT options+ $ handlingServiceError+ $ f subOptions withInfo :: Text -> Parser a -> ParserInfo a withInfo d p = info (p <**> helper) $ progDesc (unpack d) <> fullDesc
src/Stackctl/TagOption.hs view
@@ -9,12 +9,14 @@ import Stackctl.AWS.CloudFormation (Tag, newTag) tagOption :: Parser Tag-tagOption = option (eitherReader readTag) $ mconcat- [ short 't'- , long "tag"- , metavar "KEY=[VALUE]"- , help "Override the given Tag for this operation"- ]+tagOption =+ option (eitherReader readTag)+ $ mconcat+ [ short 't'+ , long "tag"+ , metavar "KEY=[VALUE]"+ , help "Override the given Tag for this operation"+ ] readTag :: String -> Either String Tag readTag s = case T.breakOn "=" t of@@ -22,4 +24,5 @@ (k, _) | T.null k -> Left $ "Empty key (" <> s <> ")" (k, "=") -> Right $ newTag k "" (k, v) -> Right $ newTag k $ T.drop 1 v- where t = pack s+ where+ t = pack s
src/Stackctl/VerboseOption.hs view
@@ -1,7 +1,7 @@ module Stackctl.VerboseOption ( Verbosity , verbositySetLogLevels- , HasVerboseOption(..)+ , HasVerboseOption (..) , verboseOption ) where @@ -31,8 +31,12 @@ verboseOptionL = id verboseOption :: Parser Verbosity-verboseOption = fmap Verbosity $ many $ flag' () $ mconcat- [ short 'v'- , long "verbose"- , help "Increase verbosity (can be passed multiple times)"- ]+verboseOption =+ fmap Verbosity+ $ many+ $ flag' ()+ $ mconcat+ [ short 'v'+ , long "verbose"+ , help "Increase verbosity (can be passed multiple times)"+ ]
− src/UnliftIO/Exception/Lens.hs
@@ -1,33 +0,0 @@--- | A copy of "Control.Exception.Lens" on 'MonadUnliftIO'------ And only the parts we use in this code-base----module UnliftIO.Exception.Lens- ( handling_- , trying- ) where--import Prelude--import Control.Lens (Getting, preview)-import Control.Monad.IO.Unlift (MonadUnliftIO)-import Data.Monoid (First)-import UnliftIO.Exception (SomeException, catchJust, tryJust)--catching_- :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m r -> m r-catching_ l a b = catchJust (preview l) a (const b)-{-# INLINE catching_ #-}--handling_- :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m r -> m r-handling_ l = flip (catching_ l)-{-# INLINE handling_ #-}--trying- :: MonadUnliftIO m- => Getting (First a) SomeException a- -> m r- -> m (Either a r)-trying l = tryJust (preview l)-{-# INLINE trying #-}
stackctl.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: stackctl-version: 1.4.2.1+version: 1.4.2.2 license: MIT license-file: LICENSE copyright: 2022 Renaissance Learning Inc@@ -60,7 +60,6 @@ Stackctl.TagOption Stackctl.VerboseOption Stackctl.Version- UnliftIO.Exception.Lens hs-source-dirs: src other-modules: Paths_stackctl@@ -82,19 +81,19 @@ -Wno-unsafe -optP-Wno-nonportable-include-path build-depends:- Blammo >=1.1.1.1,+ Blammo >=1.1.2.1, Glob, QuickCheck, aeson, aeson-casing, aeson-pretty,- amazonka,- amazonka-cloudformation,- amazonka-core,- amazonka-ec2,- amazonka-lambda,- amazonka-sso,- amazonka-sts,+ amazonka >=2.0,+ amazonka-cloudformation >=2.0,+ amazonka-core >=2.0,+ amazonka-ec2 >=2.0,+ amazonka-lambda >=2.0,+ amazonka-sso >=2.0,+ amazonka-sts >=2.0, base >=4 && <5, bytestring, cfn-flip >=0.1.0.3,@@ -117,8 +116,7 @@ time, transformers, typed-process,- unliftio,- unliftio-core,+ unliftio >=0.2.25.0, unordered-containers, uuid, yaml
test/Spec.hs view
@@ -1,2 +1,2 @@-{-# OPTIONS_GHC -fno-warn-missing-export-lists #-} {-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}
test/Stackctl/AWS/ScopeSpec.hs view
@@ -12,12 +12,12 @@ spec :: Spec spec = do describe "awsScopeSpecStackName" $ do- let- scope = AwsScope- { awsAccountId = AccountId "123"- , awsAccountName = "testing"- , awsRegion = "us-east-1"- }+ let scope =+ AwsScope+ { awsAccountId = AccountId "123"+ , awsAccountName = "testing"+ , awsRegion = "us-east-1"+ } it "parses full paths to stacks in the current scope" $ do awsScopeSpecStackName scope "stacks/123.testing/us-east-1/foo.yaml"
test/Stackctl/Config/RequiredVersionSpec.hs view
@@ -39,7 +39,6 @@ it "compares with >=" $ prop (>=) $ Just ">=" it "compares with =~" $ prop (=~) $ Just "=~" - describe "=~" $ do it "treats equal versions as satisfying" $ do makeVersion [1, 2, 3] =~ makeVersion [1, 2, 3] `shouldBe` True@@ -83,4 +82,5 @@ -> Either String Bool runRequiredVersion mOperator required current = (`isRequiredVersionSatisfied` current) <$> requiredVersionFromText rvText- where rvText = maybe "" (<> " ") mOperator <> pack (showVersion required)+ where+ rvText = maybe "" (<> " ") mOperator <> pack (showVersion required)
test/Stackctl/ConfigSpec.hs view
@@ -19,15 +19,15 @@ spec = do describe "loadConfigFromBytes" $ do it "loads a valid config" $ do- let- result = loadConfigFromLines- [ "required_version: " <> BS8.pack (showVersion Paths.version)- , "defaults:"- , " parameters:"- , " Some: Parameter"- , " tags:"- , " Some: Tag"- ]+ let result =+ loadConfigFromLines+ [ "required_version: " <> BS8.pack (showVersion Paths.version)+ , "defaults:"+ , " parameters:"+ , " Some: Parameter"+ , " tags:"+ , " Some: Tag"+ ] case result of Left err -> do@@ -42,15 +42,16 @@ describe "applyConfig" $ do it "defaults missing Tags" $ do let- specYaml = StackSpecYaml- { ssyDescription = Nothing- , ssyTemplate = ""- , ssyDepends = Nothing- , ssyActions = Nothing- , ssyParameters = Nothing- , ssyCapabilities = Nothing- , ssyTags = Just $ toTagsYaml [("Hi", "There"), ("Keep", "Me")]- }+ specYaml =+ StackSpecYaml+ { ssyDescription = Nothing+ , ssyTemplate = ""+ , ssyDepends = Nothing+ , ssyActions = Nothing+ , ssyParameters = Nothing+ , ssyCapabilities = Nothing+ , ssyTags = Just $ toTagsYaml [("Hi", "There"), ("Keep", "Me")]+ } Right config = loadConfigFromBytes@@ -61,8 +62,9 @@ Just tags = ssyTags (applyConfig config specYaml) - tags `shouldBe` toTagsYaml- [("From", "Defaults"), ("Hi", "There"), ("Keep", "Me")]+ tags+ `shouldBe` toTagsYaml+ [("From", "Defaults"), ("Hi", "There"), ("Keep", "Me")] loadConfigFromLines :: MonadError ConfigError m => [ByteString] -> m Config loadConfigFromLines = loadConfigFromBytes . mconcat . map (<> "\n")
test/Stackctl/FilterOptionSpec.hs view
@@ -91,8 +91,9 @@ describe "filterOptionFromPaths" $ do it "finds full paths (e.g. as output by generate)" $ do let- option = filterOptionFromPaths- $ pure "stacks/1234567890.test-account/us-east-1/stack.yaml"+ option =+ filterOptionFromPaths+ $ pure "stacks/1234567890.test-account/us-east-1/stack.yaml" specs = [ toSpec "some-name" "stack.yaml" Nothing , toSpec "other-path" "other-stack.yaml" $ Just "x"@@ -102,26 +103,29 @@ `shouldMatchList` ["some-name"] toSpec :: Text -> FilePath -> Maybe FilePath -> StackSpec-toSpec name path mTemplate = flip runReader emptyConfig- $ buildStackSpec ".platform/specs" specPath specBody+toSpec name path mTemplate =+ flip runReader emptyConfig+ $ buildStackSpec ".platform/specs" specPath specBody where stackName = StackName name specPath = stackSpecPath scope stackName path- specBody = StackSpecYaml- { ssyDescription = Nothing- , ssyDepends = Nothing- , ssyActions = Nothing- , ssyTemplate = fromMaybe path mTemplate- , ssyParameters = Nothing- , ssyCapabilities = Nothing- , ssyTags = Nothing- }+ specBody =+ StackSpecYaml+ { ssyDescription = Nothing+ , ssyDepends = Nothing+ , ssyActions = Nothing+ , ssyTemplate = fromMaybe path mTemplate+ , ssyParameters = Nothing+ , ssyCapabilities = Nothing+ , ssyTags = Nothing+ } - scope = AwsScope- { awsAccountId = AccountId "1234567890"- , awsAccountName = "test-account"- , awsRegion = Region' "us-east-1"- }+ scope =+ AwsScope+ { awsAccountId = AccountId "1234567890"+ , awsAccountName = "test-account"+ , awsRegion = Region' "us-east-1"+ } specName :: StackSpec -> Text specName = unStackName . stackSpecStackName
test/Stackctl/StackDescriptionSpec.hs view
@@ -26,8 +26,8 @@ it "does not clobber or duplicate an existing Description" $ do addStackDescription- aDescription- "Resources: []\nDescription: Existing description\n"+ aDescription+ "Resources: []\nDescription: Existing description\n" `shouldBe` "Resources: []\nDescription: Existing description\n" context "JSON" $ do@@ -37,6 +37,6 @@ it "does not clobber or duplicate an existing Description" $ do addStackDescription- aDescription- "{\"Resources\":[],\"Description\":\"Existing description\"}"+ aDescription+ "{\"Resources\":[],\"Description\":\"Existing description\"}" `shouldBe` "{\"Resources\":[],\"Description\":\"Existing description\"}"
test/Stackctl/StackSpecSpec.hs view
@@ -16,38 +16,40 @@ spec = do describe "sortStackSpecs" $ do it "orders dependencies before dependents" $ do- let- specs =- [ toSpec "app" ["roles", "iam", "networking"]- , toSpec "roles" ["iam"]- , toSpec "iam" []- , toSpec "networking" []- ]+ let specs =+ [ toSpec "app" ["roles", "iam", "networking"]+ , toSpec "roles" ["iam"]+ , toSpec "iam" []+ , toSpec "networking" []+ ] map specName (sortStackSpecs specs) `shouldBe` ["iam", "roles", "networking", "app"] toSpec :: Text -> [Text] -> StackSpec-toSpec name depends = flip runReader emptyConfig- $ buildStackSpec "." specPath specBody+toSpec name depends =+ flip runReader emptyConfig+ $ buildStackSpec "." specPath specBody where stackName = StackName name specPath = stackSpecPath scope stackName "a/b.yaml"- specBody = StackSpecYaml- { ssyDescription = Nothing- , ssyDepends = Just $ map StackName depends- , ssyActions = Nothing- , ssyTemplate = ""- , ssyParameters = Nothing- , ssyCapabilities = Nothing- , ssyTags = Nothing- }+ specBody =+ StackSpecYaml+ { ssyDescription = Nothing+ , ssyDepends = Just $ map StackName depends+ , ssyActions = Nothing+ , ssyTemplate = ""+ , ssyParameters = Nothing+ , ssyCapabilities = Nothing+ , ssyTags = Nothing+ } - scope = AwsScope- { awsAccountId = AccountId ""- , awsAccountName = ""- , awsRegion = Region' ""- }+ scope =+ AwsScope+ { awsAccountId = AccountId ""+ , awsAccountName = ""+ , awsRegion = Region' ""+ } specName :: StackSpec -> Text specName = unStackName . stackSpecStackName
test/Stackctl/StackSpecYamlSpec.hs view
@@ -8,8 +8,8 @@ import Data.Aeson import qualified Data.Yaml as Yaml-import Stackctl.Action import Stackctl.AWS+import Stackctl.Action import Stackctl.StackSpecYaml import Test.Hspec @@ -17,123 +17,135 @@ spec = do describe "From/ToJSON" $ do it "round trips" $ do- let- yaml = StackSpecYaml- { ssyDescription = Just $ StackDescription "Testing Stack"- , ssyTemplate = "path/to/template.yaml"- , ssyDepends = Just [StackName "a-stack", StackName "another-stack"]- , ssyActions = Just- [newAction PostDeploy $ InvokeLambdaByName "a-lambda"]- , ssyParameters = Just $ parametersYaml $ mapMaybe- parameterYaml- [makeParameter "PKey" $ Just "PValue"]- , ssyCapabilities = Just [Capability_CAPABILITY_IAM]- , ssyTags = Just $ tagsYaml [TagYaml $ newTag "TKey" "TValue"]- }+ let yaml =+ StackSpecYaml+ { ssyDescription = Just $ StackDescription "Testing Stack"+ , ssyTemplate = "path/to/template.yaml"+ , ssyDepends = Just [StackName "a-stack", StackName "another-stack"]+ , ssyActions =+ Just+ [newAction PostDeploy $ InvokeLambdaByName "a-lambda"]+ , ssyParameters =+ Just+ $ parametersYaml+ $ mapMaybe+ parameterYaml+ [makeParameter "PKey" $ Just "PValue"]+ , ssyCapabilities = Just [Capability_CAPABILITY_IAM]+ , ssyTags = Just $ tagsYaml [TagYaml $ newTag "TKey" "TValue"]+ } eitherDecode (encode yaml) `shouldBe` Right yaml describe "decoding Yaml" $ do it "reads String parameters" $ do- StackSpecYaml {..} <- Yaml.decodeThrow $ mconcat- [ "Template: foo.yaml\n"- , "Parameters:\n"- , " - ParameterKey: Foo\n"- , " ParameterValue: Bar\n"- ]+ StackSpecYaml {..} <-+ Yaml.decodeThrow+ $ mconcat+ [ "Template: foo.yaml\n"+ , "Parameters:\n"+ , " - ParameterKey: Foo\n"+ , " ParameterValue: Bar\n"+ ] - let- Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters+ let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Foo" param ^. parameter_parameterValue `shouldBe` Just "Bar" it "reads Number parameters without decimals" $ do- StackSpecYaml {..} <- Yaml.decodeThrow $ mconcat- [ "Template: foo.yaml\n"- , "Parameters:\n"- , " - ParameterKey: Port\n"- , " ParameterValue: 80\n"- ]+ StackSpecYaml {..} <-+ Yaml.decodeThrow+ $ mconcat+ [ "Template: foo.yaml\n"+ , "Parameters:\n"+ , " - ParameterKey: Port\n"+ , " ParameterValue: 80\n"+ ] - let- Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters+ let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Port" param ^. parameter_parameterValue `shouldBe` Just "80" it "reads Number parameters with decimals" $ do- StackSpecYaml {..} <- Yaml.decodeThrow $ mconcat- [ "Template: foo.yaml\n"- , "Parameters:\n"- , " - ParameterKey: Pie\n"- , " ParameterValue: 3.14\n"- ]+ StackSpecYaml {..} <-+ Yaml.decodeThrow+ $ mconcat+ [ "Template: foo.yaml\n"+ , "Parameters:\n"+ , " - ParameterKey: Pie\n"+ , " ParameterValue: 3.14\n"+ ] - let- Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters+ let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Pie" param ^. parameter_parameterValue `shouldBe` Just "3.14" it "has informative errors" $ do- let- Left ex = Yaml.decodeEither' @StackSpecYaml $ mconcat- [ "Template: foo.yaml\n"- , "Parameters:\n"- , " - ParameterKey: Norway\n"- , " ParameterValue: no\n"- ]+ let Left ex =+ Yaml.decodeEither' @StackSpecYaml+ $ mconcat+ [ "Template: foo.yaml\n"+ , "Parameters:\n"+ , " - ParameterKey: Norway\n"+ , " ParameterValue: no\n"+ ] show ex `shouldBe` "AesonException \"Error in $.Parameters[0].ParameterValue: Expected String or Number, got: Bool False\"" it "has informative errors in Object form" $ do- let- Left ex = Yaml.decodeEither' @StackSpecYaml $ mconcat- ["Template: foo.yaml\n", "Parameters:\n", " Norway: no\n"]+ let Left ex =+ Yaml.decodeEither' @StackSpecYaml+ $ mconcat+ ["Template: foo.yaml\n", "Parameters:\n", " Norway: no\n"] show ex `shouldBe` "AesonException \"Error in $.Parameters.Norway: Expected String or Number, got: Bool False\"" it "handles null Value" $ do- StackSpecYaml {..} <- Yaml.decodeThrow $ mconcat- [ "Template: foo.yaml\n"- , "Parameters:\n"- , " - ParameterKey: Foo\n"- , " ParameterValue: null\n"- ]+ StackSpecYaml {..} <-+ Yaml.decodeThrow+ $ mconcat+ [ "Template: foo.yaml\n"+ , "Parameters:\n"+ , " - ParameterKey: Foo\n"+ , " ParameterValue: null\n"+ ] - let- Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters+ let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Foo" param ^. parameter_parameterValue `shouldBe` Nothing it "handles missing Value" $ do- StackSpecYaml {..} <- Yaml.decodeThrow $ mconcat- ["Template: foo.yaml\n", "Parameters:\n", " - ParameterKey: Foo\n"]+ StackSpecYaml {..} <-+ Yaml.decodeThrow+ $ mconcat+ ["Template: foo.yaml\n", "Parameters:\n", " - ParameterKey: Foo\n"] - let- Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters+ let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Foo" param ^. parameter_parameterValue `shouldBe` Nothing it "also accepts CloudGenesis formatted values" $ do- StackSpecYaml {..} <- Yaml.decodeThrow $ mconcat- [ "Template: foo.yaml\n"- , "Parameters:\n"- , " - Name: Foo\n"- , " Value: Bar\n"- ]+ StackSpecYaml {..} <-+ Yaml.decodeThrow+ $ mconcat+ [ "Template: foo.yaml\n"+ , "Parameters:\n"+ , " - Name: Foo\n"+ , " Value: Bar\n"+ ] - let- Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters+ let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Foo" param ^. parameter_parameterValue `shouldBe` Just "Bar" it "also accepts objects" $ do- StackSpecYaml {..} <- Yaml.decodeThrow- $ mconcat ["Template: foo.yaml\n", "Parameters:\n", " Foo: Bar\n"]+ StackSpecYaml {..} <-+ Yaml.decodeThrow+ $ mconcat ["Template: foo.yaml\n", "Parameters:\n", " Foo: Bar\n"] - let- Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters+ let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Foo" param ^. parameter_parameterValue `shouldBe` Just "Bar" @@ -141,18 +153,20 @@ it "has overriding Semigroup semantics" $ do let a = parametersYaml []- b = parametersYaml- $ catMaybes [parameterYaml $ makeParameter "Key" (Just "B")]- c = parametersYaml- $ catMaybes [parameterYaml $ makeParameter "Key" (Just "C")]- d = parametersYaml- $ catMaybes [parameterYaml $ makeParameter "Key" Nothing]+ b =+ parametersYaml+ $ catMaybes [parameterYaml $ makeParameter "Key" (Just "B")]+ c =+ parametersYaml+ $ catMaybes [parameterYaml $ makeParameter "Key" (Just "C")]+ d =+ parametersYaml+ $ catMaybes [parameterYaml $ makeParameter "Key" Nothing] a <> b `shouldBe` b -- keeps keys in B b <> c `shouldBe` c -- C overrides B (Last) c <> d `shouldBe` c -- C overrides D (Just) d <> c `shouldBe` c -- C overrides D (Just)- describe "TagsYaml" $ do it "has overriding Semigroup semantics" $ do let