diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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)
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
diff --git a/src/Stackctl/AWS/CloudFormation.hs b/src/Stackctl/AWS/CloudFormation.hs
--- a/src/Stackctl/AWS/CloudFormation.hs
+++ b/src/Stackctl/AWS/CloudFormation.hs
@@ -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
- ]
diff --git a/src/Stackctl/AWS/Core.hs b/src/Stackctl/AWS/Core.hs
--- a/src/Stackctl/AWS/Core.hs
+++ b/src/Stackctl/AWS/Core.hs
@@ -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
+ ]
diff --git a/src/Stackctl/AWS/EC2.hs b/src/Stackctl/AWS/EC2.hs
--- a/src/Stackctl/AWS/EC2.hs
+++ b/src/Stackctl/AWS/EC2.hs
@@ -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
diff --git a/src/Stackctl/AWS/Lambda.hs b/src/Stackctl/AWS/Lambda.hs
--- a/src/Stackctl/AWS/Lambda.hs
+++ b/src/Stackctl/AWS/Lambda.hs
@@ -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
diff --git a/src/Stackctl/AWS/Orphans.hs b/src/Stackctl/AWS/Orphans.hs
--- a/src/Stackctl/AWS/Orphans.hs
+++ b/src/Stackctl/AWS/Orphans.hs
@@ -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
diff --git a/src/Stackctl/AWS/Scope.hs b/src/Stackctl/AWS/Scope.hs
--- a/src/Stackctl/AWS/Scope.hs
+++ b/src/Stackctl/AWS/Scope.hs
@@ -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
diff --git a/src/Stackctl/Action.hs b/src/Stackctl/Action.hs
--- a/src/Stackctl/Action.hs
+++ b/src/Stackctl/Action.hs
@@ -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
diff --git a/src/Stackctl/AutoSSO.hs b/src/Stackctl/AutoSSO.hs
--- a/src/Stackctl/AutoSSO.hs
+++ b/src/Stackctl/AutoSSO.hs
@@ -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)
]
diff --git a/src/Stackctl/CLI.hs b/src/Stackctl/CLI.hs
--- a/src/Stackctl/CLI.hs
+++ b/src/Stackctl/CLI.hs
@@ -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
diff --git a/src/Stackctl/ColorOption.hs b/src/Stackctl/ColorOption.hs
--- a/src/Stackctl/ColorOption.hs
+++ b/src/Stackctl/ColorOption.hs
@@ -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"]
diff --git a/src/Stackctl/Colors.hs b/src/Stackctl/Colors.hs
--- a/src/Stackctl/Colors.hs
+++ b/src/Stackctl/Colors.hs
@@ -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
diff --git a/src/Stackctl/Commands.hs b/src/Stackctl/Commands.hs
--- a/src/Stackctl/Commands.hs
+++ b/src/Stackctl/Commands.hs
@@ -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
+ }
diff --git a/src/Stackctl/Config.hs b/src/Stackctl/Config.hs
--- a/src/Stackctl/Config.hs
+++ b/src/Stackctl/Config.hs
@@ -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"
+ ]
diff --git a/src/Stackctl/Config/RequiredVersion.hs b/src/Stackctl/Config/RequiredVersion.hs
--- a/src/Stackctl/Config/RequiredVersion.hs
+++ b/src/Stackctl/Config/RequiredVersion.hs
@@ -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
diff --git a/src/Stackctl/DirectoryOption.hs b/src/Stackctl/DirectoryOption.hs
--- a/src/Stackctl/DirectoryOption.hs
+++ b/src/Stackctl/DirectoryOption.hs
@@ -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"
+ ]
diff --git a/src/Stackctl/FilterOption.hs b/src/Stackctl/FilterOption.hs
--- a/src/Stackctl/FilterOption.hs
+++ b/src/Stackctl/FilterOption.hs
@@ -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
+ ]
diff --git a/src/Stackctl/Options.hs b/src/Stackctl/Options.hs
--- a/src/Stackctl/Options.hs
+++ b/src/Stackctl/Options.hs
@@ -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
diff --git a/src/Stackctl/ParameterOption.hs b/src/Stackctl/ParameterOption.hs
--- a/src/Stackctl/ParameterOption.hs
+++ b/src/Stackctl/ParameterOption.hs
@@ -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
diff --git a/src/Stackctl/Prelude.hs b/src/Stackctl/Prelude.hs
--- a/src/Stackctl/Prelude.hs
+++ b/src/Stackctl/Prelude.hs
@@ -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) #-}
diff --git a/src/Stackctl/RemovedStack.hs b/src/Stackctl/RemovedStack.hs
--- a/src/Stackctl/RemovedStack.hs
+++ b/src/Stackctl/RemovedStack.hs
@@ -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
diff --git a/src/Stackctl/Spec/Capture.hs b/src/Stackctl/Spec/Capture.hs
--- a/src/Stackctl/Spec/Capture.hs
+++ b/src/Stackctl/Spec/Capture.hs
@@ -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
diff --git a/src/Stackctl/Spec/Cat.hs b/src/Stackctl/Spec/Cat.hs
--- a/src/Stackctl/Spec/Cat.hs
+++ b/src/Stackctl/Spec/Cat.hs
@@ -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 " "
diff --git a/src/Stackctl/Spec/Changes.hs b/src/Stackctl/Spec/Changes.hs
--- a/src/Stackctl/Spec/Changes.hs
+++ b/src/Stackctl/Spec/Changes.hs
@@ -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
diff --git a/src/Stackctl/Spec/Changes/Format.hs b/src/Stackctl/Spec/Changes/Format.hs
--- a/src/Stackctl/Spec/Changes/Format.hs
+++ b/src/Stackctl/Spec/Changes/Format.hs
@@ -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"
- , "\nFull changes
"
- , "\n"
- , "\n```json"
- , "\n" <> changeSetJSON cs
- , "\n```"
- , "\n"
- , "\n "
- ]
+ OmitFull -> []
+ IncludeFull ->
+ [ "\n"
+ , "\n"
+ , "\nFull changes
"
+ , "\n"
+ , "\n```json"
+ , "\n" <> changeSetJSON cs
+ , "\n```"
+ , "\n"
+ , "\n "
+ ]
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 =
diff --git a/src/Stackctl/Spec/Deploy.hs b/src/Stackctl/Spec/Deploy.hs
--- a/src/Stackctl/Spec/Deploy.hs
+++ b/src/Stackctl/Spec/Deploy.hs
@@ -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
diff --git a/src/Stackctl/Spec/Discover.hs b/src/Stackctl/Spec/Discover.hs
--- a/src/Stackctl/Spec/Discover.hs
+++ b/src/Stackctl/Spec/Discover.hs
@@ -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])
diff --git a/src/Stackctl/Spec/Generate.hs b/src/Stackctl/Spec/Generate.hs
--- a/src/Stackctl/Spec/Generate.hs
+++ b/src/Stackctl/Spec/Generate.hs
@@ -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
diff --git a/src/Stackctl/Spec/List.hs b/src/Stackctl/Spec/List.hs
--- a/src/Stackctl/Spec/List.hs
+++ b/src/Stackctl/Spec/List.hs
@@ -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
diff --git a/src/Stackctl/StackDescription.hs b/src/Stackctl/StackDescription.hs
--- a/src/Stackctl/StackDescription.hs
+++ b/src/Stackctl/StackDescription.hs
@@ -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
diff --git a/src/Stackctl/StackSpec.hs b/src/Stackctl/StackSpec.hs
--- a/src/Stackctl/StackSpec.hs
+++ b/src/Stackctl/StackSpec.hs
@@ -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
diff --git a/src/Stackctl/StackSpecPath.hs b/src/Stackctl/StackSpecPath.hs
--- a/src/Stackctl/StackSpecPath.hs
+++ b/src/Stackctl/StackSpecPath.hs
@@ -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
diff --git a/src/Stackctl/StackSpecYaml.hs b/src/Stackctl/StackSpecYaml.hs
--- a/src/Stackctl/StackSpecYaml.hs
+++ b/src/Stackctl/StackSpecYaml.hs
@@ -17,9 +17,8 @@
-- - Key:
-- Value:
-- @
---
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
diff --git a/src/Stackctl/Subcommand.hs b/src/Stackctl/Subcommand.hs
--- a/src/Stackctl/Subcommand.hs
+++ b/src/Stackctl/Subcommand.hs
@@ -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
diff --git a/src/Stackctl/TagOption.hs b/src/Stackctl/TagOption.hs
--- a/src/Stackctl/TagOption.hs
+++ b/src/Stackctl/TagOption.hs
@@ -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
diff --git a/src/Stackctl/VerboseOption.hs b/src/Stackctl/VerboseOption.hs
--- a/src/Stackctl/VerboseOption.hs
+++ b/src/Stackctl/VerboseOption.hs
@@ -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)"
+ ]
diff --git a/src/UnliftIO/Exception/Lens.hs b/src/UnliftIO/Exception/Lens.hs
deleted file mode 100644
--- a/src/UnliftIO/Exception/Lens.hs
+++ /dev/null
@@ -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 #-}
diff --git a/stackctl.cabal b/stackctl.cabal
--- a/stackctl.cabal
+++ b/stackctl.cabal
@@ -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
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,2 +1,2 @@
-{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}
diff --git a/test/Stackctl/AWS/ScopeSpec.hs b/test/Stackctl/AWS/ScopeSpec.hs
--- a/test/Stackctl/AWS/ScopeSpec.hs
+++ b/test/Stackctl/AWS/ScopeSpec.hs
@@ -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"
diff --git a/test/Stackctl/Config/RequiredVersionSpec.hs b/test/Stackctl/Config/RequiredVersionSpec.hs
--- a/test/Stackctl/Config/RequiredVersionSpec.hs
+++ b/test/Stackctl/Config/RequiredVersionSpec.hs
@@ -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)
diff --git a/test/Stackctl/ConfigSpec.hs b/test/Stackctl/ConfigSpec.hs
--- a/test/Stackctl/ConfigSpec.hs
+++ b/test/Stackctl/ConfigSpec.hs
@@ -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")
diff --git a/test/Stackctl/FilterOptionSpec.hs b/test/Stackctl/FilterOptionSpec.hs
--- a/test/Stackctl/FilterOptionSpec.hs
+++ b/test/Stackctl/FilterOptionSpec.hs
@@ -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
diff --git a/test/Stackctl/StackDescriptionSpec.hs b/test/Stackctl/StackDescriptionSpec.hs
--- a/test/Stackctl/StackDescriptionSpec.hs
+++ b/test/Stackctl/StackDescriptionSpec.hs
@@ -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\"}"
diff --git a/test/Stackctl/StackSpecSpec.hs b/test/Stackctl/StackSpecSpec.hs
--- a/test/Stackctl/StackSpecSpec.hs
+++ b/test/Stackctl/StackSpecSpec.hs
@@ -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
diff --git a/test/Stackctl/StackSpecYamlSpec.hs b/test/Stackctl/StackSpecYamlSpec.hs
--- a/test/Stackctl/StackSpecYamlSpec.hs
+++ b/test/Stackctl/StackSpecYamlSpec.hs
@@ -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