├── .editorconfig ├── .github ├── CODEOWNERS ├── PULL_REQUEST_TEMPLATE.md └── workflows │ ├── add-asana-comment.yml │ ├── ci.yml │ ├── pages.yml │ ├── release.yml │ └── restyled.yml ├── .gitignore ├── .hlint.yaml ├── .releaserc.yaml ├── .restyled.yaml ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── app └── Main.hs ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── install ├── integration └── tests │ └── discover.t ├── man ├── custom.css ├── index.txt ├── stackctl-capture.1.ronn ├── stackctl-cat.1.ronn ├── stackctl-changes.1.ronn ├── stackctl-deploy.1.ronn ├── stackctl-ls.1.ronn ├── stackctl-version.1.ronn └── stackctl.1.ronn ├── package.yaml ├── renovate.json ├── src └── Stackctl │ ├── AWS.hs │ ├── AWS │ ├── CloudFormation.hs │ ├── Core.hs │ ├── EC2.hs │ ├── Lambda.hs │ ├── Orphans.hs │ ├── STS.hs │ └── Scope.hs │ ├── Action.hs │ ├── AutoSSO.hs │ ├── CLI.hs │ ├── CancelHandler.hs │ ├── ColorOption.hs │ ├── Colors.hs │ ├── Commands.hs │ ├── Config.hs │ ├── Config │ └── RequiredVersion.hs │ ├── DirectoryOption.hs │ ├── FilterOption.hs │ ├── OneOrListOf.hs │ ├── Options.hs │ ├── ParameterOption.hs │ ├── Prelude.hs │ ├── Prompt.hs │ ├── RemovedStack.hs │ ├── Sort.hs │ ├── Spec │ ├── Capture.hs │ ├── Cat.hs │ ├── Changes.hs │ ├── Changes │ │ └── Format.hs │ ├── Deploy.hs │ ├── Discover.hs │ ├── Generate.hs │ └── List.hs │ ├── StackDescription.hs │ ├── StackSpec.hs │ ├── StackSpecPath.hs │ ├── StackSpecYaml.hs │ ├── Subcommand.hs │ ├── TagOption.hs │ ├── VerboseOption.hs │ └── Version.hs ├── stack.yaml ├── stack.yaml.lock ├── stackctl.cabal └── test ├── Spec.hs ├── Stackctl ├── AWS │ ├── CloudFormationSpec.hs │ ├── EC2Spec.hs │ ├── LambdaSpec.hs │ └── ScopeSpec.hs ├── CancelHandlerSpec.hs ├── Config │ └── RequiredVersionSpec.hs ├── ConfigSpec.hs ├── FilterOptionSpec.hs ├── OneOrListOfSpec.hs ├── RemovedStackSpec.hs ├── Spec │ └── Changes │ │ └── FormatSpec.hs ├── StackDescriptionSpec.hs ├── StackSpecSpec.hs ├── StackSpecYamlSpec.hs └── Test │ └── App.hs └── files └── change-sets ├── prod-faktory.json ├── prod-faktory.md └── prod-faktory.txt /.editorconfig: -------------------------------------------------------------------------------- 1 | # Stop traversing up parent directories here 2 | root = true 3 | 4 | [*] 5 | charset = utf-8 6 | end_of_line = lf 7 | insert_final_newline = true 8 | 9 | [*.hs] 10 | indent_size = 2 11 | indent_style = space 12 | max_line_length = 80 13 | -------------------------------------------------------------------------------- /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | * @freckle/team-platform 2 | -------------------------------------------------------------------------------- /.github/PULL_REQUEST_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | _Replace this content with your own_ 2 | 3 | ## Checklists 4 | 5 | ### About the changes 6 | 7 | - [ ] Tests added if necessary 8 | - [ ] man-pages (`./man`) updated if necessary 9 | - [ ] Formatted properly (e.g. Restyled passes) 10 | 11 | ### About the PR 12 | 13 | - [ ] Descriptive, imperative-tense title 14 | - [ ] Body explaining the _why_ of the change 15 | - [ ] `breaking-change` or `enhancement` label applied if appropriate 16 | -------------------------------------------------------------------------------- /.github/workflows/add-asana-comment.yml: -------------------------------------------------------------------------------- 1 | name: Asana 2 | 3 | on: 4 | pull_request: 5 | types: [opened] 6 | 7 | jobs: 8 | link-asana-task: 9 | if: ${{ github.actor != 'dependabot[bot]' }} 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: Asana/create-app-attachment-github-action@v1.3 13 | id: postAttachment 14 | with: 15 | asana-secret: ${{ secrets.ASANA_API_ACCESS_KEY }} 16 | - run: echo "Status is ${{ steps.postAttachment.outputs.status }}" 17 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | 6 | concurrency: 7 | group: ${{ github.workflow }}-${{ github.ref }} 8 | cancel-in-progress: true 9 | 10 | jobs: 11 | generate: 12 | runs-on: ubuntu-latest 13 | steps: 14 | - uses: actions/checkout@v4 15 | - id: generate 16 | uses: freckle/stack-action/generate-matrix@v5 17 | outputs: 18 | stack-yamls: ${{ steps.generate.outputs.stack-yamls }} 19 | 20 | build: 21 | needs: generate 22 | strategy: 23 | matrix: 24 | stack-yaml: ${{ fromJSON(needs.generate.outputs.stack-yamls) }} 25 | fail-fast: false 26 | runs-on: ubuntu-latest 27 | steps: 28 | - uses: actions/checkout@v4 29 | - uses: freckle/stack-action@v5 30 | with: 31 | stack-arguments: --stack-yaml ${{ matrix.stack-yaml }} 32 | 33 | lint: 34 | runs-on: ubuntu-latest 35 | steps: 36 | - uses: actions/checkout@v4 37 | - uses: haskell-actions/hlint-setup@v2 38 | - uses: haskell-actions/hlint-run@v2 39 | with: 40 | fail-on: warning 41 | -------------------------------------------------------------------------------- /.github/workflows/pages.yml: -------------------------------------------------------------------------------- 1 | name: Pages 2 | 3 | on: 4 | push: 5 | branches: "main" 6 | 7 | permissions: 8 | contents: read 9 | pages: write 10 | id-token: write 11 | 12 | concurrency: 13 | group: "pages" 14 | cancel-in-progress: true 15 | 16 | jobs: 17 | deploy: 18 | environment: 19 | name: github-pages 20 | url: ${{ steps.deployment.outputs.page_url }} 21 | runs-on: ubuntu-latest 22 | steps: 23 | - run: gem install --user ronn-ng 24 | - run: | 25 | for bin in "$HOME"/.local/share/gem/ruby/*/bin; do 26 | echo "$bin" 27 | done >>"$GITHUB_PATH" 28 | - uses: actions/checkout@v4 29 | 30 | - name: Generate HTML man-pages 31 | run: ronn --style toc,custom --html man/*.ronn 32 | env: 33 | RONN_STYLE: ./man 34 | RONN_ORGANIZATION: Freckle Engineering 35 | 36 | - name: Copy HTML sources to _site 37 | run: | 38 | mkdir -p _site 39 | cp -v man/*.html _site/ 40 | cp -v _site/stackctl.1.html _site/index.html 41 | 42 | - uses: actions/configure-pages@v5 43 | - uses: actions/upload-pages-artifact@v3 44 | with: 45 | path: _site 46 | - id: deployment 47 | uses: actions/deploy-pages@v4 48 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | name: Release 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | - rc/* 8 | 9 | jobs: 10 | build: 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | include: 15 | - os: ubuntu-latest 16 | suffix: x86_64-linux 17 | - os: macOS-latest 18 | suffix: x86_64-osx 19 | 20 | runs-on: ${{ matrix.os }} 21 | steps: 22 | - if: ${{ runner.os == 'macOS' }} 23 | run: brew install coreutils # need GNU install 24 | - run: gem install --user ronn-ng 25 | - run: | 26 | for bin in "$HOME"/.local/share/gem/ruby/*/bin; do 27 | echo "$bin" 28 | done >>"$GITHUB_PATH" 29 | - uses: actions/checkout@v4 30 | 31 | - id: release 32 | uses: cycjimmy/semantic-release-action@v4 33 | with: 34 | dry_run: true 35 | extra_plugins: | 36 | semantic-release-stack-upload 37 | env: 38 | FORCE_COLOR: 1 39 | PREPARE_IN_VERIFY: 1 40 | 41 | # These are unused, but needed for verify to succeed 42 | GITHUB_TOKEN: ${{ github.token }} 43 | HACKAGE_KEY: ${{ secrets.HACKAGE_UPLOAD_API_KEY }} 44 | 45 | - uses: freckle/stack-action@v5 46 | - run: | 47 | make install.check # creates dist/stackctl.tar.gz 48 | cp -v dist/stackctl.tar.gz stackctl-${{ matrix.suffix }}.tar.gz 49 | - uses: actions/upload-artifact@v4 50 | with: 51 | name: ${{ matrix.os }}-binaries 52 | path: "stackctl-*.tar.gz" 53 | if-no-files-found: error 54 | 55 | release: 56 | needs: build 57 | runs-on: ubuntu-latest 58 | steps: 59 | - uses: actions/checkout@v4 60 | with: 61 | persist-credentials: false 62 | 63 | - uses: actions/download-artifact@v4 64 | 65 | - id: token 66 | uses: actions/create-github-app-token@v2 67 | with: 68 | app-id: ${{ vars.FRECKLE_AUTOMATION_APP_ID }} 69 | private-key: ${{ secrets.FRECKLE_AUTOMATION_PRIVATE_KEY }} 70 | 71 | - id: release 72 | uses: cycjimmy/semantic-release-action@v4 73 | with: 74 | extra_plugins: | 75 | semantic-release-stack-upload 76 | env: 77 | FORCE_COLOR: 1 78 | GITHUB_TOKEN: ${{ steps.token.outputs.token }} 79 | HACKAGE_KEY: ${{ secrets.HACKAGE_UPLOAD_API_KEY }} 80 | -------------------------------------------------------------------------------- /.github/workflows/restyled.yml: -------------------------------------------------------------------------------- 1 | name: Restyled 2 | 3 | on: 4 | pull_request: 5 | 6 | concurrency: 7 | group: ${{ github.workflow }}-${{ github.ref }} 8 | cancel-in-progress: true 9 | 10 | permissions: 11 | contents: read 12 | pull-requests: write 13 | 14 | jobs: 15 | restyled: 16 | runs-on: ubuntu-latest 17 | steps: 18 | - uses: actions/checkout@v4 19 | - uses: restyled-io/actions/setup@v4 20 | - uses: restyled-io/actions/run@v4 21 | with: 22 | suggestions: true 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.hie 2 | .stack-work 3 | dist/ 4 | man/* 5 | !man/index.txt 6 | !man/*.css 7 | !man/*.ronn 8 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - ignore: {name: "Redundant do", within: spec} 3 | - ignore: {name: "Eta reduce"} 4 | - ignore: {name: "Use list comprehension"} 5 | - ignore: {name: "Reduce duplication"} 6 | - ignore: {name: "Use fmap"} # we use classy prelude so this would be in error 7 | - ignore: {name: "Avoid restricted function", within: Application} 8 | - ignore: {name: "Use ."} # commonly broken or less readable 9 | - ignore: {name: "Use &&"} # we like "and" at 3+ elements 10 | - ignore: {name: "Use ||"} # we like "or" at 3+ elements 11 | - ignore: {name: "Use join"} # this often leads to cryptic code when do notation is easier to read 12 | - ignore: {name: "Redundant ^."} # commonly broken by esqueleto 13 | - ignore: {name: "Use ++"} # less readable for commandline option lists 14 | - ignore: {name: "Functor law"} # too aggressive 15 | 16 | # Custom Warnings 17 | - warn: {lhs: mapM, rhs: traverse} 18 | - warn: {lhs: mapM_, rhs: traverse_} 19 | - warn: {lhs: forM, rhs: for} 20 | - warn: {lhs: forM_, rhs: for_} 21 | - warn: {lhs: return, rhs: pure} 22 | 23 | # Specify additional command line arguments 24 | - arguments: 25 | - -XBangPatterns 26 | - -XDataKinds 27 | - -XDeriveAnyClass 28 | - -XDeriveFoldable 29 | - -XDeriveFunctor 30 | - -XDeriveGeneric 31 | - -XDeriveLift 32 | - -XDeriveTraversable 33 | - -XDerivingStrategies 34 | - -XDerivingVia 35 | - -XFlexibleContexts 36 | - -XFlexibleInstances 37 | - -XGADTs 38 | - -XGeneralizedNewtypeDeriving 39 | - -XLambdaCase 40 | - -XMultiParamTypeClasses 41 | - -XNoImplicitPrelude 42 | - -XNoMonomorphismRestriction 43 | - -XOverloadedStrings 44 | - -XRankNTypes 45 | - -XRecordWildCards 46 | - -XScopedTypeVariables 47 | - -XStandaloneDeriving 48 | - -XTypeApplications 49 | - -XTypeFamilies 50 | 51 | - modules: 52 | - {name: [Data.Set], as: Set} 53 | - {name: [Data.Map], as: Map} 54 | - {name: [Data.HashSet], as: HashSet} 55 | - {name: [Data.HashMap.Strict], as: HashMap} 56 | - {name: [Data.Text], as: T} 57 | - {name: [Data.Text.Encoding], as: T} 58 | - {name: [Data.Text.IO], as: T} 59 | - {name: [Data.Text.Lazy], as: TL} 60 | - {name: [Data.Text.Lazy.Encoding], as: TL} 61 | - {name: [Data.Text.IO.Lazy], as: TL} 62 | - {name: [Data.ByteString], as: BS} 63 | - {name: [Data.ByteString.Lazy], as: BSL} 64 | - {name: [Data.ByteString.Char8], as: BS8} 65 | - {name: [Data.ByteString.Lazy.Char8], as: BSL8} 66 | - {name: [Data.List.NonEmpty], as: NE} 67 | - {name: [Data.Sequence], as: Seq} 68 | -------------------------------------------------------------------------------- /.releaserc.yaml: -------------------------------------------------------------------------------- 1 | tagFormat: "v1.${version}" # PVP prefixed 2 | 3 | plugins: 4 | - "@semantic-release/commit-analyzer" 5 | - "@semantic-release/release-notes-generator" 6 | - - "@semantic-release/github" 7 | - assets: "*-binaries/stackctl-*.tar.gz" 8 | successCommentCondition: false 9 | failCommentCondition: false 10 | - - "semantic-release-stack-upload" 11 | - pvpBounds: lower 12 | stripSuffix: true 13 | 14 | branches: 15 | - main 16 | - name: rc/* 17 | prerelease: '${name.replace(/^rc\//, "rc-")}' 18 | -------------------------------------------------------------------------------- /.restyled.yaml: -------------------------------------------------------------------------------- 1 | restylers_version: dev 2 | restylers: 3 | - cabal-fmt: 4 | enabled: false 5 | - fourmolu: 6 | image: 7 | tag: v0.17.0.0 8 | - stylish-haskell: 9 | enabled: false 10 | - prettier-markdown: 11 | enabled: false 12 | - whitespace: 13 | include: 14 | - "**/*" 15 | - "!**/*.t" # cram tests have whitespace in assertions 16 | - "!README.md" # help code blocks have trailing whitespace 17 | - "*" 18 | 19 | also_exclude: 20 | - "test/files/**/*" 21 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | See https://github.com/freckle/stackctl/releases 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2022 Renaissance Learning Inc 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | dist: dist/stackctl.tar.gz 2 | 3 | ARCHIVE_TARGETS := \ 4 | dist/stackctl/stackctl \ 5 | dist/stackctl/completion/bash \ 6 | dist/stackctl/completion/fish \ 7 | dist/stackctl/completion/zsh \ 8 | dist/stackctl/doc/stackctl.1 \ 9 | dist/stackctl/doc/stackctl-cat.1 \ 10 | dist/stackctl/doc/stackctl-capture.1 \ 11 | dist/stackctl/doc/stackctl-changes.1 \ 12 | dist/stackctl/doc/stackctl-deploy.1 \ 13 | dist/stackctl/doc/stackctl-version.1 \ 14 | dist/stackctl/Makefile 15 | 16 | dist/stackctl.tar.gz: $(ARCHIVE_TARGETS) 17 | tar -C ./dist -czvf $@ ./stackctl 18 | 19 | SRCS := $(shell \ 20 | find ./src ./app -name '*.hs'; \ 21 | echo stack.yaml; \ 22 | echo stackctl.cabal \ 23 | ) 24 | 25 | dist/stackctl/stackctl: $(SRCS) 26 | mkdir -p ./dist/stackctl 27 | stack build --pedantic --test --copy-bins --local-bin-path dist/stackctl 28 | 29 | dist/stackctl/completion/%: dist/stackctl/stackctl 30 | mkdir -p ./dist/stackctl/completion 31 | ./$< --$(@F)-completion-script stackctl > dist/stackctl/completion/$(@F) 32 | 33 | dist/stackctl/doc/%: man/%.ronn 34 | mkdir -p ./dist/stackctl/doc 35 | ronn --organization "Freckle Engineering" --roff <"$<" >"$@" 36 | 37 | dist/stackctl/Makefile: Makefile 38 | mkdir -p dist/stackctl 39 | cp $< $@ 40 | 41 | .PHONY: clean 42 | clean: 43 | $(RM) -r ./dist 44 | stack clean --full 45 | 46 | DESTDIR ?= 47 | PREFIX ?= /usr/local 48 | MANPREFIX ?= $(PREFIX)/share/man 49 | 50 | INSTALL ?= $(shell command -v ginstall 2>/dev/null || echo install) 51 | 52 | .PHONY: install 53 | install: 54 | $(INSTALL) -Dm755 stackctl $(DESTDIR)$(PREFIX)/bin/stackctl 55 | $(INSTALL) -Dm644 completion/bash $(DESTDIR)$(PREFIX)/share/bash-completion/completions/stackctl 56 | $(INSTALL) -Dm644 completion/fish $(DESTDIR)$(PREFIX)/share/fish/vendor_completions.d/stackctl.fish 57 | $(INSTALL) -Dm644 completion/zsh $(DESTDIR)$(PREFIX)/share/zsh/site-functions/_stackctl 58 | $(INSTALL) -Dm644 doc/stackctl.1 $(DESTDIR)$(MANPREFIX)/man1/stackctl.1 59 | $(INSTALL) -Dm644 doc/stackctl-cat.1 $(DESTDIR)$(MANPREFIX)/man1/stackctl-cat.1 60 | $(INSTALL) -Dm644 doc/stackctl-capture.1 $(DESTDIR)$(MANPREFIX)/man1/stackctl-capture.1 61 | $(INSTALL) -Dm644 doc/stackctl-changes.1 $(DESTDIR)$(MANPREFIX)/man1/stackctl-changes.1 62 | $(INSTALL) -Dm644 doc/stackctl-deploy.1 $(DESTDIR)$(MANPREFIX)/man1/stackctl-deploy.1 63 | $(INSTALL) -Dm644 doc/stackctl-version.1 $(DESTDIR)$(MANPREFIX)/man1/stackctl-version.1 64 | 65 | .PHONY: uninstall 66 | uninstall: 67 | $(RM) $(DESTDIR)$(PREFIX)/bin/stackctl 68 | $(RM) $(DESTDIR)$(PREFIX)/share/bash-completion/completions/stackctl 69 | $(RM) $(DESTDIR)$(PREFIX)/share/fish/vendor_completions.d/stackctl.fish 70 | $(RM) $(DESTDIR)$(PREFIX)/share/zsh/site-functions/_stackctl 71 | $(RM) $(DESTDIR)$(MANPREFIX)/man1/stackctl.1 72 | $(RM) $(DESTDIR)$(MANPREFIX)/man1/stackctl-cat.1 73 | $(RM) $(DESTDIR)$(MANPREFIX)/man1/stackctl-capture.1 74 | $(RM) $(DESTDIR)$(MANPREFIX)/man1/stackctl-changes.1 75 | $(RM) $(DESTDIR)$(MANPREFIX)/man1/stackctl-deploy.1 76 | $(RM) $(DESTDIR)$(MANPREFIX)/man1/stackctl-version.1 77 | 78 | .PHONY: install.check 79 | install.check: dist/stackctl.tar.gz 80 | cp dist/stackctl.tar.gz /tmp && \ 81 | cd /tmp && \ 82 | tar xvf stackctl.tar.gz && \ 83 | cd stackctl && \ 84 | make install PREFIX=$$HOME/.local 85 | PATH=$$HOME/.local/bin:$$PATH stackctl version 86 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Stackctl 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/stackctl.svg?style=flat)](https://hackage.haskell.org/package/stackctl) 4 | [![CI](https://github.com/freckle/stackctl/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/stackctl/actions/workflows/ci.yml) 5 | 6 | Manage CloudFormation Stacks through specifications. 7 | 8 | ## About 9 | 10 | `stackctl` is a command-line tool for working with [Stack Specifications][spec]. A Stack 11 | Specification is a file-system format for describing deployed (or 12 | to-be-deployed) CloudFormation Stacks including the Template, Parameters, and 13 | Tags. `stackctl` can be used to pretty-print, diff, and deploy these 14 | specifications. 15 | 16 | [spec]: https://freckle.github.io/stackctl/#STACK-SPECIFICATIONS 17 | 18 | This project also contains a Haskell library for doing the same. 19 | 20 | ## Install 21 | 22 | ### Pre-requisites 23 | 24 | - Have `~/.local/bin` on your `$PATH` 25 | - Have `~/.local/share/man` on your `$MANPATH` (for documentation) 26 | - If on OSX, `brew install coreutils` (i.e. have `ginstall` available) 27 | - If on OSX, `brew install jq` 28 | 29 | ### Scripted 30 | 31 | ```console 32 | curl -L https://raw.githubusercontent.com/freckle/stackctl/main/install | bash 33 | ``` 34 | 35 | > [!NOTE] 36 | > Some in the community have expressed [concerns][curlsh-bad] about the 37 | > security of so-called "curl-sh" installations. We think the argument has been 38 | > [pretty well debunked][curlsh-ok], but feel free to use the manual steps 39 | > instead. 40 | 41 | [curlsh-bad]: https://0x46.net/thoughts/2019/04/27/piping-curl-to-shell/ 42 | [curlsh-ok]: https://www.arp242.net/curl-to-sh.html 43 | 44 | ### Manual 45 | 46 | Go to the [latest release][latest] and download the `.tar.gz` asset appropriate 47 | for your OS. Navigate to the directory containing the downloaded file and run: 48 | 49 | [latest]: https://github.com/freckle/stackctl/releases/latest 50 | 51 | ```console 52 | tar xvf stackctl-*.tar.gz 53 | cd stackctl 54 | ``` 55 | 56 | User installation: 57 | 58 | ```console 59 | make install PREFIX="$HOME/.local" 60 | ``` 61 | 62 | Global installation 63 | 64 | ```console 65 | sudo make install 66 | ``` 67 | 68 | ## Usage 69 | 70 | Once installed, see: 71 | 72 | - `stackctl --help`, 73 | - `stackctl --help`, 74 | - `man 1 stackctl`, or 75 | - `man 1 stackctl ` 76 | 77 | The man pages are also available [online](https://freckle.github.io/stackctl/), 78 | but contain documentation as of `main`, and not your installed version. 79 | 80 | ## Release 81 | 82 | To trigger a release in this project, merge a commit to `main` with a 83 | conventionally-formatted commit message. In short, one that starts with: 84 | 85 | 1. `fix:` to trigger a patch release, 86 | 1. `feat:` for minor, or 87 | 1. `feat!:` for major 88 | 89 | Conventional commits are not required generally for this project, though you're 90 | free to always use them. They are only required when you want to trigger a 91 | release. 92 | 93 | ## Comparison to AWS CloudFormation Git Sync 94 | 95 | [AWS CloudFormation Git Sync][aws-git-sync] was recently released by AWS. It 96 | allows you to link a repository on GitHub to a CloudFormation Stack. The 97 | repository contains a "deployment file" that defines a `template-file-path`, 98 | `parameters`, and `tags` -- effectively, a Stack Specification. 99 | 100 | When AWS notices updates to the deployment or template file land on a defined 101 | branch, it updates the configured Stack accordingly, emitting events to SNS as 102 | it does. 103 | 104 | This is great for simple use-cases, and we fully expect they'll improve and 105 | extend it such that it obviates Stackctl one day. In the meantime, there are 106 | currently the following limitations when compared to Stackctl: 107 | 108 | 1. A repository can only target a single account and region 109 | 1. There is no changeset flow amenable to previewing changes via PRs. You update 110 | the file(s) on `main` and it syncs, that's it. If you're using a PR, you have 111 | only linting and human review as possible pre-deployment steps. 112 | 1. There is no way to specify description, capabilities, or dependencies 113 | 1. As of 12/23, there seemed to be some bugs, and the setup installs a managed 114 | event bridge that "phones home", sending events about your updates to some 115 | other AWS account ([source][first-look-blog]) 116 | 117 | [aws-git-sync]: https://docs.aws.amazon.com/AWSCloudFormation/latest/UserGuide/git-sync.html 118 | [first-look-blog]: https://medium.com/@mattgillard/first-look-git-sync-for-cloudformation-stacks-9e2f39c311ac 119 | 120 | ## Relationship to CloudGenesis 121 | 122 | [CloudGenesis][] is a project that also takes a directory of Stack 123 | Specifications and deploys them when changed. Its on-disk format inspired ours 124 | and, in fact, directories built for CloudGenesis can be managed by `stackctl` 125 | (not necessarily the other way around). 126 | 127 | [cloudgenesis]: https://github.com/LifeWay/CloudGenesis 128 | 129 | The key differences are: 130 | 131 | - CloudGenesis supplies AWS CodeBuild tooling for handling changes to your 132 | GitOps repository; Stackctl expects you to implement a GitHub Action that 133 | installs and executes `stackctl` commands as appropriate 134 | 135 | This makes Stackctl better if you need or want to also run the same tooling in 136 | a local context, but it makes CloudGenesis better if you need or want this 137 | activity to remain within the boundaries of your AWS VPC. 138 | 139 | - CloudGenesis reacts to file-change events in S3, which only happens when you 140 | synchronize from `main`; Stackctl can run on any branch and easily be scoped 141 | to files changed in the PR or push. 142 | 143 | This enables Stackctl features like commenting with ChangeSet details on PRs, 144 | which are not possible in CloudGenesis as it's currently implemented. 145 | 146 | - Stackctl adds the `Depends` key, for ordering multi-Stack processing 147 | 148 | --- 149 | 150 | [CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) 151 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import qualified Stackctl.Commands as Commands 8 | import Stackctl.Subcommand 9 | 10 | main :: IO () 11 | main = 12 | runSubcommand 13 | $ subcommand Commands.cat 14 | <> subcommand Commands.capture 15 | <> subcommand Commands.changes 16 | <> subcommand Commands.deploy 17 | <> subcommand Commands.list 18 | <> subcommand Commands.version 19 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | stable.url = "github:nixos/nixpkgs/nixos-23.11"; 4 | freckle.url = "git+ssh://git@github.com/freckle/flakes?dir=main"; 5 | flake-utils.url = "github:numtide/flake-utils"; 6 | }; 7 | outputs = inputs: inputs.flake-utils.lib.eachDefaultSystem (system: 8 | let 9 | nixpkgsArgs = { inherit system; config = { }; }; 10 | nixpkgs = { 11 | stable = import inputs.stable nixpkgsArgs; 12 | }; 13 | freckle = inputs.freckle.packages.${system}; 14 | freckleLib = inputs.freckle.lib.${system}; 15 | in 16 | rec { 17 | packages = { 18 | awscli = freckle.aws-cli-2-11-x; 19 | 20 | cabal = nixpkgs.stable.cabal-install; 21 | 22 | fourmolu = freckle.fourmolu-0-13-x; 23 | 24 | ghc = freckleLib.haskellBundle { 25 | ghcVersion = "ghc-9-6-3"; 26 | packageSelection = p: [ ]; 27 | enableHLS = true; 28 | }; 29 | 30 | hlint = 31 | nixpkgs.stable.haskell.lib.justStaticExecutables 32 | nixpkgs.stable.hlint; 33 | 34 | stack = nixpkgs.stable.writeShellApplication { 35 | name = "stack"; 36 | text = '' 37 | ${nixpkgs.stable.stack}/bin/stack --system-ghc --no-nix "$@" 38 | ''; 39 | } 40 | ; 41 | }; 42 | 43 | devShells.default = nixpkgs.stable.mkShell { 44 | buildInputs = with (nixpkgs.stable); [ 45 | pcre 46 | pcre.dev 47 | zlib 48 | zlib.dev 49 | ]; 50 | 51 | nativeBuildInputs = with (packages); [ 52 | awscli 53 | cabal 54 | fourmolu 55 | ghc 56 | hlint 57 | stack 58 | ]; 59 | 60 | shellHook = '' 61 | export STACK_YAML=stack.yaml 62 | ''; 63 | }; 64 | }); 65 | } 66 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | column-limit: 80 # needs v0.12 3 | function-arrows: leading 4 | comma-style: leading # default 5 | import-export-style: leading 6 | import-grouping: # needs v0.17 7 | - name: "Preludes" 8 | rules: 9 | - glob: Prelude 10 | - glob: "**.Prelude" 11 | - glob: RIO 12 | - glob: Stackctl.Test.App 13 | - name: "Everything else" 14 | rules: 15 | - match: all 16 | priority: 100 17 | indent-wheres: false # default 18 | record-brace-space: true 19 | newlines-between-decls: 1 # default 20 | haddock-style: single-line 21 | let-style: mixed 22 | in-style: left-align 23 | single-constraint-parens: never # needs v0.12 24 | sort-constraints: false # default 25 | sort-derived-classes: false # default 26 | sort-derived-clauses: false # default 27 | trailing-section-operators: false # needs v0.17 28 | unicode: never # default 29 | respectful: true # default 30 | 31 | # fourmolu can't figure this out because of the re-exports we use 32 | fixities: 33 | - "infixl 1 &" 34 | - "infixr 4 .~" 35 | - "infixr 4 ?~" 36 | -------------------------------------------------------------------------------- /install: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | : "${OS:=$(uname -s)}" 5 | : "${PREFIX:=$HOME/.local}" 6 | : "${RELEASE_TAG:=""}" 7 | 8 | case "$OS" in 9 | Linux) 10 | asset_name=stackctl-x86_64-linux.tar.gz 11 | ;; 12 | Darwin) 13 | asset_name=stackctl-x86_64-osx.tar.gz 14 | ;; 15 | *) 16 | echo "Unsupported (unknown OS: $OS)" >&2 17 | exit 1 18 | ;; 19 | esac 20 | 21 | if [[ -z "$RELEASE_TAG" ]]; then 22 | path=/releases/latest 23 | else 24 | path=/releases/tags/$RELEASE_TAG 25 | fi 26 | 27 | url=$( 28 | curl --fail "https://api.github.com/repos/freckle/stackctl$path" | 29 | jq --raw-output " 30 | .assets[] 31 | | select(.name == \"$asset_name\") 32 | | .browser_download_url 33 | " 34 | ) 35 | 36 | cd /tmp 37 | curl --fail --location "$url" | tar vxzf - 38 | cd stackctl && make install PREFIX="$PREFIX" 39 | 40 | echo 41 | echo "Installed $PREFIX/bin/stackctl" 42 | set -x +e 43 | which stackctl 44 | stackctl version 45 | -------------------------------------------------------------------------------- /integration/tests/discover.t: -------------------------------------------------------------------------------- 1 | Discovering Stack name collisions 2 | 3 | $ mkdir -p \ 4 | > stacks/539282909833.x/us-east-1/dev \ 5 | > stacks/539282909833.x/us-east-1/foo/bar \ 6 | > stacks/539282909833.x/us-east-1/foo-bar 7 | > touch \ 8 | > stacks/539282909833.x/us-east-1/dev-app.yaml \ 9 | > stacks/539282909833.x/us-east-1/dev/app.yaml \ 10 | > stacks/539282909833.x/us-east-1/foo/bar/app.yaml \ 11 | > stacks/539282909833.x/us-east-1/foo-bar/app.yaml \ 12 | > stacks/539282909833.x/us-east-1/foo-bar-app.yaml \ 13 | > stacks/539282909833.x/us-east-1/foo/bar-app.yaml 14 | > LOG_FORMAT=json stackctl cat |& jq --sort-keys '.message' 15 | { 16 | "meta": { 17 | "name": "dev-app", 18 | "paths": [ 19 | "dev-app.yaml", 20 | "dev/app.yaml" 21 | ] 22 | }, 23 | "text": "Multiple specifications produced the same Stack name" 24 | } 25 | { 26 | "meta": { 27 | "name": "foo-bar-app", 28 | "paths": [ 29 | "foo-bar-app.yaml", 30 | "foo/bar-app.yaml", 31 | "foo/bar/app.yaml", 32 | "foo-bar/app.yaml" 33 | ] 34 | }, 35 | "text": "Multiple specifications produced the same Stack name" 36 | } 37 | -------------------------------------------------------------------------------- /man/custom.css: -------------------------------------------------------------------------------- 1 | .mp h1, 2 | .mp h2, 3 | .mp h3, 4 | .mp h4, 5 | .mp h5, 6 | .mp h6, 7 | .mp code { 8 | color: #A00000; 9 | } 10 | 11 | .mp var { 12 | color: #006000; 13 | } 14 | -------------------------------------------------------------------------------- /man/index.txt: -------------------------------------------------------------------------------- 1 | # manuals included in this project: 2 | stackctl-cat(1) stackctl-cat.1.ronn 3 | stackctl-capture(1) stackctl-capture.1.ronn 4 | stackctl-changes(1) stackctl-changes.1.ronn 5 | stackctl-deploy(1) stackctl-deploy.1.ronn 6 | stackctl-version(1) stackctl-version.1.ronn 7 | 8 | # external manuals 9 | -------------------------------------------------------------------------------- /man/stackctl-capture.1.ronn: -------------------------------------------------------------------------------- 1 | stackctl-capture(1) - Generate stack specifications from deployed stacks 2 | ======================================================================== 3 | 4 | ## SYNOPSIS 5 | 6 | `stackctl capture` [] 7 | 8 | ## DESCRIPTION 9 | 10 | Fetches the CloudFormation Template and currently supplied Parameters of a 11 | deployed Stack and stores it as a stack specification under the 12 | currently-authorized AWS Account and Region. 13 | 14 | If files already exist at the inferred locations, they will be overwritten. 15 | 16 | ## OPTIONS 17 | 18 | * `-n`, `--account-name`=: 19 | Write specs paths to `stacks/{account-id}.NAME/...`. If not given, we will 20 | use `${AWS_PROFILE:-unknown}`. 21 | 22 | * `-t`, `--template-path`=: 23 | Relative path for template. Default is `${STACK}.yaml`. 24 | 25 | * `-p`, `--path`=: 26 | Relative path for specification. Default is `${STACK}.yaml`. 27 | 28 | * `--no-flip`: 29 | Don't flip JSON templates to Yaml. This option is ignored if the template is 30 | not JSON. 31 | 32 | * `STACK`: 33 | Name of Stack to capture. 34 | 35 | Globs are also supported and all matching Stacks will be captured. When 36 | there are multiple Stacks being captured, the `--path` and `--template-path` 37 | will be ignored and all Stacks will be captured to their inferred paths. 38 | 39 | ## ENVIRONMENT 40 | 41 | * `AWS_PROFILE`: 42 | If set, will be used when defaulting `-n`. 43 | -------------------------------------------------------------------------------- /man/stackctl-cat.1.ronn: -------------------------------------------------------------------------------- 1 | stackctl-cat(1) - pretty-print stack specifications and templates 2 | ================================================================= 3 | 4 | ## SYNOPSIS 5 | 6 | `stackctl cat` [] 7 | 8 | ## DESCRIPTION 9 | 10 | This command locates `stacks/` for the currently-authorized AWS Account and 11 | Region and lists them in a tree-like display along with abbreviated contents. It 12 | then lists any `templates/` files used by those stacks in a similar fashion. 13 | 14 | ## OPTIONS 15 | 16 | * `--no-stacks`: 17 | Don't print `stacks/`. 18 | 19 | * `--no-templates`: 20 | Don't print `templates/`. 21 | 22 | * `-b`, `--brief`: 23 | Don't print file contents, only paths. 24 | -------------------------------------------------------------------------------- /man/stackctl-changes.1.ronn: -------------------------------------------------------------------------------- 1 | stackctl-changes(1) - create and present Change Sets for stack specifications 2 | ============================================================================= 3 | 4 | ## SYNOPSIS 5 | 6 | `stackctl changes` [] 7 | 8 | ## DESCRIPTION 9 | 10 | For each stack specification in the currently-active AWS Account and Region, 11 | creates a Change Set and prints it. The Change Set is not removed after 12 | successful operation. 13 | 14 | ## OPTIONS 15 | 16 | * `-f`, `--format`=: 17 | Output changes in . See dedicated section. 18 | 19 | * `--no-include-full`: 20 | Don't include full Change Set JSON details. This option only applies to the 21 | format. 22 | 23 | * `-p`, `--parameter`=: 24 | Override the given Parameter for this operation. Omitting will 25 | result in overriding the Parameter as an empty string. May be specified 0 or 26 | more times. 27 | 28 | * `-t`, `--tag`=: 29 | Override the given Tag for this operation. Omitting will result in 30 | overriding the Tag as an empty string. May be specified 0 or more times. 31 | 32 | * `PATH`: 33 | Write changes to , instead of printing them. 34 | 35 | ## AVAILABLE FORMATS 36 | 37 | * `tty`: 38 | The default. Produces a simplified but colorized (unless redirected) 39 | listing. 40 | 41 | * `pr`: 42 | Produces markdown suitable to post as a comment to a GitHub Pull Request. 43 | -------------------------------------------------------------------------------- /man/stackctl-deploy.1.ronn: -------------------------------------------------------------------------------- 1 | stackctl-deploy(1) - deploy stack specifications 2 | ================================================ 3 | 4 | ## SYNOPSIS 5 | 6 | `stackctl deploy` [] 7 | 8 | ## DESCRIPTION 9 | 10 | For each stack specification in the currently-active AWS Account and Region, 11 | creates a Change Set and executes it after confirmation. 12 | 13 | ## OPTIONS 14 | 15 | * `-p`, `--parameter`=: 16 | Override the given Parameter for this operation. Omitting will 17 | result in overriding the Parameter as an empty string. May be specified 0 or 18 | more times. 19 | 20 | * `-t`, `--tag`=: 21 | Override the given Tag for this operation. Omitting will result in 22 | overriding the Tag as an empty string. May be specified 0 or more times. 23 | 24 | * `--save-change-sets`=: 25 | Save generated Change Sets to `{PATH}/{STACK}.json`. 26 | 27 | * `--no-confirm`: 28 | Don't confirm before deployment. 29 | 30 | * `--clean`: 31 | If successful, remove all Change Sets from the deployed Stack. 32 | -------------------------------------------------------------------------------- /man/stackctl-ls.1.ronn: -------------------------------------------------------------------------------- 1 | stackctl-ls(1) - list stack specifications 2 | ========================================== 3 | 4 | ## SYNOPSIS 5 | 6 | `stackctl ls` [] 7 | 8 | ## DESCRIPTION 9 | 10 | This command locates `stacks/` for the currently-authorized AWS Account and 11 | Region and lists them. 12 | 13 | The key differences between this and stackctl-cat(1) is that this command lists 14 | things as simple rows and indicates for each spec the state of the stack in the 15 | first column. 16 | 17 | ## OPTIONS 18 | 19 | * `--no-legend`: 20 | Don't print indicators legend at the end. 21 | -------------------------------------------------------------------------------- /man/stackctl-version.1.ronn: -------------------------------------------------------------------------------- 1 | stackctl-version(1) - display version information about Stackctl 2 | ================================================================ 3 | 4 | ## SYNOPSIS 5 | 6 | `stackctl version` 7 | 8 | ## OPTIONS 9 | 10 | None. 11 | -------------------------------------------------------------------------------- /man/stackctl.1.ronn: -------------------------------------------------------------------------------- 1 | stackctl(1) - manage CloudFormation Stacks through specifications 2 | ================================================================= 3 | 4 | ## SYNOPSIS 5 | 6 | `stackctl` [] 7 | 8 | ## OPTIONS 9 | 10 | * `-d`, `--directory`=: 11 | Where to find specifications. Default is `.`. 12 | 13 | * `--filter`=: 14 | Restrict specifications to those whose paths match any given . 15 | 16 | * `--color`=: 17 | When to colorize output. `auto` (the default) will colorize output when 18 | connected to a terminal. 19 | 20 | * `-v`, `--verbose`: 21 | Log more verbosely 22 | 23 | * `--auto-sso`=: 24 | When to automatically run `aws sso login` in response to AWS SSO 25 | authorization errors. `always`, `ask`, or `never`. Default is to `ask`. 26 | 27 | ## COMMANDS 28 | 29 | * `cat`: 30 | Pretty-print specifications. 31 | 32 | * `capture`: 33 | Generate specifications for already-deployed Stacks. 34 | 35 | * `changes`: 36 | Show changes between on-disk specifications and their deployed state. 37 | 38 | * `deploy`: 39 | Make deployed state match on-disk specifications. 40 | 41 | * `ls`: 42 | List specifications. 43 | 44 | * `version`: 45 | Print the CLI's version. 46 | 47 | Run `man stackctl ` for more details. 48 | 49 | ## STACK SPECIFICATIONS 50 | 51 | A *Stack Specification* is a file format and file-system structure used to fully 52 | describe a deployed (or deployable) CloudFormation Stack. *stackctl* is your way 53 | of creating, displaying, and using such files. 54 | 55 | ### FORMAT 56 | 57 | Specification files ("specs") have the following path structure: 58 | 59 | stacks/{account-id}.{account-name}/{region}/{stack-name}.yaml 60 | 61 | Its constituent parts are used as follows: 62 | 63 | * `{account-id}`: 64 | The AWS Account Id in which to deploy this Stack. 65 | 66 | * `{account-name}`: 67 | A friendly name for this Account. This is never used logically and can be 68 | whatever you find useful for identifying this Account. 69 | 70 | * `{region}`: 71 | The AWS Region in which to deploy this Stack. 72 | 73 | * `{stack-name}`: 74 | The name to use for this Stack. 75 | 76 | `{stack/name}`.yaml is also supported, so that directories can be used for 77 | your own organization. Such paths will have directory-separators replaced by 78 | hyphens when used. 79 | 80 | These files' contents should be: 81 | 82 | Description: 83 | 84 | Template: 85 | 86 | Depends: 87 | - 88 | 89 | Actions: 90 | - on: 91 | run: 92 | : 93 | 94 | Parameters: Object 95 | 96 | Capabilities: 97 | - 98 | 99 | Tags: Object 100 | 101 | And these constituent parts are used as follows: 102 | 103 | * `{.Description}`: 104 | Optional. Set the Stack's description. 105 | 106 | This value will be inserted as the *Description* key in the template body on 107 | deployment, which becomes the deployed Stack's description. If the template 108 | already contains a description, the specification value will be ignored. 109 | 110 | * `{.Template}`: 111 | Required. The template to use when deploying this Stack. Must be a relative 112 | path under `templates/`. 113 | 114 | * `{.Depends}`: 115 | Optional. Other Stacks (by name) that should be ordered before this one if 116 | deployed together. 117 | 118 | * `{.Actions}`: 119 | Optional. Actions to run when certain Stack management events occur. 120 | 121 | * `{.Actions[].on}`: 122 | The event on which to perform the action: 123 | 124 | **PostDeploy**: run the action after a successful deployment. 125 | 126 | * `{.Actions[].run}`: 127 | An action or list of actions to perform on the given event: 128 | 129 | **InvokeLambdaByStackOutput**: : invoke the function whose name 130 | is found in the given Output of the deployed Stack. 131 | 132 | **InvokeLambdaByName**: : invoke the given function. 133 | 134 | **Exec**: [, ]: execute the given `command` and 135 | `argument`s. 136 | 137 | **Shell**: : execute the given argument via `sh -c`. 138 | 139 | Executed processes will inherit any environment variables and print their 140 | own `stdout` and `stderr`. If they do not exit 0, an exception is thrown and 141 | `stackctl` itself exits. 142 | 143 | * `{.Parameters}`: 144 | Optional. Parameters to use when deploying the Stack. 145 | 146 | The _Parameters_ key can be specified in any of 3 forms: 147 | 148 | # Natural (recommended) 149 | Parameters: 150 | Foo: Bar 151 | Baz: Bat 152 | 153 | # CloudFormation 154 | Parameters: 155 | - ParameterKey: Foo 156 | ParameterValue: Bar 157 | - ParameterKey: Baz 158 | ParameterValue: Bat 159 | 160 | # CloudGenesis 161 | Parameters: 162 | - Key: Foo 163 | Value: Bar 164 | - Key: Baz 165 | Value: Bat 166 | 167 | * `{.Capabilities}`: 168 | Optional. Capabilities to use when deploying the Stack. 169 | 170 | Valid _Capabilities_ are **CAPABILITY_AUTO_EXPAND**, **CAPABILITY_IAM**, and 171 | **CAPABILITY_NAMED_IAM**. 172 | 173 | * `{.Tags}`: 174 | Optional. Tags to use when deploying the Stack. 175 | 176 | The _Tags_ key can be specified in either of 2 forms: 177 | 178 | # Natural (recommended) 179 | Tags: 180 | Foo: Bar 181 | Baz: Bat 182 | 183 | # CloudFormation / CloudGenesis 184 | Parameters: 185 | - Key: Foo 186 | Value: Bar 187 | - Key: Baz 188 | Value: Bat 189 | 190 | ## EXAMPLE 191 | 192 | The following example shares a single Template between two deployments in two 193 | regions of a single account. 194 | 195 | stacks/ 196 | 111111111111.prod/ 197 | us-east-1/ 198 | my-app.yaml 199 | | Template: web.yaml 200 | | Parameters: 201 | | ... 202 | 203 | us-west-2/ 204 | my-app.yaml 205 | | Template: web.yaml 206 | | Parameters: 207 | | ... 208 | 209 | templates/ 210 | web.yaml 211 | | Parameters: 212 | | ... 213 | | Resources: 214 | | ... 215 | 216 | ## DEPLOYMENT 217 | 218 | Once we have a specification, deployment is _conceptually_ simple: 219 | 220 | aws configure # for {account-id} 221 | 222 | aws --region {region} cloudformation deploy \ 223 | --stack-name {stack-name} \ 224 | --template-file templates/{.Template} \ 225 | --parameter-overrides {.Parameters} \ 226 | --capabilities {.Capabilities} \ 227 | --tags {.Tags} 228 | 229 | In reality, we create changesets, optionally present them for review, execute 230 | them, wait, stream events, and finally clean up. 231 | 232 | See stackctl-changes(1) and stackctl-deploy(1). 233 | 234 | ## ENVIRONMENT 235 | 236 | * `STACKCTL_DIRECTORY`: 237 | Environment-based alternative for `--directory`. 238 | 239 | * `STACKCTL_FILTER`: 240 | Environment-based alternative for `--filter`. 241 | 242 | * `STACKCTL_AUTO_SSO`: 243 | Environment-based alternative for `--auto-sso`. 244 | 245 | * `LOG_*`: 246 | Variables such as *LOG_COLOR* or *LOG_LEVEL* will be respected by the 247 | underlying logging framework (Blammo). Please see [its documentation][blammo] 248 | for complete details. 249 | 250 | [blammo]: https://github.com/freckle/blammo#configuration 251 | 252 | * `AWS_PROFILE`: 253 | If set, will be used as in commands that create new 254 | specifications. 255 | 256 | ## AUTHOR 257 | 258 | Freckle Engineering 259 | 260 | ## SEE ALSO 261 | 262 | stackctl-cat(1), stackctl-capture(1), stackctl-changes(1), stackctl-deploy(1), 263 | stackctl-ls(1), stackctl-version(1). 264 | 265 | ## ACKNOWLEDGEMENTS 266 | 267 | The specification format and semantics is a minor extension of that used by the 268 | CloudGenesis project, capturing more of a CloudFormation Stack's deployed state 269 | statically is terraform-inspired, and GitOps as an approach was pioneered for 270 | Kubernetes by Flux CD. 271 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: stackctl 2 | version: 1.7.2.0 3 | github: freckle/stackctl 4 | license: MIT 5 | author: Freckle Engineering 6 | maintainer: freckle-engineering@renaissance.com 7 | copyright: 2022 Renaissance Learning Inc 8 | 9 | extra-doc-files: 10 | - README.md 11 | - CHANGELOG.md 12 | 13 | description: Please see 14 | 15 | dependencies: 16 | - base >= 4 && < 5 17 | 18 | ghc-options: 19 | - -fignore-optim-changes 20 | - -fwrite-ide-info 21 | - -Weverything 22 | - -Wno-all-missed-specialisations 23 | - -Wno-missed-specialisations 24 | - -Wno-missing-import-lists 25 | - -Wno-missing-kind-signatures 26 | - -Wno-missing-local-signatures 27 | - -Wno-missing-role-annotations 28 | - -Wno-missing-safe-haskell-mode 29 | - -Wno-prepositive-qualified-module 30 | - -Wno-unsafe 31 | - -optP-Wno-nonportable-include-path # workaround [Filename case on macOS · Issue #4739 · haskell/cabal](https://github.com/haskell/cabal/issues/4739) 32 | 33 | default-extensions: 34 | - BangPatterns 35 | - DataKinds 36 | - DeriveAnyClass 37 | - DeriveFoldable 38 | - DeriveFunctor 39 | - DeriveGeneric 40 | - DeriveLift 41 | - DeriveTraversable 42 | - DerivingStrategies 43 | - DerivingVia 44 | - FlexibleContexts 45 | - FlexibleInstances 46 | - GADTs 47 | - GeneralizedNewtypeDeriving 48 | - LambdaCase 49 | - MultiParamTypeClasses 50 | - NoImplicitPrelude 51 | - NoMonomorphismRestriction 52 | - OverloadedStrings 53 | - RankNTypes 54 | - RecordWildCards 55 | - ScopedTypeVariables 56 | - StandaloneDeriving 57 | - TypeApplications 58 | - TypeFamilies 59 | 60 | library: 61 | source-dirs: src 62 | dependencies: 63 | - Blammo >= 1.1.2.3 # flushLogger bugfix 64 | - Glob 65 | - QuickCheck 66 | - aeson 67 | - aeson-casing 68 | - aeson-pretty 69 | - amazonka >= 2.0 70 | - amazonka-cloudformation >= 2.0 71 | - amazonka-core >= 2.0 72 | - amazonka-ec2 >= 2.0 73 | - amazonka-lambda >= 2.0 74 | - amazonka-mtl 75 | - amazonka-sso >= 2.0 76 | - amazonka-sts >= 2.0 77 | - bytestring 78 | - cfn-flip >= 0.1.0.3 # bugfix for Condition 79 | - conduit 80 | - containers 81 | - envparse 82 | - errors 83 | - exceptions 84 | - extra 85 | - filepath 86 | - lens 87 | - lens-aeson 88 | - monad-logger 89 | - mtl 90 | - optparse-applicative 91 | - resourcet 92 | - rio 93 | - semigroups 94 | - text 95 | - text-metrics 96 | - time 97 | - transformers 98 | - typed-process 99 | - unix 100 | - unliftio >= 0.2.25.0 # UnliftIO.Exception.Lens 101 | - unordered-containers 102 | - uuid 103 | - yaml 104 | 105 | executables: 106 | stackctl: 107 | main: Main.hs 108 | source-dirs: app 109 | dependencies: 110 | - stackctl 111 | ghc-options: 112 | - -threaded 113 | - -rtsopts 114 | - -with-rtsopts=-N 115 | 116 | tests: 117 | spec: 118 | main: Spec.hs 119 | source-dirs: test 120 | dependencies: 121 | - Blammo 122 | - Glob 123 | - QuickCheck 124 | - aeson 125 | - amazonka 126 | - amazonka-cloudformation 127 | - amazonka-ec2 128 | - amazonka-lambda 129 | - amazonka-mtl 130 | - bytestring 131 | - filepath 132 | - hspec 133 | - hspec-expectations-lifted 134 | - hspec-golden >= 0.2.1.0 135 | - http-types 136 | - lens 137 | - mtl 138 | - stackctl 139 | - text 140 | - time 141 | - unliftio 142 | - yaml 143 | -------------------------------------------------------------------------------- /renovate.json: -------------------------------------------------------------------------------- 1 | { 2 | "$schema": "https://docs.renovatebot.com/renovate-schema.json", 3 | "extends": [ 4 | "local>freckle/renovate-config" 5 | ], 6 | "minimumReleaseAge": "0 days" 7 | } 8 | -------------------------------------------------------------------------------- /src/Stackctl/AWS.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS 2 | ( module X 3 | ) where 4 | 5 | import Stackctl.AWS.CloudFormation as X 6 | import Stackctl.AWS.Core as X 7 | import Stackctl.AWS.EC2 as X 8 | import Stackctl.AWS.STS as X 9 | -------------------------------------------------------------------------------- /src/Stackctl/AWS/Core.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS.Core 2 | ( MonadAWS 3 | , send 4 | , paginate 5 | , await 6 | , withAuth 7 | , localEnv 8 | 9 | -- * "Control.Monad.AWS" extensions 10 | , simple 11 | , discover 12 | , withAssumedRole 13 | 14 | -- * Error-handling 15 | , handlingServiceError 16 | , formatServiceError 17 | 18 | -- * "Amazonka" extensions 19 | , AccountId (..) 20 | 21 | -- * "Amazonka" re-exports 22 | , Region (..) 23 | , FromText (..) 24 | , ToText (..) 25 | 26 | -- * Deprecated 27 | , assumeRole 28 | ) where 29 | 30 | import Stackctl.Prelude 31 | 32 | import Amazonka 33 | ( AWSRequest 34 | , AWSResponse 35 | , Env' (auth) 36 | , Region 37 | , ServiceError 38 | , serviceError_code 39 | , serviceError_message 40 | , serviceError_requestId 41 | , _Sensitive 42 | , _ServiceError 43 | ) 44 | import qualified Amazonka 45 | import Amazonka.Auth.Background (fetchAuthInBackground) 46 | import Amazonka.Auth.Keys (fromSession) 47 | import Amazonka.Data.Text (FromText (..), ToText (..)) 48 | import qualified Amazonka.Env as Amazonka 49 | import Amazonka.STS.AssumeRole 50 | import Control.Monad.AWS 51 | import Control.Monad.Logger (defaultLoc, toLogStr) 52 | import Data.Typeable (typeRep) 53 | import Stackctl.AWS.Orphans () 54 | import UnliftIO.Exception.Lens (handling) 55 | 56 | discover :: MonadLoggerIO m => m Amazonka.Env 57 | discover = do 58 | env <- liftIO $ Amazonka.newEnv Amazonka.discover 59 | loggerIO <- askLoggerIO 60 | 61 | let logger level = do 62 | loggerIO 63 | defaultLoc 64 | "Amazonka" 65 | ( case level of 66 | Amazonka.Info -> LevelInfo 67 | Amazonka.Error -> LevelError 68 | Amazonka.Debug -> LevelDebug 69 | Amazonka.Trace -> LevelOther "trace" 70 | ) 71 | . toLogStr 72 | pure $ env & Amazonka.env_logger .~ logger 73 | 74 | simple 75 | :: forall a m b 76 | . ( HasCallStack 77 | , MonadIO m 78 | , MonadAWS m 79 | , AWSRequest a 80 | ) 81 | => a 82 | -> (AWSResponse a -> Maybe b) 83 | -> m b 84 | simple req post = do 85 | resp <- send req 86 | 87 | let 88 | name = show $ typeRep $ Proxy @a 89 | err = name <> " successful, but processing the response failed" 90 | 91 | maybe (throwString err) pure $ post resp 92 | 93 | -- | Use 'withAssumedRole' instead 94 | -- 95 | -- This function is like 'withAssumedRole' except it doesn't spawn a background 96 | -- thread to keep credentials refreshed. You may encounter expired credentials 97 | -- if the block used under 'assumeRole' goes for long enough. 98 | assumeRole 99 | :: (MonadIO m, MonadAWS m) 100 | => Text 101 | -- ^ Role ARN 102 | -> Text 103 | -- ^ Session name 104 | -> m a 105 | -- ^ Action to run as the assumed role 106 | -> m a 107 | assumeRole role sessionName f = do 108 | let req = newAssumeRole role sessionName 109 | 110 | assumeEnv <- simple req $ \resp -> do 111 | let creds = resp ^. assumeRoleResponse_credentials 112 | token <- creds ^. Amazonka.authEnv_sessionToken 113 | 114 | let 115 | accessKeyId = creds ^. Amazonka.authEnv_accessKeyId 116 | secretAccessKey = creds ^. Amazonka.authEnv_secretAccessKey . _Sensitive 117 | sessionToken = token ^. _Sensitive 118 | 119 | pure $ fromSession accessKeyId secretAccessKey sessionToken 120 | 121 | localEnv assumeEnv f 122 | {-# DEPRECATED assumeRole "Use withAssumedRole instead" #-} 123 | 124 | -- | Assume a role using the @sts:AssumeRole@ API and run an action 125 | withAssumedRole 126 | :: (MonadUnliftIO m, MonadAWS m) 127 | => Text 128 | -- ^ Role ARN 129 | -> Text 130 | -- ^ Role session name 131 | -> m a 132 | -- ^ Action to run as the assumed role 133 | -> m a 134 | withAssumedRole roleArn roleSessionName f = do 135 | keys <- withRunInIO $ \runInIO -> do 136 | let getCredentials = do 137 | resp <- 138 | runInIO 139 | $ send 140 | $ newAssumeRole roleArn roleSessionName 141 | pure $ resp ^. assumeRoleResponse_credentials 142 | 143 | fetchAuthInBackground getCredentials 144 | 145 | localEnv (\env -> env {auth = Identity keys}) f 146 | 147 | newtype AccountId = AccountId 148 | { unAccountId :: Text 149 | } 150 | deriving newtype (Eq, Ord, Show, ToJSON) 151 | 152 | -- | Handle 'ServiceError', log it and 'exitFailure' 153 | -- 154 | -- This is useful at the top-level of the app, where we'd be crashing anyway. It 155 | -- makes things more readable and easier to debug. 156 | handlingServiceError :: (MonadUnliftIO m, MonadLogger m) => m a -> m a 157 | handlingServiceError = 158 | handling _ServiceError $ \e -> do 159 | logError 160 | $ "Exiting due to AWS Service error" 161 | :# [ "code" .= toText (e ^. serviceError_code) 162 | , "message" .= fmap toText (e ^. serviceError_message) 163 | , "requestId" .= fmap toText (e ^. serviceError_requestId) 164 | ] 165 | exitFailure 166 | 167 | formatServiceError :: ServiceError -> Text 168 | formatServiceError e = 169 | mconcat 170 | [ toText $ e ^. serviceError_code 171 | , maybe "" ((": " <>) . toText) $ e ^. serviceError_message 172 | , maybe "" (("\nRequest Id: " <>) . toText) $ e ^. serviceError_requestId 173 | ] 174 | -------------------------------------------------------------------------------- /src/Stackctl/AWS/EC2.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS.EC2 2 | ( awsEc2DescribeFirstAvailabilityZoneRegionName 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Amazonka.EC2.DescribeAvailabilityZones 8 | import Amazonka.EC2.Types (AvailabilityZone (..)) 9 | import Stackctl.AWS.Core as AWS 10 | 11 | awsEc2DescribeFirstAvailabilityZoneRegionName 12 | :: (MonadIO m, MonadAWS m) => m Region 13 | awsEc2DescribeFirstAvailabilityZoneRegionName = do 14 | let req = newDescribeAvailabilityZones 15 | AWS.simple req $ \resp -> do 16 | azs <- resp ^. describeAvailabilityZonesResponse_availabilityZones 17 | az <- listToMaybe azs 18 | rn <- regionName az 19 | hush $ fromText rn 20 | -------------------------------------------------------------------------------- /src/Stackctl/AWS/Lambda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | module Stackctl.AWS.Lambda 4 | ( LambdaInvokeResult (..) 5 | , LambdaError (..) 6 | , logLambdaInvocationResult 7 | , isLambdaInvocationSuccess 8 | , awsLambdaInvoke 9 | ) where 10 | 11 | import Stackctl.Prelude hiding (trace) 12 | 13 | import Amazonka (globalTimeout) 14 | import Amazonka.Lambda.Invoke 15 | import Data.Aeson 16 | import qualified Data.ByteString.Lazy as BSL 17 | import Stackctl.AWS.Core as AWS 18 | 19 | data LambdaInvokeResult 20 | = LambdaInvokeSuccess ByteString 21 | | LambdaInvokeError LambdaError (Maybe Text) 22 | | LambdaInvokeFailure Int (Maybe Text) 23 | deriving stock (Show) 24 | 25 | logLambdaInvocationResult :: MonadLogger m => LambdaInvokeResult -> m () 26 | logLambdaInvocationResult = \case 27 | LambdaInvokeSuccess bs -> do 28 | let meta = case decode @Value $ BSL.fromStrict bs of 29 | Nothing -> ["response" .= decodeUtf8 bs] 30 | Just response -> ["response" .= response] 31 | logInfo $ "LambdaInvokeSuccess" :# meta 32 | LambdaInvokeError LambdaError {..} mFunctionError -> 33 | logError 34 | $ (:# []) 35 | $ mconcat 36 | [ "LambdaInvokeError" 37 | , "\n errorType: " <> errorType 38 | , "\n errorMessage: " <> errorMessage 39 | , "\n trace: " 40 | , mconcat $ map ("\n " <>) trace 41 | , "\n FunctionError: " <> fromMaybe "none" mFunctionError 42 | ] 43 | LambdaInvokeFailure status mFunctionError -> 44 | logError 45 | $ (:# []) 46 | $ mconcat 47 | [ "LambdaInvokeFailure" 48 | , "\n StatusCode: " <> pack (show status) 49 | , "\n FunctionError: " <> fromMaybe "none" mFunctionError 50 | ] 51 | 52 | isLambdaInvocationSuccess :: LambdaInvokeResult -> Bool 53 | isLambdaInvocationSuccess = \case 54 | LambdaInvokeSuccess {} -> True 55 | LambdaInvokeError {} -> False 56 | LambdaInvokeFailure {} -> False 57 | 58 | data LambdaError = LambdaError 59 | { errorType :: Text 60 | , errorMessage :: Text 61 | , trace :: [Text] 62 | } 63 | deriving stock (Eq, Show, Generic) 64 | deriving anyclass (FromJSON, ToJSON) 65 | 66 | awsLambdaInvoke 67 | :: ( MonadIO m 68 | , MonadLogger m 69 | , MonadAWS m 70 | , ToJSON a 71 | ) 72 | => Text 73 | -> a 74 | -- ^ Payload 75 | -> m LambdaInvokeResult 76 | awsLambdaInvoke name payload = do 77 | logDebug $ "Invoking function" :# ["name" .= name] 78 | 79 | -- Match Lambda's own limit (15 minutes) and add some buffer 80 | resp <- 81 | AWS.localEnv (globalTimeout 905) 82 | $ AWS.send 83 | $ newInvoke name 84 | $ BSL.toStrict 85 | $ encode 86 | payload 87 | 88 | let 89 | status = resp ^. invokeResponse_statusCode 90 | mError = decode . BSL.fromStrict =<< resp ^. invokeResponse_payload 91 | mFunctionError = resp ^. invokeResponse_functionError 92 | response = fromMaybe "" $ resp ^. invokeResponse_payload 93 | 94 | logDebug 95 | $ "Function result" 96 | :# [ "name" .= name 97 | , "status" .= status 98 | , "error" .= mError 99 | , "functionError" .= mFunctionError 100 | ] 101 | 102 | pure 103 | $ if 104 | | statusIsUnsuccessful status -> LambdaInvokeFailure status mFunctionError 105 | | Just e <- mError -> LambdaInvokeError e mFunctionError 106 | | otherwise -> LambdaInvokeSuccess response 107 | 108 | statusIsUnsuccessful :: Int -> Bool 109 | statusIsUnsuccessful s = s < 200 || s >= 300 110 | -------------------------------------------------------------------------------- /src/Stackctl/AWS/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | -- | 5 | -- 6 | -- Orphans so we can get @'ToJSON' 'ChangeSet'@ without hand-writing a massive, 7 | -- incomplete, and doomed-to-drift instance ourselves. 8 | module Stackctl.AWS.Orphans () where 9 | 10 | import Stackctl.Prelude 11 | 12 | import Amazonka.CloudFormation.DescribeChangeSet 13 | import Amazonka.CloudFormation.Types 14 | import Data.Aeson 15 | import GHC.Generics (Rep) 16 | 17 | -- TODO: upstream 18 | deriving newtype instance MonadUnliftIO m => MonadUnliftIO (WithLogger env m) 19 | 20 | -- Makes it syntactally easier to do a bunch of these 21 | newtype Generically a = Generically {unGenerically :: a} 22 | 23 | instance 24 | ( Generic a 25 | , GFromJSON Zero (Rep a) 26 | ) 27 | => FromJSON (Generically a) 28 | where 29 | parseJSON = fmap Generically . genericParseJSON defaultOptions 30 | 31 | instance 32 | ( Generic a 33 | , GToJSON' Value Zero (Rep a) 34 | , GToJSON' Encoding Zero (Rep a) 35 | ) 36 | => ToJSON (Generically a) 37 | where 38 | toJSON = genericToJSON defaultOptions . unGenerically 39 | toEncoding = genericToEncoding defaultOptions . unGenerically 40 | 41 | {- FOURMOLU_DISABLE -} 42 | 43 | deriving via (Generically Change) instance FromJSON Change 44 | deriving via (Generically Change) instance ToJSON Change 45 | deriving via (Generically DescribeChangeSetResponse) instance FromJSON DescribeChangeSetResponse 46 | deriving via (Generically DescribeChangeSetResponse) instance ToJSON DescribeChangeSetResponse 47 | deriving via (Generically ModuleInfo) instance FromJSON ModuleInfo 48 | deriving via (Generically ModuleInfo) instance ToJSON ModuleInfo 49 | deriving via (Generically Parameter) instance FromJSON Parameter 50 | deriving via (Generically Parameter) instance ToJSON Parameter 51 | deriving via (Generically ResourceChange) instance FromJSON ResourceChange 52 | deriving via (Generically ResourceChange) instance ToJSON ResourceChange 53 | deriving via (Generically ResourceChangeDetail) instance FromJSON ResourceChangeDetail 54 | deriving via (Generically ResourceChangeDetail) instance ToJSON ResourceChangeDetail 55 | deriving via (Generically ResourceTargetDefinition) instance FromJSON ResourceTargetDefinition 56 | deriving via (Generically ResourceTargetDefinition) instance ToJSON ResourceTargetDefinition 57 | deriving via (Generically RollbackConfiguration) instance FromJSON RollbackConfiguration 58 | deriving via (Generically RollbackConfiguration) instance ToJSON RollbackConfiguration 59 | deriving via (Generically RollbackTrigger) instance FromJSON RollbackTrigger 60 | deriving via (Generically RollbackTrigger) instance ToJSON RollbackTrigger 61 | deriving via (Generically Tag) instance FromJSON Tag 62 | deriving via (Generically Tag) instance ToJSON Tag 63 | -------------------------------------------------------------------------------- /src/Stackctl/AWS/STS.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS.STS 2 | ( awsGetCallerIdentityAccount 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Amazonka.STS.GetCallerIdentity 8 | import Stackctl.AWS.Core as AWS 9 | 10 | awsGetCallerIdentityAccount :: (MonadIO m, MonadAWS m) => m AccountId 11 | awsGetCallerIdentityAccount = do 12 | AWS.simple newGetCallerIdentity $ \resp -> do 13 | AccountId <$> resp ^. getCallerIdentityResponse_account 14 | -------------------------------------------------------------------------------- /src/Stackctl/AWS/Scope.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS.Scope 2 | ( AwsScope (..) 3 | , awsScopeSpecPatterns 4 | , awsScopeSpecStackName 5 | , HasAwsScope (..) 6 | , fetchAwsScope 7 | ) where 8 | 9 | import Stackctl.Prelude 10 | 11 | import qualified Data.Text as T 12 | import Stackctl.AWS 13 | import System.Environment (lookupEnv) 14 | import System.FilePath (joinPath, splitPath) 15 | import System.FilePath.Glob (Pattern, compile, match) 16 | 17 | data AwsScope = AwsScope 18 | { awsAccountId :: AccountId 19 | , awsAccountName :: Text 20 | , awsRegion :: Region 21 | } 22 | deriving stock (Eq, Show, Generic) 23 | deriving anyclass (ToJSON) 24 | 25 | awsScopeSpecPatterns :: AwsScope -> [Pattern] 26 | awsScopeSpecPatterns AwsScope {..} = 27 | [ compile 28 | $ "stacks" 29 | unpack (unAccountId awsAccountId) <> ".*" 30 | unpack (fromRegion awsRegion) 31 | "**" 32 | "*" <.> "yaml" 33 | , compile 34 | $ "stacks" 35 | "*." <> unpack (unAccountId awsAccountId) 36 | unpack (fromRegion awsRegion) 37 | "**" 38 | "*" <.> "yaml" 39 | ] 40 | 41 | awsScopeSpecStackName :: AwsScope -> FilePath -> Maybe StackName 42 | awsScopeSpecStackName scope path = do 43 | guard $ any (`match` path) $ awsScopeSpecPatterns scope 44 | 45 | -- once we've guarded that the path matches our scope patterns, we can play it 46 | -- pretty fast and loose with the "parsing" step 47 | pure 48 | $ path -- stacks/account/region/x/y.yaml 49 | & splitPath -- [stacks/, account/, region/, x/, y.yaml] 50 | & drop 3 -- [x, y.yaml] 51 | & joinPath -- x/y.yaml 52 | & dropExtension -- x/y 53 | & pack 54 | & T.replace "/" "-" -- x-y 55 | & StackName 56 | 57 | class HasAwsScope env where 58 | awsScopeL :: Lens' env AwsScope 59 | 60 | instance HasAwsScope AwsScope where 61 | awsScopeL = id 62 | 63 | fetchAwsScope :: (MonadIO m, MonadAWS m) => m AwsScope 64 | fetchAwsScope = 65 | AwsScope 66 | <$> awsGetCallerIdentityAccount 67 | <*> liftIO (maybe "unknown" pack <$> lookupEnv "AWS_PROFILE") 68 | <*> awsEc2DescribeFirstAvailabilityZoneRegionName 69 | -------------------------------------------------------------------------------- /src/Stackctl/Action.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | -- | Actions that can be performed on certain Stack management events 4 | -- 5 | -- For example, to invoke a Lambda whose name is found in the deploying Stack's 6 | -- outputs after it's been deployed: 7 | -- 8 | -- @ 9 | -- Actions: 10 | -- - on: PostDeploy 11 | -- run: 12 | -- InvokeLambdaByStackOutput: OnDeployFunction 13 | -- @ 14 | module Stackctl.Action 15 | ( Action 16 | , newAction 17 | , ActionOn (..) 18 | , ActionRun (..) 19 | , runActions 20 | ) where 21 | 22 | import Stackctl.Prelude hiding (on) 23 | 24 | import Blammo.Logging.Logger (flushLogger) 25 | import Data.Aeson 26 | import Data.List (find) 27 | import qualified Data.List.NonEmpty as NE 28 | import Stackctl.AWS 29 | import Stackctl.AWS.Lambda 30 | import Stackctl.OneOrListOf 31 | import qualified Stackctl.OneOrListOf as OneOrListOf 32 | import System.Process.Typed 33 | 34 | data Action = Action 35 | { on :: ActionOn 36 | , run :: OneOrListOf ActionRun 37 | } 38 | deriving stock (Eq, Show, Generic) 39 | deriving anyclass (FromJSON, ToJSON) 40 | 41 | newAction :: ActionOn -> [ActionRun] -> Action 42 | newAction on runs = Action {on, run = OneOrListOf.fromList runs} 43 | 44 | data ActionOn = PostDeploy 45 | deriving stock (Eq, Show, Generic) 46 | 47 | instance FromJSON ActionOn where 48 | parseJSON = withText "ActionOn" $ \case 49 | "PostDeploy" -> pure PostDeploy 50 | x -> 51 | fail $ "Invalid ActionOn: " <> show x <> ", must be one of [PostDeploy]" 52 | 53 | instance ToJSON ActionOn where 54 | toJSON = \case 55 | PostDeploy -> toJSON @Text "PostDeploy" 56 | toEncoding = \case 57 | PostDeploy -> toEncoding @Text "PostDeploy" 58 | 59 | data ActionRun 60 | = InvokeLambdaByStackOutput Text 61 | | InvokeLambdaByName Text 62 | | Exec (NonEmpty String) 63 | | Shell String 64 | deriving stock (Eq, Show) 65 | 66 | instance FromJSON ActionRun where 67 | parseJSON = withObject "ActionRun" $ \o -> 68 | (InvokeLambdaByStackOutput <$> o .: "InvokeLambdaByStackOutput") 69 | <|> (InvokeLambdaByName <$> o .: "InvokeLambdaByName") 70 | <|> (Exec <$> o .: "Exec") 71 | <|> (Shell <$> o .: "Shell") 72 | 73 | instance ToJSON ActionRun where 74 | toJSON = 75 | object . \case 76 | InvokeLambdaByStackOutput name -> ["InvokeLambdaByStackOutput" .= name] 77 | InvokeLambdaByName name -> ["InvokeLambdaByName" .= name] 78 | Exec args -> ["Exec" .= args] 79 | Shell arg -> ["Shell" .= arg] 80 | toEncoding = 81 | pairs . \case 82 | InvokeLambdaByStackOutput name -> "InvokeLambdaByStackOutput" .= name 83 | InvokeLambdaByName name -> "InvokeLambdaByName" .= name 84 | Exec args -> "Exec" .= args 85 | Shell arg -> "Shell" .= arg 86 | 87 | data ActionFailure 88 | = NoSuchOutput 89 | | InvokeLambdaFailure 90 | | ExecFailure ExitCode 91 | deriving stock (Show) 92 | deriving anyclass (Exception) 93 | 94 | runActions 95 | :: ( MonadIO m 96 | , MonadLogger m 97 | , MonadAWS m 98 | , MonadReader env m 99 | , HasLogger env 100 | ) 101 | => StackName 102 | -> ActionOn 103 | -> [Action] 104 | -> m () 105 | runActions stackName on = 106 | traverse_ (runAction stackName) . filter (`shouldRunOn` on) 107 | 108 | shouldRunOn :: Action -> ActionOn -> Bool 109 | shouldRunOn Action {on} on' = on == on' 110 | 111 | runAction 112 | :: ( MonadIO m 113 | , MonadLogger m 114 | , MonadAWS m 115 | , MonadReader env m 116 | , HasLogger env 117 | ) 118 | => StackName 119 | -> Action 120 | -> m () 121 | runAction stackName Action {on, run} = do 122 | logInfo $ "Running action" :# ["on" .= on, "run" .= run] 123 | 124 | for_ run $ \case 125 | InvokeLambdaByStackOutput outputName -> do 126 | outputs <- awsCloudFormationDescribeStackOutputs stackName 127 | case findOutputValue outputName outputs of 128 | Nothing -> do 129 | logError 130 | $ "Output not found" 131 | :# [ "stackName" .= stackName 132 | , "desiredOutput" .= outputName 133 | , "availableOutputs" .= map (^. output_outputKey) outputs 134 | ] 135 | throwIO NoSuchOutput 136 | Just name -> invoke name 137 | InvokeLambdaByName name -> invoke name 138 | Exec args -> execProcessAction (NE.head args) (NE.tail args) 139 | Shell arg -> execProcessAction "sh" ["-c", arg] 140 | where 141 | invoke name = do 142 | result <- awsLambdaInvoke name payload 143 | logLambdaInvocationResult result 144 | unless (isLambdaInvocationSuccess result) $ throwIO InvokeLambdaFailure 145 | 146 | payload = object ["stack" .= stackName, "event" .= on] 147 | 148 | findOutputValue :: Text -> [Output] -> Maybe Text 149 | findOutputValue name = 150 | view output_outputValue <=< find ((== Just name) . view output_outputKey) 151 | 152 | execProcessAction 153 | :: (MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) 154 | => String 155 | -> [String] 156 | -> m () 157 | execProcessAction cmd args = do 158 | logDebug $ "runProcess" :# ["command" .= (cmd : args)] 159 | flushLogger 160 | 161 | ec <- runProcess $ proc cmd args 162 | unless (ec == ExitSuccess) $ throwIO $ ExecFailure ec 163 | -------------------------------------------------------------------------------- /src/Stackctl/AutoSSO.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AutoSSO 2 | ( AutoSSOOption 3 | , defaultAutoSSOOption 4 | , HasAutoSSOOption (..) 5 | , autoSSOOption 6 | , envAutoSSOOption 7 | , handleAutoSSO 8 | ) where 9 | 10 | import Stackctl.Prelude 11 | 12 | import Amazonka.SSO (_UnauthorizedException) 13 | import Data.Semigroup (Last (..)) 14 | import qualified Env 15 | import Options.Applicative 16 | import Stackctl.AWS.Core as AWS (formatServiceError) 17 | import Stackctl.Prompt 18 | import System.Process.Typed 19 | import UnliftIO.Exception.Lens (catching) 20 | 21 | data AutoSSOOption 22 | = AutoSSOAlways 23 | | AutoSSOAsk 24 | | AutoSSONever 25 | deriving (Semigroup) via Last AutoSSOOption 26 | 27 | defaultAutoSSOOption :: AutoSSOOption 28 | defaultAutoSSOOption = AutoSSOAsk 29 | 30 | readAutoSSO :: String -> Either String AutoSSOOption 31 | readAutoSSO = \case 32 | "always" -> Right AutoSSOAlways 33 | "ask" -> Right AutoSSOAsk 34 | "never" -> Right AutoSSONever 35 | x -> 36 | Left $ "Invalid choice for auto-sso: " <> x <> ", must be always|ask|never" 37 | 38 | class HasAutoSSOOption env where 39 | autoSSOOptionL :: Lens' env AutoSSOOption 40 | 41 | autoSSOOption :: Parser AutoSSOOption 42 | autoSSOOption = 43 | option (eitherReader readAutoSSO) 44 | $ mconcat [long "auto-sso", help autoSSOHelp, metavar "WHEN"] 45 | 46 | envAutoSSOOption :: Env.Parser Env.Error AutoSSOOption 47 | envAutoSSOOption = 48 | Env.var (first Env.UnreadError . readAutoSSO) "AUTO_SSO" 49 | $ Env.help autoSSOHelp 50 | 51 | autoSSOHelp :: IsString a => a 52 | autoSSOHelp = "Automatically run aws-sso-login if necessary?" 53 | 54 | handleAutoSSO 55 | :: ( MonadUnliftIO m 56 | , MonadReader env m 57 | , MonadLogger m 58 | , HasLogger env 59 | , HasAutoSSOOption options 60 | ) 61 | => options 62 | -> m a 63 | -> m a 64 | handleAutoSSO options f = do 65 | catching _UnauthorizedException f $ \ex -> do 66 | case options ^. autoSSOOptionL of 67 | AutoSSOAlways -> do 68 | logWarn $ ssoErrorMessage ex 69 | logInfo "Running `aws sso login' automatically" 70 | AutoSSOAsk -> do 71 | logWarn $ ssoErrorMessage ex 72 | promptOrExit "Run `aws sso login'" 73 | AutoSSONever -> do 74 | logError $ ssoErrorMessage ex 75 | exitFailure 76 | 77 | runProcess_ $ proc "aws" ["sso", "login"] 78 | f 79 | where 80 | ssoErrorMessage ex = 81 | "AWS SSO authorization error" 82 | :# [ "message" .= formatServiceError ex 83 | , "hint" .= ("Run `aws sso login' and try again" :: Text) 84 | ] 85 | -------------------------------------------------------------------------------- /src/Stackctl/CLI.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.CLI 2 | ( App 3 | , optionsL 4 | , AppT 5 | , runAppT 6 | ) where 7 | 8 | import Stackctl.Prelude 9 | 10 | import Blammo.Logging.LogSettings 11 | import qualified Blammo.Logging.LogSettings.Env as LoggingEnv 12 | import Control.Monad.AWS as AWS 13 | import Control.Monad.AWS.ViaReader as AWS 14 | import Control.Monad.Catch (MonadCatch) 15 | import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT) 16 | import qualified Stackctl.AWS.Core as AWS 17 | import Stackctl.AWS.Scope 18 | import Stackctl.AutoSSO 19 | import Stackctl.ColorOption 20 | import Stackctl.Config 21 | import Stackctl.DirectoryOption 22 | import Stackctl.FilterOption 23 | import Stackctl.VerboseOption 24 | 25 | data App options = App 26 | { appLogger :: Logger 27 | , appConfig :: Config 28 | , appOptions :: options 29 | , appAwsScope :: AwsScope 30 | , appAwsEnv :: AWS.Env 31 | } 32 | 33 | optionsL :: Lens' (App options) options 34 | optionsL = lens appOptions $ \x y -> x {appOptions = y} 35 | 36 | instance HasLogger (App options) where 37 | loggerL = lens appLogger $ \x y -> x {appLogger = y} 38 | 39 | instance HasConfig (App options) where 40 | configL = lens appConfig $ \x y -> x {appConfig = y} 41 | 42 | instance HasAwsScope (App options) where 43 | awsScopeL = lens appAwsScope $ \x y -> x {appAwsScope = y} 44 | 45 | instance AWS.HasEnv (App options) where 46 | envL = lens appAwsEnv $ \x y -> x {appAwsEnv = y} 47 | 48 | instance HasDirectoryOption options => HasDirectoryOption (App options) where 49 | directoryOptionL = optionsL . directoryOptionL 50 | 51 | instance HasFilterOption options => HasFilterOption (App options) where 52 | filterOptionL = optionsL . filterOptionL 53 | 54 | instance HasColorOption options => HasColorOption (App options) where 55 | colorOptionL = optionsL . colorOptionL 56 | 57 | instance HasVerboseOption options => HasVerboseOption (App options) where 58 | verboseOptionL = optionsL . verboseOptionL 59 | 60 | instance HasAutoSSOOption options => HasAutoSSOOption (App options) where 61 | autoSSOOptionL = optionsL . autoSSOOptionL 62 | 63 | newtype AppT app m a = AppT 64 | { unAppT :: ReaderT app (ResourceT m) a 65 | } 66 | deriving newtype 67 | ( Functor 68 | , Applicative 69 | , Monad 70 | , MonadIO 71 | , MonadUnliftIO 72 | , MonadResource 73 | , MonadReader app 74 | , MonadThrow 75 | , MonadCatch 76 | , MonadMask 77 | ) 78 | deriving (MonadAWS) via (ReaderAWS (AppT app m)) 79 | deriving (MonadLogger) via (WithLogger app (ResourceT m)) 80 | deriving (MonadLoggerIO) via (WithLogger app (ResourceT m)) 81 | 82 | runAppT 83 | :: ( MonadMask m 84 | , MonadUnliftIO m 85 | , HasColorOption options 86 | , HasVerboseOption options 87 | , HasAutoSSOOption options 88 | ) 89 | => options 90 | -> AppT (App options) m a 91 | -> m a 92 | runAppT options f = do 93 | envLogSettings <- 94 | liftIO 95 | . LoggingEnv.parseWith 96 | . setLogSettingsConcurrency (Just 1) 97 | $ defaultLogSettings 98 | 99 | let logSettings = 100 | adjustLogSettings 101 | (options ^. colorOptionL) 102 | (options ^. verboseOptionL) 103 | envLogSettings 104 | 105 | withLogger logSettings $ \appLogger -> do 106 | appAwsEnv <- runWithLogger appLogger $ handleAutoSSO options $ do 107 | logDebug "Discovering AWS credentials" 108 | AWS.discover 109 | appConfig <- runWithLogger appLogger loadConfigOrExit 110 | appAwsScope <- AWS.runEnvT fetchAwsScope appAwsEnv 111 | 112 | let 113 | AwsScope {..} = appAwsScope 114 | 115 | context = 116 | [ "region" .= awsRegion 117 | , "accountId" .= awsAccountId 118 | , "accountName" .= awsAccountName 119 | ] 120 | 121 | appOptions = options 122 | app = App {..} 123 | 124 | runResourceT 125 | $ flip runReaderT app 126 | $ withThreadContext context 127 | $ unAppT f 128 | 129 | adjustLogSettings 130 | :: Maybe ColorOption -> Verbosity -> LogSettings -> LogSettings 131 | adjustLogSettings mco v = 132 | maybe id (setLogSettingsColor . unColorOption) mco . verbositySetLogLevels v 133 | -------------------------------------------------------------------------------- /src/Stackctl/CancelHandler.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.CancelHandler 2 | ( with 3 | , install 4 | , remove 5 | , trigger 6 | ) where 7 | 8 | import Stackctl.Prelude 9 | 10 | import System.Posix.Signals 11 | 12 | -- | Install a 'keyboardSignal' handler, run an action, then remove it 13 | with :: MonadUnliftIO m => m a -> m b -> m b 14 | with f = bracket_ (install f) remove 15 | 16 | -- | Install a 'keyboardSignal' handler that runs the given action once 17 | install :: MonadUnliftIO m => m a -> m () 18 | install f = do 19 | withRunInIO $ \runInIO -> do 20 | let handler = Catch $ void $ do 21 | remove -- so next Ctl-C will truly cancel 22 | runInIO f 23 | void $ installHandler keyboardSignal handler Nothing 24 | 25 | -- | Remove the current handler for 'keyboardSignal' (i.e. install 'Default') 26 | remove :: MonadIO m => m () 27 | remove = liftIO $ void $ installHandler keyboardSignal Default Nothing 28 | 29 | -- | Trigger the installed 'keyboardSignal' handler 30 | -- 31 | -- This is used by our test suite. 32 | trigger :: MonadIO m => m () 33 | trigger = liftIO $ raiseSignal keyboardSignal 34 | -------------------------------------------------------------------------------- /src/Stackctl/ColorOption.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.ColorOption 2 | ( ColorOption (..) 3 | , HasColorOption (..) 4 | , colorOption 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Blammo.Logging.LogSettings 10 | import Data.Semigroup (Last (..)) 11 | import Options.Applicative 12 | 13 | newtype ColorOption = ColorOption 14 | { unColorOption :: LogColor 15 | } 16 | deriving (Semigroup) via Last ColorOption 17 | 18 | class HasColorOption env where 19 | colorOptionL :: Lens' env (Maybe ColorOption) 20 | 21 | colorOption :: Parser ColorOption 22 | colorOption = 23 | option (eitherReader $ fmap ColorOption . readLogColor) 24 | $ mconcat 25 | [long "color", help "When to colorize output", metavar "auto|always|never"] 26 | -------------------------------------------------------------------------------- /src/Stackctl/Colors.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Colors 2 | ( module Blammo.Logging.Colors 3 | ) where 4 | 5 | import Blammo.Logging.Colors 6 | -------------------------------------------------------------------------------- /src/Stackctl/Commands.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Commands 2 | ( module Stackctl.Commands 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Stackctl.AutoSSO 8 | import Stackctl.ColorOption 9 | import Stackctl.DirectoryOption 10 | import Stackctl.FilterOption 11 | import Stackctl.Spec.Capture 12 | import Stackctl.Spec.Cat 13 | import Stackctl.Spec.Changes 14 | import Stackctl.Spec.Deploy 15 | import Stackctl.Spec.List 16 | import Stackctl.Subcommand 17 | import Stackctl.VerboseOption 18 | import Stackctl.Version 19 | 20 | cat 21 | :: ( HasColorOption options 22 | , HasVerboseOption options 23 | , HasDirectoryOption options 24 | , HasFilterOption options 25 | , HasAutoSSOOption options 26 | ) 27 | => Subcommand options CatOptions 28 | cat = 29 | Subcommand 30 | { name = "cat" 31 | , description = "Pretty-print specifications" 32 | , parse = parseCatOptions 33 | , run = runAppSubcommand runCat 34 | } 35 | 36 | capture 37 | :: ( HasColorOption options 38 | , HasVerboseOption options 39 | , HasDirectoryOption options 40 | , HasAutoSSOOption options 41 | ) 42 | => Subcommand options CaptureOptions 43 | capture = 44 | Subcommand 45 | { name = "capture" 46 | , description = "Capture deployed Stacks as specifications" 47 | , parse = parseCaptureOptions 48 | , run = runAppSubcommand runCapture 49 | } 50 | 51 | changes 52 | :: ( HasColorOption options 53 | , HasVerboseOption options 54 | , HasDirectoryOption options 55 | , HasFilterOption options 56 | , HasAutoSSOOption options 57 | ) 58 | => Subcommand options ChangesOptions 59 | changes = 60 | Subcommand 61 | { name = "changes" 62 | , description = "Review changes between specification and deployed state" 63 | , parse = parseChangesOptions 64 | , run = runAppSubcommand runChanges 65 | } 66 | 67 | deploy 68 | :: ( HasColorOption options 69 | , HasVerboseOption options 70 | , HasDirectoryOption options 71 | , HasFilterOption options 72 | , HasAutoSSOOption options 73 | ) 74 | => Subcommand options DeployOptions 75 | deploy = 76 | Subcommand 77 | { name = "deploy" 78 | , description = "Deploy specifications" 79 | , parse = parseDeployOptions 80 | , run = runAppSubcommand runDeploy 81 | } 82 | 83 | list 84 | :: ( HasColorOption options 85 | , HasVerboseOption options 86 | , HasDirectoryOption options 87 | , HasFilterOption options 88 | , HasAutoSSOOption options 89 | ) 90 | => Subcommand options ListOptions 91 | list = 92 | Subcommand 93 | { name = "ls" 94 | , description = "List specifications" 95 | , parse = parseListOptions 96 | , run = runAppSubcommand runList 97 | } 98 | 99 | version :: Subcommand options () 100 | version = 101 | Subcommand 102 | { name = "version" 103 | , description = "Output the version" 104 | , parse = pure () 105 | , run = \() _ -> logVersion 106 | } 107 | -------------------------------------------------------------------------------- /src/Stackctl/Config.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Config 2 | ( Config (..) 3 | , configParameters 4 | , configTags 5 | , emptyConfig 6 | , HasConfig (..) 7 | , ConfigError (..) 8 | , loadConfigOrExit 9 | , loadConfigFromBytes 10 | , applyConfig 11 | ) where 12 | 13 | import Stackctl.Prelude 14 | 15 | import Control.Monad.Except 16 | import Data.Aeson 17 | import Data.Version 18 | import qualified Data.Yaml as Yaml 19 | import Paths_stackctl as Paths 20 | import Stackctl.Config.RequiredVersion 21 | import Stackctl.StackSpecYaml 22 | import UnliftIO.Directory (doesFileExist) 23 | 24 | data Config = Config 25 | { required_version :: Maybe RequiredVersion 26 | , defaults :: Maybe Defaults 27 | } 28 | deriving stock (Generic) 29 | deriving anyclass (FromJSON) 30 | 31 | configParameters :: Config -> Maybe ParametersYaml 32 | configParameters = parameters <=< defaults 33 | 34 | configTags :: Config -> Maybe TagsYaml 35 | configTags = tags <=< defaults 36 | 37 | emptyConfig :: Config 38 | emptyConfig = Config Nothing Nothing 39 | 40 | data Defaults = Defaults 41 | { parameters :: Maybe ParametersYaml 42 | , tags :: Maybe TagsYaml 43 | } 44 | deriving stock (Generic) 45 | deriving anyclass (FromJSON) 46 | 47 | class HasConfig env where 48 | configL :: Lens' env Config 49 | 50 | instance HasConfig Config where 51 | configL = id 52 | 53 | data ConfigError 54 | = ConfigInvalidYaml Yaml.ParseException 55 | | ConfigInvalid (NonEmpty Text) 56 | | ConfigVersionNotSatisfied RequiredVersion Version 57 | deriving stock (Show) 58 | 59 | configErrorMessage :: ConfigError -> Message 60 | configErrorMessage = \case 61 | ConfigInvalidYaml ex -> 62 | "Configuration is not valid Yaml" 63 | :# ["error" .= Yaml.prettyPrintParseException ex] 64 | ConfigInvalid errs -> "Invalid configuration" :# ["errors" .= errs] 65 | ConfigVersionNotSatisfied rv v -> 66 | "Incompatible Stackctl version" 67 | :# ["current" .= v, "required" .= show (requiredVersionToText rv)] 68 | 69 | loadConfigOrExit :: (MonadIO m, MonadLogger m) => m Config 70 | loadConfigOrExit = either die pure =<< loadConfig 71 | where 72 | die e = do 73 | logError $ configErrorMessage e 74 | exitFailure 75 | 76 | loadConfig :: MonadIO m => m (Either ConfigError Config) 77 | loadConfig = 78 | runExceptT 79 | $ getConfigFile >>= \case 80 | Nothing -> pure emptyConfig 81 | Just cf -> loadConfigFrom cf 82 | 83 | loadConfigFrom :: (MonadIO m, MonadError ConfigError m) => FilePath -> m Config 84 | loadConfigFrom path = loadConfigFromBytes =<< liftIO (readFileBinary path) 85 | 86 | loadConfigFromBytes :: MonadError ConfigError m => ByteString -> m Config 87 | loadConfigFromBytes bs = do 88 | config <- either (throwError . ConfigInvalidYaml) pure $ Yaml.decodeEither' bs 89 | config <$ traverse_ checkRequiredVersion (required_version config) 90 | where 91 | checkRequiredVersion rv = 92 | unless (isRequiredVersionSatisfied rv Paths.version) 93 | $ throwError 94 | $ ConfigVersionNotSatisfied rv Paths.version 95 | 96 | applyConfig :: Config -> StackSpecYaml -> StackSpecYaml 97 | applyConfig config ss@StackSpecYaml {..} = 98 | ss 99 | { ssyParameters = configParameters config <> ssyParameters 100 | , ssyTags = configTags config <> ssyTags 101 | } 102 | 103 | getConfigFile :: MonadIO m => m (Maybe FilePath) 104 | getConfigFile = 105 | listToMaybe 106 | <$> filterM 107 | doesFileExist 108 | [ ".stackctl" "config" <.> "yaml" 109 | , ".stackctl" "config" <.> "yml" 110 | , ".stackctl" <.> "yaml" 111 | , ".stackctl" <.> "yml" 112 | ] 113 | -------------------------------------------------------------------------------- /src/Stackctl/Config/RequiredVersion.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Config.RequiredVersion 2 | ( RequiredVersion (..) 3 | , RequiredVersionOp (..) 4 | , requiredVersionToText 5 | , requiredVersionFromText 6 | , isRequiredVersionSatisfied 7 | 8 | -- * Exported for testing 9 | , (=~) 10 | ) where 11 | 12 | import Stackctl.Prelude 13 | 14 | import Data.Aeson 15 | import Data.List (uncons) 16 | import qualified Data.List.NonEmpty as NE 17 | import qualified Data.Text as T 18 | import Data.Version hiding (parseVersion) 19 | import qualified Data.Version as Version 20 | import Test.QuickCheck 21 | import Text.ParserCombinators.ReadP (readP_to_S) 22 | 23 | data RequiredVersion = RequiredVersion 24 | { requiredVersionOp :: RequiredVersionOp 25 | , requiredVersionCompareWith :: Version 26 | } 27 | deriving stock (Eq, Ord, Show) 28 | 29 | instance Arbitrary RequiredVersion where 30 | arbitrary = RequiredVersion <$> arbitrary <*> arbitrary 31 | 32 | instance FromJSON RequiredVersion where 33 | parseJSON = 34 | withText "RequiredVersion" $ either fail pure . requiredVersionFromText 35 | 36 | instance ToJSON RequiredVersion where 37 | toJSON = toJSON . requiredVersionToText 38 | toEncoding = toEncoding . requiredVersionToText 39 | 40 | requiredVersionToText :: RequiredVersion -> Text 41 | requiredVersionToText RequiredVersion {..} = 42 | requiredVersionOpToText requiredVersionOp 43 | <> " " 44 | <> pack 45 | (showVersion requiredVersionCompareWith) 46 | 47 | requiredVersionFromText :: Text -> Either String RequiredVersion 48 | requiredVersionFromText = fromWords . T.words 49 | where 50 | fromWords :: [Text] -> Either String RequiredVersion 51 | fromWords = \case 52 | [w] -> parseRequiredVersion "=" w 53 | [op, w] -> parseRequiredVersion op w 54 | ws -> 55 | Left 56 | $ show (unpack $ T.unwords ws) 57 | <> " did not parse as optional operator and version string" 58 | 59 | parseRequiredVersion :: Text -> Text -> Either String RequiredVersion 60 | parseRequiredVersion op w = RequiredVersion <$> parseOp op <*> parseVersion w 61 | 62 | parseOp :: Text -> Either String RequiredVersionOp 63 | parseOp = \case 64 | "=" -> Right RequiredVersionEQ 65 | "==" -> Right RequiredVersionEQ 66 | "<" -> Right RequiredVersionLT 67 | "<=" -> Right RequiredVersionLTE 68 | ">" -> Right RequiredVersionGT 69 | ">=" -> Right RequiredVersionGTE 70 | "=~" -> Right RequiredVersionIsh 71 | op -> 72 | Left 73 | $ "Invalid comparison operator (" 74 | <> unpack op 75 | <> "), may only be =, <, <=, >, >=, or =~" 76 | 77 | parseVersion :: Text -> Either String Version 78 | parseVersion t = 79 | fmap (fst . NE.last) 80 | $ note ("Failed to parse as a version " <> s) 81 | $ NE.nonEmpty 82 | $ readP_to_S Version.parseVersion s 83 | where 84 | s = unpack t 85 | 86 | isRequiredVersionSatisfied :: RequiredVersion -> Version -> Bool 87 | isRequiredVersionSatisfied RequiredVersion {..} = 88 | (`requiredVersionCompare` requiredVersionCompareWith) 89 | where 90 | requiredVersionCompare = requiredVersionOpCompare requiredVersionOp 91 | 92 | data RequiredVersionOp 93 | = RequiredVersionEQ 94 | | RequiredVersionLT 95 | | RequiredVersionLTE 96 | | RequiredVersionGT 97 | | RequiredVersionGTE 98 | | RequiredVersionIsh 99 | deriving stock (Eq, Ord, Show, Bounded, Enum) 100 | 101 | instance Arbitrary RequiredVersionOp where 102 | arbitrary = arbitraryBoundedEnum 103 | 104 | requiredVersionOpToText :: RequiredVersionOp -> Text 105 | requiredVersionOpToText = \case 106 | RequiredVersionEQ -> "==" 107 | RequiredVersionLT -> "<" 108 | RequiredVersionLTE -> "<=" 109 | RequiredVersionGT -> ">" 110 | RequiredVersionGTE -> ">=" 111 | RequiredVersionIsh -> "=~" 112 | 113 | requiredVersionOpCompare :: RequiredVersionOp -> Version -> Version -> Bool 114 | requiredVersionOpCompare = \case 115 | RequiredVersionEQ -> (==) 116 | RequiredVersionLT -> (<) 117 | RequiredVersionLTE -> (<=) 118 | RequiredVersionGT -> (>) 119 | RequiredVersionGTE -> (>=) 120 | RequiredVersionIsh -> (=~) 121 | 122 | (=~) :: Version -> Version -> Bool 123 | a =~ b = a >= b && a < incrementVersion b 124 | where 125 | incrementVersion = onVersion $ backwards $ onHead (+ 1) 126 | onVersion f = makeVersion . f . versionBranch 127 | backwards f = reverse . f . reverse 128 | onHead f as = maybe as (uncurry (:) . first f) $ uncons as 129 | -------------------------------------------------------------------------------- /src/Stackctl/DirectoryOption.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.DirectoryOption 2 | ( DirectoryOption (..) 3 | , defaultDirectoryOption 4 | , HasDirectoryOption (..) 5 | , envDirectoryOption 6 | , directoryOption 7 | ) where 8 | 9 | import Stackctl.Prelude 10 | 11 | import Data.Semigroup (Last (..)) 12 | import qualified Env 13 | import Options.Applicative 14 | 15 | newtype DirectoryOption = DirectoryOption 16 | { unDirectoryOption :: FilePath 17 | } 18 | deriving newtype (IsString) 19 | deriving (Semigroup) via Last DirectoryOption 20 | 21 | defaultDirectoryOption :: DirectoryOption 22 | defaultDirectoryOption = "." 23 | 24 | class HasDirectoryOption env where 25 | directoryOptionL :: Lens' env DirectoryOption 26 | 27 | instance HasDirectoryOption DirectoryOption where 28 | directoryOptionL = id 29 | 30 | envDirectoryOption :: Env.Parser Env.Error DirectoryOption 31 | envDirectoryOption = 32 | Env.var (Env.str <=< Env.nonempty) "DIRECTORY" 33 | $ Env.help "Operate on specifications in this directory" 34 | 35 | directoryOption :: Parser DirectoryOption 36 | directoryOption = 37 | option str 38 | $ mconcat 39 | [ short 'd' 40 | , long "directory" 41 | , metavar "PATH" 42 | , help "Operate on specifications in PATH" 43 | , action "directory" 44 | ] 45 | -------------------------------------------------------------------------------- /src/Stackctl/FilterOption.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.FilterOption 2 | ( FilterOption 3 | , defaultFilterOption 4 | , HasFilterOption (..) 5 | , envFilterOption 6 | , filterOption 7 | , filterOptionFromPaths 8 | , filterOptionFromText 9 | , filterOptionToPaths 10 | , filterStackSpecs 11 | ) where 12 | 13 | import Stackctl.Prelude 14 | 15 | import qualified Data.List.NonEmpty as NE 16 | import Data.Semigroup (Last (..)) 17 | import qualified Data.Text as T 18 | import qualified Env 19 | import Options.Applicative 20 | import Stackctl.AWS.CloudFormation (StackName (..)) 21 | import Stackctl.StackSpec 22 | import System.FilePath (hasExtension) 23 | import System.FilePath.Glob 24 | 25 | newtype FilterOption = FilterOption 26 | { unFilterOption :: NonEmpty Pattern 27 | } 28 | deriving (Semigroup) via Last FilterOption 29 | 30 | instance ToJSON FilterOption where 31 | toJSON = toJSON . showFilterOption 32 | toEncoding = toEncoding . showFilterOption 33 | 34 | class HasFilterOption env where 35 | filterOptionL :: Lens' env FilterOption 36 | 37 | instance HasFilterOption FilterOption where 38 | filterOptionL = id 39 | 40 | envFilterOption :: String -> Env.Parser Env.Error FilterOption 41 | envFilterOption items = var "FILTERS" <|> var "FILTER" 42 | where 43 | var name = 44 | Env.var (first Env.UnreadError . readFilterOption) name 45 | $ Env.help 46 | $ "Filter " 47 | <> items 48 | <> " by patterns" 49 | 50 | filterOption :: String -> Parser FilterOption 51 | filterOption items = 52 | option (eitherReader readFilterOption) 53 | $ mconcat 54 | [ long "filter" 55 | , metavar "PATTERN[,PATTERN]" 56 | , help $ "Filter " <> items <> " to match PATTERN(s)" 57 | ] 58 | 59 | filterOptionFromPaths :: NonEmpty FilePath -> FilterOption 60 | filterOptionFromPaths = FilterOption . fmap compile 61 | 62 | filterOptionFromText :: Text -> Maybe FilterOption 63 | filterOptionFromText = 64 | fmap FilterOption 65 | . NE.nonEmpty 66 | . concatMap expandPatterns 67 | . filter (not . T.null) 68 | . map T.strip 69 | . T.splitOn "," 70 | 71 | expandPatterns :: Text -> [Pattern] 72 | expandPatterns t = map compile $ s : expanded 73 | where 74 | expanded 75 | | "**" `T.isPrefixOf` t = suffixed 76 | | otherwise = map ("**" ) $ s : suffixed 77 | 78 | suffixed 79 | | "*" `T.isSuffixOf` t || hasExtension s = [] 80 | | otherwise = (s "**" "*") : map (s <.>) extensions 81 | 82 | extensions = ["json", "yaml"] 83 | 84 | s = unpack t 85 | 86 | readFilterOption :: String -> Either String FilterOption 87 | readFilterOption = note err . filterOptionFromText . pack 88 | where 89 | err = "Must be non-empty, comma-separated list of non-empty patterns" 90 | 91 | showFilterOption :: FilterOption -> String 92 | showFilterOption = 93 | unpack 94 | . T.intercalate "," 95 | . map (pack . decompile) 96 | . NE.toList 97 | . unFilterOption 98 | 99 | defaultFilterOption :: FilterOption 100 | defaultFilterOption = filterOptionFromPaths $ pure "**/*" 101 | 102 | filterOptionToPaths :: FilterOption -> [FilePath] 103 | filterOptionToPaths = map decompile . NE.toList . unFilterOption 104 | 105 | filterStackSpecs :: FilterOption -> [StackSpec] -> [StackSpec] 106 | filterStackSpecs fo = 107 | filter $ \spec -> any (`matchStackSpec` spec) $ unFilterOption fo 108 | 109 | matchStackSpec :: Pattern -> StackSpec -> Bool 110 | matchStackSpec p spec = 111 | or 112 | [ match p $ unpack $ unStackName $ stackSpecStackName spec 113 | , match p $ stackSpecStackFile spec 114 | , match p $ stackSpecTemplateFile spec 115 | ] 116 | -------------------------------------------------------------------------------- /src/Stackctl/OneOrListOf.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.OneOrListOf 2 | ( OneOrListOf 3 | , fromList 4 | ) where 5 | 6 | import Stackctl.Prelude 7 | 8 | import Data.Aeson 9 | 10 | -- | Type representing one @a@ or a list of @a@ 11 | -- 12 | -- This type is isomorphic both @'NonEmpty' a@ and @'Either' a [a]@. Its primary 13 | -- use-case is to parse Yaml (through its 'FromJSON') where users may specify a 14 | -- list of values, but specifying a single value is worth supporting, typically 15 | -- for backwards-compatibility: 16 | -- 17 | -- @ 18 | -- something: 19 | -- field: 20 | -- - one 21 | -- - two 22 | -- 23 | -- something: 24 | -- field: one # => should be treated like field: [one] 25 | -- @ 26 | -- 27 | -- The 'Foldable' instance should be used to treat the value like a list, such 28 | -- as extracting it directly via 'toList'. 29 | -- 30 | -- Implementation note: this type preserves the form in which it was decoded (in 31 | -- other words, it's not a @newtype@ over one of the isomorphic types mentioned 32 | -- above), so that we can encode it back out in the same format. 33 | data OneOrListOf a = One a | List [a] 34 | deriving stock (Eq, Show, Generic, Foldable) 35 | 36 | fromList :: [a] -> OneOrListOf a 37 | fromList = List 38 | 39 | instance Semigroup (OneOrListOf a) where 40 | One a <> One b = List [a, b] 41 | One a <> List bs = List $ a : bs 42 | List as <> One b = List $ as <> [b] 43 | List as <> List bs = List $ as <> bs 44 | 45 | instance FromJSON a => FromJSON (OneOrListOf a) where 46 | parseJSON = \case 47 | Array xs -> List . toList <$> traverse parseJSON xs 48 | v -> One <$> parseJSON v 49 | 50 | instance ToJSON a => ToJSON (OneOrListOf a) where 51 | toJSON = \case 52 | One a -> toJSON a 53 | List as -> toJSON as 54 | toEncoding = \case 55 | One a -> toEncoding a 56 | List as -> toEncoding as 57 | -------------------------------------------------------------------------------- /src/Stackctl/Options.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Options 2 | ( Options 3 | , envParser 4 | , optionsParser 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Data.Semigroup.Generic 10 | import qualified Env 11 | import Options.Applicative 12 | import Stackctl.AutoSSO 13 | import Stackctl.ColorOption 14 | import Stackctl.DirectoryOption 15 | import Stackctl.FilterOption 16 | import Stackctl.VerboseOption 17 | 18 | data Options = Options 19 | { oDirectory :: Maybe DirectoryOption 20 | , oFilter :: Maybe FilterOption 21 | , oColor :: Maybe ColorOption 22 | , oVerbose :: Verbosity 23 | , oAutoSSO :: Maybe AutoSSOOption 24 | } 25 | deriving stock (Generic) 26 | deriving (Semigroup) via GenericSemigroupMonoid Options 27 | 28 | directoryL :: Lens' Options (Maybe DirectoryOption) 29 | directoryL = lens oDirectory $ \x y -> x {oDirectory = y} 30 | 31 | filterL :: Lens' Options (Maybe FilterOption) 32 | filterL = lens oFilter $ \x y -> x {oFilter = y} 33 | 34 | autoSSOL :: Lens' Options (Maybe AutoSSOOption) 35 | autoSSOL = lens oAutoSSO $ \x y -> x {oAutoSSO = y} 36 | 37 | instance HasDirectoryOption Options where 38 | directoryOptionL = directoryL . maybeLens defaultDirectoryOption 39 | 40 | instance HasFilterOption Options where 41 | filterOptionL = filterL . maybeLens defaultFilterOption 42 | 43 | instance HasColorOption Options where 44 | colorOptionL = lens oColor $ \x y -> x {oColor = y} 45 | 46 | instance HasVerboseOption Options where 47 | verboseOptionL = lens oVerbose $ \x y -> x {oVerbose = y} 48 | 49 | instance HasAutoSSOOption Options where 50 | autoSSOOptionL = autoSSOL . maybeLens defaultAutoSSOOption 51 | 52 | -- brittany-disable-next-binding 53 | 54 | envParser :: Env.Parser Env.Error Options 55 | envParser = 56 | Env.prefixed "STACKCTL_" 57 | $ Options 58 | <$> optional envDirectoryOption 59 | <*> optional (envFilterOption "specifications") 60 | <*> pure mempty -- use LOG_COLOR 61 | <*> pure mempty -- use LOG_LEVEL 62 | <*> optional envAutoSSOOption 63 | 64 | -- brittany-disable-next-binding 65 | 66 | optionsParser :: Parser Options 67 | optionsParser = 68 | Options 69 | <$> optional directoryOption 70 | <*> optional (filterOption "specifications") 71 | <*> optional colorOption 72 | <*> verboseOption 73 | <*> optional autoSSOOption 74 | -------------------------------------------------------------------------------- /src/Stackctl/ParameterOption.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.ParameterOption 2 | ( parameterOption 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import qualified Data.Text as T 8 | import Options.Applicative 9 | import Stackctl.AWS.CloudFormation (Parameter, makeParameter) 10 | 11 | parameterOption :: Parser Parameter 12 | parameterOption = 13 | option (eitherReader readParameter) 14 | $ mconcat 15 | [ short 'p' 16 | , long "parameter" 17 | , metavar "KEY=[VALUE]" 18 | , help "Override the given Parameter for this operation" 19 | ] 20 | 21 | readParameter :: String -> Either String Parameter 22 | readParameter s = case T.breakOn "=" t of 23 | (_, v) | T.null v -> Left $ "No '=' found (" <> s <> ")" 24 | (k, _) | T.null k -> Left $ "Empty key (" <> s <> ")" 25 | (k, "=") -> Right $ makeParameter k $ Just "" 26 | (k, v) -> Right $ makeParameter k $ Just $ T.drop 1 v 27 | where 28 | t = pack s 29 | -------------------------------------------------------------------------------- /src/Stackctl/Prelude.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Prelude 2 | ( module X 3 | , decodeUtf8 4 | , maybeLens 5 | ) where 6 | 7 | import RIO as X hiding 8 | ( LogLevel (..) 9 | , LogSource 10 | , logDebug 11 | , logDebugS 12 | , logError 13 | , logErrorS 14 | , logInfo 15 | , logInfoS 16 | , logOther 17 | , logOtherS 18 | , logWarn 19 | , logWarnS 20 | ) 21 | 22 | import Blammo.Logging as X 23 | import Blammo.Logging.Setup as X 24 | import Blammo.Logging.ThreadContext as X 25 | import Control.Error.Util as X (hush, note) 26 | import Data.Aeson as X (ToJSON (..), object) 27 | import Data.Text as X (pack, unpack) 28 | import System.FilePath as X 29 | ( dropExtension 30 | , takeBaseName 31 | , takeDirectory 32 | , (<.>) 33 | , () 34 | ) 35 | import UnliftIO.Directory as X (withCurrentDirectory) 36 | 37 | {-# ANN module ("HLint: ignore Avoid restricted alias" :: String) #-} 38 | 39 | decodeUtf8 :: ByteString -> Text 40 | decodeUtf8 = decodeUtf8With lenientDecode 41 | 42 | maybeLens :: a -> Lens' (Maybe a) a 43 | maybeLens x = lens (fromMaybe x) $ const Just 44 | -------------------------------------------------------------------------------- /src/Stackctl/Prompt.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Prompt 2 | ( prompt 3 | , promptContinue 4 | , promptOrExit 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Blammo.Logging.Logger (flushLogger) 10 | import qualified Data.Text as T 11 | import qualified Data.Text.IO as T 12 | 13 | prompt 14 | :: (MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) 15 | => Text 16 | -- ^ Message to present 17 | -> (Text -> Either Text a) 18 | -- ^ Parse user input (stripped) 19 | -> (a -> m r) 20 | -- ^ Action to take on result 21 | -> m r 22 | prompt message parse dispatch = do 23 | flushLogger 24 | 25 | x <- liftIO $ do 26 | T.putStr $ message <> "? " 27 | hFlush stdout 28 | T.strip <$> T.getLine 29 | 30 | case parse x of 31 | Left err -> do 32 | logWarn $ "Invalid input" :# ["error" .= err] 33 | prompt message parse dispatch 34 | Right a -> dispatch a 35 | 36 | promptContinue 37 | :: (MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) => m () 38 | promptContinue = promptOrExit "Continue" 39 | 40 | promptOrExit 41 | :: (MonadIO m, MonadLogger m, MonadReader env m, HasLogger env) 42 | => Text 43 | -> m () 44 | promptOrExit msg = prompt (msg <> " (y/n)") parse dispatch 45 | where 46 | parse x 47 | | x `elem` ["y", "Y"] = Right True 48 | | x `elem` ["n", "N"] = Right False 49 | | otherwise = Left $ "Must be y, Y, n, or N (saw " <> x <> ")" 50 | 51 | dispatch b = unless b exitSuccess 52 | -------------------------------------------------------------------------------- /src/Stackctl/RemovedStack.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.RemovedStack 2 | ( inferRemovedStacks 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Control.Error.Util (hoistMaybe) 8 | import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) 9 | import Stackctl.AWS.CloudFormation 10 | import Stackctl.AWS.Core as AWS 11 | import Stackctl.AWS.Scope 12 | import Stackctl.DirectoryOption 13 | import Stackctl.FilterOption 14 | import UnliftIO.Directory (doesFileExist) 15 | 16 | inferRemovedStacks 17 | :: ( MonadUnliftIO m 18 | , MonadAWS m 19 | , MonadReader env m 20 | , HasAwsScope env 21 | , HasDirectoryOption env 22 | , HasFilterOption env 23 | ) 24 | => m [Stack] 25 | inferRemovedStacks = do 26 | scope <- view awsScopeL 27 | paths <- view $ filterOptionL . to filterOptionToPaths 28 | dir <- view $ directoryOptionL . to unDirectoryOption 29 | catMaybes <$> traverse (findRemovedStack scope dir) paths 30 | 31 | findRemovedStack 32 | :: (MonadUnliftIO m, MonadAWS m) 33 | => AwsScope 34 | -> FilePath 35 | -- ^ Root directory 36 | -> FilePath 37 | -> m (Maybe Stack) 38 | findRemovedStack scope dir path = runMaybeT $ do 39 | -- The filter is a full path to a specification in the current 40 | -- account/region... 41 | stackName <- hoistMaybe $ awsScopeSpecStackName scope path 42 | 43 | -- that no longer exists... 44 | guard . not =<< doesFileExist (dir path) 45 | 46 | -- but the Stack it would point to does 47 | MaybeT $ awsCloudFormationDescribeStackMaybe stackName 48 | -------------------------------------------------------------------------------- /src/Stackctl/Sort.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Sort 2 | ( sortByDependencies 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Data.Graph (graphFromEdges, topSort) 8 | 9 | sortByDependencies 10 | :: Ord k 11 | => (a -> k) 12 | -- ^ How to identify a given item 13 | -> (a -> [k]) 14 | -- ^ How to get the given item's dependencies 15 | -> [a] 16 | -> [a] 17 | sortByDependencies toName toDepends specs = 18 | map nodeFromVertex $ reverse $ topSort graph 19 | where 20 | (graph, tripleFromVertex, _) = graphFromEdges $ map tripleFromNode specs 21 | 22 | nodeFromVertex = nodeFromTriple . tripleFromVertex 23 | 24 | tripleFromNode n = (n, toName n, toDepends n) 25 | 26 | nodeFromTriple (n, _, _) = n 27 | -------------------------------------------------------------------------------- /src/Stackctl/Spec/Capture.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Spec.Capture 2 | ( CaptureOptions (..) 3 | , parseCaptureOptions 4 | , runCapture 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Options.Applicative 10 | import Stackctl.AWS 11 | import Stackctl.AWS.Scope 12 | import Stackctl.Config (HasConfig) 13 | import Stackctl.DirectoryOption (HasDirectoryOption) 14 | import Stackctl.Spec.Generate 15 | import Stackctl.StackSpec 16 | import Stackctl.StackSpecYaml 17 | ( StackSpecYaml (..) 18 | , TagYaml (..) 19 | , parameterYaml 20 | , parametersYaml 21 | , tagsYaml 22 | ) 23 | import System.FilePath.Glob 24 | 25 | data CaptureOptions = CaptureOptions 26 | { scoAccountName :: Maybe Text 27 | , scoTemplatePath :: Maybe FilePath 28 | , scoStackPath :: Maybe FilePath 29 | , scoDepends :: Maybe [StackName] 30 | , scoTemplateFormat :: TemplateFormat 31 | , scoStackName :: Pattern 32 | } 33 | 34 | -- brittany-disable-next-binding 35 | 36 | parseCaptureOptions :: Parser CaptureOptions 37 | parseCaptureOptions = 38 | CaptureOptions 39 | <$> optional 40 | ( strOption 41 | ( short 'n' 42 | <> long "account-name" 43 | <> metavar "NAME" 44 | <> help "Account name to use in generated files" 45 | ) 46 | ) 47 | <*> optional 48 | ( strOption 49 | ( short 't' 50 | <> long "template-path" 51 | <> metavar "PATH" 52 | <> help "Write Template to PATH. Default is based on STACK" 53 | ) 54 | ) 55 | <*> optional 56 | ( strOption 57 | ( short 'p' 58 | <> long "path" 59 | <> metavar "PATH" 60 | <> help "Write specification to PATH. Default is based on STACK" 61 | ) 62 | ) 63 | <*> optional 64 | ( some 65 | ( StackName 66 | <$> strOption 67 | ( long "depend" 68 | <> metavar "STACK" 69 | <> help "Add a dependency on STACK" 70 | ) 71 | ) 72 | ) 73 | <*> flag 74 | TemplateFormatYaml 75 | TemplateFormatJson 76 | ( long "no-flip" 77 | <> help "Don't flip JSON templates to Yaml" 78 | ) 79 | <*> strArgument 80 | ( metavar "STACK" 81 | <> help "Name of deployed Stack to capture" 82 | ) 83 | 84 | runCapture 85 | :: ( MonadMask m 86 | , MonadUnliftIO m 87 | , MonadAWS m 88 | , MonadLogger m 89 | , MonadReader env m 90 | , HasAwsScope env 91 | , HasConfig env 92 | , HasDirectoryOption env 93 | ) 94 | => CaptureOptions 95 | -> m () 96 | runCapture CaptureOptions {..} = do 97 | let 98 | setScopeName scope = 99 | maybe scope (\name -> scope {awsAccountName = name}) scoAccountName 100 | 101 | generate' stack template mPath mTemplatePath = do 102 | let 103 | stackName = StackName $ stack ^. stack_stackName 104 | templateBody = templateBodyFromValue template 105 | 106 | void 107 | $ local (awsScopeL %~ setScopeName) 108 | $ generate 109 | False 110 | ( case mPath of 111 | Nothing -> GenerateSpec stackName 112 | Just sp -> GenerateSpecTo stackName sp 113 | ) 114 | ( case mTemplatePath of 115 | Nothing -> GenerateTemplate templateBody scoTemplateFormat 116 | Just tp -> GenerateTemplateTo templateBody tp 117 | ) 118 | ( \templatePath -> 119 | StackSpecYaml 120 | { ssyDescription = stackDescription stack 121 | , ssyTemplate = templatePath 122 | , ssyDepends = scoDepends 123 | , ssyActions = Nothing 124 | , ssyParameters = parametersYaml . mapMaybe parameterYaml <$> parameters stack 125 | , ssyCapabilities = capabilities stack 126 | , ssyTags = tagsYaml . map TagYaml <$> tags stack 127 | } 128 | ) 129 | 130 | results <- awsCloudFormationGetStackNamesMatching scoStackName 131 | 132 | case results of 133 | [] -> do 134 | logError 135 | $ "No Active Stacks match " <> pack (decompile scoStackName) 136 | :# [] 137 | exitFailure 138 | [stackName] -> do 139 | stack <- awsCloudFormationDescribeStack stackName 140 | template <- awsCloudFormationGetTemplate stackName 141 | generate' stack template scoStackPath scoTemplatePath 142 | stackNames -> do 143 | logInfo "Capturing multiple matching Stacks" 144 | for_ scoStackPath $ \_ -> logWarn "--path option ignored" 145 | for_ scoTemplatePath $ \_ -> logWarn "--template-path option ignored" 146 | for_ stackNames $ \stackName -> do 147 | stack <- awsCloudFormationDescribeStack stackName 148 | template <- awsCloudFormationGetTemplate stackName 149 | generate' stack template Nothing Nothing 150 | -------------------------------------------------------------------------------- /src/Stackctl/Spec/Cat.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Spec.Cat 2 | ( CatOptions (..) 3 | , parseCatOptions 4 | , runCat 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Blammo.Logging.Logger (flushLogger) 10 | import Data.Aeson 11 | import qualified Data.Aeson.Key as Key 12 | import Data.Aeson.Lens 13 | import qualified Data.HashMap.Strict as HashMap 14 | import Data.List (sort, sortOn) 15 | import qualified Data.List.NonEmpty as NE 16 | import qualified Data.Text as T 17 | import qualified Data.Text.IO as T 18 | import qualified Data.Yaml as Yaml 19 | import Options.Applicative 20 | import Stackctl.AWS 21 | import Stackctl.AWS.Scope 22 | import Stackctl.Colors 23 | import Stackctl.Config (HasConfig) 24 | import Stackctl.DirectoryOption (HasDirectoryOption (..), unDirectoryOption) 25 | import Stackctl.FilterOption (HasFilterOption) 26 | import Stackctl.Spec.Discover 27 | import Stackctl.StackSpec 28 | import Stackctl.StackSpecPath 29 | import Stackctl.StackSpecYaml 30 | 31 | data CatOptions = CatOptions 32 | { sctoNoStacks :: Bool 33 | , sctoNoTemplates :: Bool 34 | , sctoBrief :: Bool 35 | } 36 | 37 | -- brittany-disable-next-binding 38 | 39 | parseCatOptions :: Parser CatOptions 40 | parseCatOptions = 41 | CatOptions 42 | <$> switch 43 | ( long "no-stacks" 44 | <> help "Only show templates/" 45 | ) 46 | <*> switch 47 | ( long "no-templates" 48 | <> help "Only show stacks/" 49 | ) 50 | <*> switch 51 | ( short 'b' 52 | <> long "brief" 53 | <> help "Don't show file contents, only paths" 54 | ) 55 | 56 | runCat 57 | :: ( MonadIO m 58 | , MonadMask m 59 | , MonadLogger m 60 | , MonadReader env m 61 | , HasLogger env 62 | , HasAwsScope env 63 | , HasConfig env 64 | , HasDirectoryOption env 65 | , HasFilterOption env 66 | ) 67 | => CatOptions 68 | -> m () 69 | runCat CatOptions {..} = do 70 | dir <- unDirectoryOption <$> view directoryOptionL 71 | colors@Colors {..} <- getColorsStdout 72 | tree <- specTree <$> discoverSpecs 73 | 74 | let 75 | putStack n x = if sctoNoStacks then pure () else put n x 76 | putStackBody n x = 77 | if sctoNoStacks || sctoBrief then pure () else putBoxed n x 78 | putTemplate n x = if sctoNoTemplates then pure () else put n x 79 | putTemplateBody n x = 80 | if sctoNoTemplates || sctoBrief then pure () else putBoxed n x 81 | 82 | flushLogger 83 | 84 | put 0 $ fromString dir <> "/" 85 | putStack 2 "stacks/" 86 | templates <- for tree $ \((accountId, accountName), regions) -> do 87 | putStack 4 $ magenta (unAccountId accountId) <> "." <> accountName <> "/" 88 | 89 | for regions $ \(region, specs) -> do 90 | putStack 6 $ magenta (toText region) <> "/" 91 | 92 | let sorted = sortOn (stackSpecPathBasePath . stackSpecSpecPath) specs 93 | for sorted $ \spec -> do 94 | let 95 | base = stackSpecPathBasePath $ stackSpecSpecPath spec 96 | body = stackSpecSpecBody spec 97 | name = stackSpecStackName spec 98 | yaml = prettyPrintStackSpecYaml colors name body 99 | 100 | putStack 8 $ magenta (fromString base) 101 | putStackBody 10 yaml 102 | pure $ ssyTemplate body 103 | 104 | putTemplate 2 "templates/" 105 | for_ (sort $ nubOrd $ concat $ concat templates) $ \template -> do 106 | val <- Yaml.decodeFileThrow @_ @Value $ dir "templates" template 107 | 108 | putTemplate 4 $ green $ fromString template 109 | putTemplateBody 6 $ prettyPrintTemplate colors val 110 | 111 | specTree :: [StackSpec] -> [((AccountId, Text), [(Region, [StackSpec])])] 112 | specTree = map (second groupRegion) . groupAccount 113 | where 114 | groupRegion :: [StackSpec] -> [(Region, [StackSpec])] 115 | groupRegion = groupTo (stackSpecPathRegion . stackSpecSpecPath) 116 | 117 | groupAccount :: [StackSpec] -> [((AccountId, Text), [StackSpec])] 118 | groupAccount = 119 | groupTo 120 | ((stackSpecPathAccountId &&& stackSpecPathAccountName) . stackSpecSpecPath) 121 | 122 | groupTo :: Ord b => (a -> b) -> [a] -> [(b, [a])] 123 | groupTo f = map (f . NE.head &&& NE.toList) . NE.groupAllWith f 124 | 125 | prettyPrintStackSpecYaml :: Colors -> StackName -> StackSpecYaml -> [Text] 126 | prettyPrintStackSpecYaml Colors {..} name StackSpecYaml {..} = 127 | concat 128 | [ [cyan "Name" <> ": " <> green (unStackName name)] 129 | , maybe [] ppDescription ssyDescription 130 | , [cyan "Template" <> ": " <> green (pack ssyTemplate)] 131 | , ppObject "Parameters" parametersYamlKVs ssyParameters 132 | , ppList "Capabilities" ppCapabilities ssyCapabilities 133 | , ppObject "Tags" tagsYamlKVs ssyTags 134 | ] 135 | where 136 | ppObject :: Text -> (a -> [(Text, Maybe Text)]) -> Maybe a -> [Text] 137 | ppObject label f mA = fromMaybe [] $ do 138 | kvs <- f <$> mA 139 | pure 140 | $ [cyan label <> ":"] 141 | <> map 142 | ( \(k, mV) -> 143 | " " <> cyan k <> ":" <> maybe "" (\v -> " " <> green v) mV 144 | ) 145 | kvs 146 | 147 | ppList :: Text -> (a -> [Text]) -> Maybe a -> [Text] 148 | ppList label f = maybe [] (((cyan label <> ":") :) . f) 149 | 150 | ppDescription d = 151 | [cyan "Description" <> ": " <> green (unStackDescription d)] 152 | ppCapabilities = map ((" - " <>) . green . toText) 153 | 154 | parametersYamlKVs :: ParametersYaml -> [(Text, Maybe Text)] 155 | parametersYamlKVs = mapMaybe parameterYamlKV . unParametersYaml 156 | 157 | parameterYamlKV :: ParameterYaml -> Maybe (Text, Maybe Text) 158 | parameterYamlKV py = 159 | (,) 160 | <$> (p ^. parameter_parameterKey) 161 | <*> pure 162 | (p ^. parameter_parameterValue) 163 | where 164 | p = unParameterYaml py 165 | 166 | tagsYamlKVs :: TagsYaml -> [(Text, Maybe Text)] 167 | tagsYamlKVs = map (tagKV . unTagYaml) . unTagsYaml 168 | 169 | tagKV :: Tag -> (Text, Maybe Text) 170 | tagKV tg = (tg ^. tag_key, tg ^. tag_value . to Just) 171 | 172 | prettyPrintTemplate :: Colors -> Value -> [Text] 173 | prettyPrintTemplate Colors {..} val = 174 | concat 175 | [ displayTextProperty "Description" 176 | , displayObjectProperty "Parameters" 177 | , displayObjectProperty "Resources" 178 | , displayObjectProperty "Outputs" 179 | ] 180 | where 181 | displayTextProperty :: Text -> [Text] 182 | displayTextProperty = displayPropertyWith 183 | $ \v -> let tp = T.dropWhileEnd (== '\n') $ pack v in [" " <> green tp] 184 | 185 | displayObjectProperty :: Text -> [Text] 186 | displayObjectProperty = 187 | displayPropertyWith @(HashMap Text Value) 188 | $ map ((" - " <>) . green) 189 | . sort 190 | . HashMap.keys 191 | 192 | displayPropertyWith 193 | :: (FromJSON a, ToJSON a) => (a -> [Text]) -> Text -> [Text] 194 | displayPropertyWith f k = cyan k <> ": " : fromMaybe [] displayValue 195 | where 196 | displayValue = val ^? key (Key.fromText k) . _JSON . to f 197 | 198 | putBoxed :: MonadIO m => Int -> [Text] -> m () 199 | putBoxed n xs = do 200 | traverse_ (put n . ("│ " <>)) xs 201 | put n "└──────────" 202 | put 0 "" 203 | 204 | put :: MonadIO m => Int -> Text -> m () 205 | put n = liftIO . T.putStrLn . (indent <>) 206 | where 207 | indent = mconcat $ replicate n " " 208 | -------------------------------------------------------------------------------- /src/Stackctl/Spec/Changes.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Spec.Changes 2 | ( ChangesOptions (..) 3 | , parseChangesOptions 4 | , runChanges 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Blammo.Logging.Logger (pushLoggerLn) 10 | import qualified Data.Text.IO as T 11 | import Options.Applicative 12 | import Stackctl.AWS hiding (action) 13 | import Stackctl.AWS.Scope 14 | import Stackctl.Colors 15 | import Stackctl.Config (HasConfig) 16 | import Stackctl.DirectoryOption (HasDirectoryOption) 17 | import Stackctl.FilterOption (HasFilterOption) 18 | import Stackctl.ParameterOption 19 | import Stackctl.RemovedStack 20 | import Stackctl.Spec.Changes.Format 21 | import Stackctl.Spec.Discover 22 | import Stackctl.StackSpec 23 | import Stackctl.StackSpecPath 24 | import Stackctl.TagOption 25 | 26 | data ChangesOptions = ChangesOptions 27 | { scoFormat :: Format 28 | , scoOmitFull :: OmitFull 29 | , scoParameters :: [Parameter] 30 | , scoTags :: [Tag] 31 | , scoOutput :: Maybe FilePath 32 | } 33 | 34 | -- brittany-disable-next-binding 35 | 36 | parseChangesOptions :: Parser ChangesOptions 37 | parseChangesOptions = 38 | ChangesOptions 39 | <$> formatOption 40 | <*> omitFullOption 41 | <*> many parameterOption 42 | <*> many tagOption 43 | <*> optional 44 | ( argument 45 | str 46 | ( metavar "PATH" 47 | <> help "Write changes summary to PATH" 48 | <> action "file" 49 | ) 50 | ) 51 | 52 | runChanges 53 | :: ( MonadMask m 54 | , MonadUnliftIO m 55 | , MonadAWS m 56 | , MonadLogger m 57 | , MonadReader env m 58 | , HasLogger env 59 | , HasAwsScope env 60 | , HasConfig env 61 | , HasDirectoryOption env 62 | , HasFilterOption env 63 | ) 64 | => ChangesOptions 65 | -> m () 66 | runChanges ChangesOptions {..} = do 67 | -- Clear file before starting, as we have to use append for each spec 68 | liftIO $ traverse_ (`T.writeFile` "") scoOutput 69 | 70 | colors <- case scoOutput of 71 | Nothing -> getColorsLogger 72 | Just {} -> pure noColors 73 | 74 | let write formatted = case scoOutput of 75 | Nothing -> pushLoggerLn formatted 76 | Just p -> liftIO $ T.appendFile p $ formatted <> "\n" 77 | 78 | forEachSpec_ $ \spec -> do 79 | withThreadContext ["stackName" .= stackSpecStackName spec] $ do 80 | emChangeSet <- createChangeSet spec scoParameters scoTags 81 | 82 | case emChangeSet of 83 | Left err -> do 84 | logError $ "Error creating ChangeSet" :# ["error" .= err] 85 | exitFailure 86 | Right mChangeSet -> do 87 | let name = pack $ stackSpecPathFilePath $ stackSpecSpecPath spec 88 | write $ formatChangeSet colors scoOmitFull name scoFormat mChangeSet 89 | 90 | removed <- inferRemovedStacks 91 | traverse_ (write . formatRemovedStack colors scoFormat) removed 92 | -------------------------------------------------------------------------------- /src/Stackctl/Spec/Changes/Format.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Spec.Changes.Format 2 | ( Format (..) 3 | , formatOption 4 | , OmitFull (..) 5 | , omitFullOption 6 | , formatChangeSet 7 | , formatRemovedStack 8 | , formatTTY 9 | ) where 10 | 11 | import Stackctl.Prelude 12 | 13 | import qualified Data.List.NonEmpty as NE 14 | import qualified Data.Text as T 15 | import Options.Applicative hiding (action) 16 | import Stackctl.AWS 17 | import Stackctl.Colors 18 | 19 | data Format 20 | = FormatTTY 21 | | FormatPullRequest 22 | deriving stock (Bounded, Enum, Show) 23 | 24 | data OmitFull 25 | = OmitFull 26 | | IncludeFull 27 | 28 | formatOption :: Parser Format 29 | formatOption = 30 | option (eitherReader readFormat) 31 | $ mconcat 32 | [ short 'f' 33 | , long "format" 34 | , help "Format to output changes in" 35 | , value FormatTTY 36 | , showDefaultWith showFormat 37 | ] 38 | 39 | readFormat :: String -> Either String Format 40 | readFormat = \case 41 | "tty" -> Right FormatTTY 42 | "pr" -> Right FormatPullRequest 43 | x -> Left $ "Invalid format: " <> x 44 | 45 | showFormat :: Format -> String 46 | showFormat = \case 47 | FormatTTY -> "tty" 48 | FormatPullRequest -> "pr" 49 | 50 | -- brittany-disable-next-binding 51 | 52 | omitFullOption :: Parser OmitFull 53 | omitFullOption = 54 | flag 55 | IncludeFull 56 | OmitFull 57 | ( long "no-include-full" 58 | <> help "Don't include full ChangeSet JSON details" 59 | ) 60 | 61 | formatChangeSet 62 | :: Colors -> OmitFull -> Text -> Format -> Maybe ChangeSet -> Text 63 | formatChangeSet colors omitFull name = \case 64 | FormatTTY -> formatTTY colors name 65 | FormatPullRequest -> formatPullRequest omitFull name 66 | 67 | formatRemovedStack :: Colors -> Format -> Stack -> Text 68 | formatRemovedStack Colors {..} format stack = case format of 69 | FormatTTY -> red "DELETE" <> " stack " <> cyan name 70 | FormatPullRequest -> ":x: This PR will **delete** the stack `" <> name <> "`" 71 | where 72 | name = stack ^. stack_stackName 73 | 74 | formatTTY :: Colors -> Text -> Maybe ChangeSet -> Text 75 | formatTTY colors@Colors {..} name mChangeSet = case (mChangeSet, rChanges) of 76 | (Nothing, _) -> "No changes for " <> name 77 | (_, Nothing) -> "Metadata only changes (e.g. Tags or Outputs)" 78 | (_, Just rcs) -> 79 | ("\n" <>) 80 | $ (<> "\n") 81 | $ mconcat 82 | $ ("Changes for " <> cyan name <> ":") 83 | : map (("\n " <>) . formatResourceChange) (NE.toList rcs) 84 | where 85 | rChanges = do 86 | cs <- mChangeSet 87 | changes <- csChanges cs 88 | NE.nonEmpty $ mapMaybe resourceChange changes 89 | 90 | formatResourceChange ResourceChange' {..} = 91 | maybe "" colorAction action 92 | <> " " 93 | <> maybe "" toText logicalResourceId 94 | <> " (" 95 | <> maybe "" cyan resourceType 96 | <> ")" 97 | <> maybe "" ((" " <>) . magenta) physicalResourceId 98 | <> maybe "" (("\n Replacement: " <>) . colorReplacement) replacement 99 | <> maybe "" (("\n Scope: " <>) . T.intercalate ", " . map toText) scope 100 | <> maybe "" (("\n Details:" <>) . formatDetails) details 101 | 102 | formatDetails = 103 | mconcat . map ("\n * " <>) . mapMaybe (formatDetail colors) 104 | 105 | colorAction = \case 106 | x@ChangeAction_Add -> green (toText x) 107 | x@ChangeAction_Modify -> yellow (toText x) 108 | x@ChangeAction_Remove -> red (toText x) 109 | ChangeAction' x -> x 110 | 111 | colorReplacement = \case 112 | x@Replacement_True -> red (toText x) 113 | x@Replacement_False -> green (toText x) 114 | x@Replacement_Conditional -> yellow (toText x) 115 | Replacement' x -> x 116 | 117 | formatPullRequest :: OmitFull -> Text -> Maybe ChangeSet -> Text 118 | formatPullRequest omitFull name mChangeSet = 119 | emoji 120 | <> " This PR generates " 121 | <> description 122 | <> " for `" 123 | <> name 124 | <> "`." 125 | <> fromMaybe "" (commentBody omitFull <$> mChangeSet <*> rChanges) 126 | <> "\n" 127 | where 128 | emoji = case (mChangeSet, nChanges) of 129 | (Nothing, _) -> ":heavy_check_mark:" 130 | (_, Nothing) -> ":book:" 131 | (_, Just _) -> ":warning:" 132 | 133 | description = case (mChangeSet, nChanges) of 134 | (Nothing, _) -> "no changes" 135 | (_, Nothing) -> "only metadata changes (Tags, Outputs, etc)" 136 | (_, Just 1) -> "**1** change" 137 | (_, Just n) -> "**" <> pack (show n) <> "** changes" 138 | 139 | nChanges = length <$> rChanges 140 | 141 | rChanges = do 142 | cs <- mChangeSet 143 | changes <- csChanges cs 144 | NE.nonEmpty $ mapMaybe resourceChange changes 145 | 146 | commentBody :: OmitFull -> ChangeSet -> NonEmpty ResourceChange -> Text 147 | commentBody omitFull cs rcs = 148 | mconcat 149 | $ [ "\n" 150 | , "\n| Action | Logical Id | Physical Id | Type | Replacement | Scope | Details |" 151 | , "\n| --- | --- | --- | --- | --- | --- | --- |" 152 | ] 153 | <> map commentTableRow (NE.toList rcs) 154 | <> case omitFull of 155 | OmitFull -> [] 156 | IncludeFull -> 157 | [ "\n" 158 | , "\n
" 159 | , "\nFull changes" 160 | , "\n" 161 | , "\n```json" 162 | , "\n" <> changeSetJSON cs 163 | , "\n```" 164 | , "\n" 165 | , "\n
" 166 | ] 167 | 168 | commentTableRow :: ResourceChange -> Text 169 | commentTableRow ResourceChange' {..} = 170 | mconcat 171 | [ "\n" 172 | , "| " <> maybe "" toText action <> " " 173 | , "| " <> maybe "" toText logicalResourceId <> " " 174 | , "| " <> maybe "" toText physicalResourceId <> " " 175 | , "| " <> maybe "" toText resourceType <> " " 176 | , "| " <> maybe "" toText replacement <> " " 177 | , "| " <> maybe "" (T.intercalate ", " . map toText) scope <> " " 178 | , "| " <> maybe "" (mdList . mapMaybe (formatDetail noColors)) details <> " " 179 | , "|" 180 | ] 181 | 182 | mdList :: [Text] -> Text 183 | mdList xs = 184 | "
    " <> mconcat (map (\x -> "
  • " <> x <> "
    • ") xs) <> "
