diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,25 @@ -## [_Unreleased_](https://github.com/freckle/stackctl/compare/v1.1.2.2...main) +## [_Unreleased_](https://github.com/freckle/stackctl/compare/v1.1.3.0...main) + +## [v1.1.3.0](https://github.com/freckle/stackctl/compare/v1.1.2.2...v1.1.3.0) + +- Repository-local configuration + + See https://github.com/freckle/stackctl/commit/564678203fe70b5c4c46c655dd3daeaafb6de9e0 + +- Don't duplicate re-used templates in `stackctl-cat` +- Improve `--filter` + + - Match against stack name and template, in addition to spec path. + - Automatically prepend `**/` (unless there is already a leading wildcard) and + append `{/*,.yaml,.json}` (unless there is already a trailing wildcard or + extension). + + In general, this aims to make `--filter` match more things more intuitively + for operators, but still match exactly in programmatic use-cases. + +- Various documentation improvements +- Support more natural `{Key}: {Value}` syntax in `Parameters` and `Tags` +- Fix bug where we may generate an `{}` element in `Parameters` ## [v1.1.2.2](https://github.com/freckle/stackctl/compare/v1.1.2.1...v1.1.2.2) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,8 @@ # Stackctl +[![Hackage](https://img.shields.io/hackage/v/stackctl.svg?style=flat)](https://hackage.haskell.org/package/stackctl) +[![CI](https://github.com/freckle/stackctl/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/stackctl/actions/workflows/ci.yml) + Manage CloudFormation Stacks through specifications. ## About diff --git a/src/Stackctl/CLI.hs b/src/Stackctl/CLI.hs --- a/src/Stackctl/CLI.hs +++ b/src/Stackctl/CLI.hs @@ -13,12 +13,14 @@ import Stackctl.AWS import Stackctl.AWS.Scope import Stackctl.ColorOption +import Stackctl.Config import Stackctl.DirectoryOption import Stackctl.FilterOption import Stackctl.VerboseOption data App options = App { appLogger :: Logger + , appConfig :: Config , appOptions :: options , appAwsScope :: AwsScope , appAwsEnv :: AwsEnv @@ -30,6 +32,9 @@ instance HasLogger (App options) where loggerL = lens appLogger $ \x y -> x { appLogger = y } +instance HasConfig (App options) where + configL = lens appConfig $ \x y -> x { appConfig = y } + instance HasAwsScope (App options) where awsScopeL = lens appAwsScope $ \x y -> x { appAwsScope = y } @@ -86,14 +91,14 @@ (options ^. verboseOptionL) envLogSettings - aws <- runLoggerLoggingT logger awsEnvDiscover - - let - runAws - :: MonadUnliftIO m => ReaderT AwsEnv (LoggingT (ResourceT m)) a -> m a - runAws = runResourceT . runLoggerLoggingT logger . flip runReaderT aws + app <- runResourceT $ runLoggerLoggingT logger $ do + aws <- awsEnvDiscover - app <- App logger options <$> runAws fetchAwsScope <*> pure aws + App logger + <$> loadConfigOrExit + <*> pure options + <*> runReaderT fetchAwsScope aws + <*> pure aws let AwsScope {..} = appAwsScope app diff --git a/src/Stackctl/Commands.hs b/src/Stackctl/Commands.hs --- a/src/Stackctl/Commands.hs +++ b/src/Stackctl/Commands.hs @@ -11,6 +11,7 @@ import Stackctl.AWS import Stackctl.AWS.Scope import Stackctl.Colors +import Stackctl.Config (HasConfig) import Stackctl.DirectoryOption import Stackctl.FilterOption import Stackctl.Spec.Capture @@ -23,6 +24,7 @@ cat :: ( HasLogger env , HasAwsScope env + , HasConfig env , HasDirectoryOption env , HasFilterOption env , HasColorOption env @@ -36,7 +38,7 @@ } capture - :: (HasAwsScope env, HasAwsEnv env, HasDirectoryOption env) + :: (HasAwsScope env, HasAwsEnv env, HasConfig env, HasDirectoryOption env) => Subcommand CaptureOptions env capture = Subcommand { name = "capture" @@ -49,6 +51,7 @@ :: ( HasLogger env , HasAwsScope env , HasAwsEnv env + , HasConfig env , HasDirectoryOption env , HasFilterOption env ) @@ -64,6 +67,7 @@ :: ( HasLogger env , HasAwsScope env , HasAwsEnv env + , HasConfig env , HasDirectoryOption env , HasFilterOption env ) diff --git a/src/Stackctl/Config.hs b/src/Stackctl/Config.hs new file mode 100644 --- /dev/null +++ b/src/Stackctl/Config.hs @@ -0,0 +1,106 @@ +module Stackctl.Config + ( Config(..) + , configParameters + , configTags + , emptyConfig + , HasConfig(..) + , ConfigError(..) + , loadConfigOrExit + , loadConfigFromBytes + , applyConfig + ) where + +import Stackctl.Prelude + +import Control.Monad.Except +import Data.Aeson +import Data.Version +import qualified Data.Yaml as Yaml +import Paths_stackctl as Paths +import Stackctl.Config.RequiredVersion +import Stackctl.StackSpecYaml +import UnliftIO.Directory (doesFileExist) + +data Config = Config + { required_version :: Maybe RequiredVersion + , defaults :: Maybe Defaults + } + deriving stock Generic + deriving anyclass FromJSON + +configParameters :: Config -> Maybe ParametersYaml +configParameters = parameters <=< defaults + +configTags :: Config -> Maybe TagsYaml +configTags = tags <=< defaults + +emptyConfig :: Config +emptyConfig = Config Nothing Nothing + +data Defaults = Defaults + { parameters :: Maybe ParametersYaml + , tags :: Maybe TagsYaml + } + deriving stock Generic + deriving anyclass FromJSON + +class HasConfig env where + configL :: Lens' env Config + +instance HasConfig Config where + configL = id + +data ConfigError + = ConfigInvalidYaml Yaml.ParseException + | ConfigInvalid (NonEmpty Text) + | ConfigVersionNotSatisfied RequiredVersion Version + deriving stock Show + +configErrorMessage :: ConfigError -> Message +configErrorMessage = \case + ConfigInvalidYaml ex -> + "Configuration is not valid Yaml" + :# ["error" .= Yaml.prettyPrintParseException ex] + ConfigInvalid errs -> "Invalid configuration" :# ["errors" .= errs] + ConfigVersionNotSatisfied rv v -> + "Incompatible Stackctl version" :# ["current" .= v, "required" .= show rv] + +loadConfigOrExit :: (MonadIO m, MonadLogger m) => m Config +loadConfigOrExit = either die pure =<< loadConfig + where + die e = do + logError $ configErrorMessage e + exitFailure + +loadConfig :: MonadIO m => m (Either ConfigError Config) +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) + +loadConfigFromBytes :: MonadError ConfigError m => ByteString -> m Config +loadConfigFromBytes bs = do + config <- either (throwError . ConfigInvalidYaml) pure $ Yaml.decodeEither' bs + config <$ traverse_ checkRequiredVersion (required_version config) + where + checkRequiredVersion rv = + unless (isRequiredVersionSatisfied rv Paths.version) + $ throwError + $ ConfigVersionNotSatisfied rv Paths.version + +applyConfig :: Config -> StackSpecYaml -> StackSpecYaml +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" + ] diff --git a/src/Stackctl/Config/RequiredVersion.hs b/src/Stackctl/Config/RequiredVersion.hs new file mode 100644 --- /dev/null +++ b/src/Stackctl/Config/RequiredVersion.hs @@ -0,0 +1,81 @@ +module Stackctl.Config.RequiredVersion + ( RequiredVersion(..) + , requiredVersionFromText + , isRequiredVersionSatisfied + + -- * Exported for testing + , (=~) + ) where + +import Stackctl.Prelude + +import Data.Aeson +import Data.List (uncons) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Data.Version hiding (parseVersion) +import qualified Data.Version as Version +import Text.ParserCombinators.ReadP (readP_to_S) + +data RequiredVersion = RequiredVersion + { requiredVersionOp :: Text + , requiredVersionCompare :: Version -> Version -> Bool + , requiredVersionCompareWith :: Version + } + +instance Show RequiredVersion where + show RequiredVersion {..} = + unpack requiredVersionOp <> " " <> showVersion requiredVersionCompareWith + +instance FromJSON RequiredVersion where + parseJSON = + withText "RequiredVersion" $ either fail pure . requiredVersionFromText + +requiredVersionFromText :: Text -> Either String RequiredVersion +requiredVersionFromText = fromWords . T.words + where + fromWords :: [Text] -> Either String RequiredVersion + fromWords = \case + [w] -> parseRequiredVersion "=" w + [op, w] -> parseRequiredVersion op w + ws -> + Left + $ show (unpack $ T.unwords ws) + <> " did not parse as optional operator and version string" + + parseRequiredVersion :: Text -> Text -> Either String RequiredVersion + parseRequiredVersion op w = do + v <- parseVersion w + + case op of + "=" -> Right $ RequiredVersion op (==) v + "<" -> Right $ RequiredVersion op (<) v + "<=" -> Right $ RequiredVersion op (<=) v + ">" -> Right $ RequiredVersion op (>) v + ">=" -> Right $ RequiredVersion op (>=) v + "=~" -> Right $ RequiredVersion op (=~) v + _ -> + Left + $ "Invalid comparison operator (" + <> unpack op + <> "), may only be =, <, <=, >, >=, or =~" + + parseVersion :: Text -> Either String Version + parseVersion t = + fmap (fst . NE.last) + $ note ("Failed to parse as a version " <> s) + $ NE.nonEmpty + $ readP_to_S Version.parseVersion s + where s = unpack t + +(=~) :: Version -> Version -> Bool +a =~ b = a >= b && a < incrementVersion b + where + incrementVersion = onVersion $ backwards $ onHead (+ 1) + onVersion f = makeVersion . f . versionBranch + backwards f = reverse . f . reverse + onHead f as = maybe as (uncurry (:) . first f) $ uncons as + +isRequiredVersionSatisfied :: RequiredVersion -> Version -> Bool +isRequiredVersionSatisfied RequiredVersion {..} = + (`requiredVersionCompare` requiredVersionCompareWith) diff --git a/src/Stackctl/FilterOption.hs b/src/Stackctl/FilterOption.hs --- a/src/Stackctl/FilterOption.hs +++ b/src/Stackctl/FilterOption.hs @@ -3,7 +3,8 @@ , HasFilterOption(..) , filterOption , filterOptionFromPaths - , filterFilePaths + , filterOptionFromText + , filterStackSpecs ) where import Stackctl.Prelude @@ -11,6 +12,9 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import Options.Applicative +import Stackctl.AWS.CloudFormation (StackName(..)) +import Stackctl.StackSpec +import System.FilePath (hasExtension) import System.FilePath.Glob newtype FilterOption = FilterOption @@ -39,15 +43,32 @@ filterOptionFromPaths :: NonEmpty FilePath -> FilterOption filterOptionFromPaths = FilterOption . fmap compile -readFilterOption :: String -> Either String FilterOption -readFilterOption = - maybe (Left err) (Right . FilterOption) +filterOptionFromText :: Text -> Maybe FilterOption +filterOptionFromText = + fmap FilterOption . NE.nonEmpty - . map (compile . unpack) + . concatMap expandPatterns . filter (not . T.null) . map T.strip . T.splitOn "," - . pack + +expandPatterns :: Text -> [Pattern] +expandPatterns t = map compile $ s : expanded + where + expanded + | "**" `T.isPrefixOf` t = suffixed + | otherwise = map ("**" ) $ s : suffixed + + suffixed + | "*" `T.isSuffixOf` t || hasExtension s = [] + | otherwise = (s "*") : map (s <.>) extensions + + extensions = ["json", "yaml"] + + s = unpack t + +readFilterOption :: String -> Either String FilterOption +readFilterOption = note err . filterOptionFromText . pack where err = "Must be non-empty, comma-separated list of non-empty patterns" showFilterOption :: FilterOption -> String @@ -61,5 +82,13 @@ defaultFilterOption :: FilterOption defaultFilterOption = filterOptionFromPaths $ pure "**/*" -filterFilePaths :: FilterOption -> [FilePath] -> [FilePath] -filterFilePaths fo = filter $ \path -> any (`match` path) $ unFilterOption fo +filterStackSpecs :: FilterOption -> [StackSpec] -> [StackSpec] +filterStackSpecs fo = + 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 + ] 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 @@ -9,6 +9,7 @@ import Options.Applicative import Stackctl.AWS import Stackctl.AWS.Scope +import Stackctl.Config (HasConfig) import Stackctl.DirectoryOption (HasDirectoryOption(..)) import Stackctl.Spec.Generate import Stackctl.StackSpec @@ -66,6 +67,7 @@ , MonadReader env m , HasAwsScope env , HasAwsEnv env + , HasConfig env , HasDirectoryOption env ) => CaptureOptions 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 @@ -20,6 +20,7 @@ import Stackctl.AWS import Stackctl.AWS.Scope import Stackctl.Colors +import Stackctl.Config (HasConfig) import Stackctl.DirectoryOption (HasDirectoryOption(..)) import Stackctl.FilterOption (HasFilterOption) import Stackctl.Spec.Discover @@ -58,6 +59,7 @@ , MonadReader env m , HasLogger env , HasAwsScope env + , HasConfig env , HasDirectoryOption env , HasFilterOption env , HasColorOption env @@ -100,7 +102,7 @@ pure $ ssyTemplate body putTemplate 2 "templates/" - for_ (sort $ concat $ concat templates) $ \template -> do + for_ (sort $ nubOrd $ concat $ concat templates) $ \template -> do val <- Yaml.decodeFileThrow @_ @Value $ dir "templates" template putTemplate 4 $ green $ fromString template @@ -122,32 +124,44 @@ prettyPrintStackSpecYaml :: Colors -> StackName -> StackSpecYaml -> [Text] prettyPrintStackSpecYaml Colors {..} name StackSpecYaml {..} = concat [ [cyan "Name" <> ": " <> green (unStackName name)] + , maybe [] ppDescription ssyDescription , [cyan "Template" <> ": " <> green (pack ssyTemplate)] - , ppList "Parameters" (ppParameters . map unParameterYaml) ssyParameters + , ppObject "Parameters" parametersYamlKVs ssyParameters , ppList "Capabilities" ppCapabilities ssyCapabilities - , ppList "Tags" (ppTags . map unTagYaml) ssyTags + , ppObject "Tags" tagsYamlKVs ssyTags ] where + ppObject :: Text -> (a -> [(Text, Maybe Text)]) -> Maybe a -> [Text] + ppObject label f mA = fromMaybe [] $ do + kvs <- f <$> mA + pure + $ [cyan label <> ":"] + <> map + (\(k, mV) -> + " " <> cyan k <> ":" <> maybe "" (\v -> " " <> green v) mV + ) + kvs + ppList :: Text -> (a -> [Text]) -> Maybe a -> [Text] ppList label f = maybe [] (((cyan label <> ":") :) . f) - ppParameters = concatMap $ \p -> - [ " - " <> cyan "ParameterKey" <> ": " <> maybe - "" - green - (p ^. parameter_parameterKey) - , " " <> cyan "ParameterValue" <> ": " <> maybe - "" - toText - (p ^. parameter_parameterValue) - ] - + ppDescription d = + [cyan "Description" <> ": " <> green (unStackDescription d)] ppCapabilities = map ((" - " <>) . green . toText) - ppTags = concatMap $ \tg -> - [ " - " <> cyan "Key" <> ": " <> green (tg ^. tag_key) - , " " <> cyan "Value" <> ": " <> (tg ^. tag_value) - ] +parametersYamlKVs :: ParametersYaml -> [(Text, Maybe Text)] +parametersYamlKVs = mapMaybe parameterYamlKV . unParametersYaml + +parameterYamlKV :: ParameterYaml -> Maybe (Text, Maybe Text) +parameterYamlKV py = (,) <$> (p ^. parameter_parameterKey) <*> pure + (p ^. parameter_parameterValue) + where p = unParameterYaml py + +tagsYamlKVs :: TagsYaml -> [(Text, Maybe Text)] +tagsYamlKVs = map (tagKV . unTagYaml) . unTagsYaml + +tagKV :: Tag -> (Text, Maybe Text) +tagKV tg = (tg ^. tag_key, tg ^. tag_value . to Just) prettyPrintTemplate :: Colors -> Value -> [Text] prettyPrintTemplate Colors {..} val = concat 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 @@ -12,6 +12,7 @@ import Stackctl.AWS hiding (action) import Stackctl.AWS.Scope import Stackctl.Colors +import Stackctl.Config (HasConfig) import Stackctl.DirectoryOption (HasDirectoryOption) import Stackctl.FilterOption (HasFilterOption) import Stackctl.ParameterOption @@ -47,6 +48,7 @@ , HasLogger env , HasAwsScope env , HasAwsEnv env + , HasConfig env , HasDirectoryOption env , HasFilterOption env ) 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 @@ -11,10 +11,11 @@ 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) import Stackctl.FilterOption (HasFilterOption) import Stackctl.ParameterOption @@ -60,6 +61,7 @@ , HasLogger env , HasAwsScope env , HasAwsEnv env + , HasConfig env , HasDirectoryOption env , HasFilterOption env ) 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 @@ -9,8 +9,9 @@ import qualified Data.List.NonEmpty as NE import Stackctl.AWS import Stackctl.AWS.Scope +import Stackctl.Config (HasConfig) import Stackctl.DirectoryOption (HasDirectoryOption(..)) -import Stackctl.FilterOption (HasFilterOption(..), filterFilePaths) +import Stackctl.FilterOption (HasFilterOption(..), filterStackSpecs) import Stackctl.StackSpec import Stackctl.StackSpecPath import System.FilePath (isPathSeparator) @@ -22,6 +23,7 @@ , MonadLogger m , MonadReader env m , HasAwsScope env + , HasConfig env , HasDirectoryOption env , HasFilterOption env ) @@ -29,7 +31,7 @@ discoverSpecs = do dir <- view directoryOptionL scope@AwsScope {..} <- view awsScopeL - discovered <- globRelativeTo + paths <- globRelativeTo dir [ compile $ "stacks" @@ -52,24 +54,27 @@ filterOption <- view filterOptionL let - matched = filterFilePaths filterOption discovered toSpecPath = stackSpecPathFromFilePath scope - (errs, specPaths) = partitionEithers $ map toSpecPath matched + (errs, specPaths) = partitionEithers $ map toSpecPath paths context = [ "path" .= dir , "filters" .= filterOption - , "discovered" .= length discovered - , "matched" .= length matched + , "paths" .= length paths , "errors" .= length errs + , "specs" .= length specPaths ] withThreadContext context $ do - logDebug "Discovered specs" - when (null matched) $ logWarn "No specs found" checkForDuplicateStackNames specPaths - sortStackSpecs <$> traverse (readStackSpec dir) specPaths + specs <- + sortStackSpecs + . filterStackSpecs filterOption + <$> traverse (readStackSpec dir) specPaths + + when (null specs) $ logWarn "No specs found" + specs <$ logDebug ("Discovered specs" :# ["matched" .= length specs]) checkForDuplicateStackNames :: (MonadIO m, MonadLogger m) => [StackSpecPath] -> m () 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 @@ -9,6 +9,7 @@ import Stackctl.Action import Stackctl.AWS import Stackctl.AWS.Scope +import Stackctl.Config (HasConfig) import Stackctl.Spec.Discover (buildSpecPath) import Stackctl.StackSpec import Stackctl.StackSpecPath @@ -41,6 +42,7 @@ , MonadUnliftIO m , MonadLogger m , MonadReader env m + , HasConfig env , HasAwsScope env ) => Generate @@ -64,12 +66,12 @@ , ssyTemplate = templatePath , ssyDepends = gDepends , ssyActions = gActions - , ssyParameters = map ParameterYaml <$> gParameters + , ssyParameters = parametersYaml . mapMaybe parameterYaml <$> gParameters , ssyCapabilities = gCapabilities - , ssyTags = map TagYaml <$> gTags + , ssyTags = tagsYaml . map TagYaml <$> gTags } - stackSpec = buildStackSpec gOutputDirectory specPath specYaml + stackSpec <- buildStackSpec gOutputDirectory specPath specYaml withThreadContext ["stackName" .= stackSpecStackName stackSpec] $ do logInfo "Generating specification" diff --git a/src/Stackctl/StackSpec.hs b/src/Stackctl/StackSpec.hs --- a/src/Stackctl/StackSpec.hs +++ b/src/Stackctl/StackSpec.hs @@ -7,6 +7,8 @@ , stackSpecActions , stackSpecParameters , stackSpecCapabilities + , stackSpecStackFile + , stackSpecTemplateFile , stackSpecTags , buildStackSpec , TemplateBody @@ -26,9 +28,11 @@ import qualified Data.Yaml as Yaml import Stackctl.Action import Stackctl.AWS +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 UnliftIO.Directory (createDirectoryIfMissing) @@ -56,22 +60,39 @@ stackSpecActions :: StackSpec -> [Action] stackSpecActions = fromMaybe [] . ssyActions . ssSpecBody -stackSpecTemplateFile :: StackSpec -> StackTemplate +-- | Normalized, relative path to the @[{root}/]stacks/@ file +stackSpecStackFile :: StackSpec -> FilePath +stackSpecStackFile StackSpec {..} = + FilePath.normalise $ ssSpecRoot stackSpecPathFilePath ssSpecPath + +-- | Normalized, relative path to the @[{root}/]templates/@ file +stackSpecTemplateFile :: StackSpec -> FilePath stackSpecTemplateFile StackSpec {..} = - StackTemplate $ ssSpecRoot "templates" ssyTemplate ssSpecBody + FilePath.normalise $ ssSpecRoot "templates" ssyTemplate ssSpecBody stackSpecParameters :: StackSpec -> [Parameter] stackSpecParameters = - maybe [] (map unParameterYaml) . ssyParameters . ssSpecBody + maybe [] (map unParameterYaml . unParametersYaml) . ssyParameters . ssSpecBody stackSpecCapabilities :: StackSpec -> [Capability] stackSpecCapabilities = fromMaybe [] . ssyCapabilities . ssSpecBody stackSpecTags :: StackSpec -> [Tag] -stackSpecTags = maybe [] (map unTagYaml) . ssyTags . ssSpecBody +stackSpecTags = maybe [] (map unTagYaml . unTagsYaml) . ssyTags . ssSpecBody -buildStackSpec :: FilePath -> StackSpecPath -> StackSpecYaml -> StackSpec -buildStackSpec = StackSpec +buildStackSpec + :: (MonadReader env m, HasConfig env) + => FilePath + -> StackSpecPath + -> StackSpecYaml + -> m StackSpec +buildStackSpec dir specPath specBody = do + config <- view configL + pure StackSpec + { ssSpecRoot = dir + , ssSpecPath = specPath + , ssSpecBody = applyConfig config specBody + } data TemplateBody = TemplateText Text @@ -117,18 +138,17 @@ createDirectoryIfMissing True $ takeDirectory specPath liftIO $ Yaml.encodeFile specPath ssSpecBody where - templatePath = unStackTemplate $ stackSpecTemplateFile stackSpec + templatePath = stackSpecTemplateFile stackSpec specPath = parent stackSpecPathFilePath ssSpecPath -readStackSpec :: MonadIO m => FilePath -> StackSpecPath -> m StackSpec +readStackSpec + :: (MonadIO m, MonadReader env m, HasConfig env) + => FilePath + -> StackSpecPath + -> m StackSpec readStackSpec dir specPath = do specBody <- liftIO $ either err pure =<< Yaml.decodeFileEither path - - pure StackSpec - { ssSpecRoot = dir - , ssSpecPath = specPath - , ssSpecBody = specBody - } + buildStackSpec dir specPath specBody where path = dir stackSpecPathFilePath specPath err e = @@ -148,7 +168,7 @@ createChangeSet spec parameters = awsCloudFormationCreateChangeSet (stackSpecStackName spec) (stackSpecStackDescription spec) - (stackSpecTemplateFile spec) + (StackTemplate $ stackSpecTemplateFile spec) (nubOrdOn (^. parameter_parameterKey) $ parameters <> stackSpecParameters spec ) (stackSpecCapabilities spec) diff --git a/src/Stackctl/StackSpecYaml.hs b/src/Stackctl/StackSpecYaml.hs --- a/src/Stackctl/StackSpecYaml.hs +++ b/src/Stackctl/StackSpecYaml.hs @@ -20,7 +20,15 @@ -- module Stackctl.StackSpecYaml ( StackSpecYaml(..) - , ParameterYaml(..) + , ParametersYaml + , parametersYaml + , unParametersYaml + , ParameterYaml + , parameterYaml + , unParameterYaml + , TagsYaml + , tagsYaml + , unTagsYaml , TagYaml(..) ) where @@ -28,6 +36,11 @@ import Data.Aeson import Data.Aeson.Casing +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Types (typeMismatch) +import qualified Data.HashMap.Strict as HashMap +import Data.Monoid (Last(..)) import qualified Data.Text as T import Stackctl.Action import Stackctl.AWS @@ -37,9 +50,9 @@ , ssyTemplate :: FilePath , ssyDepends :: Maybe [StackName] , ssyActions :: Maybe [Action] - , ssyParameters :: Maybe [ParameterYaml] + , ssyParameters :: Maybe ParametersYaml , ssyCapabilities :: Maybe [Capability] - , ssyTags :: Maybe [TagYaml] + , ssyTags :: Maybe TagsYaml } deriving stock Generic @@ -50,20 +63,70 @@ toJSON = genericToJSON $ aesonPrefix id toEncoding = genericToEncoding $ aesonPrefix id -newtype ParameterYaml = ParameterYaml - { unParameterYaml :: Parameter +newtype ParametersYaml = ParametersYaml + { unParametersYaml :: [ParameterYaml] } + deriving stock (Eq, Show) + deriving newtype ToJSON +instance Semigroup ParametersYaml where + ParametersYaml as <> ParametersYaml bs = + ParametersYaml + $ map (uncurry ParameterYaml) + $ KeyMap.toList + $ KeyMap.fromListWith (<>) + $ map (pyKey &&& pyValue) + $ bs -- flipped to make sure Last-wins + <> as + +instance FromJSON ParametersYaml where + parseJSON = \case + Object o -> do + -- NB. There are simpler ways to do this, but making sure we construct + -- things such that we use (.:) to read the value from each key means that + -- 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 -> typeMismatch err v + where + err = + "Object" + <> ", list of {ParameterKey, ParameterValue} Objects" + <> ", or list of {Key, Value} Objects" + +parametersYaml :: [ParameterYaml] -> ParametersYaml +parametersYaml = ParametersYaml + +data ParameterYaml = ParameterYaml + { pyKey :: Key + , pyValue :: Last ParameterValue + } + deriving stock (Eq, Show) + +mkParameterYaml :: Text -> Maybe ParameterValue -> ParameterYaml +mkParameterYaml k = ParameterYaml (Key.fromText k) . Last + +parameterYaml :: Parameter -> Maybe ParameterYaml +parameterYaml p = do + k <- p ^. parameter_parameterKey + let mv = p ^. parameter_parameterValue + pure $ mkParameterYaml k $ ParameterValue <$> mv + +unParameterYaml :: ParameterYaml -> Parameter +unParameterYaml (ParameterYaml k v) = + makeParameter (Key.toText k) $ unParameterValue <$> getLast v + instance FromJSON ParameterYaml where parseJSON = withObject "Parameter" $ \o -> - (build <$> o .: "Name" <*> o .: "Value") - <|> (build <$> o .: "ParameterKey" <*> o .: "ParameterValue") - where - build k v = ParameterYaml $ makeParameter k $ Just $ unParameterValue v + (mkParameterYaml <$> o .: "Name" <*> o .:? "Value") + <|> (mkParameterYaml <$> o .: "ParameterKey" <*> o .:? "ParameterValue") newtype ParameterValue = ParameterValue { unParameterValue :: Text } + deriving stock (Eq, Show) + deriving newtype (Semigroup, ToJSON) instance FromJSON ParameterValue where parseJSON = \case @@ -76,14 +139,46 @@ toEncoding = pairs . mconcat . parameterPairs parameterPairs :: KeyValue a => ParameterYaml -> [a] -parameterPairs (ParameterYaml p) = fromMaybe [] $ do - k <- p ^. parameter_parameterKey - v <- p ^. parameter_parameterValue - pure ["ParameterKey" .= k, "ParameterValue" .= v] +parameterPairs (ParameterYaml k v) = [k .= v] +newtype TagsYaml = TagsYaml + { unTagsYaml :: [TagYaml] + } + deriving stock (Eq, Show) + deriving newtype ToJSON + +instance Semigroup TagsYaml where + TagsYaml as <> TagsYaml bs = + TagsYaml + $ map (TagYaml . uncurry newTag) + $ HashMap.toList + $ HashMap.fromList + $ map (toPair . unTagYaml) + $ as + <> bs + where + toPair :: Tag -> (Text, Text) + toPair = (^. tag_key) &&& (^. tag_value) + +instance FromJSON TagsYaml where + parseJSON = \case + Object o -> do + 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 -> typeMismatch err v + where err = "Object or list of {Key, Value} Objects" + +tagsYaml :: [TagYaml] -> TagsYaml +tagsYaml = TagsYaml + newtype TagYaml = TagYaml { unTagYaml :: Tag } + deriving newtype (Eq, Show) instance FromJSON TagYaml where parseJSON = withObject "Tag" $ \o -> do 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.1.2.2 +version: 1.1.3.0 license: MIT license-file: LICENSE copyright: 2022 Renaissance Learning Inc @@ -33,6 +33,8 @@ Stackctl.ColorOption Stackctl.Colors Stackctl.Commands + Stackctl.Config + Stackctl.Config.RequiredVersion Stackctl.DirectoryOption Stackctl.FilterOption Stackctl.Options @@ -99,6 +101,7 @@ lens, lens-aeson, monad-logger, + mtl, optparse-applicative, resourcet, rio, @@ -142,6 +145,8 @@ hs-source-dirs: test other-modules: Stackctl.AWS.CloudFormationSpec + Stackctl.Config.RequiredVersionSpec + Stackctl.ConfigSpec Stackctl.FilterOptionSpec Stackctl.StackDescriptionSpec Stackctl.StackSpecSpec @@ -166,7 +171,10 @@ -optP-Wno-nonportable-include-path build-depends: + QuickCheck, base >=4 && <5, + bytestring, hspec, + mtl, stackctl, yaml diff --git a/test/Stackctl/Config/RequiredVersionSpec.hs b/test/Stackctl/Config/RequiredVersionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Stackctl/Config/RequiredVersionSpec.hs @@ -0,0 +1,80 @@ +module Stackctl.Config.RequiredVersionSpec + ( spec + ) where + +import Stackctl.Prelude + +import Data.Version +import Stackctl.Config.RequiredVersion +import Test.Hspec +import Test.QuickCheck + +spec :: Spec +spec = do + describe "requiredVersionFromText" $ do + it "parses with or without operator" $ do + requiredVersionFromText "1.2.3-rc1" `shouldSatisfy` isRight + requiredVersionFromText "= 1.2.3-rc1" `shouldSatisfy` isRight + + it "rejects unknown operators" $ do + requiredVersionFromText "!! 1.2.3" `shouldSatisfy` isLeft + + it "rejects invalid versions" $ do + requiredVersionFromText "= wowOMG-2/2" `shouldSatisfy` isLeft + + describe "parsing operators" $ do + let prop cmp = property . uncurry . compareAsRequiredVersion cmp + + it "compares exactly" $ prop (==) Nothing + it "compares with = " $ prop (==) $ Just "=" + it "compares with < " $ prop (<) $ Just "<" + it "compares with <=" $ prop (<=) $ Just "<=" + it "compares with > " $ prop (>) $ Just ">" + 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 + + it "treats older versions as non-satisfying" $ do + makeVersion [1, 2, 2] =~ makeVersion [1, 2, 3] `shouldBe` False + + it "treats newer versions of the same branch as satisfying" $ do + makeVersion [1, 2, 3, 1] =~ makeVersion [1, 2, 3] `shouldBe` True + + it "treats newer versions as non-satisfying" $ do + makeVersion [1, 2, 4] =~ makeVersion [1, 2, 3] `shouldBe` False + + it "respects the number of components specified" $ do + makeVersion [1, 2] =~ makeVersion [1, 2] `shouldBe` True + makeVersion [1, 2, 3] =~ makeVersion [1, 2] `shouldBe` True + makeVersion [1, 1] =~ makeVersion [1, 2] `shouldBe` False + makeVersion [1, 3] =~ makeVersion [1, 2, 3] `shouldBe` False + +compareAsRequiredVersion + :: (Version -> Version -> Bool) + -- ^ Reference compare + -> Maybe Text + -- ^ Operator + -> Version + -- ^ Hypothetical required version + -> Version + -- ^ Hypotehtical current version + -> Bool +compareAsRequiredVersion cmp mOperator required current = + runRequiredVersion mOperator required current + == Right (current `cmp` required) + +runRequiredVersion + :: Maybe Text + -- ^ Operator + -> Version + -- ^ Hypothetical required version + -> Version + -- ^ Hypothetical current version + -> Either String Bool +runRequiredVersion mOperator required current = + (`isRequiredVersionSatisfied` current) <$> requiredVersionFromText rvText + where rvText = maybe "" (<> " ") mOperator <> pack (showVersion required) diff --git a/test/Stackctl/ConfigSpec.hs b/test/Stackctl/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Stackctl/ConfigSpec.hs @@ -0,0 +1,75 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Stackctl.ConfigSpec + ( spec + ) where + +import Stackctl.Prelude + +import Control.Monad.Except +import qualified Data.ByteString.Char8 as BS8 +import Data.Version (showVersion) +import Paths_stackctl as Paths +import Stackctl.AWS (makeParameter, newTag) +import Stackctl.Config +import Stackctl.StackSpecYaml +import Test.Hspec + +spec :: Spec +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" + ] + + case result of + Left err -> do + expectationFailure + $ "Expected to load a Config, got error: " + <> show err + Right config -> do + configParameters config + `shouldBe` Just (toParametersYaml [("Some", Just "Parameter")]) + configTags config `shouldBe` Just (toTagsYaml [("Some", "Tag")]) + + 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")] + } + + Right config = + loadConfigFromBytes + $ "defaults:" + <> "\n tags:" + <> "\n From: Defaults" + <> "\n Keep: \"You?\"" + + Just tags = ssyTags (applyConfig config specYaml) + + tags `shouldBe` toTagsYaml + [("From", "Defaults"), ("Hi", "There"), ("Keep", "Me")] + +loadConfigFromLines :: MonadError ConfigError m => [ByteString] -> m Config +loadConfigFromLines = loadConfigFromBytes . mconcat . map (<> "\n") + +toParametersYaml :: [(Text, Maybe Text)] -> ParametersYaml +toParametersYaml = + parametersYaml . mapMaybe (parameterYaml . uncurry makeParameter) + +toTagsYaml :: [(Text, Text)] -> TagsYaml +toTagsYaml = tagsYaml . map (TagYaml . uncurry newTag) diff --git a/test/Stackctl/FilterOptionSpec.hs b/test/Stackctl/FilterOptionSpec.hs --- a/test/Stackctl/FilterOptionSpec.hs +++ b/test/Stackctl/FilterOptionSpec.hs @@ -1,35 +1,114 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module Stackctl.FilterOptionSpec ( spec ) where import Stackctl.Prelude +import Stackctl.AWS +import Stackctl.AWS.Scope +import Stackctl.Config (emptyConfig) import Stackctl.FilterOption +import Stackctl.StackSpec +import Stackctl.StackSpecPath +import Stackctl.StackSpecYaml import Test.Hspec spec :: Spec spec = do - describe "filterFilePaths" $ do - it "filters paths matching any of the given patterns" $ do + describe "filterStackSpecs" $ do + it "filters specs matching any of the given patterns" $ do let - option = - filterOptionFromPaths $ "some-path" :| ["prefix/*", "**/suffix"] - paths = - [ "some-path" - , "some-path-other" - , "other-some-path" - , "prefix/foo" - , "prefix/foo-bar" - , "prefix/foo-bar/prefix" - , "foo/suffix" - , "foo/bar/suffix" - , "foo/suffix/bar" + Just option = filterOptionFromText "**/some-path,**/prefix/*,**/suffix" + specs = + [ toSpec "some-path" "some-path" Nothing + , toSpec "some-other-path" "some-path-other" Nothing + , toSpec "other-some-path" "other-some-path" Nothing + , toSpec "prefix-foo" "prefix/foo" Nothing + , toSpec "prefix-foo-bar" "prefix/foo-bar" Nothing + , toSpec "prefix-foo-bar-prefix" "prefix/foo-bar/prefix" Nothing + , toSpec "foo-suffix" "foo/suffix" Nothing + , toSpec "foo-bar-suffix" "foo/bar/suffix" Nothing + , toSpec "foo-suffix-bar" "foo/suffix/bar" Nothing ] - filterFilePaths option paths + map specName (filterStackSpecs option specs) `shouldMatchList` [ "some-path" - , "prefix/foo" - , "prefix/foo-bar" - , "foo/suffix" - , "foo/bar/suffix" + , "prefix-foo" + , "prefix-foo-bar" + , "foo-suffix" + , "foo-bar-suffix" + , "foo-suffix-bar" ] + + it "filters specs by template too" $ do + let + Just option = filterOptionFromText "templates/x,**/y/*" + specs = + [ toSpec "some-path" "some-path" Nothing + , toSpec "some-other-path" "some-path-other" $ Just "x" + , toSpec "prefix-foo" "prefix/foo" Nothing + , toSpec "other-some-path" "other-some-path" $ Just "z/y/t" + , toSpec "prefix-foo-bar" "prefix/foo-bar" Nothing + ] + + map specName (filterStackSpecs option specs) + `shouldMatchList` ["some-other-path", "other-some-path"] + + it "filters specs by name too" $ do + let + Just option = filterOptionFromText "some-name,**/prefix/*,templates/x" + specs = + [ toSpec "some-name" "some-path" Nothing + , toSpec "some-path" "some-path-other" $ Just "x" + , toSpec "prefix-foo" "prefix/foo" Nothing + , toSpec "other-some-path" "other-some-path" $ Just "z/y/t" + , toSpec "prefix-foo-bar" "prefix/foo-bar" Nothing + ] + + map specName (filterStackSpecs option specs) + `shouldMatchList` [ "some-name" + , "some-path" + , "prefix-foo" + , "prefix-foo-bar" + ] + + it "adds some intuitive fuzziness" $ do + let + Just option = filterOptionFromText "some/path,file,file.ext" + specs = + [ toSpec "some-name" "x/some/path/y" Nothing + , toSpec "some-path" "some-path/other" $ Just "x" + , toSpec "prefix-foo" "prefix/file.json" Nothing + , toSpec "other-some-path" "other-some-path" $ Just "z/y/t" + , toSpec "prefix-foo-bar" "prefix/foo-bar" Nothing + ] + + map specName (filterStackSpecs option specs) + `shouldMatchList` ["some-name", "prefix-foo"] + +toSpec :: Text -> FilePath -> Maybe FilePath -> StackSpec +toSpec name path mTemplate = flip runReader emptyConfig + $ buildStackSpec "." 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 + } + + scope = AwsScope + { awsAccountId = AccountId "1234567890" + , awsAccountName = "test-account" + , awsRegion = Region' "us-east-1" + } + +specName :: StackSpec -> Text +specName = unStackName . stackSpecStackName diff --git a/test/Stackctl/StackSpecSpec.hs b/test/Stackctl/StackSpecSpec.hs --- a/test/Stackctl/StackSpecSpec.hs +++ b/test/Stackctl/StackSpecSpec.hs @@ -6,6 +6,7 @@ import Stackctl.AWS import Stackctl.AWS.Scope +import Stackctl.Config (emptyConfig) import Stackctl.StackSpec import Stackctl.StackSpecPath import Stackctl.StackSpecYaml @@ -27,7 +28,8 @@ `shouldBe` ["iam", "roles", "networking", "app"] toSpec :: Text -> [Text] -> StackSpec -toSpec name depends = buildStackSpec "." specPath specBody +toSpec name depends = flip runReader emptyConfig + $ buildStackSpec "." specPath specBody where stackName = StackName name specPath = stackSpecPath scope stackName "a/b.yaml" diff --git a/test/Stackctl/StackSpecYamlSpec.hs b/test/Stackctl/StackSpecYamlSpec.hs --- a/test/Stackctl/StackSpecYamlSpec.hs +++ b/test/Stackctl/StackSpecYamlSpec.hs @@ -22,7 +22,8 @@ , " ParameterValue: Bar\n" ] - let Just [ParameterYaml param] = ssyParameters + let + Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Foo" param ^. parameter_parameterValue `shouldBe` Just "Bar" @@ -34,7 +35,8 @@ , " ParameterValue: 80\n" ] - let Just [ParameterYaml param] = ssyParameters + let + Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Port" param ^. parameter_parameterValue `shouldBe` Just "80" @@ -46,7 +48,8 @@ , " ParameterValue: 3.14\n" ] - let Just [ParameterYaml param] = ssyParameters + let + Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters param ^. parameter_parameterKey `shouldBe` Just "Pie" param ^. parameter_parameterValue `shouldBe` Just "3.14" @@ -62,6 +65,36 @@ 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"] + + 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" + ] + + 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"] + + 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" @@ -70,6 +103,42 @@ , " Value: Bar\n" ] - let Just [ParameterYaml param] = 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"] + + let + Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters + param ^. parameter_parameterKey `shouldBe` Just "Foo" + param ^. parameter_parameterValue `shouldBe` Just "Bar" + + describe "ParametersYaml" $ do + 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] + + 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 + a = tagsYaml [] + b = tagsYaml [TagYaml $ newTag "Key" "B"] + c = tagsYaml [TagYaml $ newTag "Key" "C"] + + a <> b `shouldBe` b -- keeps keys in B + b <> c `shouldBe` c -- C overrides B (Last)