├── .all-contributorsrc ├── .dockerignore ├── .envrc ├── .github └── workflows │ ├── README.md │ ├── build.yml │ ├── draft.yml │ ├── release.yml │ └── reusable-docker.yml ├── .gitignore ├── CHANGELOG.md ├── Dockerfile ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── default.nix ├── devenv.lock ├── devenv.nix ├── devenv.yaml ├── docs ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md └── NIX.md ├── example ├── .gitignore ├── README.md ├── Setup.hs ├── Vagrantfile ├── app │ └── Main.hs ├── example.cabal ├── hap.yaml ├── src │ └── Lib.hs ├── stack.yaml └── stack.yaml.lock ├── fixtures ├── git_repository_config.yaml └── local_directory_config.yaml ├── flake.lock ├── flake.nix ├── hapistrano.cabal ├── nix └── overlay.nix ├── release.nix ├── script ├── clean-build.sh └── haddock ├── spec ├── Spec.hs └── System │ ├── Hapistrano │ ├── ConfigSpec.hs │ └── InitSpec.hs │ ├── HapistranoPropsSpec.hs │ └── HapistranoSpec.hs ├── src └── System │ ├── Hapistrano.hs │ └── Hapistrano │ ├── Commands.hs │ ├── Commands │ └── Internal.hs │ ├── Config.hs │ ├── Core.hs │ ├── Maintenance.hs │ └── Types.hs ├── stack.yaml └── stack.yaml.lock /.all-contributorsrc: -------------------------------------------------------------------------------- 1 | { 2 | "projectName": "hapistrano", 3 | "projectOwner": "stackbuilders", 4 | "repoType": "github", 5 | "repoHost": "https://github.com", 6 | "files": [ 7 | "README.md" 8 | ], 9 | "imageSize": 100, 10 | "commit": true, 11 | "commitConvention": "none", 12 | "contributors": [ 13 | { 14 | "login": "juanpaucar", 15 | "name": "Juan Paucar", 16 | "avatar_url": "https://avatars.githubusercontent.com/u/2164411?v=4", 17 | "profile": "https://juancarlos.io/", 18 | "contributions": [ 19 | "code" 20 | ] 21 | }, 22 | { 23 | "login": "jsl", 24 | "name": "Justin S. Leitgeb", 25 | "avatar_url": "https://avatars.githubusercontent.com/u/9977?v=4", 26 | "profile": "https://www.stackbuilders.com/news/author/justin-leitgeb", 27 | "contributions": [ 28 | "code" 29 | ] 30 | }, 31 | { 32 | "login": "DavidMazarro", 33 | "name": "David Mazarro", 34 | "avatar_url": "https://avatars.githubusercontent.com/u/22799724?v=4", 35 | "profile": "https://github.com/DavidMazarro", 36 | "contributions": [ 37 | "code" 38 | ] 39 | }, 40 | { 41 | "login": "sestrella", 42 | "name": "Sebastián Estrella", 43 | "avatar_url": "https://avatars.githubusercontent.com/u/2049686?v=4", 44 | "profile": "https://github.com/sestrella", 45 | "contributions": [ 46 | "code" 47 | ] 48 | }, 49 | { 50 | "login": "mrkkrp", 51 | "name": "Mark Karpov", 52 | "avatar_url": "https://avatars.githubusercontent.com/u/8165792?v=4", 53 | "profile": "https://markkarpov.com/", 54 | "contributions": [ 55 | "code" 56 | ] 57 | }, 58 | { 59 | "login": "jpvillaisaza", 60 | "name": "Juan Pedro Villa Isaza", 61 | "avatar_url": "https://avatars.githubusercontent.com/u/584947?v=4", 62 | "profile": "https://github.com/jpvillaisaza", 63 | "contributions": [ 64 | "code" 65 | ] 66 | }, 67 | { 68 | "login": "CristhianMotoche", 69 | "name": "Cristhian Motoche", 70 | "avatar_url": "https://avatars.githubusercontent.com/u/8370088?v=4", 71 | "profile": "https://cristhianmotoche.github.io/", 72 | "contributions": [ 73 | "code" 74 | ] 75 | }, 76 | { 77 | "login": "psibi", 78 | "name": "Sibi Prabakaran", 79 | "avatar_url": "https://avatars.githubusercontent.com/u/737477?v=4", 80 | "profile": "https://psibi.in/", 81 | "contributions": [ 82 | "code" 83 | ] 84 | }, 85 | { 86 | "login": "ibarrae", 87 | "name": "Esteban Ibarra", 88 | "avatar_url": "https://avatars.githubusercontent.com/u/22796877?v=4", 89 | "profile": "https://github.com/ibarrae", 90 | "contributions": [ 91 | "code" 92 | ] 93 | }, 94 | { 95 | "login": "cptrodolfox", 96 | "name": "William R. Arellano", 97 | "avatar_url": "https://avatars.githubusercontent.com/u/20303685?v=4", 98 | "profile": "https://github.com/cptrodolfox", 99 | "contributions": [ 100 | "code" 101 | ] 102 | }, 103 | { 104 | "login": "goetzc", 105 | "name": "Götz", 106 | "avatar_url": "https://avatars.githubusercontent.com/u/2220440?v=4", 107 | "profile": "https://wikipedia.org/", 108 | "contributions": [ 109 | "code" 110 | ] 111 | }, 112 | { 113 | "login": "javcasas", 114 | "name": "Javier Casas", 115 | "avatar_url": "https://avatars.githubusercontent.com/u/4497839?v=4", 116 | "profile": "https://github.com/javcasas", 117 | "contributions": [ 118 | "code" 119 | ] 120 | }, 121 | { 122 | "login": "darthdeus", 123 | "name": "Jakub Arnold", 124 | "avatar_url": "https://avatars.githubusercontent.com/u/123374?v=4", 125 | "profile": "https://blog.jakuba.net/", 126 | "contributions": [ 127 | "code" 128 | ] 129 | }, 130 | { 131 | "login": "nickovivar", 132 | "name": "Nicko Vivar D.", 133 | "avatar_url": "https://avatars.githubusercontent.com/u/1821812?v=4", 134 | "profile": "https://github.com/nickovivar", 135 | "contributions": [ 136 | "code" 137 | ] 138 | }, 139 | { 140 | "login": "felixminom", 141 | "name": "Felix Miño", 142 | "avatar_url": "https://avatars.githubusercontent.com/u/42775600?v=4", 143 | "profile": "https://github.com/felixminom", 144 | "contributions": [ 145 | "code" 146 | ] 147 | }, 148 | { 149 | "login": "elcuy", 150 | "name": "Luis Fernando Alvarez", 151 | "avatar_url": "https://avatars.githubusercontent.com/u/11718997?v=4", 152 | "profile": "https://github.com/elcuy", 153 | "contributions": [ 154 | "code" 155 | ] 156 | }, 157 | { 158 | "login": "fefi95", 159 | "name": "Stefani Castellanos", 160 | "avatar_url": "https://avatars.githubusercontent.com/u/12057338?v=4", 161 | "profile": "https://github.com/fefi95", 162 | "contributions": [ 163 | "code" 164 | ] 165 | }, 166 | { 167 | "login": "alexisbcc", 168 | "name": "Alexis Crespo", 169 | "avatar_url": "https://avatars.githubusercontent.com/u/38666191?v=4", 170 | "profile": "https://github.com/alexisbcc", 171 | "contributions": [ 172 | "code" 173 | ] 174 | }, 175 | { 176 | "login": "GioDavid", 177 | "name": "David Proaño", 178 | "avatar_url": "https://avatars.githubusercontent.com/u/6964464?v=4", 179 | "profile": "https://giovannipro.com/", 180 | "contributions": [ 181 | "code" 182 | ] 183 | }, 184 | { 185 | "login": "FranzGB", 186 | "name": "Franz Guzmán", 187 | "avatar_url": "https://avatars.githubusercontent.com/u/46214532?v=4", 188 | "profile": "https://github.com/FranzGB", 189 | "contributions": [ 190 | "code" 191 | ] 192 | }, 193 | { 194 | "login": "hughjfchen", 195 | "name": "Hugh JF Chen", 196 | "avatar_url": "https://avatars.githubusercontent.com/u/5584544?v=4", 197 | "profile": "https://hughjfchen.github.io/", 198 | "contributions": [ 199 | "code" 200 | ] 201 | }, 202 | { 203 | "login": "boceto1", 204 | "name": "Jean Karlo Obando Ramos", 205 | "avatar_url": "https://avatars.githubusercontent.com/u/26729748?v=4", 206 | "profile": "https://www.facebook.com/CSOFTWAREESPE/", 207 | "contributions": [ 208 | "code" 209 | ] 210 | }, 211 | { 212 | "login": "ng29", 213 | "name": "Nitin Gupta", 214 | "avatar_url": "https://avatars.githubusercontent.com/u/26463272?v=4", 215 | "profile": "https://www.linkedin.com/in/ng2906/", 216 | "contributions": [ 217 | "code" 218 | ] 219 | }, 220 | { 221 | "login": "nebtrx", 222 | "name": "Omar García", 223 | "avatar_url": "https://avatars.githubusercontent.com/u/1876959?v=4", 224 | "profile": "http://nebtrx.github.com/", 225 | "contributions": [ 226 | "code" 227 | ] 228 | }, 229 | { 230 | "login": "wanderer163", 231 | "name": "wanderer163", 232 | "avatar_url": "https://avatars.githubusercontent.com/u/93438190?v=4", 233 | "profile": "https://github.com/wanderer163", 234 | "contributions": [ 235 | "code" 236 | ] 237 | }, 238 | { 239 | "login": "blackheaven", 240 | "name": "Gautier DI FOLCO", 241 | "avatar_url": "https://avatars.githubusercontent.com/u/1362807?v=4", 242 | "profile": "https://gautier.difolco.dev/", 243 | "contributions": [ 244 | "code" 245 | ] 246 | }, 247 | { 248 | "login": "oscar-izval", 249 | "name": "Óscar Izquierdo Valentín", 250 | "avatar_url": "https://avatars.githubusercontent.com/u/25722135?v=4", 251 | "profile": "https://github.com/oscar-izval", 252 | "contributions": [ 253 | "code" 254 | ] 255 | } 256 | ], 257 | "contributorsPerLine": 7, 258 | "linkToUsage": true, 259 | "commitType": "docs" 260 | } 261 | -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | *.nix 2 | .github/ 3 | .tool-versions 4 | Dockerfile 5 | cabal.project.* 6 | dist-newstyle/ 7 | example/ 8 | fixtures/ 9 | script/ 10 | stack.yaml* 11 | -------------------------------------------------------------------------------- /.envrc: -------------------------------------------------------------------------------- 1 | export DIRENV_WARN_TIMEOUT=20s 2 | 3 | eval "$(devenv direnvrc)" 4 | 5 | use devenv 6 | -------------------------------------------------------------------------------- /.github/workflows/README.md: -------------------------------------------------------------------------------- 1 | # CI Workflows 2 | 3 | ## Overview 4 | 5 | - [Build](build.yml) 6 | - Build and test Haskell code 7 | - Build Docker image 8 | - [Draft](draft.yml) 9 | - Create a GH draft release with a static binary 10 | - [Release](release.yml) 11 | - Upload the Docker image ghcr.io 12 | - Upload the package and docs to Hackage 13 | 14 | ## Events 15 | 16 | ```mermaid 17 | graph LR 18 | event[GH Event]-->|on push|Build 19 | event-->|tag created|Draft 20 | Draft-->|create draft release|End 21 | event-->|release published|Release 22 | Release-->|upload artifacts to Hackage/GHCR|End 23 | Build-->End 24 | ``` 25 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Build 3 | 4 | on: 5 | push: 6 | branches: 7 | - main 8 | pull_request: 9 | types: 10 | - opened 11 | - synchronize 12 | 13 | concurrency: 14 | group: build-${{ github.ref }} 15 | cancel-in-progress: true 16 | 17 | jobs: 18 | build: 19 | strategy: 20 | matrix: 21 | runner: 22 | - macos-latest 23 | - ubuntu-latest 24 | runs-on: ${{ matrix.runner }} 25 | env: 26 | LANG: en_US.UTF-8 27 | LC_ALL: en_US.UTF-8 28 | steps: 29 | - name: Checkout code 30 | uses: actions/checkout@v4 31 | - name: Install Nix 32 | uses: cachix/install-nix-action@v31 33 | - name: Setup Cachix 34 | uses: cachix/cachix-action@v16 35 | with: 36 | name: devenv 37 | - name: Install devenv 38 | run: nix profile install nixpkgs#devenv 39 | - name: Setup cache for `~/.stack` 40 | uses: actions/cache@v4 41 | with: 42 | path: ~/.stack 43 | key: ${{ runner.os }}-stack-global-${{ hashFiles('stack.yaml') }}-${{ hashFiles('hapistrano.cabal') }} 44 | restore-keys: | 45 | ${{ runner.os }}-stack-global-${{ hashFiles('stack.yaml') }}- 46 | ${{ runner.os }}-stack-global- 47 | - name: Install dependencies 48 | run: devenv shell -- stack build --only-dependencies --test 49 | - name: Setup cache for `.stack-work` 50 | uses: actions/cache@v4 51 | with: 52 | path: .stack-work 53 | key: ${{ runner.os }}-stack-work-${{ hashFiles('stack.yaml') }}-${{ hashFiles('hapistrano.cabal') }}-${{ hashFiles('**/*.hs') }} 54 | restore-keys: | 55 | ${{ runner.os }}-stack-work-${{ hashFiles('stack.yaml') }}-${{ hashFiles('hapistrano.cabal') }}- 56 | ${{ runner.os }}-stack-work-${{ hashFiles('stack.yaml') }}- 57 | ${{ runner.os }}-stack-work- 58 | - name: Compile code 59 | run: devenv shell -- stack build --test --no-run-tests 60 | - name: Run tests 61 | run: devenv shell -- stack test 62 | 63 | nix-build: 64 | strategy: 65 | matrix: 66 | runner: 67 | - macos-latest 68 | - ubuntu-latest 69 | runs-on: ${{ matrix.runner }} 70 | steps: 71 | - name: Checkout code 72 | uses: actions/checkout@v4 73 | - name: Install Nix 74 | uses: cachix/install-nix-action@v31 75 | - name: Setup Cachix 76 | uses: cachix/cachix-action@v16 77 | with: 78 | name: stackbuilders 79 | authToken: ${{ secrets.CACHIX_AUTH_TOKEN }} 80 | - name: Build `default` package 81 | run: nix build 82 | 83 | docker: 84 | uses: ./.github/workflows/reusable-docker.yml 85 | with: 86 | push: false 87 | -------------------------------------------------------------------------------- /.github/workflows/draft.yml: -------------------------------------------------------------------------------- 1 | # The present workflow was made based on the following references: 2 | # - https://evilmartians.com/chronicles/build-images-on-github-actions-with-docker-layer-caching 3 | # - https://github.com/docker/build-push-action/blob/master/docs/advanced/cache.md 4 | # - https://github.com/commercialhaskell/stack/blob/master/.github/workflows/integration-tests.yml 5 | --- 6 | name: Draft 7 | 8 | on: 9 | push: 10 | tags: 11 | - v* 12 | 13 | concurrency: 14 | group: draft-${{ github.ref }} 15 | cancel-in-progress: true 16 | 17 | jobs: 18 | build: 19 | runs-on: ubuntu-latest 20 | permissions: 21 | contents: write 22 | 23 | steps: 24 | - name: Checkout 25 | uses: actions/checkout@v3 26 | 27 | - name: Setup Docker Buildx 28 | uses: docker/setup-buildx-action@v2 29 | 30 | - name: Cache Docker layers 31 | uses: actions/cache@v3 32 | with: 33 | path: /tmp/.buildx-cache 34 | key: ${{ runner.os }}-buildx-${{ github.sha }} 35 | restore-keys: ${{ runner.os }}-buildx- 36 | 37 | - name: Build Docker image 38 | uses: docker/build-push-action@v2 39 | with: 40 | context: . 41 | load: true 42 | tags: ${{ github.repository }} 43 | cache-from: type=local,src=/tmp/.buildx-cache 44 | cache-to: type=local,dest=/tmp/.buildx-cache-new,mode=max 45 | 46 | - name: Copy static binary 47 | run: | 48 | docker run \ 49 | --entrypoint cp \ 50 | --volume $PWD/bin:/root/bin \ 51 | ${{ github.repository }} \ 52 | /usr/local/bin/hap \ 53 | /root/bin/hap-${{ github.ref_name }}-linux-x86_64-bin 54 | 55 | - name: Change owner before compression 56 | run: sudo chown $USER:$USER bin/hap-${{ github.ref_name }}-linux-x86_64-bin 57 | 58 | - name: Compress binary 59 | uses: svenstaro/upx-action@v2 60 | with: 61 | file: bin/hap-${{ github.ref_name }}-linux-x86_64-bin 62 | args: --best --lzma 63 | strip: true 64 | 65 | - name: Create draft release 66 | uses: softprops/action-gh-release@v1 67 | with: 68 | files: | 69 | bin/hap-* 70 | LICENSE 71 | draft: true 72 | 73 | - name: Move cache 74 | run: | 75 | rm -rf /tmp/.buildx-cache 76 | mv /tmp/.buildx-cache-new /tmp/.buildx-cache 77 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | # The present workflow was made based on the following references: 2 | # - https://github.com/tfausak/strive/blob/main/.github/workflows/ci.yaml 3 | # - https://hackage.haskell.org/upload 4 | --- 5 | name: Release 6 | 7 | on: 8 | release: 9 | types: 10 | - published 11 | 12 | concurrency: 13 | group: release-${{ github.ref }} 14 | cancel-in-progress: true 15 | 16 | jobs: 17 | ghcr: 18 | uses: ./.github/workflows/reusable-docker.yml 19 | with: 20 | push: true 21 | 22 | hackage: 23 | uses: stackbuilders/reusable-workflows/.github/workflows/cabal-upload.yml@v0.1.0 24 | secrets: 25 | HACKAGE_USERNAME: ${{ secrets.HACKAGE_USERNAME }} 26 | HACKAGE_PASSWORD: ${{ secrets.HACKAGE_PASSWORD }} 27 | -------------------------------------------------------------------------------- /.github/workflows/reusable-docker.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Docker 3 | 4 | on: 5 | workflow_call: 6 | inputs: 7 | push: 8 | type: boolean 9 | required: true 10 | 11 | jobs: 12 | build: 13 | runs-on: ubuntu-latest 14 | permissions: 15 | packages: write 16 | 17 | steps: 18 | - name: Checkout 19 | uses: actions/checkout@v3 20 | - name: Setup Docker Buildx 21 | uses: docker/setup-buildx-action@v3 22 | - name: Cache Docker layers 23 | uses: actions/cache@v3 24 | with: 25 | path: /tmp/.buildx-cache 26 | key: ${{ runner.os }}-buildx-${{ github.sha }} 27 | restore-keys: ${{ runner.os }}-buildx- 28 | - name: Login to ghcr.io 29 | if: ${{ inputs.push }} 30 | uses: docker/login-action@v2 31 | with: 32 | registry: ghcr.io 33 | username: ${{ github.actor }} 34 | password: ${{ secrets.GITHUB_TOKEN }} 35 | - name: Docker meta 36 | id: meta 37 | uses: docker/metadata-action@v4 38 | with: 39 | images: ghcr.io/${{ github.repository }} 40 | - name: Build and/or push Docker image 41 | uses: docker/build-push-action@v3 42 | with: 43 | context: . 44 | load: ${{ !inputs.push }} 45 | push: ${{ inputs.push }} 46 | tags: ${{ steps.meta.outputs.tags }} 47 | labels: ${{ steps.meta.outputs.labels }} 48 | cache-from: type=local,src=/tmp/.buildx-cache 49 | cache-to: type=local,dest=/tmp/.buildx-cache-new,mode=max 50 | - name: Smoke test 51 | if: ${{ !inputs.push }} 52 | run: docker run ghcr.io/${{ github.repository }} --version 53 | - name: Move cache 54 | run: | 55 | rm -rf /tmp/.buildx-cache 56 | mv /tmp/.buildx-cache-new /tmp/.buildx-cache 57 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.chi 2 | *.chs.h 3 | *.dyn_hi 4 | *.dyn_o 5 | *.hi 6 | *.o 7 | .cabal-sandbox/ 8 | .direnv/ 9 | .hpc 10 | .hsenv 11 | .tool-versions 12 | cabal-dev 13 | dist 14 | cabal.project.freeze 15 | cabal.project.local 16 | cabal.sandbox.config 17 | *.prof 18 | *.aux 19 | *.hp 20 | .stack-work/ 21 | dist-newstyle 22 | result 23 | .ghc.environment.* 24 | .tmuxinator.yml 25 | # Devenv 26 | .devenv* 27 | devenv.local.nix 28 | 29 | # direnv 30 | .direnv 31 | 32 | # pre-commit 33 | .pre-commit-config.yaml 34 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.4.9.0 2 | ### Added 3 | * Add support for lead target commands 4 | 5 | ## 0.4.8.0 6 | ### Modified 7 | * Fix issue before activating release 8 | 9 | ## 0.4.7.0 10 | ### Modified 11 | * Fix issue #210 which cuased concurrent deploys to pick only the first target. 12 | 13 | ## 0.4.6.0 14 | ### Modified 15 | * It sets the origin repository (`git remote set-url origin `) on every pushed release. 16 | 17 | ## 0.4.5.0 18 | ### Added 19 | * New commands that let you enable/disable a maintenance mode 20 | * New configuration variables: 21 | * `maintenance_directory:`- The name of the directory on which the maintenance file will be placed. `{deploy_path}/{maintenance_directory}`. The default directory name is `maintenance` 22 | * `maintenance_filename:`- The name of the file that is going to be created in the maintenance_directory. It has to have the `.html` extension to be seen in the browser. `{deploy_path}/{maintenance_directory}/{maintenance_filename}`. The default filename is `maintenance.html` 23 | 24 | ## 0.4.4.0 25 | ### Added 26 | * Ability to keep all failed releases or just one ([issue #154](https://github.com/stackbuilders/hapistrano/issues/154)) 27 | * Config Option: `keep_one_failed` 28 | * CLI Option: `--keep-one-failed` 29 | 30 | ### Modified 31 | * Some types and functions were modified to support the new features (e.g. `Hapistrano`, `runHapistrano`, etc.) 32 | 33 | ## 0.4.3.1 34 | ### Added 35 | * Add support for aeson 2.0 36 | 37 | ## 0.4.3.0 38 | ### Added 39 | * Add support for GHC 9.0 40 | * Docker image is built on a newer compiler, cabal and alpine version 41 | ### Removed 42 | * Official support for GHC versions older than 8.6 43 | 44 | ## 0.4.2.0 45 | ### Added 46 | * Add support for working directory 47 | 48 | ### Removed 49 | * GHC support for versions older than 8.0. Bounds for base corrected 50 | 51 | ## 0.4.1.4 52 | ### Changed 53 | * Bump path version upper constraint to 0.9 54 | 55 | ## 0.4.1.3 56 | ### Changed 57 | * Allow formatting-7.0 58 | 59 | ## 0.4.1.2 60 | ### Changed 61 | * Allow optparse-applicative-0.16.0.0 62 | 63 | ## 0.4.1.1 64 | ### Changed 65 | * Allow `ansi-terminal` 0.11 66 | 67 | ## 0.4.1.0 68 | ### Added 69 | * Support for GHC 8.10 70 | * Support for aeson-1.5 71 | 72 | ## 0.4.0.1 73 | ### Changed 74 | * Allow `time` 1.10 75 | * Correct the package to reenable Hapistrano in Stackage 76 | 77 | ## 0.4.0.0 78 | ### Added 79 | * Copy a directory's contents with `local_directory` instead of using _git_ with `repo` and `revision`. 80 | 81 | ### Changed 82 | * Update upper bounds for `path` and `path-io` packages. 83 | 84 | ## 0.3.10.1 85 | ### Added 86 | * Update Dockerfile and maintainer. 87 | 88 | ## 0.3.10.0 89 | ### Added 90 | * Colorize the output in the terminal. 91 | 92 | ## 0.3.9.4 93 | ### Added 94 | * Support for GHC 8.8 95 | * Support for ssh args in the config file. 96 | 97 | ## 0.3.9.3 98 | ### Changed 99 | * Support for optparse-applicative-0.15 100 | * Replace deprecated function "withProcess" to "withProcessTerm" 101 | and add the version of "typed-process-0.2.6.0" as extra dependency. 102 | 103 | ## 0.3.9.2 104 | ### Changed 105 | * Update Docker base image from alpine:3.7 to alpine:3.9 106 | 107 | ## 0.3.9.1 108 | ### Added 109 | * Add timestamp to output commands: 110 | ``` 111 | [16:29:58, 2019-01-23 (-05)] INFO -- : $ find /tmp/hapistrano/releases/ -maxdepth 1 -type d 112 | /tmp/hapistrano/releases/ 113 | /tmp/hapistrano/releases/20190123212933 114 | ``` 115 | 116 | ## 0.3.9.0 117 | ### Added 118 | * Support to deploy to a host that has default `zsh` shell. 119 | * Support to deploy using a different shell. Currently supported: `zsh` and `bash`. 120 | * `linked_files` and `linked_dirs` to link files and directories located in the 121 | `{deploy_path}/shared/` directory. 122 | 123 | ## 0.3.8.0 124 | ### Added 125 | * `execWithInheritStdout` was added to `System.Hapistrano.Core` to stream output children's 126 | to the parent's `stdout`. 127 | 128 | ### Changed 129 | * `playScript` and `playScriptLocally` use `execWithInheritStdout` to stream children's 130 | stdout to parent's stdout. 131 | 132 | ## 0.3.7.0 133 | * Read `release-format` and `keep-releases` from the configuration file. 134 | 135 | ## 0.3.6.1 136 | * Loose upper bound for yaml 0.11 137 | 138 | ## 0.3.6.0 139 | * Add support to interpolate ENV variables in a configuration file. 140 | * Add support for GHC 8.6.1 141 | * Loose constraint for stm-2.5.0.0 142 | 143 | ## 0.3.5.10 144 | * Updated upper bound for yaml 0.10 145 | 146 | ## 0.3.5.9 147 | * Loose upper bound for path-io 1.4 148 | 149 | ## 0.3.5.8 150 | * Loose upper bound for yaml 0.9 151 | 152 | ## 0.3.5.7 153 | * Loose upper bound for aeson 1.4 154 | 155 | ## 0.3.5.6 156 | * Add Dockerfile 157 | 158 | ## 0.3.5.5 159 | * Adding tested compatibility with GHC 8.4 160 | 161 | ## 0.3.5.4 162 | * Support for temporary 1.3 163 | 164 | ## 0.3.5.3 165 | * Support for aeson 1.3 166 | 167 | ## 0.3.5.2 168 | * Loose uppers bounds for async 169 | 170 | ## 0.3.5.1 171 | * Standarize style 172 | * When showing version information also show git branch and commit 173 | 174 | ## 0.3.5.0 175 | * Add support for deploying to other Unix systems, besides GNU/Linux which 176 | didn't supported all the flags that Hapistrano was using. See issue #63 177 | 178 | ## 0.3.4.0 179 | * Use `git checkout` instead of `git reset` to set the release revision 180 | 181 | ## 0.3.3.0 182 | 183 | * Correct bounds for base. GHC support for versions older than 7.10 was dropped on 0.3.0.0 184 | * Add `run_locally` to run user defined commands locally before deployment. Thanks to Sibi (GitHub: psibi) for this contribution 185 | 186 | ## 0.3.2.4 187 | 188 | * Allow time 1.8 189 | * Allow process 1.6 190 | 191 | ## 0.3.2.3 192 | 193 | * Allow path-io 1.3 194 | 195 | ## 0.3.2.2 196 | 197 | * Allow optparse-applicative 0.14 198 | 199 | ## 0.3.2.1 200 | 201 | * Add support for help in subcommands. Thanks to Vanessa McHale (GitHub: vmchale) for this contribution 202 | 203 | ## 0.3.2.0 204 | 205 | * Fix `-v` switch for hap. Thanks to Sibi (GitHub: psibi) for this contribution 206 | * Add `vc_action` to control version control related tasks. Thanks to Sibi (GitHub: psibi) for this contribution 207 | 208 | ## 0.3.1.0 209 | 210 | * Fixed a bug with repos not being fetched properly. 211 | * Implemented concurrent deployment to multiple hosts. 212 | * Now completion tokens are dropped automatically like old releases. 213 | 214 | ## 0.3.0.1 215 | 216 | * Reduced verbosity of some commands to make reading logs easier. 217 | * Restart command is now invoked after activation of new release (as it 218 | should). 219 | * Fix a typo in flag that specifies SSH port for `scp`. 220 | * Ensure that containing directories for files and directories to copy 221 | exist before invoking `scp`. 222 | 223 | ## 0.3.0.0 224 | 225 | * Add proper set of dependency version constraints. 226 | * Use `optparse-applicative` to parse arguments. 227 | * Allow to specify non-standard SSH port. 228 | * Drop support for GHCs older than 7.10 (because Chris Done's `path` does 229 | not compile with them, see: https://github.com/chrisdone/path/issues/46). 230 | * Now Hapistrano uses `hap.yaml` file for all its configuration. 231 | * Added the ability to copy arbitrary files and directories verbatim from 232 | local machine to target host. 233 | 234 | ## 0.2.1.2 235 | 236 | * Add change log (#23). 237 | * Add `README.md` to extra source files. 238 | * Handle missing environment variables more graciously. 239 | * Allow GHC 8 and base 4.9. 240 | 241 | ## 0.2.1.1 242 | 243 | * Fix tests (#31). 244 | 245 | ## 0.2.1 246 | 247 | * Use Stack (#17). 248 | * Clean up package (#20). 249 | * Fix tests (#25). 250 | 251 | ## 0.2.0.2 252 | 253 | * GHC 7.10 support. 254 | 255 | ## 0.2.0.1 256 | 257 | * Refactoring and documentation improvements. 258 | 259 | ## 0.2.0.0 260 | 261 | * Various refactoring and relaxed dependency constraints. 262 | 263 | ## 0.1.0.2 264 | 265 | * Print error messages to `stderr`, return non-zero exit code on failure. 266 | 267 | ## 0.1.0.1 268 | 269 | * Initial release. 270 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # Build 2 | FROM quay.io/benz0li/ghc-musl:9.6.6 AS build 3 | 4 | WORKDIR /usr/src/app 5 | 6 | # Install upx 7 | RUN apk update && apk add --no-cache upx 8 | 9 | # Copy only the necessary files for dependency installation 10 | COPY hapistrano.cabal ./ 11 | 12 | # Install dependencies 13 | RUN cabal update && \ 14 | cabal build --only-dependencies --enable-static 15 | 16 | # Copy the rest of the files. 17 | COPY . . 18 | 19 | # Build the application and compress the binary 20 | RUN cabal build --enable-executable-static && \ 21 | cp $(cabal exec which hap) hap && \ 22 | upx hap 23 | # Final image 24 | FROM alpine:3.15 25 | 26 | LABEL maintainer="Cristhian Motoche " 27 | 28 | # Install runtime dependencies 29 | RUN apk update && \ 30 | apk add --no-cache \ 31 | ca-certificates \ 32 | git \ 33 | openssh-client 34 | 35 | # Create .ssh directory 36 | RUN mkdir -p ~/.ssh 37 | 38 | # Copy the binary from the build stage 39 | COPY --from=build /usr/src/app/hap /usr/local/bin/hap 40 | 41 | # Set the entrypoint and default command 42 | ENTRYPOINT ["/usr/local/bin/hap"] 43 | CMD ["--help"] 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-Present Stack Builders Inc. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build](https://github.com/stackbuilders/hapistrano/actions/workflows/build.yml/badge.svg?branch=main)](https://github.com/stackbuilders/hapistrano/actions/workflows/build.yml) 2 | 3 | [![All Contributors](https://img.shields.io/badge/all_contributors-27-orange.svg?style=flat-square)](#contributors-) 4 | 5 | [![Draft](https://github.com/stackbuilders/hapistrano/actions/workflows/draft.yml/badge.svg)](https://github.com/stackbuilders/hapistrano/actions/workflows/draft.yml) 6 | [![Release](https://github.com/stackbuilders/hapistrano/actions/workflows/release.yml/badge.svg)](https://github.com/stackbuilders/hapistrano/actions/workflows/release.yml) 7 | 8 | # Hapistrano 9 | 10 | ## Description 11 | 12 | Hapistrano is a deployment library for Haskell applications similar to 13 | Ruby's [Capistrano](http://capistranorb.com/). 14 | 15 | ## Purpose 16 | 17 | We created Hapistrano because: 18 | 19 | * Deploys should be simple, but as close to atomic as possible (eg, 20 | they shouldn't require much application downtime). 21 | * Rollback should be trivial to achieve to bring the application back 22 | to the last-deployed state. 23 | * Deploys shouldn't fail because of dependency problems. 24 | 25 | ## How it Works 26 | 27 | Hapistrano (like Capistrano for Ruby) deploys applications to a new 28 | directory marked with a timestamp on the remote host. It creates this 29 | new directory quickly by placing a git repository for caching purposes 30 | on the remote server. 31 | 32 | When the build process completes, it switches a symlink to the `current` 33 | release directory, and optionally restarts the web server. 34 | 35 | By default, Hapistrano keeps the last five releases on the target host 36 | filesystem and deletes previous releases to avoid filling up the disk. 37 | 38 | ## Usage 39 | 40 | Hapistrano 0.4.0.0 looks for a configuration file called `hap.yaml` that 41 | typically looks like this: 42 | 43 | ```yaml 44 | deploy_path: '/var/projects/my-project' 45 | host: user@myserver.com 46 | port: 2222 47 | # To perform version control operations 48 | repo: 'https://github.com/stackbuilders/hapistrano.git' 49 | revision: origin/main 50 | # To copy the contents of the directory 51 | local_directory: '/tmp/my-project' 52 | build_script: 53 | - stack setup 54 | - stack build 55 | restart_command: systemd restart my-app-service 56 | ``` 57 | 58 | The following parameters are required: 59 | 60 | * `deploy_path` — the root of the deploy target on the remote host. 61 | * Related to the `source` of the repository, you have the following options: 62 | - _Git repository_ **default** — consists of two parameters. When these are set, 63 | hapistrano will perform version control related operations. 64 | **Note:** Only GitHub is supported. 65 | * `repo` — the origin repository. 66 | * `revision` — the SHA1 or branch to deploy. If a branch, you will need to 67 | specify it as `origin/branch_name` due to the way that the cache repo is 68 | configured. 69 | * `local_directory` — when this parameter is set, hapistrano will copy the 70 | contents of the directory. 71 | 72 | The following parameters are *optional*: 73 | 74 | * `host` — the target host, if missing, `localhost` will be assumed (which 75 | is useful for testing and playing with `hap` locally). You can specify the 76 | user that is going to connect to the server here. Example: `user@server.com`. 77 | * `port` — SSH port number to use. If missing, 22 will be used. 78 | * `shell` — Shell to use. Currently supported: `zsh` ans `bash`. If missing, `Bash` will be used. 79 | * `ssh_args` — Optional ssh arguments. Only `-p` is passed via the `port` variable. 80 | * `build_script` — instructions how to build the application in the form of 81 | shell commands. 82 | * `restart_command` — if you need to restart a remote web server after a 83 | successful rollback, specify the command that you use in this variable. It 84 | will be run after both deploy and rollback. 85 | * `vc_action` - Controls if version control related activity should 86 | take place. It defaults to true. When you don't want activity like 87 | cloning, fetching etc. to take place, set this to `false`. 88 | * `linux` - Specify, whether or not, the target system where Hapistrano will 89 | deploy to is a GNU/Linux or other UNIX (g.e. BSD, Mac). This is set to `true` 90 | by default so unless the target system is not GNU/Linux, this should not be 91 | necessary. The platform where Hapistrano is running won't affect the 92 | available options for commands (g.e. A Mac deploying to an Ubuntu machine, 93 | doesn't need this flag) 94 | * `release_format` - The release timestamp format, the 95 | '--release-format' argument passed via the CLI takes precedence over this 96 | value. If neither CLI nor configuration file value is specified, it defaults 97 | to 'short' 98 | * `keep_releases` - The number of releases to keep, the 99 | '--keep-releases' argument passed via the CLI takes precedence over this 100 | value. If neither CLI nor configuration file value is specified, it defaults 101 | to '5' 102 | * `keep_one_failed` - A boolean specifying whether to keep all failed releases 103 | or just one (the latest failed release), the '--keep-one-failed' flag passed via 104 | the CLI takes precedence over this value. If neither CLI nor configuration file value is specified, 105 | it defaults to false (i.e. keep all failed releases). 106 | * `linked_files:`- Listed files that will be symlinked from the `{deploy_path}/shared` folder 107 | into each release directory during deployment. Can be used for configuration files 108 | that need to be persisted (e.g. dotenv files). **NOTE:** The directory structure _must_ 109 | be similar in your release directories in case you need to link a file inside a 110 | nested directory (e.g. `shared/foo/file.txt`). 111 | * `linked_dirs:`- Listed directories that will be symlinked from the `{deploy_path}/shared` folder 112 | into each release directory during deployment. Can be used for data directories 113 | that need to be persisted (e.g. upload directories). **NOTE:** Do not add a slash `/` 114 | at the end of the directory (e.g. `foo/`) because we use `parseRelFile` to create 115 | the symlink. 116 | * `run_locally:`- Instructions to run locally on your machine in the 117 | form of shell commands. Example: 118 | 119 | ``` 120 | run_locally: 121 | - pwd 122 | - bash deploy.sh 123 | ``` 124 | 125 | Note how we are even able to execute a bash script named `deploy.sh` 126 | above. Be sure to use `set -e` in your bash script to avoid 127 | headaches. Hapistrano will stop the execution on non-zero exit 128 | codes. Without the usage of `set -e`, there is a possibility that your 129 | bash script may return a zero exit code even if your intermediate 130 | command resulted in an error. 131 | 132 | After creating a configuration file as above, deploying is as simple as: 133 | 134 | ```bash 135 | $ hap deploy 136 | ``` 137 | 138 | Rollback is also trivial: 139 | 140 | ```bash 141 | $ hap rollback # to rollback to previous successful deploy 142 | $ hap rollback -n 2 # go two deploys back in time, etc. 143 | ``` 144 | * `maintenance_directory:`- The name of the directory on which the maintenance file will be placed. `{deploy_path}/{maintenance_directory}`. The default directory name is `maintenance` 145 | * `maintenance_filename:`- The name of the file that is going to be created in the maintenance_directory. It has to have the `.html` extension to be seen in the browser. `{deploy_path}/{maintenance_directory}/{maintenance_filename}`. The default filename is `maintenance.html` 146 | 147 | ### Environment Variables 148 | 149 | Configuration files are parsed using 150 | [loadYamlSettings](http://hackage.haskell.org/package/yaml-0.10.2.0/docs/Data-Yaml-Config.html#v:loadYamlSettings), 151 | therefore, variable substitution is supported. Considering the following configuration file: 152 | 153 | ```yaml 154 | revision: "_env:HAPISTRANO_REVISION:origin/main 155 | ... 156 | ``` 157 | 158 | The `revision` value could be overwritten as follows: 159 | 160 | ```sh 161 | HAPISTRANO_REVISION=origin/feature_branch hap deploy 162 | ``` 163 | 164 | ## What to do when compiling on server is not viable 165 | 166 | Sometimes the target machine (server) is not capable of compiling your 167 | application because e.g. it has not enough memory and GHC exhausts it all. 168 | You can copy pre-compiled files from local machine or CI server using 169 | `copy_files` and `copy_dirs` parameters: 170 | 171 | ```haskell 172 | copy_files: 173 | - src: '/home/stackbuilders/my-file.txt' 174 | dest: 'my-file.txt' 175 | copy_dirs: 176 | - src: .stack-work 177 | dest: .stack-work 178 | ``` 179 | 180 | `src` maybe absolute or relative, it's path to file or directory on local 181 | machine, `dest` may only be relative (it's expanded relatively to cloned 182 | repo) and specifies where to put the files/directories on target machine. 183 | Directories and files with clashing names will be overwritten. Directories 184 | are copied recursively. 185 | 186 | ## Deploying to multiple machines concurrently 187 | 188 | Beginning with Hapistrano 0.3.1.0 it's possible to deploy to several 189 | machines concurrently. The only things you need to do is to adjust your 190 | configuration file and use `targets` parameter instead of `host` and `port`, 191 | like this: 192 | 193 | ```yml 194 | targets: 195 | - host: myserver-a.com 196 | port: 2222 197 | - host: myserver-b.com 198 | # the rest is the same 199 | ``` 200 | 201 | Additionally, starting with 0.4.9.0 it is possible to run commands only on the 202 | lead target during a concurrent deploying process ensuring that certain tasks 203 | only get executed once. The lead target is considered the first entry in the 204 | `targets` list: 205 | 206 | ```yml 207 | targets: 208 | - host: app1.example.com # lead server 209 | - host: app2.example.com 210 | 211 | build_script: 212 | - command: ./run_database_migrations 213 | only_lead: true 214 | - ./build 215 | # the rest is the same 216 | ``` 217 | 218 | A few things to note here: 219 | 220 | * `host` item is required for every target, but `port` may be omitted and 221 | then it defaults to `22`. 222 | 223 | * The deployment will run concurrently and finish when interactions with all 224 | targets have finished either successfully or not. If at least one 225 | interaction was unsuccessful, the `hap` tool will exit with non-zero exit 226 | code. 227 | 228 | * The log is printed in such a way that messages from several machines get 229 | intermixed, but it's guaranteed that they won't overlap (printing itself 230 | is sequential) and the headers will tell you exactly which machine was 231 | executing which command. 232 | 233 | If you don't specify `host` and `targets`, `hap` will assume `localhost` as 234 | usually, which is mainly useful for testing. 235 | 236 | ## Docker 237 | 238 | Starting with version `0.4.4.0` all new Docker images would be published to 239 | [GitHub's Container Registry][ghcr], while the old versions remain available on 240 | [Docker Hub][dockerhub]. To download the `latest` version available, change the 241 | image reference as follows: 242 | 243 | ```diff 244 | - stackbuilders/hapistrano:latest 245 | + ghcr.io/stackbuilders/hapistrano:latest 246 | ``` 247 | 248 | ## GH Actions 249 | 250 | Check the documentation [here](.github/workflows/README.md) 251 | 252 | ## Development 253 | 254 | ### Requirements 255 | 256 | - Install [Zsh](https://www.zsh.org/) 257 | - Use [GHCup][ghcup] to install: 258 | - GHC 8.10.x or 9.0.x (it is recommended to try both for backward 259 | compatibility) 260 | - Cabal 3.x 261 | 262 | Alternatively, install only Nix following the instructions detailed 263 | [here](docs/NIX.md). 264 | 265 | ### Getting Started 266 | 267 | Update package index: 268 | 269 | ```sh 270 | cabal update 271 | ``` 272 | 273 | Enable tests: 274 | 275 | ```sh 276 | cabal configure --enable-tests 277 | ``` 278 | 279 | Install project dependencies: 280 | 281 | ```sh 282 | cabal build --only-dependencies 283 | ``` 284 | 285 | Compile the project: 286 | 287 | ```sh 288 | cabal build 289 | ``` 290 | 291 | Run tests: 292 | 293 | ```sh 294 | cabal test 295 | ``` 296 | 297 | ## Enable/disable maintenance mode 298 | 299 | Present a maintenance page to visitors. Disables your application's web interface by writing a {maintenance_filename} file to each web server. The servers must be configured to detect the presence of this file, and if it is present, always display it instead of performing the request. 300 | 301 | The maintenance page will just say the site is down for maintenance, and will be back shortly. 302 | 303 | To enable maintenance mode run: 304 | 305 | ```bash 306 | hap maintenance enable 307 | ``` 308 | Disabling maintenance mode will remove the file from the {maintenance_directory} it can be done with the following command: 309 | 310 | ```bash 311 | hap maintenance disable 312 | ``` 313 | 314 | ## Notes 315 | 316 | * Hapistrano is not supported on Windows. Please check: [Issue #96](https://github.com/stackbuilders/hapistrano/issues/96). 317 | 318 | ## Contributors ✨ 319 | 320 | Thanks goes to these wonderful people ([emoji key](https://allcontributors.org/docs/en/emoji-key)): 321 | 322 | 323 | 324 | 325 | 326 | 327 | 328 | 329 | 330 | 331 | 332 | 333 | 334 | 335 | 336 | 337 | 338 | 339 | 340 | 341 | 342 | 343 | 344 | 345 | 346 | 347 | 348 | 349 | 350 | 351 | 352 | 353 | 354 | 355 | 356 | 357 | 358 | 359 | 360 | 361 | 362 | 363 | 364 | 365 | 370 | 371 | 372 |
Juan Paucar
Juan Paucar
💻		Justin S. Leitgeb
Justin S. Leitgeb
💻		David Mazarro
David Mazarro
💻		Sebastián Estrella
Sebastián Estrella
💻		Mark Karpov
Mark Karpov
💻		Juan Pedro Villa Isaza
Juan Pedro Villa Isaza
💻		Cristhian Motoche
Cristhian Motoche
💻
Sibi Prabakaran
Sibi Prabakaran
💻		Esteban Ibarra
Esteban Ibarra
💻		William R. Arellano
William R. Arellano
💻		Götz
Götz
💻		Javier Casas
Javier Casas
💻		Jakub Arnold
Jakub Arnold
💻		Nicko Vivar D.
Nicko Vivar D.
💻
Felix Miño
Felix Miño
💻		Luis Fernando Alvarez
Luis Fernando Alvarez
💻		Stefani Castellanos
Stefani Castellanos
💻		Alexis Crespo
Alexis Crespo
💻		David Proaño
David Proaño
💻		Franz Guzmán
Franz Guzmán
💻		Hugh JF Chen
Hugh JF Chen
💻
Jean Karlo Obando Ramos
Jean Karlo Obando Ramos
💻		Nitin Gupta
Nitin Gupta
💻		Omar García
Omar García
💻		wanderer163
wanderer163
💻		Gautier DI FOLCO
Gautier DI FOLCO
💻		Óscar Izquierdo Valentín
Óscar Izquierdo Valentín
💻
366 | 367 | Add your contributions 368 | 369 |
373 | 374 | 375 | 376 | 377 | 378 | 379 | This project follows the [all-contributors](https://github.com/all-contributors/all-contributors) specification. Contributions of any kind welcome! 380 | 381 | ## License 382 | 383 | MIT, see [the LICENSE file](LICENSE). 384 | 385 | ## Contributing 386 | 387 | Do you want to contribute to this project? Please take a look at our [contributing guideline](/docs/CONTRIBUTING.md) to know how you can help us build it. 388 | 389 | --- 390 | Stack Builders 391 | [Check out our libraries](https://github.com/stackbuilders/) | [Join our team](https://www.stackbuilders.com/join-us/) 392 | 393 | [ghcup]: https://www.haskell.org/ghcup/ 394 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Main (main) where 7 | 8 | import Control.Concurrent.Async 9 | import Control.Concurrent.STM 10 | import Control.Monad 11 | #if !MIN_VERSION_base(4,13,0) 12 | import Data.Monoid ((<>)) 13 | #endif 14 | import Data.Version (showVersion) 15 | import qualified Data.Yaml.Config as Yaml 16 | import Development.GitRev 17 | import Formatting (formatToString, string, (%)) 18 | import Options.Applicative hiding (str) 19 | import Paths_hapistrano (version) 20 | import System.Exit 21 | import qualified System.Hapistrano as Hap 22 | import qualified System.Hapistrano.Config as C 23 | import qualified System.Hapistrano.Maintenance as Hap 24 | import System.Hapistrano.Types 25 | import System.IO 26 | 27 | ---------------------------------------------------------------------------- 28 | 29 | parserInfo :: ParserInfo Opts 30 | parserInfo = 31 | info 32 | (helper <*> versionOption <*> optionParser) 33 | (fullDesc <> progDesc "Deploy tool for Haskell applications" <> 34 | header "Hapistrano - A deployment library for Haskell applications") 35 | where 36 | versionOption :: Parser (a -> a) 37 | versionOption = infoOption 38 | (formatToString 39 | ("Hapistrano: "% string 40 | % "\nbranch: " % string 41 | % "\nrevision: " % string) 42 | (showVersion version) 43 | $(gitBranch) 44 | $(gitHash)) 45 | (long "version" <> short 'v' <> help "Show version information") 46 | 47 | optionParser :: Parser Opts 48 | optionParser = Opts 49 | <$> hsubparser 50 | ( command "deploy" 51 | (info deployParser (progDesc "Deploy a new release")) <> 52 | command "rollback" 53 | (info rollbackParser (progDesc "Roll back to Nth previous release")) <> 54 | command "maintenance" 55 | (info maintenanceParser (progDesc "Enable/Disable maintenance mode")) <> 56 | command "init" 57 | (info initParser (progDesc "Initialize hapistrano file")) 58 | ) 59 | <*> strOption 60 | ( long "config" 61 | <> short 'c' 62 | <> value "hap.yaml" 63 | <> metavar "PATH" 64 | <> showDefault 65 | <> help "Configuration file to use" ) 66 | <*> flag 67 | False 68 | True 69 | ( long "dry-run" 70 | <> help "Display command (without running them)" ) 71 | 72 | deployParser :: Parser Command 73 | deployParser = Deploy 74 | <$> optional 75 | ( option pReleaseFormat 76 | ( long "release-format" 77 | <> short 'r' 78 | <> help "Which format release timestamp format to use: ‘long’ or ‘short’, default is ‘short’." 79 | ) 80 | ) 81 | <*> optional 82 | ( option auto 83 | ( long "keep-releases" 84 | <> short 'k' 85 | <> help "How many releases to keep, default is '5'" 86 | ) 87 | ) 88 | <*> switch 89 | ( long "keep-one-failed" 90 | <> help "Keep all failed releases or just one -the latest-, default (without using this flag) is to keep all failed releases." 91 | ) 92 | 93 | rollbackParser :: Parser Command 94 | rollbackParser = Rollback 95 | <$> option auto 96 | ( long "use-nth" 97 | <> short 'n' 98 | <> value 1 99 | <> showDefault 100 | <> help "How many deployments back to go?" ) 101 | 102 | initParser :: Parser Command 103 | initParser = pure InitConfig 104 | 105 | maintenanceParser :: Parser Command 106 | maintenanceParser = 107 | Maintenance 108 | <$> hsubparser 109 | ( command "enable" (info (pure Enable) (progDesc "Enables maintenance mode")) 110 | <> command "disable" (info (pure Disable) (progDesc "Disables maintenance mode")) 111 | ) 112 | 113 | pReleaseFormat :: ReadM ReleaseFormat 114 | pReleaseFormat = eitherReader $ \s -> 115 | case s of 116 | "long" -> Right ReleaseLong 117 | "short" -> Right ReleaseShort 118 | _ -> Left ("Unknown format: " ++ s ++ ", try ‘long’ or ‘short’.") 119 | 120 | ---------------------------------------------------------------------------- 121 | -- Main 122 | 123 | -- | Message that is used for communication between worker threads and the 124 | -- printer thread. 125 | 126 | data Message 127 | = PrintMsg OutputDest String -- ^ Print a message to specified 'OutputDest' 128 | | FinishMsg -- ^ The worker has finished 129 | deriving (Eq, Ord, Show, Read) 130 | 131 | main :: IO () 132 | main = do 133 | opts@Opts{..} <- execParser parserInfo 134 | case optsCommand of 135 | Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed -> 136 | runHapCmd opts $ \hapConfig@C.Config{..} executionMode -> 137 | Hap.deploy 138 | hapConfig 139 | (fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat) 140 | (fromMaybeKeepReleases cliKeepReleases configKeepReleases) 141 | (cliKeepOneFailed || configKeepOneFailed) 142 | executionMode 143 | Rollback n -> 144 | runHapCmd opts $ \C.Config{..} _ -> 145 | Hap.rollback configTargetSystem configDeployPath n configRestartCommand 146 | Maintenance Enable -> 147 | runHapCmd opts $ \C.Config{..} _ -> 148 | Hap.writeMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName 149 | Maintenance _ -> 150 | runHapCmd opts $ \C.Config{..} _ -> 151 | Hap.deleteMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName 152 | InitConfig -> Hap.initConfig getLine 153 | 154 | runHapCmd :: Opts -> (C.Config -> C.ExecutionMode -> Hapistrano ()) -> IO () 155 | runHapCmd Opts{..} hapCmd = do 156 | hapConfig@C.Config{..} <- Yaml.loadYamlSettings [optsConfigFile] [] Yaml.useEnv 157 | chan <- newTChanIO 158 | let printFnc dest str = atomically $ 159 | writeTChan chan (PrintMsg dest str) 160 | hap shell sshOpts executionMode = do 161 | r <- Hap.runHapistrano optsDryRun sshOpts shell printFnc $ hapCmd hapConfig executionMode 162 | atomically (writeTChan chan FinishMsg) 163 | return r 164 | printer :: Int -> IO () 165 | printer n = when (n > 0) $ do 166 | msg <- atomically (readTChan chan) 167 | case msg of 168 | PrintMsg StdoutDest str -> 169 | putStr str >> printer n 170 | PrintMsg StderrDest str -> 171 | hPutStr stderr str >> printer n 172 | FinishMsg -> 173 | printer (n - 1) 174 | haps :: [IO (Either Int ())] 175 | haps = 176 | case configHosts of 177 | [] -> [hap Bash Nothing C.LeadTarget] -- localhost, no SSH 178 | targets@(leadTarget : _) -> 179 | let runHap currentTarget@C.Target{..} = 180 | hap targetShell (Just $ SshOptions targetHost targetPort targetSshArgs) 181 | (if leadTarget == currentTarget then C.LeadTarget else C.AllTargets) 182 | in runHap <$> targets 183 | 184 | results <- (runConcurrently . traverse Concurrently) 185 | ((Right () <$ printer (length haps)) : haps) 186 | case sequence_ results of 187 | Left n -> exitWith (ExitFailure n) 188 | Right () -> putStrLn "Success." 189 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, ansi-terminal, async, base, directory 2 | , filepath, formatting, gitrev, hspec, hspec-discover, lib, mtl 3 | , optparse-applicative, path, path-io, process, QuickCheck 4 | , silently, stdenv, stm, temporary, time, transformers 5 | , typed-process, yaml, git, zlib, zsh 6 | }: 7 | mkDerivation { 8 | pname = "hapistrano"; 9 | version = "0.4.8.0"; 10 | src = ./.; 11 | isLibrary = true; 12 | isExecutable = true; 13 | enableSeparateDataOutput = true; 14 | libraryHaskellDepends = [ 15 | aeson ansi-terminal base filepath formatting gitrev mtl path 16 | process stm time transformers typed-process 17 | ]; 18 | executableHaskellDepends = [ 19 | aeson async base formatting gitrev optparse-applicative path 20 | path-io stm yaml 21 | ]; 22 | testHaskellDepends = [ 23 | base directory filepath hspec mtl path path-io process QuickCheck 24 | silently temporary 25 | ]; 26 | testSystemDepends = [ git zlib zsh ]; 27 | testToolDepends = [ hspec-discover ]; 28 | homepage = "https://github.com/stackbuilders/hapistrano"; 29 | description = "A deployment library for Haskell applications"; 30 | license = lib.licenses.mit; 31 | } 32 | -------------------------------------------------------------------------------- /devenv.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "devenv": { 4 | "locked": { 5 | "dir": "src/modules", 6 | "lastModified": 1719003735, 7 | "owner": "cachix", 8 | "repo": "devenv", 9 | "rev": "ffbb18da9000524978d3e537f5e02f48535d2aed", 10 | "treeHash": "60ca1cd5b478a61ecc2ec0e454be4ff7b7c3241b", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "dir": "src/modules", 15 | "owner": "cachix", 16 | "repo": "devenv", 17 | "type": "github" 18 | } 19 | }, 20 | "flake-compat": { 21 | "flake": false, 22 | "locked": { 23 | "lastModified": 1733328505, 24 | "owner": "edolstra", 25 | "repo": "flake-compat", 26 | "rev": "ff81ac966bb2cae68946d5ed5fc4994f96d0ffec", 27 | "type": "github" 28 | }, 29 | "original": { 30 | "owner": "edolstra", 31 | "repo": "flake-compat", 32 | "type": "github" 33 | } 34 | }, 35 | "git-hooks": { 36 | "inputs": { 37 | "flake-compat": "flake-compat", 38 | "gitignore": "gitignore", 39 | "nixpkgs": [ 40 | "nixpkgs" 41 | ] 42 | }, 43 | "locked": { 44 | "lastModified": 1742649964, 45 | "owner": "cachix", 46 | "repo": "git-hooks.nix", 47 | "rev": "dcf5072734cb576d2b0c59b2ac44f5050b5eac82", 48 | "type": "github" 49 | }, 50 | "original": { 51 | "owner": "cachix", 52 | "repo": "git-hooks.nix", 53 | "type": "github" 54 | } 55 | }, 56 | "gitignore": { 57 | "inputs": { 58 | "nixpkgs": [ 59 | "git-hooks", 60 | "nixpkgs" 61 | ] 62 | }, 63 | "locked": { 64 | "lastModified": 1709087332, 65 | "owner": "hercules-ci", 66 | "repo": "gitignore.nix", 67 | "rev": "637db329424fd7e46cf4185293b9cc8c88c95394", 68 | "type": "github" 69 | }, 70 | "original": { 71 | "owner": "hercules-ci", 72 | "repo": "gitignore.nix", 73 | "type": "github" 74 | } 75 | }, 76 | "nixpkgs": { 77 | "locked": { 78 | "lastModified": 1716977621, 79 | "owner": "cachix", 80 | "repo": "devenv-nixpkgs", 81 | "rev": "4267e705586473d3e5c8d50299e71503f16a6fb6", 82 | "treeHash": "6d9f1f7ca0faf1bc2eeb397c78a49623260d3412", 83 | "type": "github" 84 | }, 85 | "original": { 86 | "owner": "cachix", 87 | "ref": "rolling", 88 | "repo": "devenv-nixpkgs", 89 | "type": "github" 90 | } 91 | }, 92 | "root": { 93 | "inputs": { 94 | "devenv": "devenv", 95 | "git-hooks": "git-hooks", 96 | "nixpkgs": "nixpkgs", 97 | "pre-commit-hooks": [ 98 | "git-hooks" 99 | ] 100 | } 101 | } 102 | }, 103 | "root": "root", 104 | "version": 7 105 | } 106 | -------------------------------------------------------------------------------- /devenv.nix: -------------------------------------------------------------------------------- 1 | { pkgs, lib, ... }: 2 | 3 | { 4 | packages = 5 | [ 6 | pkgs.git 7 | pkgs.stack 8 | pkgs.zsh 9 | ] 10 | ++ lib.optionals pkgs.stdenv.isLinux [ 11 | pkgs.gmp 12 | ]; 13 | } 14 | -------------------------------------------------------------------------------- /devenv.yaml: -------------------------------------------------------------------------------- 1 | # yaml-language-server: $schema=https://devenv.sh/devenv.schema.json 2 | inputs: 3 | nixpkgs: 4 | url: github:cachix/devenv-nixpkgs/rolling 5 | -------------------------------------------------------------------------------- /docs/CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of conduct 2 | 3 | ## Purpose 4 | The primary goal of this Code of Conduct is to enable an open and welcoming environment. We pledge to making participation in our project a harassment-free experience for everyone, regardless of gender, sexual 5 | orientation, ability, ethnicity, socioeconomic status, and religion (or lack thereof). 6 | 7 | ## General recommendations 8 | Examples of behavior that contributes to creating a positive environment include: 9 | 10 | - Using welcoming and inclusive language 11 | - Being respectful of differing viewpoints and experiences 12 | - Gracefully accepting constructive criticism 13 | - Focusing on what is best for the community 14 | - Showing empathy towards other community members 15 | 16 | Examples of unacceptable behavior by participants include: 17 | 18 | - The use of sexualized language or imagery and unwelcome sexual attention or advances 19 | - Trolling, insulting/derogatory comments, and personal or political attacks 20 | - Public or private harassment 21 | - Publishing others' private information, such as a physical or electronic address, without explicit permission 22 | - Other conduct which could reasonably be considered inappropriate in a professional setting 23 | 24 | ## Maintainer responsibilities 25 | Project maintainers are responsible for clarifying the standards of acceptable behavior and are expected to take appropriate and fair corrective action in response to any instances of unacceptable behavior. 26 | 27 | Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct, or to ban temporarily or permanently any contributor for other behaviors that they deem inappropriate, threatening, offensive, or harmful. 28 | 29 | ## Scope 30 | This Code of Conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. Examples of representing a project or community include using an official project e-mail address, posting via an official social media account, or acting as an appointed representative at an online or offline event. Representation of a project may be further defined and clarified by project maintainers. 31 | 32 | ## Enforcement 33 | Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by contacting the project team at [community@stackbuilders.com](mailto:community@stackbuilders.com). All complaints will be reviewed and investigated and will result in a response that is deemed necessary and appropriate to the circumstances. The project team is obligated to maintain confidentiality with regard to the reporter of an incident. Further details of specific enforcement policies may be posted separately. 34 | 35 | Project maintainers who do not follow or enforce the Code of Conduct in good faith may face temporary or permanent repercussions as determined by other members of the project's leadership. 36 | -------------------------------------------------------------------------------- /docs/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contribution Guide 2 | 3 | Thank you for your interest in contributing to this Stack Builders' library. To contribute, please take our [Code of Conduct](CODE_OF_CONDUCT.md) into account, along with the following recommendations: 4 | 5 | - When submitting contributions to this repository, please make sure to discuss with the maintainer(s) the change you want to make. You can do this through an issue, or by sending an email to [community@stackbuilders.com](mailto:community@stackbuilders.com) 6 | 7 | - Once the change has been discussed with the maintainer(s), feel free to open a Pull Request. Please include a link to the issue you're trying to solve, or a quick summary of the discussed changes. 8 | 9 | - If adding any new features that you think should be considered in the README file, please add that information in your Pull Request. 10 | 11 | - Once you get an approval from any of the maintainers, please merge your Pull Request. Keep in mind that some of our Stack Builders repositories use CI/CD pipelines, so you will need to pass all of the required checks before merging. 12 | 13 | ## Getting help 14 | Contact any of our current maintainers, or send us an email at [community@stackbuilders.com](mailto:community@stackbuilders.com) for more information. Thank you for contributing! 15 | -------------------------------------------------------------------------------- /docs/NIX.md: -------------------------------------------------------------------------------- 1 | # Nix 2 | 3 | ## Requirements 4 | 5 | - Install [Nix](https://nixos.org/download.html) 6 | - Enable [Flakes](https://nixos.wiki/wiki/Flakes#Permanent) permanently 7 | - Install [devenv](https://devenv.sh/getting-started/): 8 | 9 | ## Project Structure 10 | 11 | The project uses: 12 | - Nix Flakes for reproducible builds and development environments 13 | - `stacklock2nix` for deriving Nix packages from stack.yaml.lock 14 | - `devenv` for creating consistent development environments 15 | 16 | ### Flake.nix 17 | 18 | The flake.nix file has the following inputs: 19 | - `nixpkgs`: Standard Nix packages repository 20 | - `stacklock2nix`: A tool for generating Nix packages from stack.yaml.lock files 21 | 22 | The flake outputs: 23 | - `packages.default`: The Hapistrano package for each supported system 24 | - `overlays.default`: An overlay for integrating Hapistrano into other Nix 25 | systems 26 | 27 | ## Development Environments 28 | 29 | The project includes a `devenv.nix` configuration that provides a consistent 30 | development environment with all necessary dependencies. 31 | 32 | To use devenv: 33 | 34 | ``` 35 | devenv shell 36 | ``` 37 | 38 | The devenv configuration includes: 39 | - Essential tools like git, stack, and zsh 40 | - System-specific dependencies (e.g., gmp for Linux systems) 41 | 42 | ### Using nix-direnv 43 | 44 | If you are using [nix-direnv](https://github.com/nix-community/nix-direnv), run: 45 | 46 | ``` 47 | direnv allow 48 | ``` 49 | 50 | This will enable the development shell according to the contents of 51 | [.envrc](../.envrc). Always check the contents of [.envrc](../.envrc) files 52 | before running `direnv allow` to ensure nothing malicious is executed. 53 | -------------------------------------------------------------------------------- /example/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | .vagrant 4 | -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | # Example project to test hapistrano's working_dir feature 2 | 3 | We're going to test the hapistrano's `working_dir` feature by deploying this project to a local server (Virtual machine). 4 | To do this we need to: 5 | 6 | 1. Install [VirtualBox][virtualbox] 7 | 2. Install [Vagrant][vagrant] 8 | 3. Make sure you have hapistrano installed. You can install it via [stack] by running 9 | ```bash 10 | stack install hapistrano 11 | ``` 12 | 4. You must have a ssh key with the name `id_rsa`.If you're not sure this [article][ssh] can be helpful. 13 | 5. Go to the `/hapistano/example` directory. 14 | 6. Execute in your terminal the next line. `*` 15 | ```bash 16 | #This could take a couple of minutes 17 | $ vagrant up 18 | $ hap deploy 19 | ``` 20 | If everything went fine, this should trigger the deployment process to the virtual machine. 21 | 7. To check if the project was built you can ssh the vagrant vm, and do the following: 22 | ```bash 23 | vagrant ssh 24 | cd /tmp/hap-examle/current/example 25 | stack build 26 | ``` 27 | Nothing should happen since your project is already compiled. 28 | 29 | `*` A known issue occurs if you have other vagrant vms. When trying to run `hap deploy` you could get the following console result. To avoid this issue remove the line that contains the previous RSA host key and try running `hap deploy` again. 30 | 31 | ```bash 32 | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 33 | @ WARNING: REMOTE HOST IDENTIFICATION HAS CHANGED! @ 34 | @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 35 | IT IS POSSIBLE THAT SOMEONE IS DOING SOMETHING NASTY! 36 | Someone could be eavesdropping on you right now (man-in-the-middle attack)! 37 | It is also possible that the RSA host key has just been changed. 38 | The fingerprint for the RSA key sent by the remote host is 39 | . 40 | Please contact your system administrator. 41 | Add correct host key in /path/to/.ssh/known_hosts to get rid of this message. 42 | Offending key in /path/to/.ssh/known_hosts: 43 | RSA host key for [ip-or-host]: has changed and you have requested strict checking. 44 | Host key verification failed. 45 | ``` 46 | 47 | [virtualbox]: https://www.virtualbox.org/wiki/Downloads 48 | [vagrant]: https://www.vagrantup.com/docs/installation 49 | [ssh]: https://docs.github.com/en/github/authenticating-to-github/checking-for-existing-ssh-keys 50 | [stack]: https://docs.haskellstack.org/en/stable/README/ 51 | -------------------------------------------------------------------------------- /example/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/Vagrantfile: -------------------------------------------------------------------------------- 1 | Vagrant.configure("2") do |config| 2 | config.vm.box = "debian/buster64" 3 | config.vm.provider "virtualbox" do |v| 4 | v.memory = 1024 5 | v.cpus = 2 6 | end 7 | 8 | # ~/.ssh/id_rsa.pub is a file in the host machine 9 | config.vm.provision "file", source: "~/.ssh/id_rsa.pub", destination: "~/.ssh/me.pub" 10 | config.vm.provision "shell", inline: <<-SCRIPT 11 | apt update 12 | apt install -y curl 13 | curl -sSL https://get.haskellstack.org/ | sh 14 | cat /home/vagrant/.ssh/me.pub >> /home/vagrant/.ssh/authorized_keys 15 | SCRIPT 16 | end 17 | -------------------------------------------------------------------------------- /example/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | 5 | main :: IO () 6 | main = helloWorld 7 | -------------------------------------------------------------------------------- /example/example.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | name: example 3 | version: 0.1.0.0 4 | description: 5 | This is an example project that has been created in order to test 6 | the deployment process using the working_dir feature of hapistrano. 7 | author: Justin Leitgeb 8 | maintainer: hackage@stackbuilders.com 9 | copyright: 2015-Present Stack Builders Inc. 10 | license: MIT 11 | license-file: ../LICENSE 12 | build-type: Simple 13 | extra-source-files: 14 | README.md 15 | 16 | source-repository head 17 | type: git 18 | location: https://github.com/stackbuilders/hapistrano/ 19 | 20 | library 21 | exposed-modules: 22 | Lib 23 | other-modules: 24 | Paths_example 25 | hs-source-dirs: 26 | src 27 | build-depends: 28 | base >=4.7 && <5 29 | default-language: Haskell2010 30 | 31 | executable example-exe 32 | main-is: Main.hs 33 | other-modules: 34 | Paths_example 35 | hs-source-dirs: 36 | app 37 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 38 | build-depends: 39 | base >=4.7 && <5 40 | , example 41 | default-language: Haskell2010 42 | -------------------------------------------------------------------------------- /example/hap.yaml: -------------------------------------------------------------------------------- 1 | deploy_path: "/tmp/hap-example" 2 | repo: "https://github.com/stackbuilders/hapistrano.git" 3 | revision: "origin/main" 4 | host: vagrant@127.0.0.1 5 | port: 2222 6 | working_directory: example 7 | 8 | build_script: 9 | - stack build -j1 10 | -------------------------------------------------------------------------------- /example/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( helloWorld 3 | ) where 4 | 5 | helloWorld :: IO () 6 | helloWorld = putStrLn "Hello world!" 7 | -------------------------------------------------------------------------------- /example/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.10 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /example/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/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 567241 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/10.yaml 11 | sha256: 321b3b9f0c7f76994b39e0dabafdc76478274b4ff74cc5e43d410897a335ad3b 12 | original: lts-17.10 13 | -------------------------------------------------------------------------------- /fixtures/git_repository_config.yaml: -------------------------------------------------------------------------------- 1 | deploy_path: '/' 2 | host: www.example.com 3 | repo: 'my-repo' 4 | revision: 'my-revision' 5 | -------------------------------------------------------------------------------- /fixtures/local_directory_config.yaml: -------------------------------------------------------------------------------- 1 | deploy_path: '/' 2 | host: www.example.com 3 | local_directory: '/' 4 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "nixpkgs": { 4 | "locked": { 5 | "lastModified": 1742850322, 6 | "narHash": "sha256-iinn8lHhcpWHL7ccJFH/SUIPb4+YdvTUhFkdzHLt7n0=", 7 | "owner": "nixos", 8 | "repo": "nixpkgs", 9 | "rev": "b7a97f713793d62f2090a703fca9b7a21cdd8314", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "nixos", 14 | "repo": "nixpkgs", 15 | "type": "github" 16 | } 17 | }, 18 | "root": { 19 | "inputs": { 20 | "nixpkgs": "nixpkgs", 21 | "stacklock2nix": "stacklock2nix" 22 | } 23 | }, 24 | "stacklock2nix": { 25 | "locked": { 26 | "lastModified": 1742355519, 27 | "narHash": "sha256-X5niEE/oc58LORprUdwWo/sHH0Gs776WeTbylfzrxwg=", 28 | "owner": "cdepillabout", 29 | "repo": "stacklock2nix", 30 | "rev": "65fb3f8537b063b9036a8033a905795fa0b1952c", 31 | "type": "github" 32 | }, 33 | "original": { 34 | "owner": "cdepillabout", 35 | "repo": "stacklock2nix", 36 | "type": "github" 37 | } 38 | } 39 | }, 40 | "root": "root", 41 | "version": 7 42 | } 43 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:nixos/nixpkgs"; 4 | stacklock2nix.url = "github:cdepillabout/stacklock2nix"; 5 | }; 6 | 7 | outputs = 8 | { 9 | self, 10 | nixpkgs, 11 | stacklock2nix, 12 | ... 13 | }: 14 | let 15 | supportedSystems = [ 16 | "aarch64-darwin" 17 | "aarch64-linux" 18 | "x86_64-darwin" 19 | "x86_64-linux" 20 | ]; 21 | unstestedSystems = [ 22 | "aarch64-linux" 23 | "x86_64-darwin" 24 | ]; 25 | forAllSystems = f: nixpkgs.lib.genAttrs supportedSystems (system: f system); 26 | nixpkgsFor = forAllSystems ( 27 | system: 28 | import nixpkgs { 29 | inherit system; 30 | overlays = [ 31 | stacklock2nix.overlay 32 | (import ./nix/overlay.nix) 33 | ]; 34 | } 35 | ); 36 | in 37 | { 38 | packages = forAllSystems ( 39 | system: 40 | let 41 | pkgs = nixpkgsFor.${system}; 42 | in 43 | { 44 | default = 45 | pkgs.lib.warnIf (builtins.any (x: x == system) unstestedSystems) 46 | "'${system}' is not tested as part of the CI workflow; please report any issues you encounter while dealing with it." 47 | pkgs.hapistrano; 48 | } 49 | ); 50 | overlays.default = final: prev: { 51 | hapistrano = self.packages.${prev.system}.default; 52 | }; 53 | }; 54 | } 55 | -------------------------------------------------------------------------------- /hapistrano.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.18 2 | name: hapistrano 3 | version: 0.4.10.0 4 | synopsis: A deployment library for Haskell applications 5 | description: 6 | . 7 | Hapistrano makes it easy to reliably deploy Haskell applications 8 | to a server. 9 | . 10 | Following popular libraries like Ruby's , 11 | Hapistrano does the work of building the application 12 | with dependencies into a distinct folder, and then atomically moves 13 | a symlink to the latest complete build. 14 | . 15 | This allows for atomic switchovers to new application code after the 16 | build is complete. Rollback is even simpler, since Hapistrano can 17 | just point the `current` symlink to the previous release. 18 | . 19 | See 20 | for more information. 21 | . 22 | license: MIT 23 | license-file: LICENSE 24 | author: Justin Leitgeb 25 | maintainer: hackage@stackbuilders.com 26 | copyright: 2015-Present Stack Builders Inc. 27 | category: System 28 | homepage: https://github.com/stackbuilders/hapistrano 29 | bug-reports: https://github.com/stackbuilders/hapistrano/issues 30 | build-type: Simple 31 | tested-with: GHC==9.8.4 32 | extra-doc-files: CHANGELOG.md 33 | , README.md 34 | 35 | flag dev 36 | description: Turn on development settings. 37 | manual: True 38 | default: False 39 | 40 | flag static 41 | description: Build a static binary. 42 | manual: True 43 | default: False 44 | 45 | library 46 | hs-source-dirs: src 47 | exposed-modules: System.Hapistrano 48 | , System.Hapistrano.Commands 49 | , System.Hapistrano.Config 50 | , System.Hapistrano.Core 51 | , System.Hapistrano.Types 52 | , System.Hapistrano.Commands.Internal 53 | , System.Hapistrano.Maintenance 54 | build-depends: aeson >= 2.0 && < 3.0 55 | , ansi-terminal >= 0.9 && < 2.0 56 | , base >= 4.9 && < 5.0 57 | , directory >= 1.2.5 && < 1.4 58 | , filepath >= 1.2 && < 1.5 59 | , gitrev >= 1.2 && < 1.4 60 | , mtl >= 2.0 && < 3.0 61 | , megaparsec >= 9.0 && < 10.0 62 | , stm >= 2.0 && < 2.6 63 | , path >= 0.5 && < 1.0 64 | , path-io >= 1.2 && < 1.9 65 | , process >= 1.4 && < 1.7 66 | , text >= 1.2 && < 3 67 | , typed-process >= 0.2 && < 0.3 68 | , time >= 1.5 && < 1.13 69 | , transformers >= 0.4 && < 0.7 70 | , exceptions >= 0.10 && < 0.11 71 | , yaml >= 0.11.7 && < 0.12 72 | if flag(dev) 73 | ghc-options: -Wall -Werror 74 | else 75 | ghc-options: -O2 -Wall 76 | default-language: Haskell2010 77 | 78 | executable hap 79 | hs-source-dirs: app 80 | main-is: Main.hs 81 | other-modules: Paths_hapistrano 82 | build-depends: async >= 2.0.1.6 && < 2.4 83 | , base >= 4.9 && < 5.0 84 | , formatting >= 6.2 && < 8.0 85 | , gitrev >= 1.2 && < 1.4 86 | , hapistrano 87 | , optparse-applicative >= 0.11 && < 0.19 88 | , stm >= 2.4 && < 2.6 89 | , yaml >= 0.11.7 && < 0.12 90 | if flag(dev) 91 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror 92 | else 93 | if flag(static) 94 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -static -optl-static 95 | else 96 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall 97 | default-language: Haskell2010 98 | 99 | test-suite test 100 | type: exitcode-stdio-1.0 101 | hs-source-dirs: spec 102 | main-is: Spec.hs 103 | other-modules: System.HapistranoSpec 104 | , System.Hapistrano.ConfigSpec 105 | , System.Hapistrano.InitSpec 106 | , System.HapistranoPropsSpec 107 | build-depends: base >= 4.9 && < 5.0 108 | , aeson 109 | , directory >= 1.2.5 && < 1.4 110 | , filepath >= 1.2 && < 1.5 111 | , hapistrano 112 | , hspec >= 2.0 && < 3.0 113 | , mtl >= 2.0 && < 3.0 114 | , path 115 | , path-io 116 | , process >= 1.4 && < 1.7 117 | , QuickCheck >= 2.5.1 && < 3.0 118 | , silently >= 1.2 && < 1.3 119 | , temporary >= 1.1 && < 1.4 120 | , yaml >= 0.8.16 && < 0.12 121 | build-tools: hspec-discover >= 2.0 && < 3.0 122 | 123 | if flag(dev) 124 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Werror 125 | else 126 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall 127 | default-language: Haskell2010 128 | 129 | source-repository head 130 | type: git 131 | location: https://github.com/stackbuilders/hapistrano.git 132 | -------------------------------------------------------------------------------- /nix/overlay.nix: -------------------------------------------------------------------------------- 1 | final: prev: { 2 | hapistrano-stacklock = final.stacklock2nix { 3 | stackYaml = ../stack.yaml; 4 | # The version of the compiler declared here must match the GHC version 5 | # provided by the stack resolver. 6 | baseHaskellPkgSet = final.haskell.packages.ghc984; 7 | all-cabal-hashes = final.fetchFromGitHub { 8 | owner = "commercialhaskell"; 9 | repo = "all-cabal-hashes"; 10 | rev = "299918adb3205b2dfe960bcdc79a9b1b300b11e6"; 11 | sha256 = 12 | if final.stdenv.isLinux then 13 | "sha256-9nkHnZusYNDntpH9LrLTamY9BimRWfeX2m99lAuMCMI=" 14 | else 15 | "sha256-Z0UJ78I3O8kWduNOqz7jASnR5XB8mwBDP0fVvjJoqOg="; 16 | }; 17 | additionalHaskellPkgSetOverrides = hfinal: hprev: { 18 | hapistrano = final.haskell.lib.compose.overrideCabal (drv: { 19 | testToolDepends = drv.testToolDepends ++ [ 20 | final.git 21 | final.zsh 22 | ]; 23 | }) hprev.hapistrano; 24 | }; 25 | }; 26 | hapistrano = final.hapistrano-stacklock.pkgSet.hapistrano; 27 | } 28 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import { }; 3 | in 4 | pkgs.haskellPackages.callPackage ./default.nix { 5 | git = pkgs.git; 6 | zlib = pkgs.zlib; 7 | zsh = pkgs.zsh; 8 | } 9 | -------------------------------------------------------------------------------- /script/clean-build.sh: -------------------------------------------------------------------------------- 1 | # This is a comment 2 | export PATH=~/.cabal/bin:/usr/local/bin:$PATH 3 | 4 | cabal sandbox delete # kill it with fire! 5 | cabal sandbox init 6 | cabal clean 7 | cabal update 8 | cabal install --only-dependencies -j 9 | cabal build -j 10 | -------------------------------------------------------------------------------- /script/haddock: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -o errexit 3 | set -o nounset 4 | set -o pipefail 5 | 6 | min_count=4 7 | count=$(cabal haddock | grep "100%" | wc -l) 8 | 9 | if [ "$count" -le "$min_count" ]; 10 | then 11 | echo "Haddock failed with exit code 1. Have you checked that the minimum of ${min_count} modules with 100% documentation is fulfilled?" 12 | exit 1 13 | fi 14 | -------------------------------------------------------------------------------- /spec/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /spec/System/Hapistrano/ConfigSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module System.Hapistrano.ConfigSpec 6 | ( spec 7 | ) where 8 | 9 | import qualified Data.Aeson as A 10 | import Data.Maybe (fromJust) 11 | import System.Hapistrano.Commands (mkGenericCommand) 12 | import System.Hapistrano.Config (Config (..), Target (..), 13 | BuildCommand (..), ExecutionMode (..)) 14 | import System.Hapistrano.Types (Shell (..), Source (..), 15 | TargetSystem (..)) 16 | 17 | import qualified Data.Yaml.Config as Yaml 18 | #if MIN_VERSION_base(4,15,0) 19 | import Path (mkAbsDir, mkRelDir, mkRelFile) 20 | #else 21 | import Path (Abs, Dir, File, Rel, mkAbsDir, 22 | mkRelDir, mkRelFile) 23 | #endif 24 | import Test.Hspec 25 | 26 | 27 | spec :: Spec 28 | spec = 29 | describe "Hapistrano's configuration file" $ do 30 | describe "BuildCommand" $ do 31 | let cmd = fromJust $ mkGenericCommand "ls" 32 | 33 | context "when \"only_lead\" is present" $ do 34 | it "decodes \"true\" as \"LeadTarget\"" $ 35 | A.eitherDecode "{\"command\":\"ls\",\"only_lead\":true}" `shouldBe` Right (BuildCommand cmd LeadTarget) 36 | 37 | it "decodes \"false\" as \"AllTargets\"" $ 38 | A.eitherDecode "{\"command\":\"ls\",\"only_lead\":false}" `shouldBe` Right (BuildCommand cmd AllTargets) 39 | 40 | context "when \"only_lead\" is not present" $ do 41 | it "decodes a single string" $ 42 | A.eitherDecode "\"ls\"" `shouldBe` Right (BuildCommand cmd AllTargets) 43 | 44 | it "decodos an object with a \"command\" field" $ 45 | A.eitherDecode "{\"command\":\"ls\"}" `shouldBe` Right (BuildCommand cmd AllTargets) 46 | 47 | context "when the key 'local-repository' is present" $ 48 | it "loads LocalRepository as the configuration's source" $ 49 | Yaml.loadYamlSettings ["fixtures/local_directory_config.yaml"] [] Yaml.useEnv 50 | >>= 51 | (`shouldBe` 52 | (defaultConfiguration 53 | { configSource = LocalDirectory { localDirectoryPath = $(mkAbsDir "/") } } 54 | ) 55 | ) 56 | 57 | context "when the keys 'repo' and 'revision' are present" $ 58 | it "loads GitRepository as the configuration's source" $ 59 | Yaml.loadYamlSettings ["fixtures/git_repository_config.yaml"] [] Yaml.useEnv 60 | >>= (`shouldBe` defaultConfiguration) 61 | 62 | describe "Config From JSON instances" $ do 63 | context "when contains unique targets" $ 64 | it "parses all unique targets" $ 65 | let eiHosts = fmap targetHost <$> configHosts <$> A.eitherDecode content 66 | content = 67 | "{\"targets\":[{\"host\":\"user@app1.com\"},{\"host\":\"user@app2.com\"}],\"deploy_path\":\"/tmp\",\"local_directory\":\"/\"}" 68 | in eiHosts `shouldBe` Right ["user@app1.com", "user@app2.com"] 69 | 70 | context "when contains duplicated targets" $ 71 | it "parses all only unique targets" $ 72 | let eiHosts = fmap targetHost <$> configHosts <$> A.eitherDecode content 73 | content = 74 | "{\"targets\":[{\"host\":\"user@app1.com\"},{\"host\":\"user@app1.com\"}],\"deploy_path\":\"/tmp\",\"local_directory\":\"/\"}" 75 | in eiHosts `shouldBe` Right ["user@app1.com"] 76 | 77 | 78 | defaultConfiguration :: Config 79 | defaultConfiguration = 80 | Config 81 | { configDeployPath = $(mkAbsDir "/") 82 | , configHosts = 83 | [ Target 84 | { targetHost = "www.example.com" 85 | , targetPort = 22 86 | , targetShell = Bash 87 | , targetSshArgs = [] 88 | } 89 | ] 90 | 91 | , configSource = GitRepository "my-repo" "my-revision" 92 | , configRestartCommand = Nothing 93 | , configBuildScript = Nothing 94 | , configCopyFiles = [] 95 | , configCopyDirs = [] 96 | , configLinkedFiles = [] 97 | , configLinkedDirs = [] 98 | , configVcAction = True 99 | , configRunLocally = Nothing 100 | , configTargetSystem = GNULinux 101 | , configReleaseFormat = Nothing 102 | , configKeepReleases = Nothing 103 | , configKeepOneFailed = False 104 | , configWorkingDir = Nothing 105 | , configMaintenanceDirectory = $(mkRelDir "maintenance") 106 | , configMaintenanceFileName = $(mkRelFile "maintenance.html") 107 | } 108 | -------------------------------------------------------------------------------- /spec/System/Hapistrano/InitSpec.hs: -------------------------------------------------------------------------------- 1 | module System.Hapistrano.InitSpec (spec) where 2 | 3 | import Test.Hspec 4 | import System.Directory (doesFileExist, getCurrentDirectory, withCurrentDirectory) 5 | import System.FilePath (()) 6 | import System.Hapistrano (initConfig) 7 | import System.IO.Temp (withSystemTempDirectory) 8 | 9 | spec :: Spec 10 | spec = do 11 | describe "initConfig" $ do 12 | it "should create a file when missing" $ 13 | withSystemTempDirectory "hapistrano-spec-initConfig-missing" $ \tempDir -> 14 | withCurrentDirectory tempDir $ do 15 | configFilePath <- ( "hap.yml") <$> getCurrentDirectory 16 | initConfig $ return "" 17 | doesFileExist configFilePath `shouldReturn` True 18 | -------------------------------------------------------------------------------- /spec/System/HapistranoPropsSpec.hs: -------------------------------------------------------------------------------- 1 | module System.HapistranoPropsSpec 2 | ( spec 3 | ) where 4 | 5 | import Data.Char (isSpace) 6 | import System.Hapistrano.Commands.Internal (mkGenericCommand, 7 | quoteCmd, trim, 8 | unGenericCommand) 9 | import Test.Hspec hiding (shouldBe, 10 | shouldReturn) 11 | import Test.QuickCheck 12 | 13 | spec :: Spec 14 | spec = 15 | describe "QuickCheck" $ 16 | context "Properties" $ do 17 | it "property of quote command" $ property propQuote' 18 | it "property of trimming a command" $ 19 | property $ forAll trimGenerator propTrim' 20 | it "property of mkGenericCommand and unGenericCommand" $ 21 | property $ forAll genericCmdGenerator propGenericCmd' 22 | 23 | -- Is quoted determine 24 | isQuoted :: String -> Bool 25 | isQuoted str = head str == '"' && last str == '"' 26 | 27 | -- | Quote function property 28 | propQuote :: String -> Bool 29 | propQuote str = 30 | if any isSpace str 31 | then isQuoted $ quoteCmd str 32 | else quoteCmd str == str 33 | 34 | propQuote' :: String -> Property 35 | propQuote' str = 36 | classify (any isSpace str) "has at least a space" $ propQuote str 37 | 38 | -- | Is trimmed 39 | isTrimmed' :: String -> Bool 40 | isTrimmed' [] = True 41 | isTrimmed' [x] = not $ isSpace x 42 | isTrimmed' str = 43 | let a = not . isSpace $ head str 44 | b = not . isSpace $ last str 45 | in a && b 46 | 47 | -- | Prop trimm 48 | propTrim :: String -> Bool 49 | propTrim = isTrimmed' . trim 50 | 51 | propTrim' :: String -> Property 52 | propTrim' str = 53 | classify (not $ isTrimmed' str) "non trimmed strings" $ propTrim str 54 | 55 | -- | Check that the string is perfect command String 56 | isCmdString :: String -> Bool 57 | isCmdString str = all ($str) [not . null, notElem '#', notElem '\n', isTrimmed'] 58 | 59 | -- | Prop Generic Command 60 | -- If the string does not contain # or \n, is trimmed and non null, the command should be created 61 | propGenericCmd :: String -> Bool 62 | propGenericCmd str = 63 | if isCmdString str 64 | then maybe False ((== str) . unGenericCommand) (mkGenericCommand str) 65 | else maybe True ((/= str) . unGenericCommand) (mkGenericCommand str) -- Either the command cannot be created or the command str is different to the original 66 | 67 | propGenericCmd' :: String -> Property 68 | propGenericCmd' str = 69 | classify (isCmdString str) "perfect command string" propGenericCmd 70 | 71 | -- | Trim String Generator 72 | trimGenerator :: Gen String 73 | trimGenerator = 74 | let strGen = listOf arbitraryUnicodeChar 75 | in frequency 76 | [ (1, suchThat strGen isTrimmed') 77 | , (1, suchThat strGen (not . isTrimmed')) 78 | ] 79 | 80 | -- | Generic Command generator 81 | genericCmdGenerator :: Gen String 82 | genericCmdGenerator = 83 | let strGen = listOf $ elements $ ['A'..'Z'] ++ ['a'..'z'] ++ [' ', '#', '*', '/', '.'] 84 | in frequency 85 | [(1, suchThat strGen isCmdString), (1, suchThat strGen (elem '#'))] 86 | -------------------------------------------------------------------------------- /spec/System/HapistranoSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module System.HapistranoSpec 6 | ( spec 7 | ) where 8 | 9 | import Control.Monad 10 | import Control.Monad.Reader 11 | import Data.List (isPrefixOf) 12 | import Data.Maybe (fromJust, mapMaybe) 13 | import Numeric.Natural 14 | import Path 15 | 16 | 17 | 18 | 19 | import Path.IO 20 | import System.Directory (doesFileExist, 21 | getCurrentDirectory, 22 | listDirectory) 23 | import System.Hapistrano (releasePath) 24 | import qualified System.Hapistrano as Hap 25 | import qualified System.Hapistrano.Commands as Hap 26 | import System.Hapistrano.Config ( BuildCommand (..) 27 | , ExecutionMode (..) 28 | , deployStateFilename 29 | ) 30 | import qualified System.Hapistrano.Core as Hap 31 | import System.Hapistrano.Maintenance 32 | import System.Hapistrano.Types 33 | import System.Info (os) 34 | import System.IO 35 | import System.IO.Silently (capture_) 36 | import Test.Hspec hiding (shouldBe, shouldContain, 37 | shouldReturn) 38 | import qualified Test.Hspec as Hspec 39 | import Test.Hspec.QuickCheck 40 | import Test.QuickCheck hiding (Success) 41 | 42 | testBranchName :: String 43 | testBranchName = "another_branch" 44 | 45 | workingDir :: Path Rel Dir 46 | workingDir = $(mkRelDir "working_dir") 47 | 48 | releaseDir :: Path Rel Dir 49 | releaseDir = $(mkRelDir "releases") 50 | 51 | spec :: Spec 52 | spec = do 53 | describe "playScript" $ around withSandbox $ do 54 | context "when the target is the lead server" $ do 55 | it "contains the output of the lead command" $ \(deployPath, repoPath) -> do 56 | capturedOutput <- capture_ $ runHap $ do 57 | release <- Hap.pushRelease $ mkTask deployPath repoPath 58 | Hap.playScript deployPath release Nothing LeadTarget 59 | [ BuildCommand (fromJust $ Hap.mkGenericCommand "echo \"hello world\"") LeadTarget 60 | ] 61 | capturedOutput `Hspec.shouldContain` "hello world" 62 | 63 | it "contains the output of a regular command" $ \(deployPath, repoPath) -> do 64 | capturedOutput <- capture_ $ runHap $ do 65 | release <- Hap.pushRelease $ mkTask deployPath repoPath 66 | Hap.playScript deployPath release Nothing LeadTarget 67 | [ BuildCommand (fromJust $ Hap.mkGenericCommand "echo \"hello world\"") AllTargets 68 | ] 69 | capturedOutput `Hspec.shouldContain` "hello world" 70 | 71 | context "when the target is not the lead server" $ do 72 | it "does not contain the output of a lead command" $ \(deployPath, repoPath) -> do 73 | capturedOutput <- capture_ $ runHap $ do 74 | release <- Hap.pushRelease $ mkTask deployPath repoPath 75 | Hap.playScript deployPath release Nothing AllTargets 76 | [ BuildCommand (fromJust $ Hap.mkGenericCommand "echo \"hello world\"") LeadTarget 77 | ] 78 | capturedOutput `Hspec.shouldNotContain` "hello world" 79 | 80 | it "contains the output of a regular command" $ \(deployPath, repoPath) -> do 81 | capturedOutput <- capture_ $ runHap $ do 82 | release <- Hap.pushRelease $ mkTask deployPath repoPath 83 | Hap.playScript deployPath release Nothing AllTargets 84 | [ BuildCommand (fromJust $ Hap.mkGenericCommand "echo \"hello world\"") AllTargets 85 | ] 86 | capturedOutput `Hspec.shouldContain` "hello world" 87 | 88 | describe "execWithInheritStdout" $ 89 | context "given a command that prints to stdout" $ 90 | it "redirects commands' output to stdout first" $ 91 | let (Just commandTest) = 92 | Hap.mkGenericCommand 93 | "echo \"hapistrano\"; sleep 2; echo \"onartsipah\"" 94 | commandExecution = Hap.execWithInheritStdout commandTest Nothing 95 | expectedOutput = "hapistrano\nonartsipah" 96 | in do actualOutput <- capture_ (runHap commandExecution) 97 | expectedOutput `Hspec.shouldSatisfy` (`isPrefixOf` actualOutput) 98 | describe "readScript" $ 99 | it "performs all the necessary normalizations correctly" $ do 100 | spath <- do 101 | currentDirectory <- getCurrentDirectory >>= parseAbsDir 102 | scriptFile <- parseRelFile "script/clean-build.sh" 103 | return (currentDirectory scriptFile) 104 | (fmap Hap.unGenericCommand <$> Hap.readScript spath) `Hspec.shouldReturn` 105 | [ "export PATH=~/.cabal/bin:/usr/local/bin:$PATH" 106 | , "cabal sandbox delete" 107 | , "cabal sandbox init" 108 | , "cabal clean" 109 | , "cabal update" 110 | , "cabal install --only-dependencies -j" 111 | , "cabal build -j" 112 | ] 113 | describe "fromMaybeReleaseFormat" $ do 114 | context "when the command line value is present" $ do 115 | context "and the config file value is present" $ 116 | prop "returns the command line value" $ 117 | forAll ((,) <$> arbitraryReleaseFormat <*> arbitraryReleaseFormat) $ \(rf1, rf2) -> 118 | fromMaybeReleaseFormat (Just rf1) (Just rf2) `Hspec.shouldBe` rf1 119 | context "and the config file value is not present" $ 120 | prop "returns the command line value" $ 121 | forAll arbitraryReleaseFormat $ \rf -> 122 | fromMaybeReleaseFormat (Just rf) Nothing `Hspec.shouldBe` rf 123 | context "when the command line value is not present" $ do 124 | context "and the config file value is present" $ 125 | prop "returns the config file value" $ 126 | forAll arbitraryReleaseFormat $ \rf -> 127 | fromMaybeReleaseFormat Nothing (Just rf) `Hspec.shouldBe` rf 128 | context "and the config file value is not present" $ 129 | it "returns the default value" $ 130 | fromMaybeReleaseFormat Nothing Nothing `Hspec.shouldBe` ReleaseShort 131 | describe "fromMaybeKeepReleases" $ do 132 | context "when the command line value is present" $ do 133 | context "and the config file value is present" $ 134 | prop "returns the command line value" $ 135 | forAll ((,) <$> arbitraryKeepReleases <*> arbitraryKeepReleases) $ \(kr1, kr2) -> 136 | fromMaybeKeepReleases (Just kr1) (Just kr2) `Hspec.shouldBe` kr1 137 | context "and the second value is not present" $ 138 | prop "returns the command line value" $ 139 | forAll arbitraryKeepReleases $ \kr -> 140 | fromMaybeKeepReleases (Just kr) Nothing `Hspec.shouldBe` kr 141 | context "when the command line value is not present" $ do 142 | context "and the config file value is present" $ 143 | prop "returns the config file value" $ 144 | forAll arbitraryKeepReleases $ \kr -> 145 | fromMaybeKeepReleases Nothing (Just kr) `Hspec.shouldBe` kr 146 | context "and the config file value is not present" $ 147 | it "returns the default value" $ 148 | fromMaybeKeepReleases Nothing Nothing `Hspec.shouldBe` 5 149 | around withSandbox $ do 150 | describe "writeMaintenanceFile" $ 151 | context "when the file doesn't exist" $ 152 | it "creates the maintenance file in the given path" $ \(deployPath, _) -> do 153 | result <- runHap $ do 154 | writeMaintenanceFile deployPath $(mkRelDir "maintenance") $(mkRelFile "maintenance.html") 155 | liftIO $ System.Directory.doesFileExist (fromAbsDir deployPath <> "/maintenance/maintenance.html") 156 | result `shouldBe` True 157 | describe "deleteMaintenanceFile" $ 158 | context "when the file exists" $ 159 | it "removes the maintenance file from the given path" $ \(deployPath, _) -> do 160 | result <- runHap $ do 161 | writeMaintenanceFile deployPath $(mkRelDir "maintenance") $(mkRelFile "maintenance.html") 162 | deleteMaintenanceFile deployPath $(mkRelDir "maintenance") $(mkRelFile "maintenance.html") 163 | liftIO $ System.Directory.doesFileExist (fromAbsDir deployPath <> "/maintenance/maintenance.html") 164 | result `shouldBe` False 165 | describe "releasePath" $ do 166 | context "when the configWorkingDir is Nothing" $ 167 | it "should return the release path" $ \(deployPath, repoPath) -> do 168 | (rpath, release) <- runHap $ do 169 | release <- Hap.pushRelease $ mkTask deployPath repoPath 170 | (,) <$> Hap.releasePath deployPath release Nothing 171 | <*> pure release 172 | 173 | rel <- parseRelDir $ renderRelease release 174 | rpath `shouldBe` deployPath releaseDir rel 175 | 176 | context "when the configWorkingDir is Just" $ 177 | it "should return the release path with WorkingDir" $ \(deployPath, repoPath) -> do 178 | (rpath, release) <- runHap $ do 179 | release <- Hap.pushRelease $ mkTask deployPath repoPath 180 | (,) <$> Hap.releasePath deployPath release (Just workingDir) 181 | <*> pure release 182 | 183 | rel <- parseRelDir $ renderRelease release 184 | rpath `shouldBe` deployPath releaseDir rel workingDir 185 | 186 | describe "pushRelease" $ do 187 | it "sets up repo all right in Zsh" $ \(deployPath, repoPath) -> 188 | runHapWithShell Zsh $ do 189 | let task = mkTask deployPath repoPath 190 | release <- Hap.pushRelease task 191 | rpath <- Hap.releasePath deployPath release Nothing 192 | -- let's check that the dir exists and contains the right files 193 | (liftIO . readFile . fromAbsFile) (rpath $(mkRelFile "foo.txt")) `shouldReturn` 194 | "Foo!\n" 195 | it "sets up repo all right" $ \(deployPath, repoPath) -> 196 | runHap $ do 197 | let task = mkTask deployPath repoPath 198 | release <- Hap.pushRelease task 199 | rpath <- Hap.releasePath deployPath release Nothing 200 | -- let's check that the dir exists and contains the right files 201 | (liftIO . readFile . fromAbsFile) (rpath $(mkRelFile "foo.txt")) `shouldReturn` 202 | "Foo!\n" 203 | it "deploys properly a branch other than main" $ \(deployPath, repoPath) -> 204 | runHap $ do 205 | let task = mkTaskWithCustomRevision deployPath repoPath testBranchName 206 | release <- Hap.pushRelease task 207 | rpath <- Hap.releasePath deployPath release Nothing 208 | -- let's check that the dir exists and contains the right files 209 | (liftIO . readFile . fromAbsFile) (rpath $(mkRelFile "bar.txt")) `shouldReturn` 210 | "Bar!\n" 211 | -- This fails if the opened branch is not testBranchName 212 | justExec 213 | rpath 214 | ("test `git rev-parse --abbrev-ref HEAD` = " ++ testBranchName) 215 | -- This fails if there are unstaged changes 216 | justExec rpath "git diff --exit-code" 217 | it "updates the origin url when it's changed" $ \(deployPath, repoPath) -> 218 | withSystemTempDir "hap-test-repotwo" $ \repoPathTwo -> do 219 | runHap $ do 220 | let task1 = mkTask deployPath repoPath 221 | task2 = mkTask deployPath repoPathTwo 222 | repoConfigFile = deployPath $(mkRelDir "repo") $(mkRelFile "config") 223 | liftIO $ populateTestRepo repoPathTwo 224 | void $ Hap.pushRelease task1 225 | void $ Hap.pushRelease task2 226 | 227 | repoFile <- (liftIO . readFile . fromAbsFile) repoConfigFile 228 | repoFile `shouldContain` "hap-test-repotwo" 229 | 230 | describe "createHapistranoDeployState" $ do 231 | it ("creates the " <> deployStateFilename <> " file correctly") $ \(deployPath, repoPath) -> 232 | runHap $ do 233 | let task = mkTask deployPath repoPath 234 | release <- Hap.pushRelease task 235 | parseStatePath <- parseRelFile deployStateFilename 236 | actualReleasePath <- releasePath deployPath release Nothing 237 | let stateFilePath = actualReleasePath parseStatePath 238 | Hap.createHapistranoDeployState deployPath release Success 239 | Path.IO.doesFileExist stateFilePath `shouldReturn` 240 | True 241 | it "when created in a successful deploy, the contents are \"Success\"" $ \(deployPath, repoPath) -> 242 | runHap $ do 243 | let task = mkTask deployPath repoPath 244 | release <- Hap.pushRelease task 245 | Hap.createHapistranoDeployState deployPath release Success 246 | Hap.deployState deployPath Nothing release `shouldReturn` 247 | Success 248 | 249 | describe "activateRelease" $ 250 | it "creates the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> 251 | runHap $ do 252 | let task = mkTask deployPath repoPath 253 | release <- Hap.pushRelease task 254 | Hap.activateRelease currentSystem deployPath release 255 | rpath <- Hap.releasePath deployPath release Nothing 256 | let rc :: Hap.Readlink Dir 257 | rc = 258 | Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath) 259 | Hap.exec rc (Just release) `shouldReturn` rpath 260 | Path.IO.doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False 261 | describe "playScriptLocally (successful run)" $ 262 | it "check that local scripts are run and deployment is successful" $ \(deployPath, repoPath) -> 263 | runHap $ do 264 | let localCommands = mapMaybe Hap.mkGenericCommand ["pwd", "ls"] 265 | task = mkTask deployPath repoPath 266 | Hap.playScriptLocally localCommands 267 | release <- Hap.pushRelease task 268 | parseStatePath <- parseRelFile deployStateFilename 269 | actualReleasePath <- releasePath deployPath release Nothing 270 | let stateFilePath = actualReleasePath parseStatePath 271 | Hap.createHapistranoDeployState deployPath release Success 272 | Path.IO.doesFileExist stateFilePath `shouldReturn` 273 | True 274 | describe "playScriptLocally (error exit)" $ 275 | it "check that deployment isn't done" $ \(deployPath, repoPath) -> 276 | runHap (do 277 | let localCommands = 278 | mapMaybe Hap.mkGenericCommand ["pwd", "ls", "false"] 279 | task = mkTask deployPath repoPath 280 | Hap.playScriptLocally localCommands 281 | release <- Hap.pushRelease task 282 | Hap.createHapistranoDeployState deployPath release Success) `shouldThrow` 283 | anyException 284 | describe "rollback" $ 285 | it "resets the ‘current’ symlink correctly" $ \(deployPath, repoPath) -> 286 | runHap $ do 287 | let task = mkTask deployPath repoPath 288 | noCmd = Nothing 289 | rs <- replicateM 5 (Hap.pushRelease task) 290 | Hap.rollback currentSystem deployPath 2 noCmd 291 | rpath <- Hap.releasePath deployPath (rs !! 2) Nothing 292 | let rc :: Hap.Readlink Dir 293 | rc = 294 | Hap.Readlink currentSystem (Hap.currentSymlinkPath deployPath) 295 | Hap.exec rc Nothing `shouldReturn` rpath 296 | Path.IO.doesFileExist (Hap.tempSymlinkPath deployPath) `shouldReturn` False 297 | describe "rollback to non-exist release" $ 298 | it "trying to rollback to a non-exist release, should throw exception" $ \(deployPath, repoPath) -> 299 | runHap (do 300 | let task = mkTask deployPath repoPath 301 | noCmd = Nothing 302 | replicateM_ 5 (Hap.pushRelease task) 303 | Hap.rollback currentSystem deployPath 6 noCmd) `shouldThrow` 304 | anyException 305 | describe "dropOldReleases" $ do 306 | it "should not keep more than 5 releases by default after a successful release" $ \(deployPath, repoPath) -> 307 | runHap $ do 308 | rs <- 309 | replicateM 7 $ do 310 | r <- Hap.pushRelease (mkTask deployPath repoPath) 311 | Hap.createHapistranoDeployState deployPath r Success 312 | return r 313 | Hap.dropOldReleases deployPath 5 False 314 | -- two oldest releases should not survive: 315 | forM_ (take 2 rs) $ \r -> 316 | (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` False 317 | -- 5 most recent releases should stay alive: 318 | forM_ (drop 2 rs) $ \r -> 319 | (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` True 320 | context "when the --keep-one-failed flag is active" $ 321 | it "should delete failed releases other than the most recent" $ \(deployPath, repoPath) -> 322 | let successfulRelease = mkReleaseWithState deployPath repoPath Success 323 | failedRelease = mkReleaseWithState deployPath repoPath Fail in 324 | runHap $ do 325 | rs <- sequence [successfulRelease, successfulRelease, failedRelease, failedRelease, failedRelease] 326 | Hap.dropOldReleases deployPath 5 True 327 | -- The two successful releases should survive 328 | forM_ (take 2 rs) $ \r -> 329 | (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` True 330 | -- The latest failed release should survive: 331 | forM_ (drop 4 rs) $ \r -> 332 | (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` True 333 | -- The two older failed releases should not survive: 334 | forM_ (take 2 . drop 2 $ rs) $ \r -> 335 | (Hap.releasePath deployPath r Nothing >>= doesDirExist) `shouldReturn` False 336 | describe "linkToShared" $ do 337 | context "when the deploy_path/shared directory doesn't exist" $ 338 | it "should create the link anyway" $ \(deployPath, repoPath) -> 339 | runHap $ do 340 | let task = mkTask deployPath repoPath 341 | sharedDir = Hap.sharedPath deployPath 342 | release <- Hap.pushRelease task 343 | rpath <- Hap.releasePath deployPath release Nothing 344 | Hap.exec (Hap.Rm sharedDir) (Just release) 345 | Hap.linkToShared currentSystem rpath deployPath "thing" (Just release) `shouldReturn` 346 | () 347 | context "when the file/directory to link exists in the repository" $ 348 | it "should throw an error" $ \(deployPath, repoPath) -> 349 | runHap 350 | (do let task = mkTask deployPath repoPath 351 | release <- Hap.pushRelease task 352 | rpath <- Hap.releasePath deployPath release Nothing 353 | Hap.linkToShared currentSystem rpath deployPath "foo.txt" $ Just release) `shouldThrow` 354 | anyException 355 | context "when it attempts to link a file" $ do 356 | context "when the file is not at the root of the shared directory" $ 357 | it "should throw an error" $ \(deployPath, repoPath) -> 358 | runHap 359 | (do let task = mkTask deployPath repoPath 360 | sharedDir = Hap.sharedPath deployPath 361 | release <- Hap.pushRelease task 362 | rpath <- Hap.releasePath deployPath release Nothing 363 | justExec sharedDir "mkdir foo/" 364 | justExec sharedDir "echo 'Bar!' > foo/bar.txt" 365 | Hap.linkToShared currentSystem rpath deployPath "foo/bar.txt" $ Just release) `shouldThrow` 366 | anyException 367 | context "when the file is at the root of the shared directory" $ 368 | it "should link the file successfully" $ \(deployPath, repoPath) -> 369 | runHap $ do 370 | let task = mkTask deployPath repoPath 371 | sharedDir = Hap.sharedPath deployPath 372 | release <- Hap.pushRelease task 373 | rpath <- Hap.releasePath deployPath release Nothing 374 | justExec sharedDir "echo 'Bar!' > bar.txt" 375 | Hap.linkToShared currentSystem rpath deployPath "bar.txt" (Just release) 376 | (liftIO . readFile . fromAbsFile) 377 | (rpath $(mkRelFile "bar.txt")) `shouldReturn` 378 | "Bar!\n" 379 | context "when it attemps to link a directory" $ do 380 | context "when the directory ends in '/'" $ 381 | it "should throw an error" $ \(deployPath, repoPath) -> 382 | runHap 383 | (do let task = mkTask deployPath repoPath 384 | sharedDir = Hap.sharedPath deployPath 385 | release <- Hap.pushRelease task 386 | rpath <- Hap.releasePath deployPath release Nothing 387 | justExec sharedDir "mkdir foo/" 388 | justExec sharedDir "echo 'Bar!' > foo/bar.txt" 389 | justExec sharedDir "echo 'Baz!' > foo/baz.txt" 390 | Hap.linkToShared currentSystem rpath deployPath "foo/" $ Just release) `shouldThrow` 391 | anyException 392 | it "should link the file successfully" $ \(deployPath, repoPath) -> 393 | runHap $ do 394 | let task = mkTask deployPath repoPath 395 | sharedDir = Hap.sharedPath deployPath 396 | release <- Hap.pushRelease task 397 | rpath <- Hap.releasePath deployPath release Nothing 398 | justExec sharedDir "mkdir foo/" 399 | justExec sharedDir "echo 'Bar!' > foo/bar.txt" 400 | justExec sharedDir "echo 'Baz!' > foo/baz.txt" 401 | Hap.linkToShared currentSystem rpath deployPath "foo" (Just release) 402 | files <- 403 | (liftIO . listDirectory . fromAbsDir) 404 | (rpath $(mkRelDir "foo")) 405 | liftIO $ files `shouldMatchList` ["baz.txt", "bar.txt"] 406 | 407 | ---------------------------------------------------------------------------- 408 | -- Helpers 409 | infix 1 `shouldBe`, `shouldReturn` 410 | 411 | -- | Lifted 'Hspec.shouldBe'. 412 | shouldBe :: (MonadIO m, Show a, Eq a) => a -> a -> m () 413 | shouldBe x y = liftIO (x `Hspec.shouldBe` y) 414 | 415 | -- | Lifted 'Hspec.shouldContain'. 416 | shouldContain :: (MonadIO m, Show a, Eq a) => [a] -> [a] -> m () 417 | shouldContain x y = liftIO (x `Hspec.shouldContain` y) 418 | 419 | -- | Lifted 'Hspec.shouldReturn'. 420 | shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m () 421 | shouldReturn m y = m >>= (`shouldBe` y) 422 | 423 | -- | The sandbox prepares the environment for an independent round of 424 | -- testing. It provides two paths: deploy path and path where git repo is 425 | -- located. 426 | withSandbox :: ActionWith (Path Abs Dir, Path Abs Dir) -> IO () 427 | withSandbox action = 428 | withSystemTempDir "hap-test" $ \dir -> do 429 | let dpath = dir $(mkRelDir "deploy") 430 | rpath = dir $(mkRelDir "repo") 431 | ensureDir dpath 432 | ensureDir rpath 433 | populateTestRepo rpath 434 | action (dpath, rpath) 435 | 436 | -- | Given path where to put the repo, generate it for testing. 437 | populateTestRepo :: Path Abs Dir -> IO () 438 | populateTestRepo path = 439 | runHap $ do 440 | justExec path "git init -b main" 441 | justExec path "git config --local --replace-all push.default simple" 442 | justExec path "git config --local --replace-all user.email hap@hap" 443 | justExec path "git config --local --replace-all user.name Hap" 444 | justExec path "echo 'Foo!' > foo.txt" 445 | justExec path "git add -A" 446 | justExec path "git commit -m 'Initial commit'" 447 | -- Add dummy content to a branch that is not main 448 | justExec path ("git checkout -b " ++ testBranchName) 449 | justExec path "echo 'Bar!' > bar.txt" 450 | justExec path "git add bar.txt" 451 | justExec path "git commit -m 'Added more bars to another branch'" 452 | justExec path "git checkout main" 453 | 454 | -- | Execute arbitrary commands in the specified directory. 455 | justExec :: Path Abs Dir -> String -> Hapistrano () 456 | justExec path cmd' = 457 | case Hap.mkGenericCommand cmd' of 458 | Nothing -> Hap.failWith 1 (Just $ "Failed to parse the command: " ++ cmd') Nothing 459 | Just cmd -> Hap.exec (Hap.Cd path cmd) Nothing 460 | 461 | -- | Run 'Hapistrano' monad locally. 462 | runHap :: Hapistrano a -> IO a 463 | runHap = runHapWithShell Bash 464 | 465 | -- | Run 'Hapistrano' monad setting a particular shell. 466 | runHapWithShell :: Shell -> Hapistrano a -> IO a 467 | runHapWithShell shell m = do 468 | let printFnc dest str = 469 | case dest of 470 | StdoutDest -> putStr str 471 | StderrDest -> hPutStr stderr str 472 | r <- Hap.runHapistrano False Nothing shell printFnc m 473 | case r of 474 | Left n -> do 475 | expectationFailure ("Failed with status code: " ++ show n) 476 | return undefined 477 | -- ↑ because expectationFailure from Hspec has wrong type :-( 478 | Right x -> return x 479 | 480 | -- | Make a 'Task' given deploy path and path to the repo. 481 | mkTask :: Path Abs Dir -> Path Abs Dir -> Task 482 | mkTask deployPath repoPath = 483 | mkTaskWithCustomRevision deployPath repoPath "main" 484 | 485 | mkTaskWithCustomRevision :: Path Abs Dir -> Path Abs Dir -> String -> Task 486 | mkTaskWithCustomRevision deployPath repoPath revision = 487 | Task 488 | { taskDeployPath = deployPath 489 | , taskSource = 490 | GitRepository 491 | { gitRepositoryURL = fromAbsDir repoPath 492 | , gitRepositoryRevision = revision 493 | } 494 | , taskReleaseFormat = ReleaseLong 495 | } 496 | 497 | -- | Creates a release tagged with 'Success' or 'Fail' 498 | 499 | mkReleaseWithState :: Path Abs Dir -> Path Abs Dir -> DeployState -> Hapistrano Release 500 | mkReleaseWithState deployPath repoPath state = do 501 | r <- Hap.pushRelease (mkTask deployPath repoPath) 502 | Hap.createHapistranoDeployState deployPath r state 503 | return r 504 | 505 | currentSystem :: TargetSystem 506 | currentSystem = 507 | if os == "linux" 508 | then GNULinux 509 | else BSD 510 | 511 | arbitraryReleaseFormat :: Gen ReleaseFormat 512 | arbitraryReleaseFormat = elements [ReleaseShort, ReleaseLong] 513 | 514 | arbitraryKeepReleases :: Gen Natural 515 | arbitraryKeepReleases = fromInteger . getPositive <$> arbitrary 516 | 517 | -------------------------------------------------------------------------------- /src/System/Hapistrano.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : System.Hapistrano 3 | -- Copyright : © 2015-Present Stack Builders 4 | -- License : MIT 5 | -- 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- A module for creating reliable deploy processes for Haskell applications. 10 | {-# LANGUAGE CPP #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE QuasiQuotes #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | {-# LANGUAGE TypeApplications #-} 17 | 18 | module System.Hapistrano 19 | ( runHapistrano 20 | , pushRelease 21 | , pushReleaseWithoutVc 22 | , activateRelease 23 | , linkToShared 24 | , createHapistranoDeployState 25 | , deploy 26 | , rollback 27 | , dropOldReleases 28 | , playScript 29 | , playScriptLocally 30 | , initConfig 31 | -- * Path helpers 32 | , releasePath 33 | , sharedPath 34 | , currentSymlinkPath 35 | , tempSymlinkPath 36 | , deployState ) 37 | where 38 | 39 | import Control.Exception (try) 40 | import Control.Monad 41 | import Control.Monad.Catch (catch, throwM) 42 | import Control.Monad.Reader (local, MonadIO, liftIO) 43 | import Data.Char (toLower) 44 | import Data.List (dropWhileEnd, genericDrop, sortOn) 45 | import Data.Maybe (fromMaybe, mapMaybe) 46 | import Data.Ord (Down (..)) 47 | import Data.Time 48 | import Data.Void (Void) 49 | import qualified Data.Yaml as Yaml 50 | import Numeric.Natural 51 | import Path 52 | import Path.IO 53 | import qualified System.Directory as Directory 54 | import System.Exit (exitFailure) 55 | import qualified System.FilePath as FilePath 56 | import System.Hapistrano.Commands 57 | import qualified System.Hapistrano.Config as HC 58 | import System.Hapistrano.Config (BuildCommand (..), CopyThing (..), 59 | ExecutionMode (..), 60 | deployStateFilename) 61 | import System.Hapistrano.Core 62 | import System.Hapistrano.Types 63 | import Text.Read (readMaybe) 64 | import Text.Megaparsec (Parsec) 65 | import qualified Text.Megaparsec as M 66 | import qualified Text.Megaparsec.Char as M 67 | 68 | ---------------------------------------------------------------------------- 69 | 70 | -- | Run the 'Hapistrano' monad. The monad hosts 'exec' actions. 71 | runHapistrano :: 72 | MonadIO m 73 | => Bool -- ^ Is running in dry run 74 | -> Maybe SshOptions -- ^ SSH options to use or 'Nothing' if we run locally 75 | -> Shell -- ^ Shell to run commands 76 | -> (OutputDest -> String -> IO ()) -- ^ How to print messages 77 | -> Hapistrano a -- ^ The computation to run 78 | -> m (Either Int a) -- ^ Status code in 'Left' on failure, result in 79 | -- 'Right' on success 80 | runHapistrano isDryRun sshOptions shell' printFnc m = 81 | liftIO $ do 82 | let config = 83 | Config 84 | { configSshOptions = sshOptions 85 | , configShellOptions = shell' 86 | , configPrint = printFnc 87 | , configDryRun = isDryRun 88 | } 89 | r <- try @HapistranoException $ unHapistrano m config 90 | case r of 91 | Left (HapistranoException (Failure n msg, _)) -> do 92 | forM_ msg (printFnc StderrDest) 93 | return (Left n) 94 | Right x -> return (Right x) 95 | 96 | -- High-level functionality 97 | 98 | -- | Perform basic setup for a project, making sure necessary directories 99 | -- exist and pushing a new release directory with the SHA1 or branch 100 | -- specified in the configuration. Return identifier of the pushed release. 101 | 102 | pushRelease :: Task -> Hapistrano Release 103 | pushRelease Task {..} = do 104 | setupDirs taskDeployPath 105 | pushReleaseForRepository taskSource 106 | where 107 | -- When the configuration is set for a local directory, it will only create 108 | -- the release directory without any version control operations. 109 | pushReleaseForRepository GitRepository {..} = do 110 | ensureCacheInPlace gitRepositoryURL taskDeployPath Nothing 111 | release <- newRelease taskReleaseFormat 112 | cloneToRelease taskDeployPath release 113 | setReleaseRevision taskDeployPath release gitRepositoryRevision 114 | return release 115 | pushReleaseForRepository LocalDirectory {} = 116 | newRelease taskReleaseFormat 117 | 118 | -- | Same as 'pushRelease' but doesn't perform any version control 119 | -- related operations. 120 | 121 | pushReleaseWithoutVc :: Task -> Hapistrano Release 122 | pushReleaseWithoutVc Task {..} = do 123 | setupDirs taskDeployPath 124 | newRelease taskReleaseFormat 125 | 126 | -- | Switch the current symlink to point to the specified release. May be 127 | -- used in deploy or rollback cases. 128 | 129 | activateRelease 130 | :: TargetSystem 131 | -> Path Abs Dir -- ^ Deploy path 132 | -> Release -- ^ Release identifier to activate 133 | -> Hapistrano () 134 | activateRelease ts deployPath release = do 135 | rpath <- releasePath deployPath release Nothing 136 | let tpath = tempSymlinkPath deployPath 137 | cpath = currentSymlinkPath deployPath 138 | exec (Ln ts rpath tpath) (Just release) -- create a symlink for the new candidate 139 | exec (Mv ts tpath cpath) (Just release) -- atomically replace the symlink 140 | 141 | -- | Creates the file @.hapistrano__state@ containing 142 | -- @fail@ or @success@ depending on how the deployment ended. 143 | 144 | createHapistranoDeployState 145 | :: Path Abs Dir -- ^ Deploy path 146 | -> Release -- ^ Release being deployed 147 | -> DeployState -- ^ Indicates how the deployment went 148 | -> Hapistrano () 149 | createHapistranoDeployState deployPath release state = do 150 | parseStatePath <- parseRelFile deployStateFilename 151 | actualReleasePath <- releasePath deployPath release Nothing 152 | let stateFilePath = actualReleasePath parseStatePath 153 | exec (Touch stateFilePath) (Just release) -- creates '.hapistrano_deploy_state' 154 | exec (BasicWrite stateFilePath $ show state) (Just release) -- writes the deploy state to '.hapistrano_deploy_state' 155 | 156 | -- | Deploys a new release 157 | deploy 158 | :: HC.Config -- ^ Deploy configuration 159 | -> ReleaseFormat -- ^ Long or Short format 160 | -> Natural -- ^ Number of releases to keep 161 | -> Bool -- ^ Whether we should keep one failed release or not 162 | -> ExecutionMode -- ^ Is running on lead target 163 | -> Hapistrano () 164 | deploy HC.Config{..} releaseFormat keepReleases keepOneFailed executionMode = do 165 | forM_ configRunLocally playScriptLocally 166 | release <- if configVcAction 167 | then pushRelease task 168 | else pushReleaseWithoutVc task 169 | rpath <- releasePath configDeployPath release configWorkingDir 170 | forM_ (toMaybePath configSource) $ \src -> 171 | scpDir src rpath (Just release) 172 | forM_ configCopyFiles $ \(CopyThing src dest) -> do 173 | srcPath <- resolveFile' src 174 | destPath <- parseRelFile dest 175 | let dpath = rpath destPath 176 | (flip exec (Just release) . MkDir . parent) dpath 177 | scpFile srcPath dpath (Just release) 178 | forM_ configCopyDirs $ \(CopyThing src dest) -> do 179 | srcPath <- resolveDir' src 180 | destPath <- parseRelDir dest 181 | let dpath = rpath destPath 182 | (flip exec (Just release) . MkDir . parent) dpath 183 | scpDir srcPath dpath (Just release) 184 | forM_ configLinkedFiles 185 | $ flip (linkToShared configTargetSystem rpath configDeployPath) (Just release) 186 | forM_ configLinkedDirs 187 | $ flip (linkToShared configTargetSystem rpath configDeployPath) (Just release) 188 | forM_ configBuildScript (playScript configDeployPath release configWorkingDir executionMode) 189 | activateRelease configTargetSystem configDeployPath release 190 | forM_ configRestartCommand (flip exec $ Just release) 191 | createHapistranoDeployState configDeployPath release Success 192 | dropOldReleases configDeployPath keepReleases keepOneFailed 193 | `catch` failStateAndThrow 194 | where 195 | failStateAndThrow e@(HapistranoException (_, maybeRelease)) = do 196 | case maybeRelease of 197 | (Just release) -> do 198 | createHapistranoDeployState configDeployPath release Fail 199 | dropOldReleases configDeployPath keepReleases keepOneFailed 200 | throwM e 201 | Nothing -> do 202 | throwM e 203 | task = 204 | Task 205 | { taskDeployPath = configDeployPath 206 | , taskSource = configSource 207 | , taskReleaseFormat = releaseFormat 208 | } 209 | 210 | -- | Activates one of already deployed releases. 211 | 212 | rollback 213 | :: TargetSystem 214 | -> Path Abs Dir -- ^ Deploy path 215 | -> Natural -- ^ How many releases back to go, 0 re-activates current 216 | -> Maybe GenericCommand -- ^ Restart command 217 | -> Hapistrano () 218 | rollback ts deployPath n mbRestartCommand = do 219 | releases <- releasesWithState Success deployPath 220 | case genericDrop n releases of 221 | [] -> failWith 1 (Just "Could not find the requested release to rollback to.") Nothing 222 | (x:_) -> do 223 | rpath <- releasePath deployPath x Nothing 224 | isRpathExist <- doesDirExist rpath 225 | if isRpathExist 226 | then activateRelease ts deployPath x 227 | else failWith 1 (Just $ "Cannot rollback to the release path '" <> show rpath <> "'.") (Just x) 228 | forM_ mbRestartCommand (`exec` Nothing) 229 | 230 | -- | Remove older releases to avoid filling up the target host filesystem. 231 | 232 | dropOldReleases 233 | :: Path Abs Dir -- ^ Deploy path 234 | -> Natural -- ^ How many releases to keep 235 | -> Bool -- ^ Whether the @--keep-one-failed@ flag is present or not 236 | -> Hapistrano () 237 | dropOldReleases deployPath n keepOneFailed = do 238 | failedReleases <- releasesWithState Fail deployPath 239 | when (keepOneFailed && length failedReleases > 1) $ 240 | -- Remove every failed release except the most recent one 241 | forM_ (tail failedReleases) $ \release -> do 242 | rpath <- releasePath deployPath release Nothing 243 | exec (Rm rpath) Nothing 244 | dreleases <- deployedReleases deployPath 245 | forM_ (genericDrop n dreleases) $ \release -> do 246 | rpath <- releasePath deployPath release Nothing 247 | exec (Rm rpath) Nothing 248 | 249 | -- | Play the given script switching to directory of given release. 250 | 251 | playScript 252 | :: Path Abs Dir -- ^ Deploy path 253 | -> Release -- ^ Release identifier 254 | -> Maybe (Path Rel Dir) -- ^ Working directory 255 | -> ExecutionMode -- ^ Execution mode 256 | -> [BuildCommand] -- ^ Commands to execute 257 | -> Hapistrano () 258 | playScript deployDir release mWorkingDir executionMode cmds = do 259 | rpath <- releasePath deployDir release mWorkingDir 260 | forM_ (filter byTarget cmds) (flip execWithInheritStdout (Just release) . Cd rpath) 261 | where 262 | byTarget BuildCommand{..} = executionMode == LeadTarget || buildCommandExecutionMode == AllTargets 263 | 264 | -- | Plays the given script on your machine locally. 265 | 266 | playScriptLocally :: [GenericCommand] -> Hapistrano () 267 | playScriptLocally cmds = 268 | local 269 | (\c -> 270 | c 271 | { configSshOptions = Nothing 272 | }) $ 273 | forM_ cmds $ flip execWithInheritStdout Nothing 274 | 275 | -- | Create a file with an initial config file by getting information from the 276 | -- user. 277 | initConfig :: IO String -> IO () 278 | initConfig getLine' = do 279 | configFilePath <- (FilePath. "hap.yml") <$> Directory.getCurrentDirectory 280 | alreadyExisting <- Directory.doesFileExist configFilePath 281 | when alreadyExisting $ do 282 | putStrLn "'hap.yml' already exists" 283 | exitFailure 284 | 285 | putStrLn "Creating 'hap.yml'" 286 | 287 | config <- generateUserConfig defaultInitTemplateConfig 288 | 289 | Yaml.encodeFile configFilePath config 290 | putStrLn $ "Configuration written at " <> configFilePath 291 | 292 | where 293 | prompt :: Show a => String -> a -> MParser a -> IO a 294 | prompt parameterName def parser = do 295 | userInput <- prompt' (parameterName <> " (default: " <> show def <> ")") 296 | if null userInput then 297 | pure def 298 | else 299 | either 300 | (\err -> putStrLn (M.errorBundlePretty err) >> prompt parameterName def parser) 301 | pure 302 | (M.parse (parser <* M.eof) "" userInput) 303 | 304 | promptYN = do 305 | userInput <- prompt "Include restart command? y/N" 'N' yNParser 306 | pure $ case toLower userInput of 307 | 'y' -> Just "echo 'Restart command'" 308 | _ -> Nothing 309 | 310 | prompt' :: String -> IO String 311 | prompt' title = putStrLn title >> getLine' 312 | 313 | generateUserConfig :: IO InitTemplateConfig -> IO InitTemplateConfig 314 | generateUserConfig initCfg = do 315 | InitTemplateConfig{..} <- initCfg 316 | InitTemplateConfig 317 | <$> prompt "repo" repo pUri 318 | <*> prompt "revision" revision stringParser 319 | <*> prompt "host" host stringParser 320 | <*> prompt "port" port numberParser 321 | <*> pure buildScript 322 | <*> promptYN 323 | 324 | type MParser = Parsec Void String 325 | 326 | oScheme :: MParser String 327 | oScheme = M.choice [M.string "://", M.string "@"] 328 | 329 | pScheme :: MParser String 330 | pScheme = M.choice 331 | [ M.string "https" 332 | , M.string "http" 333 | , M.string "ssh" 334 | , M.string "git" ] 335 | 336 | pUri :: MParser String 337 | pUri = do 338 | r <- pScheme 339 | scheme <- oScheme 340 | rest <- stringParser 341 | pure $ r <> scheme <> rest 342 | 343 | stringParser :: MParser String 344 | stringParser = M.many $ M.satisfy (const True) 345 | 346 | numberParser :: MParser Word 347 | numberParser = read <$> M.some M.digitChar 348 | 349 | yNParser :: MParser Char 350 | yNParser = M.choice 351 | [ M.char' 'y' 352 | , M.char' 'n' ] 353 | 354 | ---------------------------------------------------------------------------- 355 | -- Helpers 356 | 357 | -- | Ensure that necessary directories exist. Idempotent. 358 | 359 | setupDirs 360 | :: Path Abs Dir -- ^ Deploy path 361 | -> Hapistrano () 362 | setupDirs deployPath = do 363 | (flip exec Nothing . MkDir . releasesPath) deployPath 364 | (flip exec Nothing . MkDir . cacheRepoPath) deployPath 365 | (flip exec Nothing . MkDir . sharedPath) deployPath 366 | 367 | -- | Ensure that the specified repo is cloned and checked out on the given 368 | -- revision. Idempotent. 369 | 370 | ensureCacheInPlace 371 | :: String -- ^ Repo URL 372 | -> Path Abs Dir -- ^ Deploy path 373 | -> Maybe Release -- ^ Release that was being attempted, if it was defined 374 | -> Hapistrano () 375 | ensureCacheInPlace repo deployPath maybeRelease = do 376 | let cpath = cacheRepoPath deployPath 377 | refs = cpath $(mkRelDir "refs") 378 | exists <- (exec (Ls refs) Nothing >> return True) 379 | `catch` (\(_ :: HapistranoException) -> return False) 380 | unless exists $ 381 | exec (GitClone True (Left repo) cpath) maybeRelease 382 | exec (Cd cpath (GitSetOrigin repo)) maybeRelease 383 | exec (Cd cpath (GitFetch "origin")) maybeRelease -- TODO store this in task description? 384 | 385 | -- | Create a new release identifier based on current timestamp. 386 | 387 | newRelease :: ReleaseFormat -> Hapistrano Release 388 | newRelease releaseFormat = 389 | mkRelease releaseFormat <$> liftIO getCurrentTime 390 | 391 | -- | Clone the repository to create the specified 'Release'. 392 | 393 | cloneToRelease 394 | :: Path Abs Dir -- ^ Deploy path 395 | -> Release -- ^ 'Release' to create 396 | -> Hapistrano () 397 | cloneToRelease deployPath release = do 398 | rpath <- releasePath deployPath release Nothing 399 | let cpath = cacheRepoPath deployPath 400 | exec (GitClone False (Right cpath) rpath) (Just release) 401 | 402 | -- | Set the release to the correct revision by checking out a branch or 403 | -- a commit. 404 | 405 | setReleaseRevision 406 | :: Path Abs Dir -- ^ Deploy path 407 | -> Release -- ^ 'Release' to checkout 408 | -> String -- ^ Revision to checkout 409 | -> Hapistrano () 410 | setReleaseRevision deployPath release revision = do 411 | rpath <- releasePath deployPath release Nothing 412 | exec (Cd rpath (GitCheckout revision)) (Just release) 413 | 414 | -- | Return a list of all currently deployed releases sorted newest first. 415 | 416 | deployedReleases 417 | :: Path Abs Dir -- ^ Deploy path 418 | -> Hapistrano [Release] 419 | deployedReleases deployPath = do 420 | let rpath = releasesPath deployPath 421 | xs <- exec (Find 1 rpath :: Find Dir) Nothing 422 | ps <- stripDirs rpath (filter (/= rpath) xs) 423 | (return . sortOn Down . mapMaybe parseRelease) 424 | (dropWhileEnd (== '/') . fromRelDir <$> ps) 425 | 426 | -- | Return a list of successfully completed releases sorted newest first. 427 | 428 | releasesWithState 429 | :: DeployState -- ^ Selector for failed or successful releases 430 | -> Path Abs Dir -- ^ Deploy path 431 | -> Hapistrano [Release] 432 | releasesWithState selectedState deployPath = do 433 | releases <- deployedReleases deployPath 434 | filterM ( 435 | fmap ((\bool -> if selectedState == Success then bool else not bool) . stateToBool) 436 | . deployState deployPath Nothing 437 | ) releases 438 | where 439 | stateToBool :: DeployState -> Bool 440 | stateToBool Fail = False 441 | stateToBool _ = True 442 | 443 | ---------------------------------------------------------------------------- 444 | -- Path helpers 445 | 446 | -- | Return the full path to the directory containing all of the release 447 | -- builds. 448 | 449 | releasesPath 450 | :: Path Abs Dir -- ^ Deploy path 451 | -> Path Abs Dir 452 | releasesPath deployPath = deployPath $(mkRelDir "releases") 453 | 454 | -- | Return the full path to the directory containing the shared files/directories. 455 | 456 | sharedPath 457 | :: Path Abs Dir -- ^ Deploy path 458 | -> Path Abs Dir 459 | sharedPath deployPath = deployPath $(mkRelDir "shared") 460 | 461 | -- | Link something (file or directory) from the {deploy_path}/shared/ directory 462 | -- to a release 463 | 464 | linkToShared 465 | :: TargetSystem -- ^ System to deploy 466 | -> Path Abs Dir -- ^ Release path 467 | -> Path Abs Dir -- ^ Deploy path 468 | -> FilePath -- ^ Thing to link in share 469 | -> Maybe Release -- ^ Release that was being attempted, if it was defined 470 | -> Hapistrano () 471 | linkToShared configTargetSystem rpath configDeployPath thingToLink maybeRelease = do 472 | destPath <- parseRelFile thingToLink 473 | let dpath = rpath destPath 474 | sharedPath' = sharedPath configDeployPath destPath 475 | exec (Ln configTargetSystem sharedPath' dpath) maybeRelease 476 | 477 | -- | Construct path to a particular 'Release'. 478 | 479 | releasePath 480 | :: Path Abs Dir -- ^ Deploy path 481 | -> Release -- ^ 'Release' identifier 482 | -> Maybe (Path Rel Dir) -- ^ Working directory 483 | -> Hapistrano (Path Abs Dir) 484 | releasePath deployPath release mWorkingDir = 485 | let rendered = renderRelease release 486 | in case parseRelDir rendered of 487 | Nothing -> failWith 1 (Just $ "Could not append path: " ++ rendered) (Just release) 488 | Just rpath -> 489 | return $ case mWorkingDir of 490 | Nothing -> releasesPath deployPath rpath 491 | Just workingDir -> releasesPath deployPath rpath workingDir 492 | 493 | -- | Return the full path to the git repo used for cache purposes on the 494 | -- target host filesystem. 495 | 496 | cacheRepoPath 497 | :: Path Abs Dir -- ^ Deploy path 498 | -> Path Abs Dir 499 | cacheRepoPath deployPath = deployPath $(mkRelDir "repo") 500 | 501 | -- | Get full path to current symlink. 502 | 503 | currentSymlinkPath 504 | :: Path Abs Dir -- ^ Deploy path 505 | -> Path Abs File 506 | currentSymlinkPath deployPath = deployPath $(mkRelFile "current") 507 | 508 | -- | Get full path to temp symlink. 509 | 510 | tempSymlinkPath 511 | :: Path Abs Dir -- ^ Deploy path 512 | -> Path Abs File 513 | tempSymlinkPath deployPath = deployPath $(mkRelFile "current_tmp") 514 | 515 | -- | Checks if a release was deployed properly or not 516 | -- by looking into the @.hapistrano_deploy_state@ file. 517 | -- If the file doesn't exist or the contents are anything other than 518 | -- 'Fail' or 'Success', it returns 'Nothing'. 519 | 520 | deployState 521 | :: Path Abs Dir -- ^ Deploy path 522 | -> Maybe (Path Rel Dir) -- ^ Working directory 523 | -> Release -- ^ 'Release' identifier 524 | -> Hapistrano DeployState -- ^ Whether the release was deployed successfully or not 525 | deployState deployPath mWorkingDir release = do 526 | parseStatePath <- parseRelFile deployStateFilename 527 | actualReleasePath <- releasePath deployPath release mWorkingDir 528 | let stateFilePath = actualReleasePath parseStatePath 529 | doesExist <- exec (CheckExists stateFilePath) (Just release) 530 | if doesExist then do 531 | deployStateContents <- exec (Cat stateFilePath) (Just release) 532 | return $ (fromMaybe Unknown . readMaybe) deployStateContents 533 | else return Unknown 534 | 535 | stripDirs :: Path Abs Dir -> [Path Abs t] -> Hapistrano [Path Rel t] 536 | stripDirs path = 537 | #if MIN_VERSION_path(0,6,0) 538 | mapM (stripProperPrefix path) 539 | #else 540 | mapM (stripDir path) 541 | #endif 542 | -------------------------------------------------------------------------------- /src/System/Hapistrano/Commands.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : System.Hapistrano.Commands 3 | -- Copyright : © 2015-Present Stack Builders 4 | -- License : MIT 5 | -- 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Collection of type safe shell commands that can be fed into 10 | -- 'System.Hapistrano.Core.runCommand'. 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | 16 | module System.Hapistrano.Commands 17 | ( Command(..) 18 | , Whoami(..) 19 | , Cd(..) 20 | , MkDir(..) 21 | , Rm(..) 22 | , Mv(..) 23 | , Ln(..) 24 | , Ls(..) 25 | , Readlink(..) 26 | , Find(..) 27 | , Touch(..) 28 | , Cat(..) 29 | , CheckExists(..) 30 | , BasicWrite(..) 31 | , GitCheckout(..) 32 | , GitClone(..) 33 | , GitSetOrigin(..) 34 | , GitFetch(..) 35 | , GitReset(..) 36 | , GenericCommand 37 | , mkGenericCommand 38 | , unGenericCommand 39 | , readScript 40 | ) where 41 | 42 | import System.Hapistrano.Commands.Internal 43 | -------------------------------------------------------------------------------- /src/System/Hapistrano/Commands/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : System.Hapistrano.Commands 3 | -- Copyright : © 2015-Present Stack Builders 4 | -- License : MIT 5 | -- 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Collection of type safe shell commands that can be fed into 10 | -- 'System.Hapistrano.Core.runCommand'. 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE CPP #-} 16 | 17 | module System.Hapistrano.Commands.Internal where 18 | 19 | import Control.Monad.IO.Class 20 | import Data.Char (isSpace) 21 | #if MIN_VERSION_base(4,15,0) 22 | import Data.Kind (Type) 23 | #endif 24 | import Data.List (dropWhileEnd) 25 | import Data.Maybe (catMaybes, fromJust, mapMaybe) 26 | import Data.Proxy 27 | import Numeric.Natural 28 | import Path 29 | 30 | import System.Hapistrano.Types (TargetSystem (..)) 31 | 32 | ---------------------------------------------------------------------------- 33 | -- Commands 34 | -- | Class for data types that represent shell commands in typed way. 35 | class Command a where 36 | -- | Type of result. 37 | #if MIN_VERSION_base(4,15,0) 38 | type Result a :: Type 39 | #else 40 | type Result a :: * 41 | #endif 42 | -- | How to render the command before feeding it into shell (possibly via 43 | -- SSH). 44 | renderCommand :: a -> String 45 | -- | How to parse the result from stdout. 46 | parseResult :: Proxy a -> String -> Result a 47 | 48 | -- | Unix @whoami@. 49 | data Whoami = 50 | Whoami 51 | deriving (Show, Eq, Ord) 52 | 53 | instance Command Whoami where 54 | type Result Whoami = String 55 | renderCommand Whoami = "whoami" 56 | parseResult Proxy = trim 57 | 58 | -- | Specify directory in which to perform another command. 59 | data Cd cmd = 60 | Cd (Path Abs Dir) cmd 61 | 62 | instance Command cmd => Command (Cd cmd) where 63 | type Result (Cd cmd) = Result cmd 64 | renderCommand (Cd path cmd) = 65 | "(cd " ++ quoteCmd (fromAbsDir path) ++ " && " ++ renderCommand cmd ++ ")" 66 | parseResult Proxy = parseResult (Proxy :: Proxy cmd) 67 | 68 | -- | Create a directory. Does not fail if the directory already exists. 69 | newtype MkDir = 70 | MkDir (Path Abs Dir) 71 | 72 | instance Command MkDir where 73 | type Result MkDir = () 74 | renderCommand (MkDir path) = 75 | formatCmd "mkdir" [Just "-pv", Just (fromAbsDir path)] 76 | parseResult Proxy _ = () 77 | 78 | -- | Delete file or directory. 79 | data Rm where 80 | Rm :: Path Abs t -> Rm 81 | 82 | instance Command Rm where 83 | type Result Rm = () 84 | renderCommand (Rm path) = formatCmd "rm" [Just "-rf", Just (toFilePath path)] 85 | parseResult Proxy _ = () 86 | 87 | -- | Move or rename files or directories. 88 | data Mv t = 89 | Mv TargetSystem (Path Abs t) (Path Abs t) 90 | 91 | instance Command (Mv File) where 92 | type Result (Mv File) = () 93 | renderCommand (Mv ts old new) = 94 | formatCmd "mv" [Just flags, Just (fromAbsFile old), Just (fromAbsFile new)] 95 | where 96 | flags = 97 | if isLinux ts 98 | then "-fvT" 99 | else "-fv" 100 | parseResult Proxy _ = () 101 | 102 | instance Command (Mv Dir) where 103 | type Result (Mv Dir) = () 104 | renderCommand (Mv _ old new) = 105 | formatCmd "mv" [Just "-fv", Just (fromAbsDir old), Just (fromAbsDir new)] 106 | parseResult Proxy _ = () 107 | 108 | -- | Create symlinks. 109 | data Ln where 110 | Ln :: TargetSystem -> Path Abs t -> Path Abs File -> Ln 111 | 112 | instance Command Ln where 113 | type Result Ln = () 114 | renderCommand (Ln ts target linkName) = 115 | formatCmd 116 | "ln" 117 | [Just flags, Just (toFilePath target), Just (fromAbsFile linkName)] 118 | where 119 | flags = 120 | if isLinux ts 121 | then "-svT" 122 | else "-sv" 123 | parseResult Proxy _ = () 124 | 125 | -- | Read link. 126 | data Readlink t = 127 | Readlink TargetSystem (Path Abs File) 128 | 129 | instance Command (Readlink File) where 130 | type Result (Readlink File) = Path Abs File 131 | renderCommand (Readlink ts path) = 132 | formatCmd "readlink" [flags, Just (toFilePath path)] 133 | where 134 | flags = 135 | if isLinux ts 136 | then Just "-f" 137 | else Nothing 138 | parseResult Proxy = fromJust . parseAbsFile . trim 139 | 140 | instance Command (Readlink Dir) where 141 | type Result (Readlink Dir) = Path Abs Dir 142 | renderCommand (Readlink ts path) = 143 | formatCmd "readlink" [flags, Just (toFilePath path)] 144 | where 145 | flags = 146 | if isLinux ts 147 | then Just "-f" 148 | else Nothing 149 | parseResult Proxy = fromJust . parseAbsDir . trim 150 | 151 | -- | @ls@, so far used only to check existence of directories, so it's not 152 | -- very functional right now. 153 | newtype Ls = 154 | Ls (Path Abs Dir) 155 | 156 | instance Command Ls where 157 | type Result Ls = () 158 | renderCommand (Ls path) = formatCmd "ls" [Just (fromAbsDir path)] 159 | parseResult Proxy _ = () 160 | 161 | -- | Find (a very limited version). 162 | data Find t = 163 | Find Natural (Path Abs Dir) 164 | 165 | instance Command (Find Dir) where 166 | type Result (Find Dir) = [Path Abs Dir] 167 | renderCommand (Find maxDepth dir) = 168 | formatCmd 169 | "find" 170 | [ Just (fromAbsDir dir) 171 | , Just "-maxdepth" 172 | , Just (show maxDepth) 173 | , Just "-type" 174 | , Just "d" 175 | ] 176 | parseResult Proxy = mapMaybe (parseAbsDir . trim) . lines 177 | 178 | instance Command (Find File) where 179 | type Result (Find File) = [Path Abs File] 180 | renderCommand (Find maxDepth dir) = 181 | formatCmd 182 | "find" 183 | [ Just (fromAbsDir dir) 184 | , Just "-maxdepth" 185 | , Just (show maxDepth) 186 | , Just "-type" 187 | , Just "f" 188 | ] 189 | parseResult Proxy = mapMaybe (parseAbsFile . trim) . lines 190 | 191 | -- | @touch@. 192 | newtype Touch = 193 | Touch (Path Abs File) 194 | 195 | instance Command Touch where 196 | type Result Touch = () 197 | renderCommand (Touch path) = formatCmd "touch" [Just (fromAbsFile path)] 198 | parseResult Proxy _ = () 199 | 200 | -- | Command that checks for the existance of a particular 201 | -- file in the host. 202 | 203 | newtype CheckExists = 204 | CheckExists 205 | (Path Abs File) -- ^ The absolute path to the file you want to check for existence 206 | 207 | instance Command CheckExists where 208 | type Result CheckExists = Bool 209 | renderCommand (CheckExists path) = 210 | "([ -r " <> fromAbsFile path <> " ] && echo True) || echo False" 211 | parseResult Proxy = read 212 | 213 | -- | Command used to read the contents of a particular 214 | -- file in the host. 215 | 216 | newtype Cat = 217 | Cat 218 | (Path Abs File) -- ^ The absolute path to the file you want to read 219 | 220 | instance Command Cat where 221 | type Result Cat = String 222 | renderCommand (Cat path) = formatCmd "cat" [Just (fromAbsFile path)] 223 | parseResult Proxy = id 224 | 225 | -- | Basic command that writes to a file some contents. 226 | -- It uses the @file > contents@ shell syntax and the @contents@ is 227 | -- represented as a 'String', so it shouldn't be used for 228 | -- bigger writing operations. Currently used to write @fail@ or @success@ 229 | -- to the @.hapistrano_deploy_state@ file. 230 | data BasicWrite = 231 | BasicWrite 232 | (Path Abs File) -- ^ The absolute path to the file to which you want to write 233 | String -- ^ The contents that will be written to the file 234 | 235 | instance Command BasicWrite where 236 | type Result BasicWrite = () 237 | renderCommand (BasicWrite path contents) = 238 | "echo \"" <> contents <> "\"" <> " > " <> fromAbsFile path 239 | parseResult Proxy _ = () 240 | 241 | -- | Git checkout. 242 | newtype GitCheckout = 243 | GitCheckout String 244 | 245 | instance Command GitCheckout where 246 | type Result GitCheckout = () 247 | renderCommand (GitCheckout revision) = 248 | formatCmd "git" [Just "checkout", Just revision] 249 | parseResult Proxy _ = () 250 | 251 | -- | Git clone. 252 | data GitClone = 253 | GitClone Bool (Either String (Path Abs Dir)) (Path Abs Dir) 254 | 255 | instance Command GitClone where 256 | type Result GitClone = () 257 | renderCommand (GitClone bare src dest) = 258 | formatCmd 259 | "git" 260 | [ Just "clone" 261 | , if bare 262 | then Just "--bare" 263 | else Nothing 264 | , Just 265 | (case src of 266 | Left repoUrl -> repoUrl 267 | Right srcPath -> fromAbsDir srcPath) 268 | , Just (fromAbsDir dest) 269 | ] 270 | parseResult Proxy _ = () 271 | 272 | -- | Git fetch (simplified). 273 | newtype GitFetch = 274 | GitFetch String 275 | 276 | instance Command GitFetch where 277 | type Result GitFetch = () 278 | renderCommand (GitFetch remote) = 279 | formatCmd 280 | "git" 281 | [Just "fetch", Just remote, Just "+refs/heads/\\*:refs/heads/\\*"] 282 | parseResult Proxy _ = () 283 | 284 | -- | Git set origin 285 | newtype GitSetOrigin = 286 | GitSetOrigin String 287 | 288 | instance Command GitSetOrigin where 289 | type Result GitSetOrigin = () 290 | renderCommand (GitSetOrigin remote) = 291 | formatCmd 292 | "git" 293 | [Just "remote", Just "set-url", Just "origin", Just remote] 294 | parseResult Proxy _ = () 295 | 296 | -- | Git reset. 297 | newtype GitReset = 298 | GitReset String 299 | 300 | instance Command GitReset where 301 | type Result GitReset = () 302 | renderCommand (GitReset revision) = 303 | formatCmd "git" [Just "reset", Just revision] 304 | parseResult Proxy _ = () 305 | 306 | -- | Weakly-typed generic command, avoid using it directly. 307 | newtype GenericCommand = 308 | GenericCommand String 309 | deriving (Show, Eq, Ord) 310 | 311 | instance Command GenericCommand where 312 | type Result GenericCommand = () 313 | renderCommand (GenericCommand cmd) = cmd 314 | parseResult Proxy _ = () 315 | 316 | -- | Smart constructor that allows to create 'GenericCommand's. Just a 317 | -- little bit more safety. 318 | mkGenericCommand :: String -> Maybe GenericCommand 319 | mkGenericCommand str = 320 | if '\n' `elem` str' || null str' 321 | then Nothing 322 | else Just (GenericCommand str') 323 | where 324 | str' = trim (takeWhile (/= '#') str) 325 | 326 | -- | Get the raw command back from 'GenericCommand'. 327 | unGenericCommand :: GenericCommand -> String 328 | unGenericCommand (GenericCommand x) = x 329 | 330 | -- | Read commands from a file. 331 | readScript :: MonadIO m => Path Abs File -> m [GenericCommand] 332 | readScript path = 333 | liftIO $ mapMaybe mkGenericCommand . lines <$> readFile (fromAbsFile path) 334 | 335 | ---------------------------------------------------------------------------- 336 | -- Helpers 337 | -- | Format a command. 338 | formatCmd :: String -> [Maybe String] -> String 339 | formatCmd cmd args = unwords (quoteCmd <$> (cmd : catMaybes args)) 340 | 341 | -- | Simple-minded quoter. 342 | quoteCmd :: String -> String 343 | quoteCmd str = 344 | if any isSpace str 345 | then "\"" ++ str ++ "\"" 346 | else str 347 | 348 | -- | Trim whitespace from beginning and end. 349 | trim :: String -> String 350 | trim = dropWhileEnd isSpace . dropWhile isSpace 351 | 352 | -- | Determines whether or not the target system is a Linux machine. 353 | isLinux :: TargetSystem -> Bool 354 | isLinux = (== GNULinux) 355 | -------------------------------------------------------------------------------- /src/System/Hapistrano/Config.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : System.Config 3 | -- Copyright : © 2015-Present Stack Builders 4 | -- License : MIT 5 | -- 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Definitions for types and functions related to the configuration 10 | -- of the Hapistrano tool. 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | 17 | {-# OPTIONS_GHC -fno-warn-orphans #-} 18 | 19 | module System.Hapistrano.Config 20 | ( Config (..) 21 | , CopyThing (..) 22 | , Target (..) 23 | , BuildCommand (..) 24 | , ExecutionMode (..) 25 | , deployStateFilename) 26 | where 27 | 28 | import Control.Applicative ((<|>)) 29 | import Data.Aeson 30 | import Data.Aeson.Types (typeMismatch) 31 | import Data.Function (on) 32 | import Data.List (nubBy) 33 | import Data.Maybe (maybeToList) 34 | import Data.Proxy 35 | import Data.Yaml 36 | import Numeric.Natural 37 | import Path 38 | import System.Hapistrano.Commands 39 | import System.Hapistrano.Types (ReleaseFormat (..), Shell (..), 40 | Source (..), TargetSystem (..)) 41 | 42 | -- | Hapistrano configuration typically loaded from @hap.yaml@ file. 43 | 44 | data Config = Config 45 | { configDeployPath :: !(Path Abs Dir) 46 | -- ^ Top-level deploy directory on target machine 47 | , configHosts :: ![Target] 48 | -- ^ Hosts\/ports\/shell\/ssh args to deploy to. If empty, localhost will be assumed. 49 | , configSource :: !Source 50 | -- ^ Location of the 'Source' that contains the code to deploy 51 | , configRestartCommand :: !(Maybe GenericCommand) 52 | -- ^ The command to execute when switching to a different release 53 | -- (usually after a deploy or rollback). 54 | , configBuildScript :: !(Maybe [BuildCommand]) 55 | -- ^ Build script to execute to build the project 56 | , configCopyFiles :: ![CopyThing] 57 | -- ^ Collection of files to copy over to target machine before building 58 | , configCopyDirs :: ![CopyThing] 59 | -- ^ Collection of directories to copy over to target machine before building 60 | , configLinkedFiles :: ![FilePath] 61 | -- ^ Collection of files to link from each release to _shared_ 62 | , configLinkedDirs :: ![FilePath] 63 | -- ^ Collection of directories to link from each release to _shared_ 64 | , configVcAction :: !Bool 65 | -- ^ Perform version control related actions. By default, it's assumed to be `True`. 66 | , configRunLocally :: !(Maybe [GenericCommand]) 67 | -- ^ Perform a series of commands on the local machine before communication 68 | -- with target server starts 69 | , configTargetSystem :: !TargetSystem 70 | -- ^ Optional parameter to specify the target system. It's GNU/Linux by 71 | -- default 72 | , configReleaseFormat :: !(Maybe ReleaseFormat) 73 | -- ^ The release timestamp format, the @--release-format@ argument passed via 74 | -- the CLI takes precedence over this value. If neither CLI or configuration 75 | -- file value is specified, it defaults to short 76 | , configKeepReleases :: !(Maybe Natural) 77 | -- ^ The number of releases to keep, the @--keep-releases@ argument passed via 78 | -- the CLI takes precedence over this value. If neither CLI or configuration 79 | -- file value is specified, it defaults to 5 80 | , configKeepOneFailed :: !Bool 81 | -- ^ Specifies whether to keep all failed releases along with the successful releases 82 | -- or just the latest failed (at least this one should be kept for debugging purposes). 83 | -- The @--keep-one-failed@ argument passed via the CLI takes precedence over this value. 84 | -- If neither CLI or configuration file value is specified, it defaults to `False` 85 | -- (i.e. keep all failed releases). 86 | , configWorkingDir :: !(Maybe (Path Rel Dir)) 87 | , configMaintenanceDirectory :: !(Path Rel Dir) 88 | , configMaintenanceFileName :: !(Path Rel File) 89 | } deriving (Eq, Ord, Show) 90 | 91 | -- | Information about source and destination locations of a file\/directory 92 | -- to copy. 93 | 94 | data CopyThing = CopyThing FilePath FilePath 95 | deriving (Eq, Ord, Show) 96 | 97 | -- | Datatype that holds information about the target host. 98 | 99 | data Target = 100 | Target 101 | { targetHost :: String 102 | , targetPort :: Word 103 | , targetShell :: Shell 104 | , targetSshArgs :: [String] 105 | } deriving (Eq, Ord, Show) 106 | 107 | -- | Command and execution mode for build command. 108 | data BuildCommand = BuildCommand 109 | { buildCommandCommand :: GenericCommand 110 | , buildCommandExecutionMode :: ExecutionMode 111 | } deriving (Eq, Ord, Show) 112 | 113 | -- | The execution mode determines whether commands will be executed 114 | -- on the lead target or on all targets. 115 | data ExecutionMode = LeadTarget | AllTargets 116 | deriving (Eq, Ord, Show) 117 | 118 | instance Command BuildCommand where 119 | type Result BuildCommand = () 120 | renderCommand (BuildCommand cmd _) = renderCommand cmd 121 | parseResult Proxy _ = () 122 | 123 | instance FromJSON BuildCommand where 124 | parseJSON str@(String _) = 125 | BuildCommand <$> (parseJSON str >>= mkCmd) 126 | <*> pure AllTargets 127 | parseJSON (Object obj) = 128 | BuildCommand <$> (obj .: "command" >>= mkCmd) 129 | <*> obj .:? "only_lead" .!= AllTargets 130 | parseJSON val = typeMismatch "BuildCommand" val 131 | 132 | instance FromJSON ExecutionMode where 133 | parseJSON = withBool "ExecutionMode" $ \b -> 134 | pure $ if b then LeadTarget else AllTargets 135 | 136 | instance FromJSON Config where 137 | parseJSON = withObject "Hapistrano configuration" $ \o -> do 138 | configDeployPath <- o .: "deploy_path" 139 | let grabPort m = m .:? "port" .!= 22 140 | grabShell m = m .:? "shell" .!= Bash 141 | grabSshArgs m = m .:? "ssh_args" .!= [] 142 | host <- o .:? "host" 143 | port <- grabPort o 144 | shell <- grabShell o 145 | sshArgs <- grabSshArgs o 146 | hs <- (o .:? "targets" .!= []) >>= mapM (\m -> 147 | Target 148 | <$> m .: "host" 149 | <*> grabPort m 150 | <*> grabShell m 151 | <*> grabSshArgs m) 152 | let configHosts = nubBy ((==) `on` targetHost) 153 | (maybeToList (Target <$> host <*> pure port <*> pure shell <*> pure sshArgs) ++ hs) 154 | source m = 155 | GitRepository <$> m .: "repo" <*> m .: "revision" 156 | <|> LocalDirectory <$> m .: "local_directory" 157 | configSource <- source o 158 | configRestartCommand <- (o .:? "restart_command") >>= 159 | maybe (return Nothing) (fmap Just . mkCmd) 160 | configBuildScript <- o .:? "build_script" .!= Nothing 161 | configCopyFiles <- o .:? "copy_files" .!= [] 162 | configCopyDirs <- o .:? "copy_dirs" .!= [] 163 | configLinkedFiles <- o .:? "linked_files" .!= [] 164 | configLinkedDirs <- o .:? "linked_dirs" .!= [] 165 | configVcAction <- o .:? "vc_action" .!= True 166 | configRunLocally <- o .:? "run_locally" >>= 167 | maybe (return Nothing) (fmap Just . mapM mkCmd) 168 | configTargetSystem <- o .:? "linux" .!= GNULinux 169 | configReleaseFormat <- o .:? "release_format" 170 | configKeepReleases <- o .:? "keep_releases" 171 | configKeepOneFailed <- o .:? "keep_one_failed" .!= False 172 | configWorkingDir <- o .:? "working_directory" 173 | configMaintenanceDirectory <- o .:? "maintenance_directory" .!= $(mkRelDir "maintenance") 174 | configMaintenanceFileName <- o .:? "maintenance_filename" .!= $(mkRelFile "maintenance.html") 175 | return Config {..} 176 | 177 | instance FromJSON CopyThing where 178 | parseJSON = withObject "src and dest of a thing to copy" $ \o -> 179 | CopyThing <$> (o .: "src") <*> (o .: "dest") 180 | 181 | instance FromJSON TargetSystem where 182 | parseJSON = withBool "linux" $ 183 | pure . \case 184 | True -> GNULinux 185 | False -> BSD 186 | 187 | mkCmd :: String -> Parser GenericCommand 188 | mkCmd raw = 189 | case mkGenericCommand raw of 190 | Nothing -> fail "invalid restart command" 191 | Just cmd -> return cmd 192 | 193 | -- | Constant with the name of the file used to store 194 | -- the deployment state information. 195 | 196 | deployStateFilename :: String 197 | deployStateFilename = ".hapistrano_deploy_state" 198 | -------------------------------------------------------------------------------- /src/System/Hapistrano/Core.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : System.Hapistrano.Core 3 | -- Copyright : © 2015-Present Stack Builders 4 | -- License : MIT 5 | -- 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Core Hapistrano functions that provide basis on which all the 10 | -- functionality is built. 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | 15 | module System.Hapistrano.Core 16 | ( failWith 17 | , exec 18 | , execWithInheritStdout 19 | , scpFile 20 | , scpDir ) 21 | where 22 | 23 | import Control.Concurrent.STM (atomically) 24 | import Control.Monad 25 | import Control.Monad.Catch (throwM) 26 | import Control.Monad.Reader 27 | import Data.Proxy 28 | import Data.Time 29 | import Path 30 | import System.Console.ANSI 31 | import System.Exit 32 | import System.Hapistrano.Commands 33 | import System.Hapistrano.Types hiding (Command) 34 | import System.Process 35 | import System.Process.Typed (ProcessConfig) 36 | import qualified System.Process.Typed as SPT 37 | 38 | -- | Fail returning the following status code and message. 39 | failWith :: Int -> Maybe String -> Maybe Release -> Hapistrano a 40 | failWith n msg maybeRelease = throwM $ HapistranoException (Failure n msg, maybeRelease) 41 | 42 | -- | Run the given sequence of command. Whether to use SSH or not is 43 | -- determined from settings contained in the 'Hapistrano' monad 44 | -- configuration. Commands that return non-zero exit codes will result in 45 | -- short-cutting of execution. 46 | -- __NOTE:__ the commands executed with 'exec' will create their own pipe and 47 | -- will stream output there and once the command finishes its execution it will 48 | -- parse the result. 49 | exec :: 50 | forall a. Command a 51 | => a -- ^ Command being executed 52 | -> Maybe Release -- ^ Release that was being attempted, if it was defined 53 | -> Hapistrano (Result a) 54 | exec typedCmd maybeRelease = do 55 | let cmd = renderCommand typedCmd 56 | (prog, args) <- getProgAndArgs cmd 57 | parseResult (Proxy :: Proxy a) <$> 58 | exec' cmd (readProcessWithExitCode prog args "") maybeRelease 59 | 60 | -- | Same as 'exec' but it streams to stdout only for _GenericCommand_s 61 | execWithInheritStdout :: 62 | Command a 63 | => a -- ^ Command being executed 64 | -> Maybe Release -- ^ Release that was being attempted, if it was defined 65 | -> Hapistrano () 66 | execWithInheritStdout typedCmd maybeRelease = do 67 | let cmd = renderCommand typedCmd 68 | (prog, args) <- getProgAndArgs cmd 69 | void $ exec' cmd (readProcessWithExitCode' (SPT.proc prog args)) maybeRelease 70 | where 71 | -- | Prepares a process, reads @stdout@ and @stderr@ and returns exit code 72 | -- NOTE: @strdout@ and @stderr@ are empty string because we're writing 73 | -- the output to the parent. 74 | readProcessWithExitCode' :: 75 | ProcessConfig stdin stdoutIgnored stderrIgnored 76 | -> IO (ExitCode, String, String) 77 | readProcessWithExitCode' pc = 78 | SPT.withProcessTerm pc' $ \p -> 79 | atomically $ (,,) <$> SPT.waitExitCodeSTM p <*> return "" <*> return "" 80 | where 81 | pc' = SPT.setStdout SPT.inherit $ SPT.setStderr SPT.inherit pc 82 | 83 | -- | Get program and args to run a command locally or remotely. 84 | getProgAndArgs :: String -> Hapistrano (String, [String]) 85 | getProgAndArgs cmd = do 86 | Config {..} <- ask 87 | return $ 88 | case configSshOptions of 89 | Nothing -> (renderShell configShellOptions, ["-c", cmd]) 90 | Just SshOptions {..} -> 91 | ("ssh", sshArgs ++ [sshHost, "-p", show sshPort, cmd]) 92 | where 93 | renderShell :: Shell -> String 94 | renderShell Zsh = "zsh" 95 | renderShell Bash = "bash" 96 | 97 | 98 | -- | Copy a file from local path to target server. 99 | scpFile :: 100 | Path Abs File -- ^ Location of the file to copy 101 | -> Path Abs File -- ^ Where to put the file on target machine 102 | -> Maybe Release -- ^ Release that was being attempted, if it was defined 103 | -> Hapistrano () 104 | scpFile src dest = scp' (fromAbsFile src) (fromAbsFile dest) ["-q"] 105 | 106 | -- | Copy a local directory recursively to target server. 107 | scpDir :: 108 | Path Abs Dir -- ^ Location of the directory to copy 109 | -> Path Abs Dir -- ^ Where to put the dir on target machine 110 | -> Maybe Release -- ^ Release that was being attempted, if it was defined 111 | -> Hapistrano () 112 | scpDir src dest = scp' (fromAbsDir src) (fromAbsDir dest) ["-qr"] 113 | 114 | scp' :: FilePath -> FilePath -> [String] -> Maybe Release -> Hapistrano () 115 | scp' src dest extraArgs maybeRelease = do 116 | Config {..} <- ask 117 | let prog = "scp" 118 | portArg = 119 | case sshPort <$> configSshOptions of 120 | Nothing -> [] 121 | Just x -> ["-P", show x] 122 | hostPrefix = 123 | case sshHost <$> configSshOptions of 124 | Nothing -> "" 125 | Just x -> x ++ ":" 126 | args = extraArgs ++ portArg ++ [src, hostPrefix ++ dest] 127 | void 128 | (exec' (prog ++ " " ++ unwords args) (readProcessWithExitCode prog args "") maybeRelease) 129 | 130 | ---------------------------------------------------------------------------- 131 | -- Helpers 132 | -- | A helper for 'exec' and similar functions. 133 | exec' :: 134 | String -- ^ How to show the command in print-outs 135 | -> IO (ExitCode, String, String) -- ^ Handler to get (ExitCode, Output, Error) it can change accordingly to @stdout@ and @stderr@ of child process 136 | -> Maybe Release -- ^ Release that was being attempted, if it was defined 137 | -> Hapistrano String -- ^ Raw stdout output of that program 138 | exec' cmd readProcessOutput maybeRelease = do 139 | Config {..} <- ask 140 | if configDryRun 141 | then do 142 | liftIO $ configPrint StderrDest $ "[Dry run] " <> cmd 143 | return "" 144 | else do 145 | time <- liftIO getZonedTime 146 | let timeStampFormat = "%T, %F (%Z)" 147 | printableTime = formatTime defaultTimeLocale timeStampFormat time 148 | hostLabel = 149 | case configSshOptions of 150 | Nothing -> "localhost" 151 | Just SshOptions {..} -> sshHost ++ ":" ++ show sshPort 152 | hostInfo = colorizeString Blue $ putLine hostLabel 153 | timestampInfo = colorizeString Cyan ("[" ++ printableTime ++ "] INFO -- : $ ") 154 | cmdInfo = colorizeString Green (cmd ++ "\n") 155 | liftIO $ configPrint StdoutDest (hostInfo ++ timestampInfo ++ cmdInfo) 156 | (exitCode', stdout', stderr') <- liftIO readProcessOutput 157 | unless (null stdout') . liftIO $ configPrint StdoutDest stdout' 158 | unless (null stderr') . liftIO $ configPrint StderrDest stderr' 159 | case exitCode' of 160 | ExitSuccess -> return stdout' 161 | ExitFailure n -> failWith n Nothing maybeRelease 162 | 163 | -- | Put something “inside” a line, sort-of beautifully. 164 | putLine :: String -> String 165 | putLine str = "*** " ++ str ++ padding ++ "\n" 166 | where 167 | padding = ' ' : replicate (75 - length str) '*' 168 | 169 | colorizeString :: Color -> String -> String 170 | colorizeString color msg = 171 | setSGRCode [SetColor Foreground Vivid color] ++ msg ++ setSGRCode [Reset] 172 | -------------------------------------------------------------------------------- /src/System/Hapistrano/Maintenance.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module System.Hapistrano.Maintenance 4 | ( writeMaintenanceFile 5 | , deleteMaintenanceFile 6 | ) where 7 | 8 | import Path (Abs, Dir, File, Path, Rel, ()) 9 | import System.Hapistrano.Commands 10 | import System.Hapistrano.Core 11 | import System.Hapistrano.Types 12 | 13 | -- | It writes an HTML page in the given directory with a given name 14 | writeMaintenanceFile :: 15 | Path Abs Dir -> Path Rel Dir -> Path Rel File -> Hapistrano () 16 | writeMaintenanceFile deployPath relDir fileName = 17 | let foo = deployPath relDir 18 | fullpath = relDir fileName 19 | root = deployPath fullpath 20 | in do exec (MkDir foo) Nothing 21 | exec (Touch root) Nothing 22 | exec (BasicWrite root maintenancePageContent) Nothing 23 | 24 | -- | It deletes the file in the given directory with the given name 25 | deleteMaintenanceFile :: 26 | Path Abs Dir -> Path Rel Dir -> Path Rel File -> Hapistrano () 27 | deleteMaintenanceFile deployPath relDir fileName = 28 | let fullpath = relDir fileName 29 | root = deployPath fullpath 30 | in exec (Rm root) Nothing 31 | 32 | maintenancePageContent :: String 33 | maintenancePageContent = 34 | " \n\ 35 | \\n\ 36 | \ \n\ 37 | \ Maintenance\n\ 38 | \ \n\ 48 | \ \n\ 49 | \ \n\ 50 | \

Maintenance

\n\ 51 | \

The system is down for maintenance

\n\ 52 | \

It'll be back shortly

\n\ 53 | \ \n\ 54 | \" 55 | -------------------------------------------------------------------------------- /src/System/Hapistrano/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : System.Hapistrano.Types 3 | -- Copyright : © 2015-Present Stack Builders 4 | -- License : MIT 5 | -- 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Type definitions for the Hapistrano tool. 10 | {-# LANGUAGE DerivingVia #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | 14 | module System.Hapistrano.Types 15 | ( Hapistrano(..) 16 | , HapistranoException(..) 17 | , Failure(..) 18 | , Config(..) 19 | , Source(..) 20 | , Task(..) 21 | , ReleaseFormat(..) 22 | , SshOptions(..) 23 | , OutputDest(..) 24 | , Release 25 | , TargetSystem(..) 26 | , DeployState(..) 27 | , Shell(..) 28 | , Opts(..) 29 | , Command(..) 30 | , MaintenanceOptions(..) 31 | , InitTemplateConfig(..) 32 | -- * Types helpers 33 | , mkRelease 34 | , releaseTime 35 | , renderRelease 36 | , parseRelease 37 | , fromMaybeReleaseFormat 38 | , fromMaybeKeepReleases 39 | , toMaybePath 40 | , defaultInitTemplateConfig 41 | ) where 42 | 43 | import Control.Applicative 44 | import Control.Monad.Catch 45 | import Control.Monad.Except 46 | import Control.Monad.Reader 47 | import Data.Aeson 48 | import Data.Maybe 49 | import qualified Data.Text as T 50 | import qualified Data.Text.Lazy as TL 51 | import qualified Data.Text.Lazy.Encoding as TL 52 | import Data.Time 53 | import Numeric.Natural 54 | import Path 55 | import System.Exit (ExitCode(ExitSuccess)) 56 | import System.Process.Typed (nullStream, readProcessStdout, setStderr, shell) 57 | 58 | -- | Hapistrano monad. 59 | newtype Hapistrano a = 60 | Hapistrano { unHapistrano :: Config -> IO a } 61 | deriving 62 | ( Functor 63 | , Applicative 64 | , Monad 65 | , MonadIO 66 | , MonadThrow 67 | , MonadCatch 68 | , MonadReader Config 69 | ) via (ReaderT Config IO) 70 | 71 | -- | Hapistrano exception 72 | newtype HapistranoException = HapistranoException (Failure, Maybe Release) 73 | deriving (Show) 74 | 75 | instance Exception HapistranoException 76 | 77 | -- | Failure with status code and a message. 78 | data Failure = 79 | Failure Int (Maybe String) 80 | deriving Show 81 | 82 | -- | Hapistrano configuration options. 83 | data Config = 84 | Config 85 | { configSshOptions :: !(Maybe SshOptions) 86 | -- ^ 'Nothing' if we are running locally, or SSH options to use. 87 | , configShellOptions :: !Shell 88 | -- ^ One of the supported 'Shell's 89 | , configPrint :: !(OutputDest -> String -> IO ()) 90 | -- ^ How to print messages 91 | , configDryRun :: !Bool 92 | } 93 | 94 | -- | The source of the repository. It can be from a version control provider 95 | -- like GitHub or a local directory. 96 | data Source 97 | = GitRepository 98 | { gitRepositoryURL :: String 99 | -- ^ The URL of remote Git repository to deploy 100 | , gitRepositoryRevision :: String 101 | -- ^ The SHA1 or branch to release 102 | } 103 | | LocalDirectory 104 | { localDirectoryPath :: Path Abs Dir 105 | -- ^ The local repository to deploy 106 | } 107 | deriving (Eq, Ord, Show) 108 | 109 | -- | The records describes deployment task. 110 | data Task = 111 | Task 112 | { taskDeployPath :: Path Abs Dir 113 | -- ^ The root of the deploy target on the remote host 114 | , taskSource :: Source 115 | -- ^ The 'Source' to deploy 116 | , taskReleaseFormat :: ReleaseFormat 117 | -- ^ The 'ReleaseFormat' to use 118 | } 119 | deriving (Show, Eq, Ord) 120 | 121 | -- | Release format mode. 122 | data ReleaseFormat 123 | = ReleaseShort -- ^ Standard release path following Capistrano's format 124 | | ReleaseLong -- ^ Long release path including picoseconds 125 | deriving (Show, Read, Eq, Ord, Enum, Bounded) 126 | 127 | instance FromJSON ReleaseFormat where 128 | parseJSON = 129 | withText "release format" $ \case 130 | "short" -> return ReleaseShort 131 | "long" -> return ReleaseLong 132 | _ -> fail "expected 'short' or 'long'" 133 | 134 | -- | Current shells supported. 135 | data Shell 136 | = Bash 137 | | Zsh 138 | deriving (Show, Eq, Ord) 139 | 140 | instance FromJSON Shell where 141 | parseJSON = 142 | withText "shell" $ \case 143 | "bash" -> return Bash 144 | "zsh" -> return Zsh 145 | _ -> fail "supported shells: 'bash' or 'zsh'" 146 | 147 | -- | SSH options. 148 | data SshOptions = 149 | SshOptions 150 | { sshHost :: String -- ^ Host to use 151 | , sshPort :: Word -- ^ Port to use 152 | , sshArgs :: [String] -- ^ Arguments for ssh 153 | } 154 | deriving (Show, Read, Eq, Ord) 155 | 156 | -- | Output destination. 157 | data OutputDest 158 | = StdoutDest 159 | | StderrDest 160 | deriving (Eq, Show, Read, Ord, Bounded, Enum) 161 | 162 | -- | Release identifier. 163 | data Release = 164 | Release ReleaseFormat UTCTime 165 | deriving (Eq, Show, Ord) 166 | 167 | -- | Target's system where application will be deployed. 168 | data TargetSystem 169 | = GNULinux 170 | | BSD 171 | deriving (Eq, Show, Read, Ord, Bounded, Enum) 172 | 173 | -- | State of the deployment after running @hap deploy@. 174 | -- __note:__ the 'Unknown' value is not intended to be 175 | -- written to the @.hapistrano_deploy_state@ file; instead, 176 | -- it's intended to represent whenever Hapistrano couldn't 177 | -- get the information on the deployment state (e.g. the file is not present). 178 | data DeployState 179 | = Fail 180 | | Success 181 | | Unknown 182 | deriving (Eq, Show, Read, Ord, Bounded, Enum) 183 | 184 | -- | Maintenance options 185 | 186 | data MaintenanceOptions = Enable | Disable 187 | 188 | -- | Command line options. 189 | 190 | data Opts = Opts 191 | { optsCommand :: Command 192 | , optsConfigFile :: FilePath 193 | , optsDryRun :: Bool 194 | } 195 | 196 | -- | Command to execute and command-specific options. 197 | 198 | data Command 199 | = Deploy (Maybe ReleaseFormat) (Maybe Natural) Bool -- ^ Deploy a new release (with timestamp 200 | -- format, how many releases to keep, and whether the failed releases except the latest one 201 | -- get deleted or not) 202 | | Rollback Natural -- ^ Rollback to Nth previous release 203 | | Maintenance MaintenanceOptions 204 | | InitConfig -- ^ initialize configuration file 205 | 206 | -- | Create a 'Release' identifier. 207 | mkRelease :: ReleaseFormat -> UTCTime -> Release 208 | mkRelease = Release 209 | 210 | -- | Extract deployment time from 'Release'. 211 | releaseTime :: Release -> UTCTime 212 | releaseTime (Release _ time) = time 213 | 214 | -- | Render 'Release' identifier as a 'String'. 215 | renderRelease :: Release -> String 216 | renderRelease (Release rfmt time) = formatTime defaultTimeLocale fmt time 217 | where 218 | fmt = 219 | case rfmt of 220 | ReleaseShort -> releaseFormatShort 221 | ReleaseLong -> releaseFormatLong 222 | 223 | -- | Initial configurable fields 224 | data InitTemplateConfig = InitTemplateConfig 225 | { repo :: String 226 | , revision :: String 227 | , host :: String 228 | , port :: Word 229 | , buildScript :: [String] 230 | , restartCommand :: Maybe String 231 | } 232 | 233 | -- | Default initial template for creating hapistrano file. 234 | defaultInitTemplateConfig :: IO InitTemplateConfig 235 | defaultInitTemplateConfig = do 236 | remoteBranch <- shellWithDefault "origin/main" "git rev-parse --abbrev-ref --symbolic-full-name @{u}" 237 | let remote = T.takeWhile (/='/') remoteBranch 238 | repository <- shellWithDefault "https://github.com/user/repo.git" ("git ls-remote --get-url " <> T.unpack remote) 239 | return $ 240 | InitTemplateConfig 241 | { repo = T.unpack repository 242 | , revision = T.unpack remoteBranch 243 | , host = "root@localhost" 244 | , port = 22 245 | , buildScript = ["echo 'Build steps'"] 246 | , restartCommand = Just "echo 'Restart command'" 247 | } 248 | where 249 | shellWithDefault def cmd = do 250 | (exitCode, stdout) <- readProcessStdout $ setStderr nullStream $ shell cmd 251 | return $ case exitCode of 252 | ExitSuccess -> 253 | maybe def (T.strip . TL.toStrict) $ listToMaybe $ TL.lines $ TL.decodeUtf8 stdout 254 | _ -> def 255 | 256 | instance ToJSON InitTemplateConfig where 257 | toJSON x = 258 | object 259 | [ "repo" .= repo x 260 | , "revision" .= revision x 261 | , "host" .= host x 262 | , "port" .= port x 263 | , "buildScript" .= buildScript x 264 | , "restartCommand" .= restartCommand x 265 | ] 266 | 267 | ---------------------------------------------------------------------------- 268 | -- Types helpers 269 | 270 | -- | Parse 'Release' identifier from a 'String'. 271 | parseRelease :: String -> Maybe Release 272 | parseRelease s = 273 | (Release ReleaseLong <$> p releaseFormatLong s) <|> 274 | (Release ReleaseShort <$> p releaseFormatShort s) 275 | where 276 | p = parseTimeM False defaultTimeLocale 277 | 278 | releaseFormatShort, releaseFormatLong :: String 279 | releaseFormatShort = "%Y%m%d%H%M%S" 280 | 281 | releaseFormatLong = "%Y%m%d%H%M%S%q" 282 | 283 | -- | Get release format based on the CLI and file configuration values. 284 | fromMaybeReleaseFormat :: 285 | Maybe ReleaseFormat -> Maybe ReleaseFormat -> ReleaseFormat 286 | fromMaybeReleaseFormat cliRF configRF = 287 | fromMaybe ReleaseShort (cliRF <|> configRF) 288 | 289 | -- | Get keep releases based on the CLI and file configuration values. 290 | fromMaybeKeepReleases :: Maybe Natural -> Maybe Natural -> Natural 291 | fromMaybeKeepReleases cliKR configKR = 292 | fromMaybe defaultKeepReleases (cliKR <|> configKR) 293 | 294 | defaultKeepReleases :: Natural 295 | defaultKeepReleases = 5 296 | 297 | -- | Get the local path to copy from the 'Source' configuration value. 298 | toMaybePath :: Source -> Maybe (Path Abs Dir) 299 | toMaybePath (LocalDirectory path) = Just path 300 | toMaybePath _ = Nothing 301 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # After upgrading the resolver, make sure that the GHC version specified in the 2 | # `./nix/overlay.nix` file under the `baseHaskellPkgSet` field matches the 3 | # compiler version provided by the resolver. 4 | resolver: lts-23.15 5 | -------------------------------------------------------------------------------- /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/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | sha256: 3020db98a5e35009543057d6e6b96890d285890fc97688933e1798da92c8bbde 10 | size: 683815 11 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/15.yaml 12 | original: lts-23.15 13 | --------------------------------------------------------------------------------