" 185 | 186 | formatDetail :: Colors -> ResourceChangeDetail -> Maybe Text 187 | formatDetail Colors {..} ResourceChangeDetail' {..} = do 188 | c <- changeSource 189 | t <- target 190 | 191 | let 192 | attr = attribute t 193 | n = name t 194 | rr = requiresRecreation t 195 | 196 | pure 197 | $ toText c 198 | <> maybe "" ((" in " <>) . toText) attr 199 | <> maybe "" (\x -> " (" <> magenta (toText x) <> ")") n 200 | <> maybe "" ((", recreation " <>) . formatRR) rr 201 | <> maybe "" ((", caused by " <>) . toText) causingEntity 202 | where 203 | formatRR = \case 204 | x@RequiresRecreation_Always -> red (toText x) 205 | x@RequiresRecreation_Never -> green (toText x) 206 | x@RequiresRecreation_Conditionally -> yellow (toText x) 207 | RequiresRecreation' x -> x 208 | -------------------------------------------------------------------------------- /src/Stackctl/Spec/Discover.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Spec.Discover 2 | ( forEachSpec_ 3 | , discoverSpecs 4 | , buildSpecPath 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Data.List.Extra (dropPrefix) 10 | import qualified Data.List.NonEmpty as NE 11 | import qualified Data.List.NonEmpty.Extra as NE 12 | import Data.Text.Metrics (levenshtein) 13 | import Stackctl.AWS 14 | import Stackctl.AWS.Scope 15 | import Stackctl.Config (HasConfig) 16 | import Stackctl.DirectoryOption (HasDirectoryOption (..), unDirectoryOption) 17 | import Stackctl.FilterOption (HasFilterOption (..), filterStackSpecs) 18 | import Stackctl.StackSpec 19 | import Stackctl.StackSpecPath 20 | import System.FilePath (isPathSeparator) 21 | import System.FilePath.Glob 22 | 23 | forEachSpec_ 24 | :: ( MonadIO m 25 | , MonadMask m 26 | , MonadLogger m 27 | , MonadReader env m 28 | , HasAwsScope env 29 | , HasConfig env 30 | , HasDirectoryOption env 31 | , HasFilterOption env 32 | ) 33 | => (StackSpec -> m ()) 34 | -> m () 35 | forEachSpec_ f = traverse_ f =<< discoverSpecs 36 | 37 | discoverSpecs 38 | :: ( MonadIO m 39 | , MonadMask m 40 | , MonadLogger m 41 | , MonadReader env m 42 | , HasAwsScope env 43 | , HasConfig env 44 | , HasDirectoryOption env 45 | , HasFilterOption env 46 | ) 47 | => m [StackSpec] 48 | discoverSpecs = do 49 | dir <- unDirectoryOption <$> view directoryOptionL 50 | scope <- view awsScopeL 51 | paths <- globRelativeTo dir $ awsScopeSpecPatterns scope 52 | filterOption <- view filterOptionL 53 | 54 | let 55 | toSpecPath = stackSpecPathFromFilePath scope 56 | (errs, specPaths) = partitionEithers $ map toSpecPath paths 57 | 58 | context = 59 | [ "path" .= dir 60 | , "filters" .= filterOption 61 | , "paths" .= length paths 62 | , "errors" .= length errs 63 | , "specs" .= length specPaths 64 | ] 65 | 66 | withThreadContext context $ do 67 | checkForDuplicateStackNames specPaths 68 | 69 | mAllSpecs <- NE.nonEmpty <$> traverse (readStackSpec dir) specPaths 70 | 71 | case mAllSpecs of 72 | Nothing -> do 73 | [] 74 | <$ logWarn 75 | ( "Missing or empty specification directory" 76 | :# [ "directory" .= dir 77 | , "hint" .= ("Is this the correct directory?" :: Text) 78 | ] 79 | ) 80 | Just allSpecs -> do 81 | let 82 | known = stackSpecStackName <$> allSpecs 83 | specs = 84 | sortStackSpecs 85 | $ filterStackSpecs filterOption 86 | $ NE.toList allSpecs 87 | 88 | traverse_ (checkForUnknownDepends known) specs 89 | when (null specs) $ logWarn "No specs matched filters" 90 | specs <$ logDebug ("Discovered specs" :# ["matched" .= length specs]) 91 | 92 | checkForDuplicateStackNames 93 | :: (MonadIO m, MonadLogger m) => [StackSpecPath] -> m () 94 | checkForDuplicateStackNames = 95 | traverse_ reportCollisions 96 | . NE.nonEmpty 97 | . filter ((> 1) . length) 98 | . NE.groupAllWith stackSpecPathStackName 99 | where 100 | reportCollisions 101 | :: (MonadIO m, MonadLogger m) => NonEmpty (NonEmpty StackSpecPath) -> m () 102 | reportCollisions errs = do 103 | for_ errs $ \specPaths -> do 104 | let collidingPaths = stackSpecPathBasePath <$> specPaths 105 | 106 | logError 107 | $ "Multiple specifications produced the same Stack name" 108 | :# [ "name" .= stackSpecPathStackName (NE.head specPaths) 109 | , "paths" .= collidingPaths 110 | ] 111 | 112 | exitFailure 113 | 114 | -- | Warn if a 'StackSpec' depends on a name not in the given 'StackName's 115 | -- 116 | -- The 'StackName's are built from all specs, but we only run this with specs 117 | -- that are filtered in. 118 | -- 119 | -- NB. This function is written so it can easily be made into a fatal error 120 | -- (like 'checkForDuplicateStackNames'), but we only warn for now. 121 | checkForUnknownDepends 122 | :: MonadLogger m => NonEmpty StackName -> StackSpec -> m () 123 | checkForUnknownDepends known spec = 124 | traverse_ reportUnknownDepends 125 | $ NE.nonEmpty 126 | $ filter (`notElem` known) 127 | $ stackSpecDepends spec 128 | where 129 | reportUnknownDepends depends = do 130 | for_ depends $ \depend -> do 131 | let (nearest, _distance) = 132 | NE.minimumBy1 (comparing snd) 133 | $ (id &&& getDistance depend) <$> known 134 | 135 | logWarn 136 | $ "Stack lists dependency that does not exist" 137 | :# [ "dependency" 138 | .= ( unStackName (stackSpecStackName spec) 139 | <> " -> " 140 | <> unStackName depend 141 | ) 142 | , "hint" .= ("Did you mean " <> unStackName nearest <> "?") 143 | ] 144 | 145 | getDistance = levenshtein `on` unStackName 146 | 147 | buildSpecPath 148 | :: (MonadReader env m, HasAwsScope env) 149 | => StackName 150 | -> FilePath 151 | -> m StackSpecPath 152 | buildSpecPath stackName stackPath = do 153 | scope <- view awsScopeL 154 | pure $ stackSpecPath scope stackName stackPath 155 | 156 | globRelativeTo :: MonadIO m => FilePath -> [Pattern] -> m [FilePath] 157 | globRelativeTo dir ps = liftIO $ do 158 | map (dropWhile isPathSeparator . dropPrefix dir) . concat <$> globDir ps dir 159 | -------------------------------------------------------------------------------- /src/Stackctl/Spec/Generate.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Spec.Generate 2 | ( GenerateSpec (..) 3 | , GenerateTemplate (..) 4 | , generate 5 | , TemplateFormat (..) 6 | ) where 7 | 8 | import Stackctl.Prelude 9 | 10 | import Stackctl.AWS 11 | import Stackctl.AWS.Scope 12 | import Stackctl.Config (HasConfig) 13 | import Stackctl.DirectoryOption 14 | import Stackctl.Spec.Discover (buildSpecPath) 15 | import Stackctl.StackSpec 16 | import Stackctl.StackSpecPath 17 | import Stackctl.StackSpecYaml 18 | 19 | data GenerateSpec 20 | = -- | Generate at an inferred name 21 | GenerateSpec StackName 22 | | -- | Generate to a given path 23 | GenerateSpecTo StackName FilePath 24 | 25 | data GenerateTemplate 26 | = -- | Generate at an inferred name 27 | GenerateTemplate TemplateBody TemplateFormat 28 | | -- | Generate to the given path 29 | GenerateTemplateTo TemplateBody FilePath 30 | | -- | Assume template exists 31 | UseExistingTemplate FilePath 32 | 33 | data TemplateFormat 34 | = TemplateFormatYaml 35 | | TemplateFormatJson 36 | 37 | generate 38 | :: ( MonadMask m 39 | , MonadUnliftIO m 40 | , MonadLogger m 41 | , MonadReader env m 42 | , HasConfig env 43 | , HasAwsScope env 44 | , HasDirectoryOption env 45 | ) 46 | => Bool 47 | -> GenerateSpec 48 | -> GenerateTemplate 49 | -> (FilePath -> StackSpecYaml) 50 | -> m FilePath 51 | generate overwrite spec template toStackSpecYaml = do 52 | let 53 | (stackName, stackPath) = case spec of 54 | GenerateSpec name -> (name, unpack (unStackName name) <> ".yaml") 55 | GenerateSpecTo name path -> (name, path) 56 | 57 | (mTemplateBody, templatePath) = case template of 58 | GenerateTemplate body format -> 59 | ( Just body 60 | , case format of 61 | TemplateFormatYaml -> unpack (unStackName stackName) <> ".yaml" 62 | TemplateFormatJson -> unpack (unStackName stackName) <> ".json" 63 | ) 64 | GenerateTemplateTo body path -> (Just body, path) 65 | UseExistingTemplate path -> (Nothing, path) 66 | 67 | specYaml = toStackSpecYaml templatePath 68 | 69 | dir <- view $ directoryOptionL . to unDirectoryOption 70 | specPath <- buildSpecPath stackName stackPath 71 | stackSpec <- buildStackSpec dir specPath specYaml 72 | 73 | withThreadContext ["stackName" .= stackSpecStackName stackSpec] $ do 74 | writeStackSpec overwrite stackSpec mTemplateBody 75 | pure $ stackSpecPathFilePath specPath 76 | -------------------------------------------------------------------------------- /src/Stackctl/Spec/List.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Spec.List 2 | ( ListOptions (..) 3 | , parseListOptions 4 | , runList 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Blammo.Logging.Logger (pushLoggerLn) 10 | import qualified Data.Text as T 11 | import Options.Applicative 12 | import Stackctl.AWS 13 | import Stackctl.AWS.Scope 14 | import Stackctl.Colors 15 | import Stackctl.Config (HasConfig) 16 | import Stackctl.DirectoryOption (HasDirectoryOption (..)) 17 | import Stackctl.FilterOption (HasFilterOption) 18 | import Stackctl.Spec.Discover 19 | import Stackctl.StackSpec 20 | 21 | newtype ListOptions = ListOptions 22 | { loLegend :: Bool 23 | } 24 | 25 | parseListOptions :: Parser ListOptions 26 | parseListOptions = 27 | ListOptions 28 | <$> ( not 29 | <$> switch 30 | ( mconcat 31 | [ long "no-legend" 32 | , help "Don't print indicators legend at the end" 33 | ] 34 | ) 35 | ) 36 | 37 | runList 38 | :: ( MonadUnliftIO m 39 | , MonadMask m 40 | , MonadAWS m 41 | , MonadLogger m 42 | , MonadReader env m 43 | , HasAwsScope env 44 | , HasLogger env 45 | , HasConfig env 46 | , HasDirectoryOption env 47 | , HasFilterOption env 48 | ) 49 | => ListOptions 50 | -> m () 51 | runList ListOptions {..} = do 52 | colors@Colors {..} <- getColorsLogger 53 | 54 | forEachSpec_ $ \spec -> do 55 | let 56 | path = stackSpecFilePath spec 57 | name = stackSpecStackName spec 58 | 59 | mStackStatus <- 60 | fmap (^. stack_stackStatus) 61 | <$> awsCloudFormationDescribeStackMaybe name 62 | 63 | let 64 | indicator = maybe NotDeployed statusIndicator mStackStatus 65 | 66 | formatted :: Text 67 | formatted = 68 | " " 69 | <> indicatorIcon colors indicator 70 | <> " " 71 | <> cyan (unStackName name) 72 | <> " => " 73 | <> magenta (pack path) 74 | 75 | pushLoggerLn formatted 76 | 77 | let legendItem i = indicatorIcon colors i <> " " <> indicatorDescription i 78 | 79 | when loLegend 80 | $ pushLoggerLn 81 | $ "\nLegend:\n " 82 | <> T.intercalate ", " (map legendItem [minBound .. maxBound]) 83 | 84 | data Indicator 85 | = Deployed 86 | | DeployFailed 87 | | NotDeployed 88 | | Reviewing 89 | | Deploying 90 | | Unknown 91 | deriving stock (Bounded, Enum) 92 | 93 | indicatorIcon :: Colors -> Indicator -> Text 94 | indicatorIcon Colors {..} = \case 95 | Deployed -> green "✓" 96 | DeployFailed -> red "✗" 97 | NotDeployed -> yellow "_" 98 | Reviewing -> yellow "∇" 99 | Deploying -> cyan "⋅" 100 | Unknown -> magenta "?" 101 | 102 | indicatorDescription :: Indicator -> Text 103 | indicatorDescription = \case 104 | Deployed -> "deployed" 105 | DeployFailed -> "failed or rolled back" 106 | NotDeployed -> "doesn't exist" 107 | Reviewing -> "reviewing" 108 | Deploying -> "deploying" 109 | Unknown -> "unknown" 110 | 111 | statusIndicator :: StackStatus -> Indicator 112 | statusIndicator = \case 113 | StackStatus_REVIEW_IN_PROGRESS -> Reviewing 114 | StackStatus_ROLLBACK_COMPLETE -> DeployFailed 115 | x | statusSuffixed "_IN_PROGRESS" x -> Deploying 116 | x | statusSuffixed "_FAILED" x -> DeployFailed 117 | x | statusSuffixed "_ROLLBACK_COMPLETE" x -> DeployFailed 118 | x | statusSuffixed "_COMPLETE" x -> Deployed 119 | _ -> Unknown 120 | where 121 | statusSuffixed x = (x `T.isSuffixOf`) . fromStackStatus 122 | -------------------------------------------------------------------------------- /src/Stackctl/StackDescription.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.StackDescription 2 | ( StackDescription (..) 3 | , addStackDescription 4 | ) where 5 | 6 | import Stackctl.Prelude 7 | 8 | import Control.Lens ((?~)) 9 | import Data.Aeson (FromJSON, Value (..)) 10 | import qualified Data.Aeson as JSON 11 | import Data.Aeson.Lens 12 | import Data.ByteString.Char8 as BS8 13 | import qualified Data.Yaml as Yaml 14 | 15 | newtype StackDescription = StackDescription 16 | { unStackDescription :: Text 17 | } 18 | deriving newtype (Eq, Ord, Show, FromJSON, ToJSON) 19 | 20 | data BodyContent 21 | = BodyContentJSON Value 22 | | BodyContentYaml Value 23 | 24 | addStackDescription :: Maybe StackDescription -> Text -> Text 25 | addStackDescription mStackDescription body = fromMaybe body $ do 26 | StackDescription d <- mStackDescription 27 | bc <- getBodyContent bs 28 | decodeUtf8 <$> case bc of 29 | BodyContentJSON v -> updateJSON d bs <$ guard (not $ hasDescription v) 30 | BodyContentYaml v -> updateYaml d bs <$ guard (not $ hasDescription v) 31 | where 32 | bs = encodeUtf8 body 33 | 34 | getBodyContent :: ByteString -> Maybe BodyContent 35 | getBodyContent body = 36 | asum 37 | [ BodyContentJSON . Object <$> JSON.decodeStrict body 38 | , hush $ BodyContentYaml . Object <$> Yaml.decodeEither' body 39 | ] 40 | 41 | -- Inserting a key is easy to do in Yaml without the parsing round-trip that 42 | -- would strip formatting and comments. But updating a key is hard. To avoid 43 | -- this, we just say that we never clobber existing keys. 44 | hasDescription :: Value -> Bool 45 | hasDescription = isJust . (^? key "Description" . _String) 46 | 47 | -- For JSON, don't worry about preserving formatting; do a proper update. 48 | updateJSON :: Text -> ByteString -> ByteString 49 | updateJSON d = atKey "Description" ?~ String d 50 | 51 | -- For Yaml, insert textually to avoid a round-trip dropping comments or 52 | -- changing whitespace. We rely on 'Show' as a naive escape. 53 | updateYaml :: Text -> ByteString -> ByteString 54 | updateYaml d bs = "Description: " <> BS8.pack (show d) <> "\n" <> bs 55 | -------------------------------------------------------------------------------- /src/Stackctl/StackSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.StackSpec 2 | ( StackSpec 3 | , stackSpecFilePath 4 | , stackSpecSpecPath 5 | , stackSpecSpecBody 6 | , stackSpecStackName 7 | , stackSpecStackDescription 8 | , stackSpecDepends 9 | , stackSpecActions 10 | , stackSpecParameters 11 | , stackSpecCapabilities 12 | , stackSpecStackFile 13 | , stackSpecTemplateFile 14 | , stackSpecTags 15 | , buildStackSpec 16 | , TemplateBody 17 | , templateBodyFromValue 18 | , writeStackSpec 19 | , readStackSpec 20 | , createChangeSet 21 | , sortStackSpecs 22 | ) where 23 | 24 | import Stackctl.Prelude 25 | 26 | import qualified CfnFlip 27 | import Data.Aeson 28 | import qualified Data.ByteString.Lazy as BSL 29 | import Data.List.Extra (nubOrdOn) 30 | import qualified Data.Yaml as Yaml 31 | import Stackctl.AWS 32 | import Stackctl.Action 33 | import Stackctl.Config (HasConfig (..), applyConfig) 34 | import Stackctl.Sort 35 | import Stackctl.StackSpecPath 36 | import Stackctl.StackSpecYaml 37 | import System.FilePath (takeExtension) 38 | import qualified System.FilePath as FilePath 39 | import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist) 40 | 41 | data StackSpec = StackSpec 42 | { ssSpecRoot :: FilePath 43 | , ssSpecPath :: StackSpecPath 44 | , ssSpecBody :: StackSpecYaml 45 | } 46 | 47 | stackSpecSpecRoot :: StackSpec -> FilePath 48 | stackSpecSpecRoot = ssSpecRoot 49 | 50 | stackSpecFilePath :: StackSpec -> FilePath 51 | stackSpecFilePath spec = 52 | FilePath.normalise $ stackSpecSpecRoot spec stackSpecStackFile spec 53 | 54 | stackSpecSpecPath :: StackSpec -> StackSpecPath 55 | stackSpecSpecPath = ssSpecPath 56 | 57 | stackSpecSpecBody :: StackSpec -> StackSpecYaml 58 | stackSpecSpecBody = ssSpecBody 59 | 60 | stackSpecStackName :: StackSpec -> StackName 61 | stackSpecStackName = stackSpecPathStackName . ssSpecPath 62 | 63 | stackSpecStackDescription :: StackSpec -> Maybe StackDescription 64 | stackSpecStackDescription = ssyDescription . ssSpecBody 65 | 66 | stackSpecDepends :: StackSpec -> [StackName] 67 | stackSpecDepends = fromMaybe [] . ssyDepends . ssSpecBody 68 | 69 | stackSpecActions :: StackSpec -> [Action] 70 | stackSpecActions = fromMaybe [] . ssyActions . ssSpecBody 71 | 72 | -- | Relative path @stacks/...@ 73 | stackSpecStackFile :: StackSpec -> FilePath 74 | stackSpecStackFile = stackSpecPathFilePath . ssSpecPath 75 | 76 | -- | Relative path @templates/...@ 77 | stackSpecTemplateFile :: StackSpec -> FilePath 78 | stackSpecTemplateFile = ("templates" ) . ssyTemplate . ssSpecBody 79 | 80 | stackSpecTemplate :: StackSpec -> StackTemplate 81 | stackSpecTemplate spec = 82 | StackTemplate 83 | $ FilePath.normalise 84 | $ ssSpecRoot spec stackSpecTemplateFile spec 85 | 86 | stackSpecParameters :: StackSpec -> [Parameter] 87 | stackSpecParameters = 88 | maybe [] (map unParameterYaml . unParametersYaml) . ssyParameters . ssSpecBody 89 | 90 | stackSpecCapabilities :: StackSpec -> [Capability] 91 | stackSpecCapabilities = fromMaybe [] . ssyCapabilities . ssSpecBody 92 | 93 | stackSpecTags :: StackSpec -> [Tag] 94 | stackSpecTags = maybe [] (map unTagYaml . unTagsYaml) . ssyTags . ssSpecBody 95 | 96 | buildStackSpec 97 | :: (MonadReader env m, HasConfig env) 98 | => FilePath 99 | -> StackSpecPath 100 | -> StackSpecYaml 101 | -> m StackSpec 102 | buildStackSpec dir specPath specBody = do 103 | config <- view configL 104 | pure 105 | StackSpec 106 | { ssSpecRoot = dir 107 | , ssSpecPath = specPath 108 | , ssSpecBody = applyConfig config specBody 109 | } 110 | 111 | data TemplateBody 112 | = TemplateText Text 113 | | TemplateJson Value 114 | 115 | newtype UnexpectedTemplateJson = UnexpectedTemplateJson 116 | { _unexpectedTemplateJsonExtension :: String 117 | } 118 | deriving stock (Show) 119 | 120 | instance Exception UnexpectedTemplateJson where 121 | displayException (UnexpectedTemplateJson ext) = 122 | "TemplateJson must be written to .yaml or .json, encountered " 123 | <> ext 124 | <> ". To write to an arbitrary path, use TemplateText." 125 | 126 | templateBodyFromValue :: Value -> TemplateBody 127 | templateBodyFromValue = \case 128 | String x -> TemplateText x 129 | v -> TemplateJson v 130 | 131 | writeTemplateBody :: MonadUnliftIO m => FilePath -> TemplateBody -> m () 132 | writeTemplateBody path body = do 133 | createDirectoryIfMissing True dir 134 | 135 | case (body, ext) of 136 | (TemplateText t, _) -> writeFileUtf8 path t 137 | (TemplateJson v, ".yaml") -> CfnFlip.jsonToYamlFile path v 138 | (TemplateJson v, ".json") -> writeFileBinary path $ BSL.toStrict $ encode v 139 | (TemplateJson _, _) -> throwIO $ UnexpectedTemplateJson ext 140 | where 141 | dir = takeDirectory path 142 | ext = takeExtension path 143 | 144 | writeStackSpec 145 | :: (MonadUnliftIO m, MonadLogger m) 146 | => Bool 147 | -> StackSpec 148 | -> Maybe TemplateBody 149 | -> m () 150 | writeStackSpec overwrite stackSpec mTemplateBody = do 151 | for_ mTemplateBody $ \templateBody -> do 152 | logInfo $ "Writing template" :# ["path" .= templatePath] 153 | writeTemplateBody templatePath templateBody 154 | 155 | exists <- doesFileExist specPath 156 | 157 | if exists && not overwrite 158 | then do 159 | let 160 | reason :: Text 161 | reason = "file exists and overwrite not set" 162 | logInfo $ "Skipping" :# ["path" .= specPath, "reason" .= reason] 163 | else do 164 | logInfo $ "Writing specification" :# ["path" .= specPath] 165 | createDirectoryIfMissing True $ takeDirectory specPath 166 | liftIO $ Yaml.encodeFile specPath $ stackSpecSpecBody stackSpec 167 | where 168 | templatePath = unStackTemplate $ stackSpecTemplate stackSpec 169 | specPath = stackSpecFilePath stackSpec 170 | 171 | readStackSpec 172 | :: (MonadIO m, MonadReader env m, HasConfig env) 173 | => FilePath 174 | -> StackSpecPath 175 | -> m StackSpec 176 | readStackSpec dir specPath = do 177 | specBody <- liftIO $ either err pure =<< Yaml.decodeFileEither path 178 | buildStackSpec dir specPath specBody 179 | where 180 | path = dir stackSpecPathFilePath specPath 181 | err e = 182 | throwString $ path <> " is invalid: " <> Yaml.prettyPrintParseException e 183 | 184 | -- | Create a Change Set between a Stack Specification and deployed state 185 | createChangeSet 186 | :: ( MonadUnliftIO m 187 | , MonadLogger m 188 | , MonadAWS m 189 | ) 190 | => StackSpec 191 | -> [Parameter] 192 | -> [Tag] 193 | -> m (Either Text (Maybe ChangeSet)) 194 | createChangeSet spec parameters tags = 195 | awsCloudFormationCreateChangeSet 196 | (stackSpecStackName spec) 197 | (stackSpecStackDescription spec) 198 | (stackSpecTemplate spec) 199 | (nubOrdOn (^. parameter_parameterKey) $ parameters <> stackSpecParameters spec) 200 | (stackSpecCapabilities spec) 201 | (nubOrdOn (^. tag_key) $ tags <> stackSpecTags spec) 202 | 203 | sortStackSpecs :: [StackSpec] -> [StackSpec] 204 | sortStackSpecs = sortByDependencies stackSpecStackName stackSpecDepends 205 | -------------------------------------------------------------------------------- /src/Stackctl/StackSpecPath.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | module Stackctl.StackSpecPath 4 | ( StackSpecPath 5 | 6 | -- * Fields 7 | , stackSpecPathAccountId 8 | , stackSpecPathAccountName 9 | , stackSpecPathRegion 10 | , stackSpecPathStackName 11 | , stackSpecPathBasePath 12 | , stackSpecPathFilePath 13 | 14 | -- * Construction 15 | , stackSpecPath 16 | , stackSpecPathFromFilePath 17 | ) where 18 | 19 | import Stackctl.Prelude 20 | 21 | import Data.Char (isDigit) 22 | import qualified Data.Text as T 23 | import Stackctl.AWS 24 | import Stackctl.AWS.Scope 25 | import System.FilePath (joinPath, splitDirectories) 26 | 27 | data StackSpecPath = StackSpecPath 28 | { sspAwsScope :: AwsScope 29 | , sspAccountPathPart :: FilePath 30 | , sspStackName :: StackName 31 | , sspPath :: FilePath 32 | } 33 | deriving stock (Eq, Show) 34 | 35 | stackSpecPath :: AwsScope -> StackName -> FilePath -> StackSpecPath 36 | stackSpecPath sspAwsScope@AwsScope {..} sspStackName sspPath = 37 | StackSpecPath 38 | { sspAwsScope 39 | , sspAccountPathPart 40 | , sspStackName 41 | , sspPath 42 | } 43 | where 44 | sspAccountPathPart = 45 | unpack $ unAccountId awsAccountId <> "." <> awsAccountName 46 | 47 | stackSpecPathAccountId :: StackSpecPath -> AccountId 48 | stackSpecPathAccountId = awsAccountId . sspAwsScope 49 | 50 | stackSpecPathAccountName :: StackSpecPath -> Text 51 | stackSpecPathAccountName = awsAccountName . sspAwsScope 52 | 53 | stackSpecPathAccountPathPart :: StackSpecPath -> FilePath 54 | stackSpecPathAccountPathPart = sspAccountPathPart 55 | 56 | stackSpecPathRegion :: StackSpecPath -> Region 57 | stackSpecPathRegion = awsRegion . sspAwsScope 58 | 59 | stackSpecPathBasePath :: StackSpecPath -> FilePath 60 | stackSpecPathBasePath = sspPath 61 | 62 | stackSpecPathStackName :: StackSpecPath -> StackName 63 | stackSpecPathStackName = sspStackName 64 | 65 | -- | Render the (relative) 'StackSpecPath' 66 | stackSpecPathFilePath :: StackSpecPath -> FilePath 67 | stackSpecPathFilePath path = 68 | "stacks" 69 | stackSpecPathAccountPathPart path 70 | unpack (fromRegion $ stackSpecPathRegion path) 71 | stackSpecPathBasePath path 72 | 73 | stackSpecPathFromFilePath 74 | :: AwsScope 75 | -> FilePath 76 | -- ^ Must be relative, @stacks/@ 77 | -> Either String StackSpecPath 78 | stackSpecPathFromFilePath awsScope@AwsScope {..} path = 79 | case splitDirectories path of 80 | ("stacks" : pathAccount : pathRegion : rest) -> do 81 | (accountName, pathAccountId) <- parseAccountPath pathAccount 82 | 83 | unless (pathAccountId == awsAccountId) 84 | $ Left 85 | $ "Unexpected account: " 86 | <> unpack (unAccountId pathAccountId) 87 | <> " != " 88 | <> unpack (unAccountId awsAccountId) 89 | 90 | unless (unpack (fromRegion awsRegion) == pathRegion) 91 | $ Left 92 | $ "Unexpected region: " 93 | <> pathRegion 94 | <> " != " 95 | <> unpack (fromRegion awsRegion) 96 | 97 | stackName <- 98 | maybe (Left "Must end in .yaml") (Right . StackName) 99 | $ T.stripSuffix ".yaml" 100 | $ T.intercalate "-" 101 | $ map pack rest 102 | 103 | Right 104 | $ StackSpecPath 105 | { sspAwsScope = awsScope {awsAccountName = accountName} 106 | , sspAccountPathPart = pathAccount 107 | , sspStackName = stackName 108 | , sspPath = joinPath rest 109 | } 110 | _ -> Left $ "Path is not stacks/././.: " <> path 111 | 112 | -- | Handle @{account-name}.{account-id}@ or @{account-id}.{account-name}@ 113 | parseAccountPath :: FilePath -> Either String (Text, AccountId) 114 | parseAccountPath path = case second (T.drop 1) $ T.breakOn "." $ pack path of 115 | (a, b) | isAccountId a -> Right (b, AccountId a) 116 | (a, b) | isAccountId b -> Right (a, AccountId b) 117 | _ -> 118 | Left 119 | $ "Path matches neither {account-id}.{account-name}, nor {account-name}.{account-id}: " 120 | <> path 121 | where 122 | isAccountId x = T.length x == 12 && T.all isDigit x 123 | -------------------------------------------------------------------------------- /src/Stackctl/Subcommand.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Subcommand 2 | ( Subcommand (..) 3 | , subcommand 4 | , runSubcommand 5 | , runSubcommand' 6 | , runAppSubcommand 7 | ) where 8 | 9 | import Stackctl.Prelude 10 | 11 | import qualified Env 12 | import Options.Applicative 13 | import Stackctl.AWS (handlingServiceError) 14 | import Stackctl.AutoSSO 15 | import Stackctl.CLI 16 | import Stackctl.ColorOption 17 | import Stackctl.Options 18 | import Stackctl.VerboseOption 19 | 20 | data Subcommand options subOptions = Subcommand 21 | { name :: Text 22 | , description :: Text 23 | , parse :: Parser subOptions 24 | , run :: subOptions -> options -> IO () 25 | } 26 | 27 | subcommand 28 | :: Subcommand options subOptions -> Mod CommandFields (options -> IO ()) 29 | subcommand Subcommand {..} = 30 | command (unpack name) (run <$> withInfo description parse) 31 | 32 | runSubcommand :: Mod CommandFields (Options -> IO a) -> IO a 33 | runSubcommand = 34 | runSubcommand' "Work with Stack specifications" envParser optionsParser 35 | 36 | -- brittany-disable-next-binding 37 | 38 | runSubcommand' 39 | :: Semigroup options 40 | => Text 41 | -> Env.Parser Env.Error options 42 | -> Parser options 43 | -> Mod CommandFields (options -> IO a) 44 | -> IO a 45 | runSubcommand' title parseEnv parseCLI sp = do 46 | (options, act) <- 47 | applyEnv 48 | <$> Env.parse (Env.header $ unpack title) parseEnv 49 | <*> execParser (withInfo title $ (,) <$> parseCLI <*> subparser sp) 50 | 51 | act options 52 | where 53 | applyEnv env = first (env <>) 54 | 55 | -- | Use this in the 'run' member of a 'Subcommand' that wants 'AppT' 56 | -- 57 | -- @ 58 | -- -- ... 59 | -- , parse = parseFooOptions 60 | -- , run = 'runAppSubcommand' runFoo 61 | -- } 62 | -- 63 | -- runFoo :: (MonadReader env m, HasAws env) => FooOptions -> m () 64 | -- runFoo = undefined 65 | -- @ 66 | runAppSubcommand 67 | :: ( HasColorOption options 68 | , HasVerboseOption options 69 | , HasAutoSSOOption options 70 | ) 71 | => (subOptions -> AppT (App options) IO a) 72 | -> subOptions 73 | -> options 74 | -> IO a 75 | runAppSubcommand f subOptions options = 76 | runAppT options 77 | $ handlingServiceError 78 | $ f subOptions 79 | 80 | withInfo :: Text -> Parser a -> ParserInfo a 81 | withInfo d p = info (p <**> helper) $ progDesc (unpack d) <> fullDesc 82 | -------------------------------------------------------------------------------- /src/Stackctl/TagOption.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.TagOption 2 | ( tagOption 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import qualified Data.Text as T 8 | import Options.Applicative 9 | import Stackctl.AWS.CloudFormation (Tag, newTag) 10 | 11 | tagOption :: Parser Tag 12 | tagOption = 13 | option (eitherReader readTag) 14 | $ mconcat 15 | [ short 't' 16 | , long "tag" 17 | , metavar "KEY=[VALUE]" 18 | , help "Override the given Tag for this operation" 19 | ] 20 | 21 | readTag :: String -> Either String Tag 22 | readTag s = case T.breakOn "=" t of 23 | (_, v) | T.null v -> Left $ "No '=' found (" <> s <> ")" 24 | (k, _) | T.null k -> Left $ "Empty key (" <> s <> ")" 25 | (k, "=") -> Right $ newTag k "" 26 | (k, v) -> Right $ newTag k $ T.drop 1 v 27 | where 28 | t = pack s 29 | -------------------------------------------------------------------------------- /src/Stackctl/VerboseOption.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.VerboseOption 2 | ( Verbosity 3 | , verbositySetLogLevels 4 | , HasVerboseOption (..) 5 | , verboseOption 6 | ) where 7 | 8 | import Stackctl.Prelude 9 | 10 | import Blammo.Logging.LogSettings 11 | import Blammo.Logging.LogSettings.LogLevels 12 | import Options.Applicative 13 | 14 | newtype Verbosity = Verbosity [()] 15 | deriving newtype (Semigroup, Monoid) 16 | 17 | verbositySetLogLevels :: Verbosity -> (LogSettings -> LogSettings) 18 | verbositySetLogLevels (Verbosity bs) = case bs of 19 | [] -> id 20 | [_] -> setLogSettingsLevels v 21 | [_, _] -> setLogSettingsLevels vv 22 | _ -> setLogSettingsLevels vvv 23 | where 24 | v = newLogLevels LevelDebug [("Amazonka", LevelInfo)] 25 | vv = newLogLevels LevelDebug [] 26 | vvv = newLogLevels (LevelOther "trace") [] 27 | 28 | class HasVerboseOption env where 29 | verboseOptionL :: Lens' env Verbosity 30 | 31 | instance HasVerboseOption Verbosity where 32 | verboseOptionL = id 33 | 34 | verboseOption :: Parser Verbosity 35 | verboseOption = 36 | fmap Verbosity 37 | $ many 38 | $ flag' () 39 | $ mconcat 40 | [ short 'v' 41 | , long "verbose" 42 | , help "Increase verbosity (can be passed multiple times)" 43 | ] 44 | -------------------------------------------------------------------------------- /src/Stackctl/Version.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Version 2 | ( logVersion 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | import Prelude (putStrLn) 7 | 8 | import Data.Version 9 | import qualified Paths_stackctl as Pkg 10 | 11 | logVersion :: MonadIO m => m () 12 | logVersion = liftIO $ putStrLn $ ("Stackctl v" <>) $ showVersion Pkg.version 13 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.7 2 | 3 | extra-deps: 4 | - github: brendanhay/amazonka 5 | commit: cf174ae30fa914439f4d1fa1c3dbd9b69b935141 # main + #1029 6 | subdirs: 7 | - lib/amazonka 8 | - lib/amazonka-core 9 | - lib/services/amazonka-cloudformation 10 | - lib/services/amazonka-ec2 11 | - lib/services/amazonka-lambda 12 | - lib/services/amazonka-sso 13 | - lib/services/amazonka-sts 14 | 15 | - amazonka-mtl-0.1.1.0 16 | - cfn-flip-0.1.0.3 17 | - microlens-pro-0.2.0.2 18 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/topics/lock_files 5 | 6 | packages: 7 | - completed: 8 | name: amazonka 9 | pantry-tree: 10 | sha256: 6a4df9d7ef86e2ecffb44ef528844a97b2339e6a6703bd304a605341c6db9842 11 | size: 1529 12 | sha256: bd186dab03b64bc3f4e61adafaa8b66df7c8aaff789bfe98172dedddad59e6dc 13 | size: 34855496 14 | subdir: lib/amazonka 15 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 16 | version: '2.0' 17 | original: 18 | subdir: lib/amazonka 19 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 20 | - completed: 21 | name: amazonka-core 22 | pantry-tree: 23 | sha256: fbd62e7df53cf2f5b944a99d0ef024c77a10e3bde2e519fb95bcb262aed29fc4 24 | size: 3222 25 | sha256: bd186dab03b64bc3f4e61adafaa8b66df7c8aaff789bfe98172dedddad59e6dc 26 | size: 34855496 27 | subdir: lib/amazonka-core 28 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 29 | version: '2.0' 30 | original: 31 | subdir: lib/amazonka-core 32 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 33 | - completed: 34 | name: amazonka-cloudformation 35 | pantry-tree: 36 | sha256: 0cacf4a7cae64a63855bf1cce2b947084e4353f46756f36e65dd351087a7f63e 37 | size: 27257 38 | sha256: bd186dab03b64bc3f4e61adafaa8b66df7c8aaff789bfe98172dedddad59e6dc 39 | size: 34855496 40 | subdir: lib/services/amazonka-cloudformation 41 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 42 | version: '2.0' 43 | original: 44 | subdir: lib/services/amazonka-cloudformation 45 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 46 | - completed: 47 | name: amazonka-ec2 48 | pantry-tree: 49 | sha256: dc171159485af8773de82731ee1cf1df56acdf1e6c6fe76864dcf24d5d6b7e85 50 | size: 234434 51 | sha256: bd186dab03b64bc3f4e61adafaa8b66df7c8aaff789bfe98172dedddad59e6dc 52 | size: 34855496 53 | subdir: lib/services/amazonka-ec2 54 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 55 | version: '2.0' 56 | original: 57 | subdir: lib/services/amazonka-ec2 58 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 59 | - completed: 60 | name: amazonka-lambda 61 | pantry-tree: 62 | sha256: 249b7557046e64a2fae70acd3e7d7e20422ef7b3db49bf01d56c619e1d0a4470 63 | size: 21343 64 | sha256: bd186dab03b64bc3f4e61adafaa8b66df7c8aaff789bfe98172dedddad59e6dc 65 | size: 34855496 66 | subdir: lib/services/amazonka-lambda 67 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 68 | version: '2.0' 69 | original: 70 | subdir: lib/services/amazonka-lambda 71 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 72 | - completed: 73 | name: amazonka-sso 74 | pantry-tree: 75 | sha256: c4575f7b7cf61c3de65e43d0d77a14dfa14c47ebff5f1a3dcd2f6e1313aaaf0a 76 | size: 1817 77 | sha256: bd186dab03b64bc3f4e61adafaa8b66df7c8aaff789bfe98172dedddad59e6dc 78 | size: 34855496 79 | subdir: lib/services/amazonka-sso 80 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 81 | version: '2.0' 82 | original: 83 | subdir: lib/services/amazonka-sso 84 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 85 | - completed: 86 | name: amazonka-sts 87 | pantry-tree: 88 | sha256: e0cb89013938230d257a2e546a78170dfdb6d507f37c6cb763a6cdf6290edb66 89 | size: 2880 90 | sha256: bd186dab03b64bc3f4e61adafaa8b66df7c8aaff789bfe98172dedddad59e6dc 91 | size: 34855496 92 | subdir: lib/services/amazonka-sts 93 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 94 | version: '2.0' 95 | original: 96 | subdir: lib/services/amazonka-sts 97 | url: https://github.com/brendanhay/amazonka/archive/cf174ae30fa914439f4d1fa1c3dbd9b69b935141.tar.gz 98 | - completed: 99 | hackage: amazonka-mtl-0.1.1.0@sha256:90b45a950c0e398b0e48d1447766f331c2ac3d5a72e15be2bf0be3b3c56159c3,6572 100 | pantry-tree: 101 | sha256: c85849d4d5caa36a3597323185d7593cb624cadee6e4f05219d3ccd498a7b270 102 | size: 965 103 | original: 104 | hackage: amazonka-mtl-0.1.1.0 105 | - completed: 106 | hackage: cfn-flip-0.1.0.3@sha256:40f33714827c35a9fd3cebde06002f54448c3efa34252efbe5e48445065f2620,5934 107 | pantry-tree: 108 | sha256: 4d5fc2c97d269deb4a34432db02a725850392542d1852a11f10c76832611e2c8 109 | size: 3139 110 | original: 111 | hackage: cfn-flip-0.1.0.3 112 | - completed: 113 | hackage: microlens-pro-0.2.0.2@sha256:2fd14b7f87d6aa76700dabf65fcdda835aa329a4fdd8a44eebdf399e798af7ab,3377 114 | pantry-tree: 115 | sha256: be8ac1093c45ec46d640c56c06d8826d364ad1243d601e731e37581e8579e9c3 116 | size: 430 117 | original: 118 | hackage: microlens-pro-0.2.0.2 119 | snapshots: 120 | - completed: 121 | sha256: 4ef79c30b9efcf07335cb3de532983a7ac4c5a4180bc17f6212a86b09ce2ff75 122 | size: 680777 123 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/7.yaml 124 | original: lts-23.7 125 | -------------------------------------------------------------------------------- /stackctl.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.18 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: stackctl 8 | version: 1.7.2.0 9 | description: Please see 10 | homepage: https://github.com/freckle/stackctl#readme 11 | bug-reports: https://github.com/freckle/stackctl/issues 12 | author: Freckle Engineering 13 | maintainer: freckle-engineering@renaissance.com 14 | copyright: 2022 Renaissance Learning Inc 15 | license: MIT 16 | license-file: LICENSE 17 | build-type: Simple 18 | extra-doc-files: 19 | README.md 20 | CHANGELOG.md 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/freckle/stackctl 25 | 26 | library 27 | exposed-modules: 28 | Stackctl.Action 29 | Stackctl.AutoSSO 30 | Stackctl.AWS 31 | Stackctl.AWS.CloudFormation 32 | Stackctl.AWS.Core 33 | Stackctl.AWS.EC2 34 | Stackctl.AWS.Lambda 35 | Stackctl.AWS.Orphans 36 | Stackctl.AWS.Scope 37 | Stackctl.AWS.STS 38 | Stackctl.CancelHandler 39 | Stackctl.CLI 40 | Stackctl.ColorOption 41 | Stackctl.Colors 42 | Stackctl.Commands 43 | Stackctl.Config 44 | Stackctl.Config.RequiredVersion 45 | Stackctl.DirectoryOption 46 | Stackctl.FilterOption 47 | Stackctl.OneOrListOf 48 | Stackctl.Options 49 | Stackctl.ParameterOption 50 | Stackctl.Prelude 51 | Stackctl.Prompt 52 | Stackctl.RemovedStack 53 | Stackctl.Sort 54 | Stackctl.Spec.Capture 55 | Stackctl.Spec.Cat 56 | Stackctl.Spec.Changes 57 | Stackctl.Spec.Changes.Format 58 | Stackctl.Spec.Deploy 59 | Stackctl.Spec.Discover 60 | Stackctl.Spec.Generate 61 | Stackctl.Spec.List 62 | Stackctl.StackDescription 63 | Stackctl.StackSpec 64 | Stackctl.StackSpecPath 65 | Stackctl.StackSpecYaml 66 | Stackctl.Subcommand 67 | Stackctl.TagOption 68 | Stackctl.VerboseOption 69 | Stackctl.Version 70 | other-modules: 71 | Paths_stackctl 72 | hs-source-dirs: 73 | src 74 | default-extensions: 75 | BangPatterns 76 | DataKinds 77 | DeriveAnyClass 78 | DeriveFoldable 79 | DeriveFunctor 80 | DeriveGeneric 81 | DeriveLift 82 | DeriveTraversable 83 | DerivingStrategies 84 | DerivingVia 85 | FlexibleContexts 86 | FlexibleInstances 87 | GADTs 88 | GeneralizedNewtypeDeriving 89 | LambdaCase 90 | MultiParamTypeClasses 91 | NoImplicitPrelude 92 | NoMonomorphismRestriction 93 | OverloadedStrings 94 | RankNTypes 95 | RecordWildCards 96 | ScopedTypeVariables 97 | StandaloneDeriving 98 | TypeApplications 99 | TypeFamilies 100 | ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-role-annotations -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-unsafe -optP-Wno-nonportable-include-path 101 | build-depends: 102 | Blammo >=1.1.2.3 103 | , Glob 104 | , QuickCheck 105 | , aeson 106 | , aeson-casing 107 | , aeson-pretty 108 | , amazonka >=2.0 109 | , amazonka-cloudformation >=2.0 110 | , amazonka-core >=2.0 111 | , amazonka-ec2 >=2.0 112 | , amazonka-lambda >=2.0 113 | , amazonka-mtl 114 | , amazonka-sso >=2.0 115 | , amazonka-sts >=2.0 116 | , base ==4.* 117 | , bytestring 118 | , cfn-flip >=0.1.0.3 119 | , conduit 120 | , containers 121 | , envparse 122 | , errors 123 | , exceptions 124 | , extra 125 | , filepath 126 | , lens 127 | , lens-aeson 128 | , monad-logger 129 | , mtl 130 | , optparse-applicative 131 | , resourcet 132 | , rio 133 | , semigroups 134 | , text 135 | , text-metrics 136 | , time 137 | , transformers 138 | , typed-process 139 | , unix 140 | , unliftio >=0.2.25.0 141 | , unordered-containers 142 | , uuid 143 | , yaml 144 | default-language: Haskell2010 145 | 146 | executable stackctl 147 | main-is: Main.hs 148 | other-modules: 149 | Paths_stackctl 150 | hs-source-dirs: 151 | app 152 | default-extensions: 153 | BangPatterns 154 | DataKinds 155 | DeriveAnyClass 156 | DeriveFoldable 157 | DeriveFunctor 158 | DeriveGeneric 159 | DeriveLift 160 | DeriveTraversable 161 | DerivingStrategies 162 | DerivingVia 163 | FlexibleContexts 164 | FlexibleInstances 165 | GADTs 166 | GeneralizedNewtypeDeriving 167 | LambdaCase 168 | MultiParamTypeClasses 169 | NoImplicitPrelude 170 | NoMonomorphismRestriction 171 | OverloadedStrings 172 | RankNTypes 173 | RecordWildCards 174 | ScopedTypeVariables 175 | StandaloneDeriving 176 | TypeApplications 177 | TypeFamilies 178 | ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-role-annotations -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-unsafe -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N 179 | build-depends: 180 | base ==4.* 181 | , stackctl 182 | default-language: Haskell2010 183 | 184 | test-suite spec 185 | type: exitcode-stdio-1.0 186 | main-is: Spec.hs 187 | other-modules: 188 | Stackctl.AWS.CloudFormationSpec 189 | Stackctl.AWS.EC2Spec 190 | Stackctl.AWS.LambdaSpec 191 | Stackctl.AWS.ScopeSpec 192 | Stackctl.CancelHandlerSpec 193 | Stackctl.Config.RequiredVersionSpec 194 | Stackctl.ConfigSpec 195 | Stackctl.FilterOptionSpec 196 | Stackctl.OneOrListOfSpec 197 | Stackctl.RemovedStackSpec 198 | Stackctl.Spec.Changes.FormatSpec 199 | Stackctl.StackDescriptionSpec 200 | Stackctl.StackSpecSpec 201 | Stackctl.StackSpecYamlSpec 202 | Stackctl.Test.App 203 | Paths_stackctl 204 | hs-source-dirs: 205 | test 206 | default-extensions: 207 | BangPatterns 208 | DataKinds 209 | DeriveAnyClass 210 | DeriveFoldable 211 | DeriveFunctor 212 | DeriveGeneric 213 | DeriveLift 214 | DeriveTraversable 215 | DerivingStrategies 216 | DerivingVia 217 | FlexibleContexts 218 | FlexibleInstances 219 | GADTs 220 | GeneralizedNewtypeDeriving 221 | LambdaCase 222 | MultiParamTypeClasses 223 | NoImplicitPrelude 224 | NoMonomorphismRestriction 225 | OverloadedStrings 226 | RankNTypes 227 | RecordWildCards 228 | ScopedTypeVariables 229 | StandaloneDeriving 230 | TypeApplications 231 | TypeFamilies 232 | ghc-options: -fignore-optim-changes -fwrite-ide-info -Weverything -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-missing-import-lists -Wno-missing-kind-signatures -Wno-missing-local-signatures -Wno-missing-role-annotations -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -Wno-unsafe -optP-Wno-nonportable-include-path 233 | build-depends: 234 | Blammo 235 | , Glob 236 | , QuickCheck 237 | , aeson 238 | , amazonka 239 | , amazonka-cloudformation 240 | , amazonka-ec2 241 | , amazonka-lambda 242 | , amazonka-mtl 243 | , base ==4.* 244 | , bytestring 245 | , filepath 246 | , hspec 247 | , hspec-expectations-lifted 248 | , hspec-golden >=0.2.1.0 249 | , http-types 250 | , lens 251 | , mtl 252 | , stackctl 253 | , text 254 | , time 255 | , unliftio 256 | , yaml 257 | default-language: Haskell2010 258 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | {-# OPTIONS_GHC -fno-warn-missing-export-lists #-} 3 | -------------------------------------------------------------------------------- /test/Stackctl/AWS/CloudFormationSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS.CloudFormationSpec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Test.App 6 | 7 | import Amazonka.CloudFormation.DeleteChangeSet 8 | import Amazonka.CloudFormation.ListChangeSets 9 | import Amazonka.CloudFormation.Types.ChangeSetSummary 10 | import Blammo.Logging.Logger (LoggedMessage (..), getLoggedMessagesUnsafe) 11 | import qualified Data.Aeson.KeyMap as KeyMap 12 | import Data.List (isSuffixOf) 13 | import Stackctl.AWS.CloudFormation 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "readParameter" $ do 18 | it "refuses empty key" $ example $ do 19 | readParameter "=Value" 20 | `shouldSatisfy` either ("empty KEY" `isSuffixOf`) (const False) 21 | 22 | it "refuses empty value" $ example $ do 23 | readParameter "Key" 24 | `shouldSatisfy` either ("empty VALUE" `isSuffixOf`) (const False) 25 | 26 | it "refuses empty value (with =)" $ example $ do 27 | readParameter "Key=" 28 | `shouldSatisfy` either ("empty VALUE" `isSuffixOf`) (const False) 29 | 30 | it "creates a parameter when valid" $ example $ do 31 | readParameter "Key=Value=More" 32 | `shouldBe` Right (makeParameter "Key" $ Just "Value=More") 33 | 34 | describe "awsCloudFormationDeleteAllChangeSets" $ do 35 | it "deletes all listed changesets" $ example $ runTestAppT $ do 36 | let 37 | stackName :: Text 38 | stackName = "some-stack" 39 | 40 | cs1 :: Text 41 | cs1 = "some-changeset-1" 42 | 43 | cs2 :: Text 44 | cs2 = "some-changeset-2" 45 | 46 | cs3 :: Text 47 | cs3 = "some-changeset-3" 48 | 49 | isListChangeSetsPage :: Maybe Text -> ListChangeSets -> Bool 50 | isListChangeSetsPage p req = 51 | and 52 | [ req ^. listChangeSets_stackName == stackName 53 | , req ^. listChangeSets_nextToken == p 54 | ] 55 | 56 | isDeleteChangeSet :: Text -> DeleteChangeSet -> Bool 57 | isDeleteChangeSet cs req = req ^. deleteChangeSet_changeSetName == cs 58 | 59 | summary1 = newChangeSetSummary & changeSetSummary_changeSetId ?~ cs1 60 | summary2 = newChangeSetSummary & changeSetSummary_changeSetId ?~ cs2 61 | summary3 = newChangeSetSummary & changeSetSummary_changeSetId ?~ cs3 62 | 63 | matchers = 64 | [ SendMatcher (isListChangeSetsPage Nothing) 65 | $ Right 66 | $ newListChangeSetsResponse 200 67 | & (listChangeSetsResponse_summaries ?~ [summary1, summary2]) 68 | & (listChangeSetsResponse_nextToken ?~ "p2") 69 | , SendMatcher (isListChangeSetsPage $ Just "p2") 70 | $ Right 71 | $ newListChangeSetsResponse 200 72 | & (listChangeSetsResponse_summaries ?~ [summary3]) 73 | , SendMatcher (isDeleteChangeSet cs1) 74 | $ Right 75 | $ newDeleteChangeSetResponse 200 76 | , SendMatcher (isDeleteChangeSet cs2) 77 | $ Right 78 | $ newDeleteChangeSetResponse 200 79 | , SendMatcher (isDeleteChangeSet cs3) 80 | $ Right 81 | $ newDeleteChangeSetResponse 200 82 | ] 83 | 84 | withMatchers matchers $ do 85 | awsCloudFormationDeleteAllChangeSets $ StackName stackName 86 | 87 | messages <- 88 | map (loggedMessageText &&& loggedMessageMeta) 89 | <$> getLoggedMessagesUnsafe 90 | 91 | messages 92 | `shouldBe` [ ("Deleting all changesets", mempty) 93 | , ("Enqueing delete", KeyMap.fromList [("changeSetId", toJSON cs1)]) 94 | , ("Enqueing delete", KeyMap.fromList [("changeSetId", toJSON cs2)]) 95 | , ("Enqueing delete", KeyMap.fromList [("changeSetId", toJSON cs3)]) 96 | ] 97 | -------------------------------------------------------------------------------- /test/Stackctl/AWS/EC2Spec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS.EC2Spec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Test.App 6 | 7 | import Amazonka.EC2.DescribeAvailabilityZones 8 | import Amazonka.EC2.Types.AvailabilityZone 9 | import Stackctl.AWS.EC2 10 | 11 | spec :: Spec 12 | spec = do 13 | describe "awsEc2DescribeFirstAvailabilityZoneRegionName" $ do 14 | it "returns the first AZ's region name" $ example $ runTestAppT $ do 15 | let 16 | zones = 17 | [ newAvailabilityZone & availabilityZone_regionName ?~ "us-east-1" 18 | , newAvailabilityZone & availabilityZone_regionName ?~ "us-east-2" 19 | , newAvailabilityZone & availabilityZone_regionName ?~ "us-west-1" 20 | ] 21 | matcher = 22 | SendMatcher (const @_ @DescribeAvailabilityZones True) 23 | $ Right 24 | $ newDescribeAvailabilityZonesResponse 200 25 | & describeAvailabilityZonesResponse_availabilityZones 26 | ?~ zones 27 | 28 | withMatcher matcher awsEc2DescribeFirstAvailabilityZoneRegionName 29 | `shouldReturn` "us-east-1" 30 | -------------------------------------------------------------------------------- /test/Stackctl/AWS/LambdaSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS.LambdaSpec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Test.App 6 | 7 | import Amazonka.Lambda.Invoke 8 | import Data.Aeson 9 | import qualified Data.ByteString.Lazy as BSL 10 | import Stackctl.AWS.Lambda 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "awsLambdaInvoke" $ do 15 | it "invokes a lambda" $ example $ runTestAppT $ do 16 | let 17 | emptyObject = object [] 18 | 19 | isInvocation name invoke = 20 | and 21 | [ invoke ^. invoke_functionName == name 22 | , invoke ^. invoke_payload == "{}" 23 | ] 24 | 25 | lambdaError = 26 | LambdaError 27 | { errorType = "exception" 28 | , errorMessage = "oops" 29 | , trace = [] 30 | } 31 | 32 | matchers = 33 | [ SendMatcher (isInvocation "lambda-1") 34 | $ Right 35 | $ newInvokeResponse 200 36 | & invokeResponse_payload ?~ "" 37 | , SendMatcher (isInvocation "lambda-2") 38 | $ Right 39 | $ newInvokeResponse 200 40 | & invokeResponse_payload ?~ BSL.toStrict (encode lambdaError) 41 | , SendMatcher (isInvocation "lambda-3") 42 | $ Right 43 | $ newInvokeResponse 500 44 | & (invokeResponse_payload ?~ "") 45 | . (invokeResponse_functionError ?~ "") 46 | ] 47 | 48 | withMatchers matchers $ do 49 | LambdaInvokeSuccess successPayload <- 50 | awsLambdaInvoke "lambda-1" emptyObject 51 | 52 | successPayload `shouldBe` "" 53 | 54 | LambdaInvokeError errorPayload _ <- 55 | awsLambdaInvoke "lambda-2" emptyObject 56 | 57 | errorPayload `shouldBe` lambdaError 58 | 59 | LambdaInvokeFailure failureStatus failureFunctionError <- 60 | awsLambdaInvoke "lambda-3" emptyObject 61 | 62 | failureStatus `shouldBe` 500 63 | failureFunctionError `shouldBe` Just "" 64 | -------------------------------------------------------------------------------- /test/Stackctl/AWS/ScopeSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.AWS.ScopeSpec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Stackctl.AWS.CloudFormation 8 | import Stackctl.AWS.Core 9 | import Stackctl.AWS.Scope 10 | import Test.Hspec 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "awsScopeSpecStackName" $ do 15 | let scope = 16 | AwsScope 17 | { awsAccountId = AccountId "123" 18 | , awsAccountName = "testing" 19 | , awsRegion = "us-east-1" 20 | } 21 | 22 | it "parses full paths to stacks in the current scope" $ do 23 | awsScopeSpecStackName scope "stacks/123.testing/us-east-1/foo.yaml" 24 | `shouldBe` Just (StackName "foo") 25 | 26 | it "parses name.account style too" $ do 27 | awsScopeSpecStackName scope "stacks/testing.123/us-east-1/foo.yaml" 28 | `shouldBe` Just (StackName "foo") 29 | 30 | it "handles sub-directories" $ do 31 | awsScopeSpecStackName scope "stacks/123.testing/us-east-1/foo/bar.yaml" 32 | `shouldBe` Just (StackName "foo-bar") 33 | 34 | it "handles mismatched name" $ do 35 | awsScopeSpecStackName scope "stacks/123.x/us-east-1/foo.yaml" 36 | `shouldBe` Just (StackName "foo") 37 | 38 | it "handles mismatched name in name.account style" $ do 39 | awsScopeSpecStackName scope "stacks/x.123/us-east-1/foo.yaml" 40 | `shouldBe` Just (StackName "foo") 41 | 42 | it "avoids wrong region" $ do 43 | awsScopeSpecStackName scope "stacks/123.testing/us-east-2/foo.yaml" 44 | `shouldBe` Nothing 45 | 46 | it "avoids arong account id" $ do 47 | awsScopeSpecStackName scope "stacks/124.testing/us-east-1/foo.yaml" 48 | `shouldBe` Nothing 49 | 50 | it "requires a stacks/ prefix" $ do 51 | awsScopeSpecStackName scope "123.testing/us-east-1/foo.yaml" 52 | `shouldBe` Nothing 53 | 54 | it "requires a .yaml suffix" $ do 55 | awsScopeSpecStackName scope "stacks/123.testing/us-east-1/foo.yml" 56 | `shouldBe` Nothing 57 | -------------------------------------------------------------------------------- /test/Stackctl/CancelHandlerSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.CancelHandlerSpec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import qualified Stackctl.CancelHandler as CancelHandler 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "with" $ do 13 | it "installs a handler for the duration of a block" $ example $ do 14 | done <- newEmptyMVar 15 | 16 | CancelHandler.install $ putMVar done () 17 | CancelHandler.trigger 18 | 19 | takeMVar done `shouldReturn` () 20 | -------------------------------------------------------------------------------- /test/Stackctl/Config/RequiredVersionSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Config.RequiredVersionSpec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Data.Aeson (decode, encode) 8 | import Data.Version 9 | import Stackctl.Config.RequiredVersion 10 | import Test.Hspec 11 | import Test.QuickCheck 12 | 13 | spec :: Spec 14 | spec = do 15 | describe "JSON" $ do 16 | it "round-trips" $ property $ \rv -> do 17 | decode (encode @RequiredVersion rv) `shouldBe` Just rv 18 | 19 | describe "requiredVersionFromText" $ do 20 | it "parses with or without operator" $ do 21 | requiredVersionFromText "1.2.3-rc1" `shouldSatisfy` isRight 22 | requiredVersionFromText "= 1.2.3-rc1" `shouldSatisfy` isRight 23 | 24 | it "rejects unknown operators" $ do 25 | requiredVersionFromText "!! 1.2.3" `shouldSatisfy` isLeft 26 | 27 | it "rejects invalid versions" $ do 28 | requiredVersionFromText "= wowOMG-2/2" `shouldSatisfy` isLeft 29 | 30 | describe "parsing operators" $ do 31 | let prop cmp = property . uncurry . compareAsRequiredVersion cmp 32 | 33 | it "compares exactly" $ prop (==) Nothing 34 | it "compares with = " $ prop (==) $ Just "=" 35 | it "compares with ==" $ prop (==) $ Just "==" 36 | it "compares with < " $ prop (<) $ Just "<" 37 | it "compares with <=" $ prop (<=) $ Just "<=" 38 | it "compares with > " $ prop (>) $ Just ">" 39 | it "compares with >=" $ prop (>=) $ Just ">=" 40 | it "compares with =~" $ prop (=~) $ Just "=~" 41 | 42 | describe "=~" $ do 43 | it "treats equal versions as satisfying" $ do 44 | makeVersion [1, 2, 3] =~ makeVersion [1, 2, 3] `shouldBe` True 45 | 46 | it "treats older versions as non-satisfying" $ do 47 | makeVersion [1, 2, 2] =~ makeVersion [1, 2, 3] `shouldBe` False 48 | 49 | it "treats newer versions of the same branch as satisfying" $ do 50 | makeVersion [1, 2, 3, 1] =~ makeVersion [1, 2, 3] `shouldBe` True 51 | 52 | it "treats newer versions as non-satisfying" $ do 53 | makeVersion [1, 2, 4] =~ makeVersion [1, 2, 3] `shouldBe` False 54 | 55 | it "respects the number of components specified" $ do 56 | makeVersion [1, 2] =~ makeVersion [1, 2] `shouldBe` True 57 | makeVersion [1, 2, 3] =~ makeVersion [1, 2] `shouldBe` True 58 | makeVersion [1, 1] =~ makeVersion [1, 2] `shouldBe` False 59 | makeVersion [1, 3] =~ makeVersion [1, 2, 3] `shouldBe` False 60 | 61 | compareAsRequiredVersion 62 | :: (Version -> Version -> Bool) 63 | -- ^ Reference compare 64 | -> Maybe Text 65 | -- ^ Operator 66 | -> Version 67 | -- ^ Hypothetical required version 68 | -> Version 69 | -- ^ Hypotehtical current version 70 | -> Bool 71 | compareAsRequiredVersion cmp mOperator required current = 72 | runRequiredVersion mOperator required current 73 | == Right (current `cmp` required) 74 | 75 | runRequiredVersion 76 | :: Maybe Text 77 | -- ^ Operator 78 | -> Version 79 | -- ^ Hypothetical required version 80 | -> Version 81 | -- ^ Hypothetical current version 82 | -> Either String Bool 83 | runRequiredVersion mOperator required current = 84 | (`isRequiredVersionSatisfied` current) <$> requiredVersionFromText rvText 85 | where 86 | rvText = maybe "" (<> " ") mOperator <> pack (showVersion required) 87 | -------------------------------------------------------------------------------- /test/Stackctl/ConfigSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 2 | 3 | module Stackctl.ConfigSpec 4 | ( spec 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Control.Monad.Except 10 | import qualified Data.ByteString.Char8 as BS8 11 | import Data.Version (showVersion) 12 | import Paths_stackctl as Paths 13 | import Stackctl.AWS (makeParameter, newTag) 14 | import Stackctl.Config 15 | import Stackctl.StackSpecYaml 16 | import Test.Hspec 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "loadConfigFromBytes" $ do 21 | it "loads a valid config" $ do 22 | let result = 23 | loadConfigFromLines 24 | [ "required_version: " <> BS8.pack (showVersion Paths.version) 25 | , "defaults:" 26 | , " parameters:" 27 | , " Some: Parameter" 28 | , " tags:" 29 | , " Some: Tag" 30 | ] 31 | 32 | case result of 33 | Left err -> do 34 | expectationFailure 35 | $ "Expected to load a Config, got error: " <> show err 36 | Right config -> do 37 | configParameters config 38 | `shouldBe` Just (toParametersYaml [("Some", Just "Parameter")]) 39 | configTags config `shouldBe` Just (toTagsYaml [("Some", "Tag")]) 40 | 41 | describe "applyConfig" $ do 42 | it "defaults missing Tags" $ do 43 | let 44 | specYaml = 45 | StackSpecYaml 46 | { ssyDescription = Nothing 47 | , ssyTemplate = "" 48 | , ssyDepends = Nothing 49 | , ssyActions = Nothing 50 | , ssyParameters = Nothing 51 | , ssyCapabilities = Nothing 52 | , ssyTags = Just $ toTagsYaml [("Hi", "There"), ("Keep", "Me")] 53 | } 54 | 55 | Right config = 56 | loadConfigFromBytes 57 | $ "defaults:" 58 | <> "\n tags:" 59 | <> "\n From: Defaults" 60 | <> "\n Keep: \"You?\"" 61 | 62 | Just tags = ssyTags (applyConfig config specYaml) 63 | 64 | tags 65 | `shouldBe` toTagsYaml 66 | [("Hi", "There"), ("From", "Defaults"), ("Keep", "Me")] 67 | 68 | loadConfigFromLines :: MonadError ConfigError m => [ByteString] -> m Config 69 | loadConfigFromLines = loadConfigFromBytes . mconcat . map (<> "\n") 70 | 71 | toParametersYaml :: [(Text, Maybe Text)] -> ParametersYaml 72 | toParametersYaml = 73 | parametersYaml . mapMaybe (parameterYaml . uncurry makeParameter) 74 | 75 | toTagsYaml :: [(Text, Text)] -> TagsYaml 76 | toTagsYaml = tagsYaml . map (TagYaml . uncurry newTag) 77 | -------------------------------------------------------------------------------- /test/Stackctl/FilterOptionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 2 | 3 | module Stackctl.FilterOptionSpec 4 | ( spec 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Stackctl.AWS 10 | import Stackctl.AWS.Scope 11 | import Stackctl.Config (emptyConfig) 12 | import Stackctl.FilterOption 13 | import Stackctl.StackSpec 14 | import Stackctl.StackSpecPath 15 | import Stackctl.StackSpecYaml 16 | import Test.Hspec 17 | 18 | spec :: Spec 19 | spec = do 20 | describe "filterStackSpecs" $ do 21 | it "filters specs matching any of the given patterns" $ do 22 | let 23 | Just option = filterOptionFromText "**/some-path,**/prefix/*,**/suffix" 24 | specs = 25 | [ toSpec "some-path" "some-path" Nothing 26 | , toSpec "some-other-path" "some-path-other" Nothing 27 | , toSpec "other-some-path" "other-some-path" Nothing 28 | , toSpec "prefix-foo" "prefix/foo" Nothing 29 | , toSpec "prefix-foo-bar" "prefix/foo-bar" Nothing 30 | , toSpec "prefix-foo-bar-prefix" "prefix/foo-bar/prefix" Nothing 31 | , toSpec "foo-suffix" "foo/suffix" Nothing 32 | , toSpec "foo-bar-suffix" "foo/bar/suffix" Nothing 33 | , toSpec "foo-suffix-bar" "foo/suffix/bar" Nothing 34 | ] 35 | 36 | map specName (filterStackSpecs option specs) 37 | `shouldMatchList` [ "some-path" 38 | , "prefix-foo" 39 | , "prefix-foo-bar" 40 | , "foo-suffix" 41 | , "foo-bar-suffix" 42 | , "foo-suffix-bar" 43 | ] 44 | 45 | it "filters specs by template too" $ do 46 | let 47 | Just option = filterOptionFromText "templates/x,**/y/*" 48 | specs = 49 | [ toSpec "some-path" "some-path" Nothing 50 | , toSpec "some-other-path" "some-path-other" $ Just "x" 51 | , toSpec "prefix-foo" "prefix/foo" Nothing 52 | , toSpec "other-some-path" "other-some-path" $ Just "z/y/t" 53 | , toSpec "prefix-foo-bar" "prefix/foo-bar" Nothing 54 | ] 55 | 56 | map specName (filterStackSpecs option specs) 57 | `shouldMatchList` ["some-other-path", "other-some-path"] 58 | 59 | it "filters specs by name too" $ do 60 | let 61 | Just option = filterOptionFromText "some-name,**/prefix/*,templates/x" 62 | specs = 63 | [ toSpec "some-name" "some-path" Nothing 64 | , toSpec "some-path" "some-path-other" $ Just "x" 65 | , toSpec "prefix-foo" "prefix/foo" Nothing 66 | , toSpec "other-some-path" "other-some-path" $ Just "z/y/t" 67 | , toSpec "prefix-foo-bar" "prefix/foo-bar" Nothing 68 | ] 69 | 70 | map specName (filterStackSpecs option specs) 71 | `shouldMatchList` [ "some-name" 72 | , "some-path" 73 | , "prefix-foo" 74 | , "prefix-foo-bar" 75 | ] 76 | 77 | it "adds some intuitive fuzziness" $ do 78 | let 79 | Just option = filterOptionFromText "some/path,file,file.ext" 80 | specs = 81 | [ toSpec "some-name" "x/some/path/y" Nothing 82 | , toSpec "some-path" "some-path/other" $ Just "x" 83 | , toSpec "prefix-foo" "prefix/file.json" Nothing 84 | , toSpec "other-some-path" "other-some-path" $ Just "z/y/t" 85 | , toSpec "prefix-foo-bar" "prefix/foo-bar" Nothing 86 | ] 87 | 88 | map specName (filterStackSpecs option specs) 89 | `shouldMatchList` ["some-name", "prefix-foo"] 90 | 91 | describe "filterOptionFromPaths" $ do 92 | it "finds full paths (e.g. as output by generate)" $ do 93 | let 94 | option = 95 | filterOptionFromPaths 96 | $ pure "stacks/1234567890.test-account/us-east-1/stack.yaml" 97 | specs = 98 | [ toSpec "some-name" "stack.yaml" Nothing 99 | , toSpec "other-path" "other-stack.yaml" $ Just "x" 100 | ] 101 | 102 | map specName (filterStackSpecs option specs) 103 | `shouldMatchList` ["some-name"] 104 | 105 | toSpec :: Text -> FilePath -> Maybe FilePath -> StackSpec 106 | toSpec name path mTemplate = 107 | flip runReader emptyConfig 108 | $ buildStackSpec ".platform/specs" specPath specBody 109 | where 110 | stackName = StackName name 111 | specPath = stackSpecPath scope stackName path 112 | specBody = 113 | StackSpecYaml 114 | { ssyDescription = Nothing 115 | , ssyDepends = Nothing 116 | , ssyActions = Nothing 117 | , ssyTemplate = fromMaybe path mTemplate 118 | , ssyParameters = Nothing 119 | , ssyCapabilities = Nothing 120 | , ssyTags = Nothing 121 | } 122 | 123 | scope = 124 | AwsScope 125 | { awsAccountId = AccountId "1234567890" 126 | , awsAccountName = "test-account" 127 | , awsRegion = Region' "us-east-1" 128 | } 129 | 130 | specName :: StackSpec -> Text 131 | specName = unStackName . stackSpecStackName 132 | -------------------------------------------------------------------------------- /test/Stackctl/OneOrListOfSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.OneOrListOfSpec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Data.Aeson 8 | import qualified Data.Yaml as Yaml 9 | import Stackctl.OneOrListOf 10 | import Test.Hspec 11 | 12 | data ExampleObject = ExampleObject 13 | { oneOf :: OneOrListOf Text 14 | , listOf :: OneOrListOf Text 15 | } 16 | deriving stock (Generic) 17 | deriving anyclass (FromJSON, ToJSON) 18 | 19 | -- N.B. the sorting and indentation must match what encode will do in order for 20 | -- the round-trip spec to pass. 21 | exampleBS :: ByteString 22 | exampleBS = 23 | mconcat 24 | [ "listOf:\n" 25 | , "- one\n" 26 | , "- two\n" 27 | , "oneOf: one\n" 28 | ] 29 | 30 | spec :: Spec 31 | spec = do 32 | it "Foldable" $ do 33 | ExampleObject {..} <- Yaml.decodeThrow exampleBS 34 | 35 | toList oneOf `shouldBe` ["one"] 36 | 37 | toList listOf `shouldBe` ["one", "two"] 38 | 39 | it "Semigroup" $ do 40 | ExampleObject {..} <- Yaml.decodeThrow exampleBS 41 | 42 | toList (oneOf <> listOf) `shouldBe` ["one", "one", "two"] 43 | 44 | it "From/ToJSON" $ do 45 | decoded <- Yaml.decodeThrow @_ @ExampleObject exampleBS 46 | 47 | Yaml.encode decoded `shouldBe` exampleBS 48 | -------------------------------------------------------------------------------- /test/Stackctl/RemovedStackSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 2 | 3 | module Stackctl.RemovedStackSpec 4 | ( spec 5 | ) where 6 | 7 | import Stackctl.Test.App 8 | 9 | import qualified Amazonka 10 | import qualified Amazonka.CloudFormation as CloudFormation 11 | import Amazonka.CloudFormation.DescribeStacks 12 | import Amazonka.CloudFormation.Types.Stack 13 | import qualified Data.Text as T 14 | import Data.Time (UTCTime (..)) 15 | import Data.Time.Calendar (DayOfMonth, MonthOfYear, Year, fromGregorian) 16 | import Network.HTTP.Types.Status (status400) 17 | import Stackctl.AWS.CloudFormation 18 | import Stackctl.DirectoryOption (DirectoryOption (..), directoryOptionL) 19 | import Stackctl.FilterOption (filterOptionFromText, filterOptionL) 20 | import Stackctl.RemovedStack 21 | import UnliftIO.Directory (createDirectoryIfMissing) 22 | 23 | spec :: Spec 24 | spec = do 25 | describe "inferRemovedStacks" $ do 26 | it "returns stacks in filters that aren't on disk" $ example $ runTestAppT $ do 27 | let 28 | Just filterOption = 29 | filterOptionFromText 30 | $ T.intercalate 31 | "," 32 | [ pack $ testAppStackFilePath "stack-exists" 33 | , pack $ testAppStackFilePath "stack-is-missing" 34 | , "stacks/0123456789.test/us-east-2/wrong-region.yaml" 35 | , "stacks/2123456789.test/us-east-1/wrong-account.yaml" 36 | ] 37 | 38 | setup :: TestApp -> TestApp 39 | setup = filterOptionL .~ filterOption 40 | 41 | matchers = 42 | [ describeStackMatcher "stack-exists" $ Just $ someStack "stack-exists" 43 | , describeStackMatcher "stack-is-missing" Nothing 44 | , describeStackMatcher "wrong-region" Nothing 45 | , describeStackMatcher "wrong-account" Nothing 46 | ] 47 | 48 | stacks <- local setup $ withMatchers matchers inferRemovedStacks 49 | map (^. stack_stackName) stacks `shouldBe` ["stack-exists"] 50 | 51 | -- If we don't check for file existence respecting STACKCTL_DIRECTORY, then 52 | -- any non-default value will cause all specs to appear non-existent and be 53 | -- flagged for removal. Eek. 54 | it "respects STACKCTL_DIRECTORY" $ example $ runTestAppT $ do 55 | let 56 | dir = "/tmp/stackctl-test" 57 | toRemove = "stack-to-remove" 58 | toKeep = "stack-to-keep" 59 | relativeToRemove = testAppStackFilePath toRemove 60 | relativeToKeep = testAppStackFilePath toKeep 61 | absoluteToKeep = dir relativeToKeep 62 | Just filterOption = 63 | filterOptionFromText 64 | $ pack relativeToRemove 65 | <> "," 66 | <> pack relativeToKeep 67 | 68 | setup :: TestApp -> TestApp 69 | setup app = 70 | app 71 | & filterOptionL .~ filterOption 72 | & directoryOptionL .~ DirectoryOption dir 73 | 74 | matchers = 75 | [ describeStackMatcher toRemove $ Just $ someStack toRemove 76 | , describeStackMatcher toKeep $ Just $ someStack toKeep 77 | ] 78 | 79 | -- Create a spec on disk for toKeep, then we should only find toRemove 80 | createDirectoryIfMissing True $ takeDirectory absoluteToKeep 81 | writeFileUtf8 absoluteToKeep "{}" 82 | 83 | stacks <- local setup $ withMatchers matchers inferRemovedStacks 84 | map (^. stack_stackName) stacks `shouldBe` [toRemove] 85 | 86 | describeStackMatcher :: Text -> Maybe Stack -> Matcher 87 | describeStackMatcher name = 88 | SendMatcher ((== Just name) . (^. describeStacks_stackName)) 89 | . maybe 90 | (Left cloudFormationValidationError) 91 | ( \stack -> 92 | Right 93 | $ newDescribeStacksResponse 200 94 | & describeStacksResponse_stacks ?~ [stack] 95 | ) 96 | 97 | someStack :: Text -> Stack 98 | someStack name = newStack name (midnight 2024 1 1) StackStatus_CREATE_COMPLETE 99 | 100 | midnight :: Year -> MonthOfYear -> DayOfMonth -> UTCTime 101 | midnight y m d = 102 | UTCTime 103 | { utctDay = fromGregorian y m d 104 | , utctDayTime = 0 105 | } 106 | 107 | cloudFormationValidationError :: Amazonka.Error 108 | cloudFormationValidationError = 109 | Amazonka.ServiceError 110 | $ Amazonka.ServiceError' 111 | { Amazonka.abbrev = CloudFormation.defaultService ^. Amazonka.service_abbrev 112 | , Amazonka.status = status400 113 | , Amazonka.headers = [] 114 | , Amazonka.code = "ValidationError" 115 | , Amazonka.message = Nothing 116 | , Amazonka.requestId = Nothing 117 | } 118 | -------------------------------------------------------------------------------- /test/Stackctl/Spec/Changes/FormatSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Spec.Changes.FormatSpec 2 | ( spec 3 | ) 4 | where 5 | 6 | import Stackctl.Prelude 7 | 8 | import Data.Aeson 9 | import Stackctl.AWS.CloudFormation (ChangeSetType (..), changeSetFromResponse) 10 | import Stackctl.Colors 11 | import Stackctl.Spec.Changes.Format 12 | import System.FilePath ((-<.>)) 13 | import System.FilePath.Glob (globDir1) 14 | import Test.Hspec 15 | import Test.Hspec.Golden 16 | 17 | spec :: Spec 18 | spec = do 19 | describe "formatChangeSet" $ do 20 | paths <- runIO $ globDir1 "**/*.json" "test/files/change-sets" 21 | 22 | for_ paths $ \path -> do 23 | for_ [minBound .. maxBound] $ \fmt -> do 24 | it (path <> " as " <> show fmt) $ do 25 | formatChangeSetGolden path fmt 26 | 27 | formatChangeSetGolden :: FilePath -> Format -> IO (Golden Text) 28 | formatChangeSetGolden path fmt = do 29 | actual <- 30 | formatChangeSet noColors OmitFull "some-stack" fmt 31 | . (changeSetFromResponse ChangeSetType_UPDATE <=< decodeStrict) 32 | . encodeUtf8 33 | <$> readFileUtf8 path 34 | 35 | pure 36 | $ Golden 37 | { output = actual 38 | , encodePretty = unpack 39 | , writeToFile = writeFileUtf8 40 | , readFromFile = readFileUtf8 41 | , goldenFile = path -<.> ext 42 | , actualFile = Nothing 43 | , failFirstTime = False 44 | } 45 | where 46 | ext = case fmt of 47 | FormatTTY -> "txt" 48 | FormatPullRequest -> "md" 49 | -------------------------------------------------------------------------------- /test/Stackctl/StackDescriptionSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.StackDescriptionSpec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Stackctl.StackDescription 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "addStackDescription" $ do 13 | let aDescription = Just $ StackDescription "A \"cool\" description" 14 | 15 | it "does nothing with nothing" $ do 16 | addStackDescription Nothing "hi there" `shouldBe` "hi there" 17 | 18 | it "does nothing invalid inputs" $ do 19 | for_ ["", "hi there", "[a list]", "{\"invalid\":", "true", "42"] 20 | $ \input -> addStackDescription aDescription input `shouldBe` input 21 | 22 | context "Yaml" $ do 23 | it "adds a Description" $ do 24 | addStackDescription aDescription "Resources: []\n" 25 | `shouldBe` "Description: \"A \\\"cool\\\" description\"\nResources: []\n" 26 | 27 | it "does not clobber or duplicate an existing Description" $ do 28 | addStackDescription 29 | aDescription 30 | "Resources: []\nDescription: Existing description\n" 31 | `shouldBe` "Resources: []\nDescription: Existing description\n" 32 | 33 | context "JSON" $ do 34 | it "adds a Description" $ do 35 | addStackDescription aDescription "{\"Resources\":[]}" 36 | `shouldBe` "{\"Description\":\"A \\\"cool\\\" description\",\"Resources\":[]}" 37 | 38 | it "does not clobber or duplicate an existing Description" $ do 39 | addStackDescription 40 | aDescription 41 | "{\"Resources\":[],\"Description\":\"Existing description\"}" 42 | `shouldBe` "{\"Resources\":[],\"Description\":\"Existing description\"}" 43 | -------------------------------------------------------------------------------- /test/Stackctl/StackSpecSpec.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.StackSpecSpec 2 | ( spec 3 | ) where 4 | 5 | import Stackctl.Prelude 6 | 7 | import Stackctl.AWS 8 | import Stackctl.AWS.Scope 9 | import Stackctl.Config (emptyConfig) 10 | import Stackctl.StackSpec 11 | import Stackctl.StackSpecPath 12 | import Stackctl.StackSpecYaml 13 | import Test.Hspec 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "sortStackSpecs" $ do 18 | it "orders dependencies before dependents" $ do 19 | let specs = 20 | [ toSpec "app" ["roles", "iam", "networking"] 21 | , toSpec "roles" ["iam"] 22 | , toSpec "iam" [] 23 | , toSpec "networking" [] 24 | ] 25 | 26 | map specName (sortStackSpecs specs) 27 | `shouldBe` ["iam", "roles", "networking", "app"] 28 | 29 | toSpec :: Text -> [Text] -> StackSpec 30 | toSpec name depends = 31 | flip runReader emptyConfig 32 | $ buildStackSpec "." specPath specBody 33 | where 34 | stackName = StackName name 35 | specPath = stackSpecPath scope stackName "a/b.yaml" 36 | specBody = 37 | StackSpecYaml 38 | { ssyDescription = Nothing 39 | , ssyDepends = Just $ map StackName depends 40 | , ssyActions = Nothing 41 | , ssyTemplate = "" 42 | , ssyParameters = Nothing 43 | , ssyCapabilities = Nothing 44 | , ssyTags = Nothing 45 | } 46 | 47 | scope = 48 | AwsScope 49 | { awsAccountId = AccountId "" 50 | , awsAccountName = "" 51 | , awsRegion = Region' "" 52 | } 53 | 54 | specName :: StackSpec -> Text 55 | specName = unStackName . stackSpecStackName 56 | -------------------------------------------------------------------------------- /test/Stackctl/StackSpecYamlSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 2 | 3 | module Stackctl.StackSpecYamlSpec 4 | ( spec 5 | ) where 6 | 7 | import Stackctl.Prelude 8 | 9 | import Data.Aeson 10 | import qualified Data.Yaml as Yaml 11 | import Stackctl.AWS 12 | import Stackctl.Action 13 | import Stackctl.StackSpecYaml 14 | import Test.Hspec 15 | 16 | spec :: Spec 17 | spec = do 18 | describe "From/ToJSON" $ do 19 | it "round trips" $ do 20 | let yaml = 21 | StackSpecYaml 22 | { ssyDescription = Just $ StackDescription "Testing Stack" 23 | , ssyTemplate = "path/to/template.yaml" 24 | , ssyDepends = Just [StackName "a-stack", StackName "another-stack"] 25 | , ssyActions = 26 | Just 27 | [newAction PostDeploy [InvokeLambdaByName "a-lambda"]] 28 | , ssyParameters = 29 | Just 30 | $ parametersYaml 31 | $ mapMaybe 32 | parameterYaml 33 | [makeParameter "PKey" $ Just "PValue"] 34 | , ssyCapabilities = Just [Capability_CAPABILITY_IAM] 35 | , ssyTags = Just $ tagsYaml [TagYaml $ newTag "TKey" "TValue"] 36 | } 37 | 38 | eitherDecode (encode yaml) `shouldBe` Right yaml 39 | 40 | describe "decoding Yaml" $ do 41 | it "reads String parameters" $ do 42 | StackSpecYaml {..} <- 43 | Yaml.decodeThrow 44 | $ mconcat 45 | [ "Template: foo.yaml\n" 46 | , "Parameters:\n" 47 | , " - ParameterKey: Foo\n" 48 | , " ParameterValue: Bar\n" 49 | ] 50 | 51 | let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters 52 | param ^. parameter_parameterKey `shouldBe` Just "Foo" 53 | param ^. parameter_parameterValue `shouldBe` Just "Bar" 54 | 55 | it "reads Number parameters without decimals" $ do 56 | StackSpecYaml {..} <- 57 | Yaml.decodeThrow 58 | $ mconcat 59 | [ "Template: foo.yaml\n" 60 | , "Parameters:\n" 61 | , " - ParameterKey: Port\n" 62 | , " ParameterValue: 80\n" 63 | ] 64 | 65 | let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters 66 | param ^. parameter_parameterKey `shouldBe` Just "Port" 67 | param ^. parameter_parameterValue `shouldBe` Just "80" 68 | 69 | it "reads Number parameters with decimals" $ do 70 | StackSpecYaml {..} <- 71 | Yaml.decodeThrow 72 | $ mconcat 73 | [ "Template: foo.yaml\n" 74 | , "Parameters:\n" 75 | , " - ParameterKey: Pie\n" 76 | , " ParameterValue: 3.14\n" 77 | ] 78 | 79 | let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters 80 | param ^. parameter_parameterKey `shouldBe` Just "Pie" 81 | param ^. parameter_parameterValue `shouldBe` Just "3.14" 82 | 83 | it "handles null Value" $ do 84 | StackSpecYaml {..} <- 85 | Yaml.decodeThrow 86 | $ mconcat 87 | [ "Template: foo.yaml\n" 88 | , "Parameters:\n" 89 | , " - ParameterKey: Foo\n" 90 | , " ParameterValue: null\n" 91 | ] 92 | 93 | let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters 94 | param ^. parameter_parameterKey `shouldBe` Just "Foo" 95 | param ^. parameter_parameterValue `shouldBe` Nothing 96 | 97 | it "handles missing Value" $ do 98 | StackSpecYaml {..} <- 99 | Yaml.decodeThrow 100 | $ mconcat 101 | ["Template: foo.yaml\n", "Parameters:\n", " - ParameterKey: Foo\n"] 102 | 103 | let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters 104 | param ^. parameter_parameterKey `shouldBe` Just "Foo" 105 | param ^. parameter_parameterValue `shouldBe` Nothing 106 | 107 | it "also accepts CloudGenesis formatted values" $ do 108 | StackSpecYaml {..} <- 109 | Yaml.decodeThrow 110 | $ mconcat 111 | [ "Template: foo.yaml\n" 112 | , "Parameters:\n" 113 | , " - Name: Foo\n" 114 | , " Value: Bar\n" 115 | ] 116 | 117 | let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters 118 | param ^. parameter_parameterKey `shouldBe` Just "Foo" 119 | param ^. parameter_parameterValue `shouldBe` Just "Bar" 120 | 121 | it "also accepts objects" $ do 122 | StackSpecYaml {..} <- 123 | Yaml.decodeThrow 124 | $ mconcat ["Template: foo.yaml\n", "Parameters:\n", " Foo: Bar\n"] 125 | 126 | let Just [param] = map unParameterYaml . unParametersYaml <$> ssyParameters 127 | param ^. parameter_parameterKey `shouldBe` Just "Foo" 128 | param ^. parameter_parameterValue `shouldBe` Just "Bar" 129 | 130 | describe "ParametersYaml" $ do 131 | it "has overriding Semigroup semantics" $ do 132 | let 133 | a = parametersYaml [] 134 | b = 135 | parametersYaml 136 | $ catMaybes [parameterYaml $ makeParameter "Key" (Just "B")] 137 | c = 138 | parametersYaml 139 | $ catMaybes [parameterYaml $ makeParameter "Key" (Just "C")] 140 | d = 141 | parametersYaml 142 | $ catMaybes [parameterYaml $ makeParameter "Key" Nothing] 143 | 144 | a <> b `shouldBe` b -- keeps keys in B 145 | b <> c `shouldBe` c -- C overrides B (Last) 146 | c <> d `shouldBe` c -- C overrides D (Just) 147 | d <> c `shouldBe` c -- C overrides D (Just) 148 | describe "TagsYaml" $ do 149 | it "has overriding Semigroup semantics" $ do 150 | let 151 | a = tagsYaml [] 152 | b = tagsYaml [TagYaml $ newTag "Key" "B"] 153 | c = tagsYaml [TagYaml $ newTag "Key" "C"] 154 | 155 | a <> b `shouldBe` b -- keeps keys in B 156 | b <> c `shouldBe` c -- C overrides B (Last) 157 | -------------------------------------------------------------------------------- /test/Stackctl/Test/App.hs: -------------------------------------------------------------------------------- 1 | module Stackctl.Test.App 2 | ( TestApp 3 | , testAppAwsScope 4 | , testAppStackFilePath 5 | , TestAppT 6 | , runTestAppT 7 | 8 | -- * Re-exports 9 | , module Stackctl.Prelude 10 | , module Control.Lens 11 | , module Control.Monad.AWS.ViaMock 12 | , module Test.Hspec 13 | , module Test.Hspec.Expectations.Lifted 14 | ) where 15 | 16 | import Stackctl.Prelude 17 | 18 | import Blammo.Logging.LogSettings (defaultLogSettings) 19 | import Blammo.Logging.Logger (newTestLogger) 20 | import Control.Lens ((?~)) 21 | import Control.Monad.AWS 22 | import Control.Monad.AWS.ViaMock 23 | import Stackctl.AWS.Core (AccountId (..)) 24 | import Stackctl.AWS.Scope 25 | import Stackctl.DirectoryOption 26 | import Stackctl.FilterOption 27 | import Test.Hspec (Spec, describe, example, it) 28 | import Test.Hspec.Expectations.Lifted 29 | 30 | data TestApp = TestApp 31 | { taLogger :: Logger 32 | , taMatchers :: Matchers 33 | , taAwsScope :: AwsScope 34 | , taFilterOption :: FilterOption 35 | , taDirectoryOption :: DirectoryOption 36 | } 37 | 38 | instance HasLogger TestApp where 39 | loggerL = lens taLogger $ \x y -> x {taLogger = y} 40 | 41 | instance HasMatchers TestApp where 42 | matchersL = lens taMatchers $ \x y -> x {taMatchers = y} 43 | 44 | instance HasAwsScope TestApp where 45 | awsScopeL = lens taAwsScope $ \x y -> x {taAwsScope = y} 46 | 47 | instance HasFilterOption TestApp where 48 | filterOptionL = lens taFilterOption $ \x y -> x {taFilterOption = y} 49 | 50 | instance HasDirectoryOption TestApp where 51 | directoryOptionL = lens taDirectoryOption $ \x y -> x {taDirectoryOption = y} 52 | 53 | newtype TestAppT m a = TestAppT 54 | { unTestAppT :: ReaderT TestApp (LoggingT m) a 55 | } 56 | deriving newtype 57 | ( Functor 58 | , Applicative 59 | , Monad 60 | , MonadIO 61 | , MonadUnliftIO 62 | , MonadLogger 63 | , MonadReader TestApp 64 | ) 65 | deriving (MonadAWS) via (MockAWS (TestAppT m)) 66 | 67 | instance MonadIO m => MonadFail (TestAppT m) where 68 | fail msg = expectationFailure msg >> error "unreachable" 69 | 70 | runTestAppT :: MonadUnliftIO m => TestAppT m a -> m a 71 | runTestAppT f = do 72 | app <- 73 | TestApp 74 | <$> newTestLogger defaultLogSettings 75 | <*> pure mempty 76 | <*> pure testAppAwsScope 77 | <*> pure defaultFilterOption 78 | <*> pure defaultDirectoryOption 79 | 80 | runLoggerLoggingT app $ runReaderT (unTestAppT f) app 81 | 82 | testAppAwsScope :: AwsScope 83 | testAppAwsScope = 84 | AwsScope 85 | { awsAccountId = AccountId "0123456789" 86 | , awsAccountName = "test" 87 | , awsRegion = "us-east-1" 88 | } 89 | 90 | -- | Gives a filepath relative to 'testAwsScope' 91 | testAppStackFilePath :: Text -> FilePath 92 | testAppStackFilePath base = 93 | "stacks" 94 | "0123456789.test" 95 | "us-east-1" 96 | unpack base <.> "yaml" 97 | -------------------------------------------------------------------------------- /test/files/change-sets/prod-faktory.md: -------------------------------------------------------------------------------- 1 | :warning: This PR generates **23** changes for `some-stack`. 2 | 3 | | Action | Logical Id | Physical Id | Type | Replacement | Scope | Details | 4 | | --- | --- | --- | --- | --- | --- | --- | 5 | | Add | ASGDepends | | AWS::CloudFormation::WaitConditionHandle | | | | 6 | | Modify | ASGLambdaExecutionRole | prod-faktory-ecs-cluster-ASGLambdaExecutionRole-U9NPRW10WHGZ | AWS::IAM::Role | False | Tags |
    | 7 | | Modify | ASGLifecycleLambdaFunction | prod-faktory-ecs-cluster-ASGLifecycleLambdaFunctio-C1RAZ4U57W7R | AWS::Lambda::Function | False | Properties, Tags |
    • DirectModification in Properties (Role), recreation Never
    • ResourceAttribute in Properties (Role), recreation Never, caused by ASGLambdaExecutionRole.Arn
    | 8 | | Modify | ASGLambdaInvokePermission | prod-faktory-ecs-cluster-ASGLambdaInvokePermission-1475JOG38K6P | AWS::Lambda::Permission | Conditional | Properties, Tags |
    • DirectModification in Properties (FunctionName), recreation Always
    • ResourceAttribute in Properties (FunctionName), recreation Always, caused by ASGLifecycleLambdaFunction.Arn
    | 9 | | Modify | ASGLambdaSNSSubscription | arn:aws:sns:us-east-1:999999999999:prod-faktory-ecs-cluster-ASGSNSTopic-1GZCULO2RMPPZ:4fec6f06-f72b-488b-9d97-c7a4621be7ca | AWS::SNS::Subscription | Conditional | Properties |
    • ResourceAttribute in Properties (Endpoint), recreation Always, caused by ASGLifecycleLambdaFunction.Arn
    • DirectModification in Properties (Endpoint), recreation Always
    | 10 | | Modify | ASGSNSTopic | arn:aws:sns:us-east-1:999999999999:prod-faktory-ecs-cluster-ASGSNSTopic-1GZCULO2RMPPZ | AWS::SNS::Topic | False | Properties, Tags |
    • ResourceAttribute in Properties (Subscription), recreation Never, caused by ASGLifecycleLambdaFunction.Arn
    • DirectModification in Properties (Subscription), recreation Never
    | 11 | | Modify | SNSLambdaRole | prod-faktory-ecs-cluster-SNSLambdaRole-YSXPOSGWHAYA | AWS::IAM::Role | False | Tags |
      | 12 | | Modify | ClusterSecurityGroup | sg-04a524560191c2e42 | AWS::EC2::SecurityGroup | True | Properties, Tags |
      • DirectModification in Properties (GroupDescription), recreation Always
      • DirectModification in Properties (SecurityGroupIngress), recreation Never
      • ParameterReference in Properties (SecurityGroupIngress), recreation Never, caused by IngressTo
      • DirectModification in Properties (VpcId), recreation Always
      • ParameterReference in Properties (GroupDescription), recreation Always, caused by Name
      • ParameterReference in Properties (SecurityGroupIngress), recreation Never, caused by IngressFrom
      | 13 | | Modify | LaunchConfiguration | prod-faktory-ecs-cluster-LaunchConfiguration-Mko0Jp8XTuKr | AWS::AutoScaling::LaunchConfiguration | True | Properties, Tags |
      • DirectModification in Properties (ImageId), recreation Always
      • DirectModification in Properties (UserData), recreation Always
      • ResourceReference in Properties (SecurityGroups), recreation Always, caused by ClusterSecurityGroup
      | 14 | | Modify | NLBTargetGroup | arn:aws:elasticloadbalancing:us-east-1:999999999999:targetgroup/prod-NLBTa-RNPHZHDRPVIZ/73c88e6d9e0e5b01 | AWS::ElasticLoadBalancingV2::TargetGroup | True | Properties, Tags |
      • DirectModification in Properties (VpcId), recreation Always
      | 15 | | Modify | AutoScalingGroup | prod-faktory-ecs-cluster-AutoScalingGroup-13NOD2PK314EV | AWS::AutoScaling::AutoScalingGroup | Conditional | Properties, Tags |
      • ResourceReference in Properties (LaunchConfigurationName), recreation Conditionally, caused by LaunchConfiguration
      • ResourceReference in Properties (TargetGroupARNs), recreation Never, caused by NLBTargetGroup
      • DirectModification in Properties (VPCZoneIdentifier), recreation Conditionally
      • ParameterReference in Tags, recreation Never, caused by Environment
      • DirectModification in Tags, recreation Never
      | 16 | | Modify | ASGTerminateHook | prod-faktory-ecs-cluster-ASGTerminateHook-18CDA25XDPELR | AWS::AutoScaling::LifecycleHook | Conditional | Properties, Tags |
      • ResourceAttribute in Properties (RoleARN), recreation Never, caused by SNSLambdaRole.Arn
      • DirectModification in Properties (RoleARN), recreation Never
      • ResourceReference in Properties (AutoScalingGroupName), recreation Always, caused by AutoScalingGroup
      | 17 | | Modify | ECSCluster | prod-faktory | AWS::ECS::Cluster | False | Tags |
        | 18 | | Modify | EFSFileSystem | fs-9529dc77 | AWS::EFS::FileSystem | False | Tags |
          | 19 | | Modify | EFSSecurityGroup | sg-07bd7bd588bafb48b | AWS::EC2::SecurityGroup | True | Properties, Tags |
          • ResourceReference in Properties (SecurityGroupIngress), recreation Never, caused by ClusterSecurityGroup
          • DirectModification in Properties (SecurityGroupIngress), recreation Never
          • DirectModification in Properties (VpcId), recreation Always
          | 20 | | Modify | EFSMountTarget | fsmt-e4d41504 | AWS::EFS::MountTarget | True | Properties, Tags |
          • ResourceReference in Properties (SecurityGroups), recreation Never, caused by EFSSecurityGroup
          • DirectModification in Properties (SubnetId), recreation Always
          | 21 | | Modify | InstanceProfile | prod-faktory-ecs-cluster-InstanceProfile-1W0KE43Y2TWDU | AWS::IAM::InstanceProfile | False | Tags |
            | 22 | | Modify | InstanceRole | prod-faktory-ecs-cluster-InstanceRole-1EEWHD4VKB56Y | AWS::IAM::Role | False | Properties, Tags |
            • DirectModification in Properties (Policies), recreation Never
            | 23 | | Modify | NLB | arn:aws:elasticloadbalancing:us-east-1:999999999999:loadbalancer/net/prod-fa-NLB-HHEBROLH5J6T/6b647d08dcc2d594 | AWS::ElasticLoadBalancingV2::LoadBalancer | False | Properties, Tags |
            • DirectModification in Properties (Subnets), recreation Never
            | 24 | | Modify | NLBDNSAliasRecord | faktory-internal.freckle.com | AWS::Route53::RecordSet | False | Properties |
            • ResourceAttribute in Properties (AliasTarget), recreation Never, caused by NLB.CanonicalHostedZoneID
            • DirectModification in Properties (AliasTarget), recreation Never
            • ResourceAttribute in Properties (AliasTarget), recreation Never, caused by NLB.DNSName
            | 25 | | Modify | NLBListener | arn:aws:elasticloadbalancing:us-east-1:999999999999:listener/net/prod-fa-NLB-HHEBROLH5J6T/6b647d08dcc2d594/80372abc7d907982 | AWS::ElasticLoadBalancingV2::Listener | False | Properties, Tags |
            • ResourceReference in Properties (DefaultActions), recreation Never, caused by NLBTargetGroup
            | 26 | | Modify | ScaleDownScheduledAction | prod-Scale-1KE1OLZRQSSXA | AWS::AutoScaling::ScheduledAction | Conditional | Properties, Tags |
            • ResourceReference in Properties (AutoScalingGroupName), recreation Always, caused by AutoScalingGroup
            | 27 | | Modify | ScaleUpScheduledAction | prod-Scale-13PIRUZGZW86O | AWS::AutoScaling::ScheduledAction | Conditional | Properties, Tags |
            • ResourceReference in Properties (AutoScalingGroupName), recreation Always, caused by AutoScalingGroup
            | 28 | -------------------------------------------------------------------------------- /test/files/change-sets/prod-faktory.txt: -------------------------------------------------------------------------------- 1 | 2 | Changes for some-stack: 3 | Add ASGDepends (AWS::CloudFormation::WaitConditionHandle) 4 | Modify ASGLambdaExecutionRole (AWS::IAM::Role) prod-faktory-ecs-cluster-ASGLambdaExecutionRole-U9NPRW10WHGZ 5 | Replacement: False 6 | Scope: Tags 7 | Details: 8 | Modify ASGLifecycleLambdaFunction (AWS::Lambda::Function) prod-faktory-ecs-cluster-ASGLifecycleLambdaFunctio-C1RAZ4U57W7R 9 | Replacement: False 10 | Scope: Properties, Tags 11 | Details: 12 | * DirectModification in Properties (Role), recreation Never 13 | * ResourceAttribute in Properties (Role), recreation Never, caused by ASGLambdaExecutionRole.Arn 14 | Modify ASGLambdaInvokePermission (AWS::Lambda::Permission) prod-faktory-ecs-cluster-ASGLambdaInvokePermission-1475JOG38K6P 15 | Replacement: Conditional 16 | Scope: Properties, Tags 17 | Details: 18 | * DirectModification in Properties (FunctionName), recreation Always 19 | * ResourceAttribute in Properties (FunctionName), recreation Always, caused by ASGLifecycleLambdaFunction.Arn 20 | Modify ASGLambdaSNSSubscription (AWS::SNS::Subscription) arn:aws:sns:us-east-1:999999999999:prod-faktory-ecs-cluster-ASGSNSTopic-1GZCULO2RMPPZ:4fec6f06-f72b-488b-9d97-c7a4621be7ca 21 | Replacement: Conditional 22 | Scope: Properties 23 | Details: 24 | * ResourceAttribute in Properties (Endpoint), recreation Always, caused by ASGLifecycleLambdaFunction.Arn 25 | * DirectModification in Properties (Endpoint), recreation Always 26 | Modify ASGSNSTopic (AWS::SNS::Topic) arn:aws:sns:us-east-1:999999999999:prod-faktory-ecs-cluster-ASGSNSTopic-1GZCULO2RMPPZ 27 | Replacement: False 28 | Scope: Properties, Tags 29 | Details: 30 | * ResourceAttribute in Properties (Subscription), recreation Never, caused by ASGLifecycleLambdaFunction.Arn 31 | * DirectModification in Properties (Subscription), recreation Never 32 | Modify SNSLambdaRole (AWS::IAM::Role) prod-faktory-ecs-cluster-SNSLambdaRole-YSXPOSGWHAYA 33 | Replacement: False 34 | Scope: Tags 35 | Details: 36 | Modify ClusterSecurityGroup (AWS::EC2::SecurityGroup) sg-04a524560191c2e42 37 | Replacement: True 38 | Scope: Properties, Tags 39 | Details: 40 | * DirectModification in Properties (GroupDescription), recreation Always 41 | * DirectModification in Properties (SecurityGroupIngress), recreation Never 42 | * ParameterReference in Properties (SecurityGroupIngress), recreation Never, caused by IngressTo 43 | * DirectModification in Properties (VpcId), recreation Always 44 | * ParameterReference in Properties (GroupDescription), recreation Always, caused by Name 45 | * ParameterReference in Properties (SecurityGroupIngress), recreation Never, caused by IngressFrom 46 | Modify LaunchConfiguration (AWS::AutoScaling::LaunchConfiguration) prod-faktory-ecs-cluster-LaunchConfiguration-Mko0Jp8XTuKr 47 | Replacement: True 48 | Scope: Properties, Tags 49 | Details: 50 | * DirectModification in Properties (ImageId), recreation Always 51 | * DirectModification in Properties (UserData), recreation Always 52 | * ResourceReference in Properties (SecurityGroups), recreation Always, caused by ClusterSecurityGroup 53 | Modify NLBTargetGroup (AWS::ElasticLoadBalancingV2::TargetGroup) arn:aws:elasticloadbalancing:us-east-1:999999999999:targetgroup/prod-NLBTa-RNPHZHDRPVIZ/73c88e6d9e0e5b01 54 | Replacement: True 55 | Scope: Properties, Tags 56 | Details: 57 | * DirectModification in Properties (VpcId), recreation Always 58 | Modify AutoScalingGroup (AWS::AutoScaling::AutoScalingGroup) prod-faktory-ecs-cluster-AutoScalingGroup-13NOD2PK314EV 59 | Replacement: Conditional 60 | Scope: Properties, Tags 61 | Details: 62 | * ResourceReference in Properties (LaunchConfigurationName), recreation Conditionally, caused by LaunchConfiguration 63 | * ResourceReference in Properties (TargetGroupARNs), recreation Never, caused by NLBTargetGroup 64 | * DirectModification in Properties (VPCZoneIdentifier), recreation Conditionally 65 | * ParameterReference in Tags, recreation Never, caused by Environment 66 | * DirectModification in Tags, recreation Never 67 | Modify ASGTerminateHook (AWS::AutoScaling::LifecycleHook) prod-faktory-ecs-cluster-ASGTerminateHook-18CDA25XDPELR 68 | Replacement: Conditional 69 | Scope: Properties, Tags 70 | Details: 71 | * ResourceAttribute in Properties (RoleARN), recreation Never, caused by SNSLambdaRole.Arn 72 | * DirectModification in Properties (RoleARN), recreation Never 73 | * ResourceReference in Properties (AutoScalingGroupName), recreation Always, caused by AutoScalingGroup 74 | Modify ECSCluster (AWS::ECS::Cluster) prod-faktory 75 | Replacement: False 76 | Scope: Tags 77 | Details: 78 | Modify EFSFileSystem (AWS::EFS::FileSystem) fs-9529dc77 79 | Replacement: False 80 | Scope: Tags 81 | Details: 82 | Modify EFSSecurityGroup (AWS::EC2::SecurityGroup) sg-07bd7bd588bafb48b 83 | Replacement: True 84 | Scope: Properties, Tags 85 | Details: 86 | * ResourceReference in Properties (SecurityGroupIngress), recreation Never, caused by ClusterSecurityGroup 87 | * DirectModification in Properties (SecurityGroupIngress), recreation Never 88 | * DirectModification in Properties (VpcId), recreation Always 89 | Modify EFSMountTarget (AWS::EFS::MountTarget) fsmt-e4d41504 90 | Replacement: True 91 | Scope: Properties, Tags 92 | Details: 93 | * ResourceReference in Properties (SecurityGroups), recreation Never, caused by EFSSecurityGroup 94 | * DirectModification in Properties (SubnetId), recreation Always 95 | Modify InstanceProfile (AWS::IAM::InstanceProfile) prod-faktory-ecs-cluster-InstanceProfile-1W0KE43Y2TWDU 96 | Replacement: False 97 | Scope: Tags 98 | Details: 99 | Modify InstanceRole (AWS::IAM::Role) prod-faktory-ecs-cluster-InstanceRole-1EEWHD4VKB56Y 100 | Replacement: False 101 | Scope: Properties, Tags 102 | Details: 103 | * DirectModification in Properties (Policies), recreation Never 104 | Modify NLB (AWS::ElasticLoadBalancingV2::LoadBalancer) arn:aws:elasticloadbalancing:us-east-1:999999999999:loadbalancer/net/prod-fa-NLB-HHEBROLH5J6T/6b647d08dcc2d594 105 | Replacement: False 106 | Scope: Properties, Tags 107 | Details: 108 | * DirectModification in Properties (Subnets), recreation Never 109 | Modify NLBDNSAliasRecord (AWS::Route53::RecordSet) faktory-internal.freckle.com 110 | Replacement: False 111 | Scope: Properties 112 | Details: 113 | * ResourceAttribute in Properties (AliasTarget), recreation Never, caused by NLB.CanonicalHostedZoneID 114 | * DirectModification in Properties (AliasTarget), recreation Never 115 | * ResourceAttribute in Properties (AliasTarget), recreation Never, caused by NLB.DNSName 116 | Modify NLBListener (AWS::ElasticLoadBalancingV2::Listener) arn:aws:elasticloadbalancing:us-east-1:999999999999:listener/net/prod-fa-NLB-HHEBROLH5J6T/6b647d08dcc2d594/80372abc7d907982 117 | Replacement: False 118 | Scope: Properties, Tags 119 | Details: 120 | * ResourceReference in Properties (DefaultActions), recreation Never, caused by NLBTargetGroup 121 | Modify ScaleDownScheduledAction (AWS::AutoScaling::ScheduledAction) prod-Scale-1KE1OLZRQSSXA 122 | Replacement: Conditional 123 | Scope: Properties, Tags 124 | Details: 125 | * ResourceReference in Properties (AutoScalingGroupName), recreation Always, caused by AutoScalingGroup 126 | Modify ScaleUpScheduledAction (AWS::AutoScaling::ScheduledAction) prod-Scale-13PIRUZGZW86O 127 | Replacement: Conditional 128 | Scope: Properties, Tags 129 | Details: 130 | * ResourceReference in Properties (AutoScalingGroupName), recreation Always, caused by AutoScalingGroup 131 | --------------------------------------------------------------------------------