├── .gitignore ├── .hindent.yaml ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── appveyor.yml ├── cache-s3.cabal ├── src └── Network │ └── AWS │ └── S3 │ ├── Cache.hs │ └── Cache │ ├── Local.hs │ ├── Remote.hs │ ├── Stack.hs │ └── Types.hs ├── stack.yaml └── tests ├── Network └── AWS │ └── S3 │ └── Cache │ └── LocalSpec.hs └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | -------------------------------------------------------------------------------- /.hindent.yaml: -------------------------------------------------------------------------------- 1 | indent-size: 2 2 | line-length: 100 3 | force-trailing-newline: true 4 | sort-imports: true 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: true 2 | 3 | # Do not choose a language; we provide our own build tools. 4 | language: generic 5 | 6 | # cache: 7 | # timeout: 1000 8 | # directories: 9 | # - $HOME/.stack 10 | # - $TRAVIS_BUILD_DIR/.stack-work 11 | 12 | matrix: 13 | include: 14 | # Build on linux 15 | - compiler: ": #stack default" 16 | addons: {apt: {packages: [libgmp-dev]}} 17 | 18 | # Build on macOS in addition to Linux 19 | # (for now MacOS is unsupported: issue with static linking) 20 | - compiler: ": #stack default osx" 21 | os: osx 22 | 23 | before_install: 24 | # Download and unpack the stack executable 25 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 26 | - mkdir -p ~/.local/bin 27 | - | 28 | if [ `uname` = "Darwin" ] 29 | then 30 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 31 | else 32 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 33 | fi 34 | if [ "$TRAVIS_PULL_REQUEST" = false ]; then 35 | if [ -n "$CACHE_S3_VERSION" ]; then 36 | travis_retry curl -f -L https://github.com/fpco/cache-s3/releases/download/$CACHE_S3_VERSION/cache-s3-$CACHE_S3_VERSION-$TRAVIS_OS_NAME-x86_64.tar.gz | tar xz -C ~/.local/bin 'cache-s3' 37 | if [ -x $(readlink -f "~/.local/bin/cache-s3") ]; then 38 | cache-s3 --prefix=$TRAVIS_REPO_SLUG \ 39 | --git-branch="$TRAVIS_BRANCH" \ 40 | --suffix="$TRAVIS_OS_NAME" \ 41 | restore stack --base-branch=master 42 | cache-s3 --prefix=$TRAVIS_REPO_SLUG \ 43 | --git-branch="$TRAVIS_BRANCH" \ 44 | --suffix="$TRAVIS_OS_NAME" \ 45 | restore stack work --base-branch=master 46 | fi 47 | fi 48 | fi 49 | 50 | install: 51 | - | 52 | set -ex 53 | stack --no-terminal setup --no-reinstall > /dev/null 54 | set +ex 55 | 56 | script: 57 | - | 58 | set -ex 59 | if [ "$TRAVIS_OS_NAME" = "linux" ]; then 60 | TIMEOUT="timeout" 61 | else 62 | TIMEOUT="gtimeout" 63 | fi 64 | ("$TIMEOUT" 1800 stack install --no-terminal --test) || ([ $? = 124 ] && echo "Timed out after 30min so the build will have to be picked up next time") 65 | set +ex 66 | 67 | after_success: 68 | - | 69 | stack --no-terminal exec -- cache-s3 --version 70 | # Do not cache PRs 71 | if [ "$TRAVIS_PULL_REQUEST" = false ]; then 72 | if [ "$TRAVIS_BRANCH" = master ]; then 73 | stack --no-terminal exec -- cache-s3 --prefix=$TRAVIS_REPO_SLUG \ 74 | --git-branch="$TRAVIS_BRANCH" \ 75 | --suffix="$TRAVIS_OS_NAME" \ 76 | save stack 77 | fi 78 | stack --no-terminal exec -- cache-s3 --prefix=$TRAVIS_REPO_SLUG \ 79 | --git-branch="$TRAVIS_BRANCH" \ 80 | --suffix="$TRAVIS_OS_NAME" \ 81 | save stack work 82 | if [ -n "$TRAVIS_TAG" ]; then 83 | travis_retry curl -L https://github.com/tfausak/github-release/releases/download/$GITHUB_RELEASE_VERSION/github-release-$TRAVIS_OS_NAME.gz | gunzip > github-release 84 | chmod a+x github-release 85 | stack exec -- cp $(which cache-s3) . 86 | tar -czf cache-s3.tar.gz cache-s3 87 | ./github-release upload --token=$GITHUB_TOKEN --repo=$TRAVIS_REPO_SLUG --file=cache-s3.tar.gz --tag=$TRAVIS_TAG --name=cache-s3-$TRAVIS_TAG-$TRAVIS_OS_NAME-x86_64.tar.gz 88 | fi 89 | fi 90 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # v0.1.10 2 | 3 | * Addition of new flag `--num-retries` 4 | * Updated Stackage LTS and had to switched back to sequential uploading, see [fpco/cache-s3#26](https://github.com/fpco/cache-s3/issues/26) for more info. 5 | 6 | # v0.1.9 7 | 8 | * Switch to `unliftio` for temporary file creation, fix cache uploading on Windows: [#23](https://github.com/fpco/cache-s3/issues/23) 9 | * Fix printing of cache creation time [#22](https://github.com/fpco/cache-s3/pull/22) 10 | 11 | # v0.1.8 12 | 13 | * Addition of `--overwrite` flag that emmits log messages whenever a file is about to be replaced 14 | upon cache restoration 15 | * Implement concurrent uploading. Addresses the upload part of [#20](https://github.com/fpco/cache-s3/issues/20) 16 | 17 | # v0.1.7 18 | 19 | * Improved command line documentation: [#15](https://github.com/fpco/cache-s3/issues/15) 20 | * Make `cache-s3` a bit more reselient to errors by not relying on `stack.yaml` format as much: [#17](https://github.com/fpco/cache-s3/issues/17) 21 | 22 | # v0.1.6 23 | 24 | * Addition ability to store relative paths with `--relative-path` argument: [#11](https://github.com/fp 25 | co/cache-s3/issues/11) 26 | 27 | # v0.1.5 28 | 29 | * Fixes [#9](https://github.com/fpco/cache-s3/issues/9) 30 | 31 | # v0.1.4 32 | 33 | * Addition of `--max-size` and `--max-age` arguments. 34 | 35 | # v0.1.3 36 | 37 | * Fixes caching of files with international names. Proper unicode handling. 38 | * Fixes `Ratio has zero denominator`, when cache size is very small. 39 | 40 | # v0.1.2 41 | 42 | * Fixes #1, #2 and #3 43 | 44 | # v0.1.1 45 | 46 | * Initial release 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Alexey Kuleshevich (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alexey Kuleshevich nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # cache-s3 2 | 3 | This tool is designed to store files, that were produced during a CI build, to an S3 bucket, so that 4 | they can be used by subsequent builds. Although this tool is tailored specifically for `stack`, it 5 | is by no means limited to Haskell or `stack` users. 6 | 7 | `cache-s3` is not simply a wrapper around a bunch of other tools, it is all written in Haskell, 8 | which comes with a great benefit of being cross platform. Executable versions for common operating 9 | systems can be downloaded from github [releases](https://github.com/fpco/cache-s3/releases) page. 10 | 11 | ## Problems it solves 12 | 13 | CI providers already have some form of caching capability in place, so natural question comes to 14 | mind is why do we even need to pay AWS for storage on S3, which we already get for free from Travis, 15 | AppVeyor, CircleCI, etc. Here are the limitations with CI providers that addressed by `cache-s3`: 16 | 17 | * __`stack` awareness__. None of the providers have support for 18 | [stack](https://docs.haskellstack.org/), which can be solved by complicated scripts that figure 19 | out which paths need caching and move the copious amounts files around so that they can be saved 20 | and restored properly. 21 | * __Cache size limit__. Some providers limit the amount of data that can be retained between builds, 22 | while S3 is limited only by the cash in your pockets. 23 | * __Cache sharing__. Most providers do not let you use cache from builds created by another branch. 24 | * __Access to cache__. For providers like Travis, that do allow reading cache created for master, it 25 | can be read even by the forked repositories during the pull requests, which has a potential of 26 | leaking sensitive data. With `cache-s3` you have full access control by the means of S3 bucket IAM 27 | policies. Despite this, I would advise not to store any private data in the cache, there are better 28 | tools for managing sensitive information out there. 29 | 30 | ### Drawback 31 | 32 | * Usage ain't free, gotta pay Amazon for S3. 33 | * Saving and restoring cache will likely be slightly slower than CI provider's native solution, 34 | since data has to move over the Internet. 35 | 36 | 37 | ## Usage 38 | 39 | There is an implicit assumption in this document that the user knows how to configure communication 40 | with AWS from the command line (credentials, roles, accounts, regions, etc.), same as with `aws-cli` 41 | for example. There are plenty of guides online how to get this setup. 42 | 43 | ### Prepare CI and S3 44 | 45 | In order for the tool to work, an S3 bucket must already be setup on AWS. I would recommend setting 46 | up a dedicated S3 bucket to be used exclusively for caching CI data, thus promoting data 47 | isolation. The bucket should also be configured to expire older files, this way cache stored for 48 | ephemeral branches will be discarded, hence avoiding unnecessary storage costs. Creating a 49 | separate user that has full access only to that bucket is also a must. Easiest way to get 50 | all of this done is with help of [terraform](https://www.terraform.io/downloads.html): 51 | 52 | Most of the boiler plate has been taking care of by the reusable terraform module 53 | [ci-cache-s3](https://github.com/fpco/terraform-aws-foundation/tree/master/modules/ci-cache-s3). Although 54 | not strictly required, I would recommend setting up a [keybase.io](https://keybase.io/) account, 55 | but having a regular PGP key will do just fine. All that is necessary is creating a `main.tf` file 56 | with this content: 57 | 58 | ```hcl 59 | module "ci-cache" { 60 | source = "github.com/fpco/fpco-terraform-aws//tf-modules/ci-cache-s3" 61 | prefix = "my-cache-" # <-- make sure to set this to a custom value. 62 | pgp_key = "keybase:user_name" # <-- or a base64 encoded PGP public key 63 | } 64 | 65 | output "bucket_name" { 66 | value = "${module.ci-cache.bucket_name}" 67 | } 68 | 69 | output "access_key" { 70 | value = "${module.ci-cache.access_key}" 71 | } 72 | 73 | output "secret_key" { 74 | value = "${module.ci-cache.secret_key}" 75 | } 76 | ``` 77 | 78 | Then simply running commands below will set up the S3 bucket and IAM user with permissions to access 79 | it for you: 80 | 81 | ``` 82 | $ terraform init 83 | $ terraform plan 84 | $ terraform apply 85 | ``` 86 | 87 | 88 | After you apply terrafom it will deploy all of the resources and print out the bucket name, 89 | `access_key` and an encrypted version of the `secret_key`. In order to get clear text version of it 90 | run: 91 | 92 | ``` 93 | terraform output secret_key | base64 --decode | keybase pgp decrypt 94 | ``` 95 | 96 | You can inspect 97 | [ci-cache-s3/variables.tf](https://github.com/fpco/terraform-aws-foundation/tree/master/modules/ci-cache-s3/variables.tf) 98 | file for a few extra variables that can be customized in the module. 99 | 100 | 101 | It is recommended to also setup a remote state for terraform, so it can be shared with all of your 102 | co-workers, but that's a totally separate discussion. 103 | 104 | _Read more on terraform if you'd like to avoid manual work in getting everything setup_: 105 | [terraform.io](https://www.terraform.io/intro/index.html)) 106 | 107 | ### Downloading the executable 108 | 109 | For every released version of `cache-s3` there will be an executable [uploaded to 110 | github](https://github.com/fpco/cache-s3/releases) for Windows, Linux and Mac OS. 111 | 112 | Linux binary is build on Ubuntu, but might work on others. In order for it to work, though, 113 | [gmp](https://gmplib.org/) might need to be installed, which can be quickly done on Ubuntu 114 | `apt-get install libgmp-dev`. 115 | 116 | Here are some examples on how to get `cache-s3` into your CI environment: 117 | 118 | * Linux and Mac 119 | 120 | ``` 121 | CACHE_S3_VERSION="v0.1.5" 122 | OS_NAME=linux # can be set by CI, eg `TRAVIS_OS_NAME` 123 | curl -f -L https://github.com/fpco/cache-s3/releases/download/$CACHE_S3_VERSION/cache-s3-$CACHE_S3_VERSION-$OS_NAME-x86_64.tar.gz | tar xz -C ~/.local/bin 'cache-s3' 124 | ``` 125 | 126 | * On Windows in PowerShell 127 | 128 | ``` 129 | $env:CACHE_S3_VERSION="v0.1.5" 130 | $env:OS_NAME="windows" 131 | [Net.ServicePointManager]::SecurityProtocol = [Net.SecurityProtocolType]::Tls12 132 | Invoke-WebRequest https://github.com/fpco/cache-s3/releases/download/$env:CACHE_S3_VERSION/cache-s3-$env:CACHE_S3_VERSION-windows-x86_64.zip -OutFile cache-s3.zip 133 | Expand-Archive cache-s3.zip -Destination . 134 | ``` 135 | 136 | ### CI Setup 137 | 138 | Every invocation of `cache-s3` requires S3 bucket name and AWS credentials to be present in the 139 | environment. Run `cache-s3 --help` to get more on that. Most common way of supplying arguments to 140 | tools on CI is through environment variables. Here is the list of variables that are understood by 141 | the tool: 142 | 143 | * `S3_BUCKET` - where to store the cache (`-b`, `--bucket` cli argument) 144 | * `AWS_ACCESS_KEY_ID` - access key 145 | * `AWS_SECRET_ACCESS_KEY` - secret key 146 | * `AWS_REGION` - region where the bucket is (`-r`, `--region` cli argument) 147 | * `GIT_DIR` - used only for inferring current git branch (`--git-dir` cli argument) 148 | * `GIT_BRANCH` - used for namespacing the cache (`--git-branch` cli argument) 149 | 150 | Stack specific ones: 151 | 152 | * `STACK_ROOT` - global stack folder (`--stack-root` cli argument) 153 | * `STACK_YAML` - path to project configuration file (`--stack-yaml` cli argument) 154 | * `STACK_WORK` - use to rename `.stack-work` directory (`--stack-work` cli argument) 155 | 156 | Further examples will assume all of the AWS related variables are set. 157 | 158 | __Important__: If the same bucket is being used for many projects, make sure to set `--prefix` 159 | argument in order to place each of them in their own namespace and avoid cache clashes. 160 | 161 | ### Saving and restoring cache 162 | 163 | At the end of the CI build supply all of the relative or absolute paths to directories and/or 164 | individual files as arguments. Directories will be traversed and cached recursively: 165 | 166 | ``` 167 | $ cache-s3 save -p ~/.npm -p ~/.cabal 168 | ``` 169 | 170 | At the beginning of the build all of the files can be restored from cache simply by running: 171 | 172 | ``` 173 | $ cache-s3 restore --base-branch=master 174 | ``` 175 | 176 | Specifying base branch will let files be restored from another branch, like `master` in example 177 | above, if current branch doesn't yet have cache of its own. 178 | 179 | Files and directories are restored to the exact same places on the files systems they were 180 | before. Attributes, permissions and modification times are preserved. Symlinks are not followed, so 181 | they are cached and restored as symlinks. _On Windows they are ignored completely!_ 182 | 183 | 184 | ### Stack 185 | 186 | For those that do not know, [stack](https://docs.haskellstack.org) is a comprehensive tool used for 187 | developing Haskell programs. In order to avoid rebuilding any of the stack projects every time, we 188 | need to cache these two location: 189 | 190 | * Global stack root directory, usually located in `~/.stack`. This is used for keeping all sorts of 191 | files that can be reused by all projects developed by a single user. 192 | * Folder with programs, such as GHC compiler, is usually nested inside the stack global directory, 193 | but can sometimes reside in a separate folder, for example on Windows. 194 | 195 | Below is the command that can be used to cache the mentioned locations, but make sure you call it 196 | from within your project directory, or at least supply `--stack-yaml` or `--resolver` for the 197 | project. This way `cache-s3` will invalidate the cache if you later decide to change Stackage 198 | resolver for your project. 199 | 200 | ``` 201 | $ cache-s3 save stack 202 | ``` 203 | 204 | Saving stack artifacts for a particular project is done in a separate step, and this is so by 205 | design. Global stack folders rarely change, namely whenever there is a change to project 206 | dependencies or a different resolver is being used. Local `.stack-work` folder(s) on the other hand 207 | do change frequently with the project under active development. Here is how to cache your project: 208 | 209 | ``` 210 | $ cache-s3 save stack work 211 | ``` 212 | 213 | This will cache your `.stack-work` directory, or all of them, if your project consists of many 214 | packages. 215 | 216 | Restoring stack cache is just as easy as regular one: 217 | 218 | ``` 219 | $ cache-s3 restore stack 220 | ``` 221 | 222 | and 223 | 224 | ``` 225 | $ cache-s3 restore stack work 226 | ``` 227 | 228 | ### Clearing 229 | 230 | In certain setups that update same cache for extensive period of times can run into a problem of 231 | long save/restore times due to constantly increasing size of cache. There are two non-mutually 232 | exclusive possible solutions to this issue: 233 | 234 | * Clear out cache that is older than specified lifespan with `--max-age` arg: 235 | 236 | ``` 237 | $ cache-s3 -c -b ci-cache-bucket --prefix test restore --max-age="5m 30s" 238 | [Info ]: - Refusing to restore, cache is too old: 2 hours, 35 minutes, 21 seconds 239 | [Info ]: - Clear cache request was successfully submitted. 240 | $ cache-s3 -c -b ci-cache-bucket --prefix test restore --max-age="5m 30s" 241 | [Info ]: - No previously stored cache was found. 242 | ``` 243 | 244 | * Prevent large cache form being either saved or restored or both with `--max-size`. Clears out 245 | cache too upon a failed restore attempt: 246 | 247 | ``` 248 | $ cache-s3 -c -b ci-cache-bucket --prefix test save -p src --max-size 10kb 249 | [Info ]: Caching: /home/lehins/fpco/cache-s3/src 250 | [Info ]: - Refusing to save, cache is too big: 13.6 KiB 251 | $ cache-s3 -c -b ci-cache-bucket --prefix test save -p src --max-size 1MiB 252 | [Info ]: Caching: /home/lehins/fpco/cache-s3/src 253 | [Info ]: - Data change detected, caching 13.6 KiB with sha256: X7Abafwff4DETyWrKP6x2RpWK6o0gh5xfpwOU4++m2A= 254 | [Info ]: Progress: 10%, speed: 57.2 KiB/s 255 | [Info ]: - Finished uploading. Files are cached on S3. 256 | $ cache-s3 -c -b ci-cache-bucket --prefix test restore --max-size 13KiB 257 | [Info ]: - Refusing to restore, cache is too big: 13.6 KiB 258 | [Info ]: - Clear cache request was successfully submitted. 259 | $ cache-s3 -c -b ci-cache-bucket --prefix test restore --max-size 13KiB 260 | [Info ]: - No previously stored cache was found. 261 | ``` 262 | 263 | If there is some other reason to remove cache for a particular build, all that is necessary is to 264 | run `cache-s3 clear`, `cache-s3 clear stack` or `cache-s3 clear stack work` with the same arguments 265 | that `cache restore` would be called with. Alternatively a file can be manually removed from an S3 266 | bucket. 267 | 268 | ## Features 269 | 270 | * Data will not be uploaded to S3 if it has not changed. By change here I don't mean only the 271 | content of files, but also attributes of files and folders, such as modification time, changes in 272 | permissions or ownership. So even `touch` of one of the files being cached will trigger an upload 273 | to S3. 274 | * Consistency of cache is verified when it's being restored. 275 | * Compression algorithm is customizable. For now on Windows only gzip is available, gzip and lz4 on 276 | others. 277 | * Default hashing algorithm SHA256 can also be overridden. 278 | * Despite that files on S3 have extension `.cache`, they are simple `.tar.gz` and can be manually 279 | inspected for content, if some CI build failure debugging is necessary. 280 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | module Main where 5 | 6 | import Control.Applicative as A 7 | import Data.Attoparsec.Text (parseOnly) 8 | import RIO.Text as T 9 | import Data.Version (Version, showVersion) 10 | import Network.AWS hiding (LogLevel) 11 | import Network.AWS.Auth 12 | import Network.AWS.Data 13 | import Network.AWS.S3.Cache 14 | import Network.AWS.S3.Types 15 | import Options.Applicative 16 | import RIO 17 | import RIO.Process 18 | import System.IO (BufferMode(LineBuffering)) 19 | import Text.Read (readMaybe) 20 | 21 | 22 | readWithMaybe :: (Text -> Maybe a) -> ReadM (Maybe a) 23 | readWithMaybe f = Just <$> maybeReader (f . T.pack) 24 | 25 | maybeAuto :: Read a => ReadM (Maybe a) 26 | maybeAuto = 27 | maybeReader $ \strVal -> 28 | case readMaybe strVal of 29 | Just val -> Just (Just val) 30 | Nothing -> Nothing 31 | 32 | readLogLevel :: ReadM LogLevel 33 | readLogLevel = 34 | maybeReader $ \case 35 | "debug" -> Just LevelDebug 36 | "info" -> Just LevelInfo 37 | "warn" -> Just LevelWarn 38 | "error" -> Just LevelError 39 | _ -> Nothing 40 | 41 | data Args = Args CommonArgs Action deriving Show 42 | 43 | readText :: ReadM T.Text 44 | readText = T.pack <$> str 45 | 46 | readRegion :: ReadM Region 47 | readRegion = do 48 | strRegion <- str 49 | either readerError return $ parseOnly parser $ T.pack strRegion 50 | 51 | 52 | helpOption :: Parser (a -> a) 53 | helpOption = abortOption ShowHelpText (long "help" <> short 'h' <> help "Display this message.") 54 | 55 | commonArgsParser :: Version -> Maybe Text -> Parser CommonArgs 56 | commonArgsParser version mS3Bucket = 57 | CommonArgs . BucketName <$> 58 | strOption 59 | (long "bucket" <> short 'b' <> metavar "S3_BUCKET" <> maybe mempty value mS3Bucket <> 60 | help 61 | "Name of the S3 bucket that will be used for caching of local files. \ 62 | \If S3_BUCKET environment variable is not set, this argument is required.") <*> 63 | option 64 | (Just <$> readRegion) 65 | (long "region" <> short 'r' <> value Nothing <> metavar "AWS_REGION" <> 66 | help 67 | "Region where S3 bucket is located. \ 68 | \By default 'us-east-1' will be used unless AWS_REGION environment variable \ 69 | \is set or defualt region is specified in ~/.aws/config") <*> 70 | option 71 | (Just <$> readText) 72 | (long "prefix" <> value Nothing <> metavar "PREFIX" <> 73 | help 74 | "Arbitrary prefix that will be used for storing objects, usually the project \ 75 | \name that this tool is being used for.") <*> 76 | option 77 | (Just <$> str) 78 | (long "git-dir" <> value Nothing <> metavar "GIT_DIR" <> 79 | help 80 | "Path to .git repository. Default is either extracted from GIT_DIR environment \ 81 | \variable or current path is traversed upwards in search for one. This argument \ 82 | \is only used for inferring --git-branch, thus it is ignored whenever a custom \ 83 | \value for above argument is specified.") <*> 84 | option 85 | (Just <$> readText) 86 | (long "git-branch" <> value Nothing <> metavar "GIT_BRANCH" <> 87 | help 88 | "Current git branch. By default will use the branch the HEAD of repository is \ 89 | \pointing to, unless GIT_BRANCH environment variables is set. This argument is \ 90 | \used for proper namespacing on S3.") <*> 91 | option 92 | (Just <$> readText) 93 | (long "suffix" <> value Nothing <> metavar "SUFFIX" <> 94 | help 95 | "Arbitrary suffix that will be used for storing objects in the S3 bucket. \ 96 | \This argument should be used to store multiple cache objects within the \ 97 | \same CI build.") <*> 98 | option 99 | readLogLevel 100 | (long "verbosity" <> metavar "LEVEL" <> short 'v' <> value LevelInfo <> 101 | help 102 | "Verbosity level (debug|info|warn|error). Default level is 'info'. \ 103 | \IMPORTANT: Level 'debug' can leak sensitive request information, thus \ 104 | \should NOT be used in production.") <*> 105 | switch 106 | (long "concise" <> short 'c' <> 107 | help "Shorten the output by removing timestamp and name of the tool.") <*> 108 | option 109 | (readWithMaybe parseBytes) 110 | (long "max-size" <> metavar "SIZE" <> value Nothing <> 111 | help 112 | "Maximum size of cache that will be acceptable for uploading/downloading to/from S3. \ 113 | \Examples: 5Gb, 750mb, etc. ") <*> 114 | option 115 | auto 116 | (long "num-retries" <> metavar "N" <> value 3 <> 117 | help 118 | "Retry a failing data transfer at most N times. (Default is 3)") <* 119 | infoOption 120 | ("cache-s3-" <> showVersion version) 121 | (long "version" <> help "Print current verison of the program.") 122 | 123 | 124 | saveArgsParser :: (Parser FilePath -> Parser [FilePath]) -> Parser SaveArgs 125 | saveArgsParser paths = 126 | SaveArgs <$> 127 | paths 128 | (option 129 | str 130 | (long "path" <> metavar "PATH" <> short 'p' <> help "All the paths that should be cached")) <*> 131 | paths 132 | (option 133 | str 134 | (long "relative-path" <> metavar "PATH" <> short 'l' <> 135 | help "All the relative paths that should be cached")) <*> 136 | option 137 | readText 138 | (long "hash" <> metavar "ALGORITHM" <> value "sha256" <> 139 | help "Hashing algorithm to use for cache validation (default is 'sha256')") <*> 140 | option 141 | (maybeReader (readCompression . T.pack)) 142 | (long "compression" <> metavar "ALGORITHM" <> value GZip <> 143 | help 144 | ("Compression algorithm to use for cache. Default 'gzip'. Supported: " <> 145 | T.unpack supportedCompression)) <*> 146 | switch 147 | (long "public" <> 148 | help 149 | "Make cache publicly readable. IMPORTANT: Make sure you know what you are \ 150 | \doing when using this flag as it will lead to cache be readable by \ 151 | \anonymous users, which will in turn also result in charges by AWS.") 152 | 153 | 154 | restoreArgsParser :: Parser RestoreArgs 155 | restoreArgsParser = 156 | RestoreArgs <$> 157 | option 158 | (Just <$> readText) 159 | (long "base-branch" <> value Nothing <> 160 | help 161 | "Base git branch. This branch will be used as a readonly fallback upon a \ 162 | \cache miss, eg. whenever it is a first build for a new branch, it is possible \ 163 | \to use cache from 'master' branch by setting --base-branch=master") <*> 164 | option 165 | (readWithMaybe parseDiffTime) 166 | (long "max-age" <> value Nothing <> 167 | help 168 | "Amount of time cache will be valid for from the moment it was initially uploaded to S3, \ 169 | \i.e. updating cache doesn't reset the time counter. Accepts common variations of \ 170 | \(year|day|hour|min|sec), \ 171 | \, eg. --max-age='30 days 1 hour' or --max-age='1h 45m'") <*> 172 | (FileOverwrite <$> 173 | option 174 | readLogLevel 175 | (long "overwrite" <> metavar "OVERWRITE" <> value LevelDebug <> 176 | help 177 | "Which log level to emmit when overwriting an existing file (debug|info|warn|error). \ 178 | \If set to 'error', restoring will be terminated whenever an existing file is detected. \ 179 | \Default is 'debug'.")) 180 | 181 | 182 | stackRootArg :: Parser (Maybe FilePath) 183 | stackRootArg = 184 | option 185 | (Just <$> str) 186 | (long "stack-root" <> value Nothing <> metavar "STACK_ROOT" <> 187 | help "Global stack directory. Default is taken from stack, i.e a value of \ 188 | \STACK_ROOT environment variable or a system dependent path: eg. \ 189 | \~/.stack/ on Linux, C:\\sr on Windows") 190 | 191 | 192 | stackProjectParser :: Parser StackProject 193 | stackProjectParser = 194 | StackProject <$> 195 | option 196 | (Just <$> str) 197 | (long "stack-yaml" <> value Nothing <> metavar "STACK_YAML" <> 198 | help 199 | "Path to stack configuration file. Default is taken from stack: i.e. \ 200 | \STACK_YAML environment variable or ./stack.yaml") <*> 201 | option 202 | (Just <$> readText) 203 | (long "resolver" <> value Nothing <> metavar "RESOLVER" <> 204 | help 205 | "Use a separate namespace for each stack resolver. Default value is \ 206 | \inferred from stack.yaml") 207 | 208 | 209 | saveStackArgsParser :: Parser SaveStackArgs 210 | saveStackArgsParser = 211 | SaveStackArgs <$> saveArgsParser many <*> stackRootArg <*> stackProjectParser 212 | 213 | 214 | saveStackWorkArgsParser :: Parser SaveStackWorkArgs 215 | saveStackWorkArgsParser = 216 | subparser $ 217 | metavar "work" <> 218 | command 219 | "work" 220 | (info 221 | (SaveStackWorkArgs <$> saveStackArgsParser <*> 222 | option 223 | (Just <$> str) 224 | (long "work-dir" <> value Nothing <> metavar "STACK_WORK" <> 225 | help 226 | "Relative stack work directory. Default is taken from stack, i.e. \ 227 | \STACK_WORK environment variable or ./.stack-work/") <* 228 | helpOption) 229 | (progDesc 230 | "Command for caching content of .stack-work directory in the S3 bucket. \ 231 | \For projects with many packages, all of the .stack-work directories will \ 232 | \be saved." <> 233 | fullDesc)) 234 | 235 | 236 | actionParser :: Parser Action 237 | actionParser = 238 | subparser 239 | (metavar "save" <> 240 | command 241 | "save" 242 | (info 243 | (Save <$> saveArgsParser many <* helpOption <|> saveStackCommandParser) 244 | (progDesc "Command for caching the data in the S3 bucket." <> fullDesc))) <|> 245 | subparser 246 | (metavar "restore" <> 247 | command 248 | "restore" 249 | (info 250 | (restoreStackCommandParser <|> Restore <$> restoreArgsParser <* helpOption) 251 | (progDesc "Command for restoring cache from S3 bucket." <> fullDesc))) <|> 252 | clearParser 253 | (pure Clear) 254 | "clear" 255 | "Clears out cache from S3 bucket. This command uses the same arguments as \ 256 | \`cache-s3 save` to uniquely identify the object on S3, therefore same arguments and \ 257 | \subcommands must be suppied in order to clear out the cache created with \ 258 | \`save` command." 259 | (clearParser 260 | (ClearStack <$> stackProjectParser) 261 | "stack" 262 | "Clear stack cache" 263 | (clearParser 264 | (ClearStackWork <$> stackProjectParser) 265 | "work" 266 | "Clear stack project work cache" 267 | A.empty)) 268 | where 269 | clearParser argsParser com desc altPreParse = 270 | subparser $ 271 | metavar com <> 272 | command com (info (altPreParse <|> argsParser <* helpOption) (progDesc desc <> fullDesc)) 273 | saveStackParser = SaveStack <$> saveStackArgsParser <* helpOption 274 | saveStackCommandParser = 275 | subparser $ 276 | metavar "stack" <> 277 | command 278 | "stack" 279 | (info 280 | (SaveStackWork <$> saveStackWorkArgsParser <|> saveStackParser) 281 | (progDesc 282 | "Command for caching global stack data in the S3 bucket. This will \ 283 | \include stack root directory and a couple of others that are used \ 284 | \by stack for storing executables. In order to save local .stack-work \ 285 | \directory(ies), use `cache-s3 save stack work` instead." <> 286 | fullDesc)) 287 | restoreStackArgsParser = 288 | RestoreStackArgs <$> restoreArgsParser <*> stackRootArg <*> stackProjectParser 289 | restoreStackCommandParser = 290 | subparser $ 291 | metavar "stack" <> 292 | command 293 | "stack" 294 | (info 295 | (restoreStackWorkParser <|> RestoreStack <$> restoreStackArgsParser <* helpOption) 296 | (progDesc "Command for restoring stack data from the S3 bucket." <> fullDesc)) 297 | restoreStackWorkParser = 298 | subparser $ 299 | metavar "work" <> 300 | command 301 | "work" 302 | (info 303 | (RestoreStackWork <$> restoreStackArgsParser <* helpOption) 304 | (progDesc "Command for restoring .stack-work directory(ies) from the S3 bucket." <> 305 | fullDesc)) 306 | 307 | 308 | main :: IO () 309 | main = do 310 | context <- mkDefaultProcessContext 311 | s3Bucket <- runRIO context $ lookupEnv "S3_BUCKET" 312 | cFile <- credFile 313 | Args commonArgs acts <- 314 | execParser $ 315 | info 316 | (Args <$> commonArgsParser cacheS3Version s3Bucket <*> actionParser <* 317 | abortOption ShowHelpText (long "help" <> short 'h' <> help "Display this message.")) 318 | (header "cache-s3 - Use an AWS S3 bucket for caching your build environment" <> 319 | progDesc 320 | ("Save local directories to S3 bucket and restore them later to their original \ 321 | \locations. AWS credentials will be extracted form the environment in a similar \ 322 | \way that aws-cli does it: you can either place them in " <> 323 | cFile <> 324 | " or set them as environment variables " <> 325 | T.unpack envAccessKey <> 326 | " and " <> 327 | T.unpack envSecretKey) <> 328 | fullDesc) 329 | hSetBuffering stdout LineBuffering 330 | let logFunc = mkCacheS3LogFunc stdout (commonConcise commonArgs) (commonVerbosity commonArgs) 331 | runRIO (App logFunc context) $ runCacheS3 commonArgs acts 332 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | version: 1.0.{build} 2 | image: Visual Studio 2015 3 | 4 | build: off 5 | 6 | environment: 7 | global: 8 | # Avoid long paths on Windows 9 | STACK_ROOT: 'c:\s' 10 | STACK_WORK: '.w' 11 | WORK_DIR: 'c:\w' 12 | 13 | before_test: 14 | # Avoid long paths not to reach MAX_PATH of 260 chars 15 | - xcopy /q /s /e /r /k /i /v /h /y "%APPVEYOR_BUILD_FOLDER%" "%WORK_DIR%" 16 | - cd "%WORK_DIR%" 17 | 18 | # Install stack 19 | - mkdir %APPDATA%\local\bin\ 20 | - set PATH=%PATH%;%APPDATA%\local\bin 21 | - curl -sSkL http://www.stackage.org/stack/windows-x86_64 -o stack.zip 22 | - 7z x stack.zip stack.exe 23 | - cp stack.exe %APPDATA%\local\bin\stack.exe 24 | 25 | - ps: >- 26 | if ( -not $env:APPVEYOR_PULL_REQUEST_NUMBER ) { 27 | if (-not ("$env:CACHE_S3_VERSION" -eq "" )) { 28 | [Net.ServicePointManager]::SecurityProtocol = [Net.SecurityProtocolType]::Tls12 29 | Invoke-WebRequest https://github.com/fpco/cache-s3/releases/download/$env:CACHE_S3_VERSION/cache-s3-$env:CACHE_S3_VERSION-windows-x86_64.zip -OutFile cache-s3.zip 30 | Expand-Archive cache-s3.zip -Destination . 31 | .\cache-s3 --prefix=$env:APPVEYOR_REPO_NAME --git-branch=$env:APPVEYOR_REPO_BRANCH --suffix=windows restore stack --base-branch=master 32 | .\cache-s3 --prefix=$env:APPVEYOR_REPO_NAME --git-branch=$env:APPVEYOR_REPO_BRANCH --suffix=windows restore stack work --base-branch=master 33 | rm cache-s3.exe 34 | } 35 | } 36 | 37 | 38 | test_script: 39 | - cd "%WORK_DIR%" 40 | - stack --no-terminal setup --no-reinstall > nul 41 | - stack install -j 2 --no-terminal --test 42 | 43 | 44 | after_test: 45 | - ps: >- 46 | cache-s3 --version 47 | - ps: >- 48 | if ( -not $env:APPVEYOR_PULL_REQUEST_NUMBER ) { 49 | if ( $env:APPVEYOR_REPO_BRANCH -eq "master" ) { 50 | cache-s3 --prefix=$env:APPVEYOR_REPO_NAME --git-branch=$env:APPVEYOR_REPO_BRANCH --suffix=windows save stack 51 | } 52 | cache-s3 --prefix=$env:APPVEYOR_REPO_NAME --git-branch=$env:APPVEYOR_REPO_BRANCH --suffix=windows save stack work 53 | } 54 | # Upload an executable to the release for every git tag 55 | - ps: >- 56 | if ($env:APPVEYOR_REPO_TAG_NAME) { 57 | Start-FileDownload https://github.com/tfausak/github-release/releases/download/$env:GITHUB_RELEASE_VERSION/github-release-windows.zip -FileName github-release.zip 58 | 7z x github-release.zip github-release.exe 59 | cp $env:APPDATA\local\bin\cache-s3.exe cache-s3.exe 60 | 7z a cache-s3.zip cache-s3.exe 61 | .\github-release upload --token=$env:GITHUB_TOKEN --repo=$env:APPVEYOR_REPO_NAME --file=cache-s3.zip --tag=$env:APPVEYOR_REPO_TAG_NAME --name=cache-s3-$env:APPVEYOR_REPO_TAG_NAME-windows-x86_64.zip 62 | } 63 | 64 | # on_finish: 65 | # - ps: $blockRdp = $true; iex ((new-object net.webclient).DownloadString('https://raw.githubusercontent.com/appveyor/ci/master/scripts/enable-rdp.ps1')) 66 | 67 | notifications: 68 | - provider: Email 69 | to: 70 | - alexey@fpcomplete.com 71 | on_build_success: false 72 | on_build_failure: false 73 | on_build_status_changed: true 74 | -------------------------------------------------------------------------------- /cache-s3.cabal: -------------------------------------------------------------------------------- 1 | name: cache-s3 2 | version: 0.1.10 3 | synopsis: Use an AWS S3 bucket for caching your stack build environment. 4 | description: Save local directories to S3 bucket and restore them later to their 5 | original locations. Designed for stack usage during CI, but can be 6 | used with other tools and for other purposes. 7 | homepage: https://github.com/fpco/cache-s3#readme 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Alexey Kuleshevich 11 | maintainer: alexey@fpcomplete.com 12 | copyright: FP Complete 13 | category: AWS 14 | build-type: Simple 15 | extra-source-files: README.md 16 | cabal-version: >=1.10 17 | 18 | library 19 | hs-source-dirs: src 20 | exposed-modules: Network.AWS.S3.Cache 21 | , Network.AWS.S3.Cache.Local 22 | other-modules: Network.AWS.S3.Cache.Remote 23 | , Network.AWS.S3.Cache.Stack 24 | , Network.AWS.S3.Cache.Types 25 | Paths_cache_s3 26 | build-depends: aeson 27 | , amazonka 28 | , amazonka-core 29 | , amazonka-s3 30 | , amazonka-s3-streaming 31 | , attoparsec 32 | , base >= 4.7 && < 5 33 | , base64-bytestring 34 | , bytestring 35 | , conduit >= 1.2.8 36 | , conduit-extra 37 | , cryptonite 38 | , cryptonite-conduit 39 | , git 40 | , http-client 41 | , http-types 42 | , lens 43 | , memory 44 | , mtl 45 | , resourcet 46 | , rio 47 | , rio-orphans 48 | , tar-conduit >= 0.2.0 49 | , text 50 | , transformers >= 0.5.2.0 51 | , unliftio 52 | , yaml 53 | default-language: Haskell2010 54 | ghc-options: -Wall 55 | if os(windows) 56 | cpp-options: -DWINDOWS 57 | else 58 | build-depends: lz4-conduit 59 | 60 | 61 | executable cache-s3 62 | hs-source-dirs: app 63 | main-is: Main.hs 64 | ghc-options: -Wall -O2 -threaded 65 | build-depends: amazonka 66 | , amazonka-s3 67 | , attoparsec 68 | , base 69 | , cache-s3 70 | , optparse-applicative 71 | , rio 72 | default-language: Haskell2010 73 | 74 | test-suite tests 75 | type: exitcode-stdio-1.0 76 | hs-source-dirs: tests 77 | main-is: Spec.hs 78 | other-modules: Network.AWS.S3.Cache.LocalSpec 79 | build-depends: base >= 4.7 && < 5 80 | , cache-s3 81 | , hspec 82 | , filepath 83 | , QuickCheck 84 | 85 | default-language: Haskell2010 86 | ghc-options: -Wall -threaded 87 | 88 | 89 | source-repository head 90 | type: git 91 | location: https://github.com/fpco/cache-s3 92 | -------------------------------------------------------------------------------- /src/Network/AWS/S3/Cache.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | -- | 7 | -- Module : Network.AWS.S3.Cache 8 | -- Copyright : (c) FP Complete 2017 9 | -- License : BSD3 10 | -- Maintainer : Alexey Kuleshevich 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | module Network.AWS.S3.Cache 15 | ( runCacheS3 16 | , cacheS3Version 17 | , mkCacheS3LogFunc 18 | , module Network.AWS.S3.Cache.Types 19 | ) where 20 | 21 | import Control.Lens 22 | import Control.Monad.Reader 23 | import Control.Monad.Trans.AWS hiding (LogLevel) 24 | import RIO.Text as T 25 | import Data.Version (Version) 26 | import Data.ByteString.Builder.Extra (flush) 27 | import Network.AWS.S3.Cache.Local 28 | import Network.AWS.S3.Cache.Remote 29 | import Network.AWS.S3.Cache.Stack 30 | import Network.AWS.S3.Cache.Types 31 | import qualified Paths_cache_s3 as Paths 32 | import Prelude as P 33 | import RIO hiding ((^.)) 34 | import RIO.Time 35 | 36 | 37 | showLogLevel :: RIO.LogLevel -> Utf8Builder 38 | showLogLevel level = 39 | case level of 40 | LevelDebug -> "Debug" 41 | LevelInfo -> "Info " 42 | LevelWarn -> "Warn " 43 | LevelError -> "Error" 44 | LevelOther o -> "Other " <> display o 45 | 46 | mkCacheS3LogFunc :: 47 | Handle 48 | -> Bool -- ^ Should logger be concise (ommit timestamp and app name) 49 | -> LogLevel -- ^ Minimum log level 50 | -> LogFunc 51 | mkCacheS3LogFunc handle' con minLevel = 52 | mkLogFunc $ \_callstack _logSource logLevel msg -> 53 | when (logLevel >= minLevel) $ do 54 | let levelStr = "[" <> showLogLevel logLevel <> "]" 55 | entryPrefix <- 56 | if con 57 | then return $ levelStr <> ": " 58 | else do 59 | now <- getCurrentTime 60 | return $ "[cache-s3]" <> levelStr <> "[" <> formatRFC822 now <> "]: " 61 | hPutBuilder handle' $ getUtf8Builder (entryPrefix <> msg <> "\n") <> flush 62 | when (logLevel == LevelError) $ exitWith (ExitFailure 1) 63 | 64 | 65 | saveCache :: Bool -> Text -> Compression -> [FilePath] -> [FilePath] -> RIO Config () 66 | saveCache isPublic hAlgTxt comp dirs relativeDirs = 67 | let hashNoSupport sup = 68 | logError $ 69 | "Hash algorithm '" <> display hAlgTxt <> "' is not supported, use one of these instead: " <> 70 | display (T.intercalate ", " sup) 71 | in withHashAlgorithm_ hAlgTxt hashNoSupport $ \hAlg -> 72 | withSystemTempFile (makeTempFileNamePattern comp) $ \fp hdl -> 73 | let tmpFile = TempFile fp hdl comp 74 | in do sizeAndHash <- writeCacheTempFile dirs relativeDirs hAlg tmpFile 75 | uploadCache isPublic tmpFile sizeAndHash 76 | 77 | 78 | 79 | withConfig :: CommonArgs -> (Config -> RIO App a) -> RIO App a 80 | withConfig CommonArgs {..} innerAction = do 81 | envInit <- liftIO $ newEnv Discover 82 | let env = maybe envInit (\reg -> envInit & envRegion .~ reg) commonRegion 83 | mGitBranch <- maybe (getBranchName commonGitDir) (return . Just) commonGitBranch 84 | let objKey = mkObjectKey commonPrefix mGitBranch commonSuffix 85 | app <- ask 86 | innerAction $ 87 | Config 88 | commonBucket 89 | objKey 90 | env 91 | commonVerbosity 92 | commonConcise 93 | Nothing 94 | commonMaxBytes 95 | commonNumRetries 96 | app 97 | 98 | 99 | runCacheS3 :: CommonArgs -> Action -> RIO App () 100 | runCacheS3 ca@CommonArgs {..} action = do 101 | let caAddSuffix suf = ca {commonSuffix = ((<> ".") <$> commonSuffix) <> Just suf} 102 | caStackSuffix res = caAddSuffix (res <> ".stack") 103 | caStackWorkSuffix res = caAddSuffix (res <> ".stack-work") 104 | case action of 105 | Save SaveArgs {..} -> 106 | withConfig ca $ \config -> 107 | runRIO config $ saveCache savePublic saveHash saveCompression savePaths saveRelativePaths 108 | SaveStack SaveStackArgs {..} -> do 109 | stackGlobalPaths <- getStackGlobalPaths saveStackRoot 110 | resolver <- getStackResolver saveStackProject 111 | runCacheS3 (caStackSuffix resolver) $ 112 | Save saveStackArgs {savePaths = savePaths saveStackArgs ++ stackGlobalPaths} 113 | SaveStackWork SaveStackWorkArgs {..} -> do 114 | let SaveStackArgs {..} = saveStackWorkArgs 115 | StackProject {..} = saveStackProject 116 | stackLocalPaths <- getStackWorkPaths saveStackRoot stackYaml saveStackWorkDir 117 | resolver <- getStackResolver saveStackProject 118 | runCacheS3 (caStackWorkSuffix resolver) $ 119 | Save saveStackArgs {savePaths = savePaths saveStackArgs ++ stackLocalPaths} 120 | Restore RestoreArgs {..} -> 121 | withConfig ca $ \config -> do 122 | restoreSuccessfull <- 123 | runRIO (config & maxAge .~ restoreMaxAge) $ restoreCache restoreOverwrite 124 | case (restoreSuccessfull, restoreBaseBranch) of 125 | (False, Just _) 126 | | restoreBaseBranch /= commonGitBranch -> do 127 | app <- ask 128 | let baseObjKey = mkObjectKey commonPrefix restoreBaseBranch commonSuffix 129 | config' = 130 | Config 131 | commonBucket 132 | baseObjKey 133 | (config ^. environment) 134 | commonVerbosity 135 | commonConcise 136 | restoreMaxAge 137 | commonMaxBytes 138 | commonNumRetries 139 | app 140 | void $ runRIO config' $ restoreCache restoreOverwrite 141 | _ -> return () 142 | RestoreStack RestoreStackArgs {..} -> do 143 | resolver <- getStackResolver restoreStackProject 144 | runCacheS3 (caStackSuffix resolver) (Restore restoreStackArgs) 145 | RestoreStackWork RestoreStackArgs {..} -> do 146 | resolver <- getStackResolver restoreStackProject 147 | runCacheS3 (caStackWorkSuffix resolver) (Restore restoreStackArgs) 148 | Clear -> withConfig ca (`runRIO` deleteCache) 149 | ClearStack proj -> do 150 | resolver <- getStackResolver proj 151 | withConfig (caStackSuffix resolver) (`runRIO` deleteCache) 152 | ClearStackWork proj -> do 153 | resolver <- getStackResolver proj 154 | withConfig (caStackWorkSuffix resolver) (`runRIO` deleteCache) 155 | 156 | cacheS3Version :: Version 157 | cacheS3Version = Paths.version 158 | -------------------------------------------------------------------------------- /src/Network/AWS/S3/Cache/Local.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | -- | 8 | -- Module : Network.AWS.S3.Cache.Local 9 | -- Copyright : (c) FP Complete 2017 10 | -- License : BSD3 11 | -- Maintainer : Alexey Kuleshevich 12 | -- Stability : experimental 13 | -- Portability : non-portable 14 | -- 15 | 16 | module Network.AWS.S3.Cache.Local where 17 | 18 | import Control.Monad.Trans.Resource (ResourceT, MonadResource) 19 | import Crypto.Hash (Digest, HashAlgorithm) 20 | import Crypto.Hash.Conduit 21 | import Data.Conduit 22 | import Data.Conduit.Binary 23 | import Data.Conduit.List as C 24 | import Data.Conduit.Tar 25 | import RIO.List as L 26 | import Network.AWS.S3.Cache.Types 27 | import RIO 28 | import RIO.Directory 29 | import RIO.FilePath 30 | import System.IO (SeekMode(AbsoluteSeek)) 31 | 32 | 33 | tarFiles :: 34 | (HasLogFunc env) 35 | => [FilePath] 36 | -> [FilePath] 37 | -> ConduitM a ByteString (ResourceT (RIO env)) () 38 | tarFiles dirs relativeDirs = do 39 | logDebug "Preparing files for saving in the cache." 40 | dirsCanonical <- RIO.mapM canonicalizePath dirs 41 | uniqueDirs <- 42 | RIO.catMaybes <$> RIO.mapM skipMissing (removeSubpaths dirsCanonical ++ relativeDirs) 43 | if L.null uniqueDirs 44 | then logError "No paths to cache has been specified." 45 | else sourceList uniqueDirs .| filePathConduit .| void tar 46 | where 47 | skipMissing fp = do 48 | exist <- doesPathExist fp 49 | if exist 50 | then Just fp <$ logInfo ("Caching: " <> fromString fp) 51 | else Nothing <$ logWarn ("File path is skipped since it is missing: " <> fromString fp) 52 | 53 | 54 | -- | Will remove any subfolders or files. Imput is expected to be a list of canonicalized file 55 | -- paths. 56 | removeSubpaths :: [FilePath] -> [FilePath] 57 | removeSubpaths dirsCanonical = 58 | L.map joinPath $ removePrefixSorted $ L.sort $ L.map splitDirectories dirsCanonical 59 | where 60 | removePrefixSorted :: [[FilePath]] -> [[FilePath]] 61 | removePrefixSorted [] = [] 62 | removePrefixSorted (x:xs) = x : L.filter (not . (x `isPathPrefixOf`)) xs 63 | isPathPrefixOf :: [FilePath] -> [FilePath] -> Bool 64 | isPathPrefixOf [] _ = True 65 | isPathPrefixOf _ [] = False 66 | isPathPrefixOf (x:xs) (y:ys) = equalFilePath x y && isPathPrefixOf xs ys 67 | 68 | 69 | prepareCache :: 70 | (HashAlgorithm h, MonadResource m, PrimMonad m, MonadThrow m) 71 | => TempFile -> ConduitM ByteString Void m (Word64, Digest h) 72 | prepareCache TempFile {tempFileHandle, tempFileCompression} = do 73 | hash <- 74 | getZipSink 75 | (ZipSink (getCompressionConduit tempFileCompression .| sinkHandle tempFileHandle) *> 76 | ZipSink sinkHash) 77 | cSize <- 78 | liftIO $ do 79 | hFlush tempFileHandle 80 | cSize <- hTell tempFileHandle 81 | hSeek tempFileHandle AbsoluteSeek 0 82 | return cSize 83 | return (fromInteger cSize, hash) 84 | 85 | 86 | -- | Create a compressed tarball and write it into a handle. Compute the hash value of the tarball 87 | -- prior to the compression, in order to avoid any possible nondeterminism with future compression 88 | -- algorithms. Returns the computed hash. File handle is set to the beginning of the file so the 89 | -- tarball can be read from. 90 | writeCacheTempFile :: 91 | (HasLogFunc env, HashAlgorithm h) 92 | => 93 | [FilePath] 94 | -> [FilePath] 95 | -> h 96 | -> TempFile 97 | -> RIO env (Word64, Digest h) 98 | writeCacheTempFile dirs relativeDirs _ tmpFile = 99 | runConduitRes $ tarFiles dirs relativeDirs .| prepareCache tmpFile 100 | 101 | 102 | -- | Restores all of the files from the tarball and computes the hash at the same time. 103 | restoreFilesFromCache :: 104 | (HasLogFunc env, HashAlgorithm h, MonadReader env m, PrimMonad m, MonadThrow m, MonadIO m) 105 | => FileOverwrite 106 | -> Compression -- ^ Compression algorithm the stream is expected to be compressed with. 107 | -> h -- ^ Hashing algorithm to use for computation of hash value of the extracted tarball. 108 | -> ConduitM ByteString Void (ResourceT m) (Digest h) 109 | restoreFilesFromCache (FileOverwrite level) comp _ = 110 | getDeCompressionConduit comp .| 111 | getZipConduit (ZipConduit (untarWithFinalizers restoreFile') *> ZipConduit sinkHash) 112 | where 113 | restoreFile' fi = do 114 | case fileType fi of 115 | FTDirectory -- Make sure nested folders are created: 116 | -> createDirectoryIfMissing True (decodeFilePath (filePath fi)) 117 | FTNormal -> do 118 | let fp = getFileInfoPath fi 119 | fileExist <- doesFileExist fp 120 | when fileExist $ do 121 | when (level == LevelError) $ 122 | throwString $ "File with name already exists: " ++ fp 123 | logGeneric "" level $ "Restoring an existing file: " <> fromString fp 124 | _ -> return () 125 | restoreFile fi 126 | -------------------------------------------------------------------------------- /src/Network/AWS/S3/Cache/Remote.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE NoImplicitPrelude #-} 8 | -- | 9 | -- Module : Network.AWS.S3.Cache.Remote 10 | -- Copyright : (c) FP Complete 2017 11 | -- License : BSD3 12 | -- Maintainer : Alexey Kuleshevich 13 | -- Stability : experimental 14 | -- Portability : non-portable 15 | -- 16 | module Network.AWS.S3.Cache.Remote where 17 | 18 | import Control.Applicative 19 | import Control.Lens hiding ((^.), to) 20 | import Control.Monad.Reader 21 | import Control.Monad.Trans.Maybe 22 | import Control.Monad.Trans.Resource (liftResourceT) 23 | import Crypto.Hash (Digest, HashAlgorithm, digestFromByteString) 24 | import Data.ByteArray as BA 25 | import Data.ByteString as S 26 | import Data.ByteString.Base64 as S64 27 | import Data.Conduit 28 | import Data.Conduit.List as CL 29 | import RIO.HashMap as HM 30 | import Data.Ratio ((%)) 31 | import RIO.Text as T 32 | import RIO.Time 33 | import Network.AWS hiding (LogLevel) 34 | import Network.AWS.Data.Body 35 | import Network.AWS.Data.Text (toText) 36 | import Network.AWS.S3.Cache.Types 37 | import Network.AWS.S3.Cache.Local (restoreFilesFromCache) 38 | import Network.AWS.S3.CreateMultipartUpload 39 | import Network.AWS.S3.DeleteObject 40 | import Network.AWS.S3.GetObject 41 | import Network.AWS.S3.StreamingUpload 42 | import Network.AWS.S3.Types 43 | import Network.HTTP.Client 44 | import Network.HTTP.Types.Status (Status(statusMessage), status404) 45 | import RIO 46 | import RIO.List as L 47 | 48 | import Data.Conduit.Binary 49 | 50 | 51 | -- | Returns the time when the cache object was created 52 | getCreateTime :: GetObjectResponse -> Maybe UTCTime 53 | getCreateTime resp = 54 | (HM.lookup metaCreateTimeKey (resp ^. gorsMetadata) >>= parseISO8601) <|> 55 | (resp ^. gorsLastModified) 56 | 57 | -- | Will check if there is already cache up on AWS and checks if it's contents has changed. 58 | -- Returns create time date if new cache should be uploaded. 59 | hasCacheChanged :: 60 | ( MonadReader r m 61 | , MonadIO m 62 | , MonadThrow m 63 | , HasBucketName r BucketName 64 | , HasLogFunc r 65 | , HasObjectKey r ObjectKey 66 | , HasNumRetries r Int 67 | , HasEnv r 68 | , HasMinLogLevel r LogLevel 69 | , HashAlgorithm h 70 | , Typeable h 71 | ) 72 | => Digest h 73 | -> m (Maybe UTCTime) 74 | hasCacheChanged newHash = do 75 | c <- ask 76 | let getObjReq = getObject (c ^. bucketName) (c ^. objectKey) 77 | hashKey = getHashMetaKey newHash 78 | onErr status 79 | | status == status404 = do 80 | logAWS LevelInfo "No previously stored cache was found." 81 | return (Nothing, (Nothing, Nothing)) 82 | | otherwise = return (Just LevelError, (Nothing, Nothing)) 83 | onSucc resp = do 84 | logAWS LevelDebug "Discovered previous cache." 85 | let mOldHash = HM.lookup hashKey (resp ^. gorsMetadata) 86 | mCreateTime = getCreateTime resp 87 | case mOldHash of 88 | Just oldHash -> 89 | logAWS LevelDebug $ 90 | "Hash value for previous cache is " <> display hashKey <> ": " <> display oldHash 91 | Nothing -> 92 | logAWS LevelWarn $ "Previous cache is missing a hash value '" <> display hashKey <> "'" 93 | return (mOldHash, mCreateTime) 94 | (mOldHashTxt, mCreateTime) <- sendAWS getObjReq onErr onSucc 95 | createTime <- maybe getCurrentTime return mCreateTime 96 | mOldHash <- maybe (return Nothing) decodeHash mOldHashTxt 97 | return 98 | (if Just newHash /= mOldHash 99 | then Just createTime 100 | else Nothing) 101 | 102 | 103 | encodeHash :: HashAlgorithm h => Digest h -> Utf8Builder 104 | encodeHash hash = displayBytesUtf8 (S64.encode (BA.convert hash)) 105 | 106 | 107 | decodeHash :: 108 | (MonadIO m, MonadReader env m, HashAlgorithm h, HasLogFunc env, HasObjectKey env ObjectKey) 109 | => Text 110 | -> m (Maybe (Digest h)) 111 | decodeHash hashTxt = 112 | case S64.decode (T.encodeUtf8 hashTxt) of 113 | Left err -> do 114 | logAWS LevelError $ 115 | "Problem decoding cache's hash value: " <> display hashTxt <> " Decoding Error: " <> 116 | fromString err 117 | return Nothing 118 | Right bstr -> return $ digestFromByteString bstr 119 | 120 | 121 | uploadCache :: 122 | ( MonadReader r m 123 | , MonadIO m 124 | , HasEnv r 125 | , HasMinLogLevel r LogLevel 126 | , HasObjectKey r ObjectKey 127 | , HasBucketName r BucketName 128 | , HasLogFunc r 129 | , HasMaxSize r (Maybe Integer) 130 | , HasNumRetries r Int 131 | , MonadThrow m 132 | , HashAlgorithm h 133 | , Typeable h 134 | ) 135 | => Bool 136 | -> TempFile -- ^ Temporary file where cache has been written to 137 | -> (Word64, Digest h) -- ^ Size and hash of the temporary file with cache 138 | -> m () 139 | uploadCache isPublic tmpFile (cSize, newHash) = 140 | void $ 141 | runMaybeT $ do 142 | c <- ask 143 | when (maybe False (fromIntegral cSize >=) (c ^. maxSize)) $ do 144 | logAWS LevelInfo $ "Refusing to save, cache is too big: " <> formatBytes (fromIntegral cSize) 145 | MaybeT $ return Nothing 146 | mCreatedTime <- hasCacheChanged newHash 147 | createTime <- mCreatedTime `onNothing` logAWS LevelInfo "No change to cache was detected." 148 | let newHashTxt = textDisplay $ encodeHash newHash 149 | hashKey = getHashMetaKey newHash 150 | cmu = 151 | createMultipartUpload (c ^. bucketName) (c ^. objectKey) & 152 | cmuMetadata .~ 153 | HM.fromList 154 | [ (metaHashAlgorithmKey, hashKey) 155 | , (metaCreateTimeKey, textDisplay $ formatISO8601 createTime) 156 | , (hashKey, newHashTxt) 157 | , (compressionMetaKey, getCompressionName (tempFileCompression tmpFile)) 158 | ] & 159 | if isPublic 160 | then cmuACL ?~ OPublicRead 161 | else id 162 | logAWS LevelInfo $ 163 | mconcat 164 | [ "Data change detected, caching " 165 | , formatBytes (fromIntegral cSize) 166 | , " with " 167 | , display hashKey 168 | , ": " 169 | , display newHashTxt 170 | ] 171 | startTime <- getCurrentTime 172 | runLoggingAWS_ $ 173 | runConduit $ 174 | sourceHandle (tempFileHandle tmpFile) .| 175 | passthroughSink (streamUpload (Just (100 * 2 ^ (20 :: Int))) cmu) (void . pure) .| 176 | transPipe (runRIO c) (getProgressReporter cSize) .| 177 | sinkNull 178 | -- Disabled due to: https://github.com/fpco/cache-s3/issues/26 179 | -- hClose (tempFileHandle tmpFile) 180 | -- runLoggingAWS_ $ 181 | -- void $ 182 | -- concurrentUpload 183 | -- (Just (8 * 1024 ^ (2 :: Int))) 184 | -- (Just 10) 185 | -- (FP (tempFilePath tmpFile)) 186 | -- cmu 187 | endTime <- getCurrentTime 188 | reportSpeed cSize $ diffUTCTime endTime startTime 189 | logAWS LevelInfo "Finished uploading. Files are cached on S3." 190 | 191 | reportSpeed :: 192 | (MonadIO m, MonadReader env m, HasLogFunc env, HasObjectKey env ObjectKey, Real p1, Real p2) 193 | => p1 194 | -> p2 195 | -> m () 196 | reportSpeed cSize delta = logAWS LevelInfo $ "Average speed: " <> formatBytes speed <> "/s" 197 | where 198 | speed 199 | | delta == 0 = 0 200 | | otherwise = round (toRational cSize / toRational delta) 201 | 202 | 203 | onNothing :: Monad m => Maybe b -> m a -> MaybeT m b 204 | onNothing mArg whenNothing = 205 | case mArg of 206 | Nothing -> do 207 | _ <- lift whenNothing 208 | MaybeT $ return Nothing 209 | Just res -> MaybeT $ return $ Just res 210 | 211 | 212 | deleteCache :: 213 | ( MonadReader c m 214 | , MonadThrow m 215 | , MonadIO m 216 | , HasEnv c 217 | , HasLogFunc c 218 | , HasMinLogLevel c LogLevel 219 | , HasNumRetries c Int 220 | , HasObjectKey c ObjectKey 221 | , HasBucketName c BucketName 222 | ) 223 | => m () 224 | deleteCache = do 225 | c <- ask 226 | sendAWS_ 227 | (deleteObject (c ^. bucketName) (c ^. objectKey)) 228 | (const $ logAWS LevelInfo "Clear cache request was successfully submitted.") 229 | 230 | -- | Download an object from S3 and handle its content using the supplied sink. 231 | restoreCache :: 232 | (MonadIO m, MonadReader Config m, MonadThrow m, PrimMonad m, MonadUnliftIO m) 233 | => FileOverwrite 234 | -> m Bool 235 | restoreCache fileOverwrite = 236 | fmap isJust $ 237 | runMaybeT $ do 238 | c <- ask 239 | let getObjReq = getObject (c ^. bucketName) (c ^. objectKey) 240 | onErr status 241 | | status == status404 = do 242 | logAWS LevelInfo "No previously stored cache was found." 243 | MaybeT $ return Nothing 244 | | otherwise = pure (Just LevelError, ()) 245 | logAWS LevelDebug "Checking for previously stored cache." 246 | sendAWS getObjReq onErr $ \resp -> do 247 | logAWS LevelDebug "Starting to download previous cache." 248 | compAlgTxt <- 249 | HM.lookup compressionMetaKey (resp ^. gorsMetadata) `onNothing` 250 | logAWS LevelWarn "Missing information on compression algorithm." 251 | compAlg <- 252 | readCompression compAlgTxt `onNothing` 253 | logAWS LevelWarn ("Compression algorithm is not supported: " <> display compAlgTxt) 254 | logAWS LevelDebug $ "Compression algorithm used: " <> display compAlgTxt 255 | hashAlgName <- 256 | HM.lookup metaHashAlgorithmKey (resp ^. gorsMetadata) `onNothing` 257 | logAWS LevelWarn "Missing information on hashing algorithm." 258 | logAWS LevelDebug $ "Hashing algorithm used: " <> display hashAlgName 259 | hashTxt <- 260 | HM.lookup hashAlgName (resp ^. gorsMetadata) `onNothing` 261 | logAWS LevelWarn ("Cache is missing a hash value '" <> display hashAlgName <> "'") 262 | logAWS LevelDebug $ "Hash value is " <> display hashAlgName <> ": " <> display hashTxt 263 | createTime <- 264 | getCreateTime resp `onNothing` logAWS LevelWarn "Cache is missing creation time info." 265 | logAWS LevelDebug $ "Cache creation timestamp: " <> formatRFC822 createTime 266 | case c ^. maxAge of 267 | Nothing -> return () 268 | Just timeDelta -> do 269 | curTime <- getCurrentTime 270 | when (curTime >= addUTCTime timeDelta createTime) $ do 271 | logAWS LevelInfo $ 272 | "Refusing to restore, cache is too old: " <> 273 | formatDiffTime (diffUTCTime curTime createTime) 274 | deleteCache 275 | MaybeT $ return Nothing 276 | case (,) <$> (resp ^. gorsContentLength) <*> (c ^. maxSize) of 277 | Nothing -> return () 278 | Just (len, maxLen) -> 279 | when (len >= maxLen) $ do 280 | logAWS LevelInfo $ "Refusing to restore, cache is too big: " <> formatBytes len 281 | deleteCache 282 | MaybeT $ return Nothing 283 | let noHashAlgSupport _ = 284 | logAWS LevelWarn $ 285 | "Hash algorithm used for the cache is not supported: " <> display hashAlgName 286 | withHashAlgorithm_ hashAlgName noHashAlgSupport $ \hashAlg -> do 287 | mHashExpected <- decodeHash hashTxt 288 | hashExpected <- 289 | mHashExpected `onNothing` 290 | logAWS LevelError ("Problem decoding cache's hash value: " <> display hashTxt) 291 | len <- 292 | (resp ^. gorsContentLength) `onNothing` 293 | logAWS LevelError "Did not receive expected cache size form AWS" 294 | logAWS LevelInfo $ 295 | "Restoring cache from " <> formatRFC822 (fromMaybe createTime (resp ^. gorsLastModified)) <> 296 | " with total size: " <> 297 | formatBytes len 298 | hashComputed <- 299 | lift $ 300 | runConduitRes $ 301 | transPipe liftResourceT (resp ^. gorsBody ^. to _streamBody) .| 302 | getProgressReporter (fromInteger len) .| 303 | restoreFilesFromCache fileOverwrite compAlg hashAlg 304 | if hashComputed == hashExpected 305 | then logAWS LevelInfo $ 306 | "Successfully restored previous cache with hash: " <> encodeHash hashComputed 307 | else do 308 | logAWS LevelError $ 309 | mconcat 310 | [ "Computed '" 311 | , display hashAlgName 312 | , "' hash mismatch: '" 313 | , encodeHash hashComputed 314 | , "' /= '" 315 | , encodeHash hashExpected 316 | , "'" 317 | ] 318 | MaybeT $ return Nothing 319 | 320 | 321 | -- | Send request to AWS and process the response with a handler. A separate error handler will be 322 | -- invoked whenever an error occurs, which suppose to return some sort of default value and the 323 | -- `LogLevel` this error corresponds to. 324 | sendAWS :: 325 | ( MonadReader r m 326 | , MonadIO m 327 | , HasEnv r 328 | , HasLogFunc r 329 | , HasMinLogLevel r LogLevel 330 | , HasObjectKey r ObjectKey 331 | , HasNumRetries r Int 332 | , AWSRequest a 333 | , MonadThrow m 334 | ) 335 | => a 336 | -> (Status -> m (Maybe LogLevel, b)) 337 | -> (Rs a -> m b) 338 | -> m b 339 | sendAWS req = runLoggingAWS (send req) 340 | 341 | 342 | -- | Same as `sendAWS`, but discard the response and simply error out on any received AWS error 343 | -- responses. 344 | sendAWS_ :: 345 | ( MonadReader r m 346 | , MonadIO m 347 | , HasEnv r 348 | , HasLogFunc r 349 | , HasMinLogLevel r LogLevel 350 | , HasNumRetries r Int 351 | , HasObjectKey r ObjectKey 352 | , AWSRequest a 353 | , MonadThrow m 354 | ) 355 | => a 356 | -> (Rs a -> m ()) 357 | -> m () 358 | sendAWS_ req = sendAWS req (const $ pure (Just LevelError, ())) 359 | 360 | 361 | -- | Report every problem as `LevelError` and discard the result. 362 | runLoggingAWS_ :: 363 | ( MonadReader r m 364 | , MonadIO m 365 | , HasEnv r 366 | , HasLogFunc r 367 | , HasMinLogLevel r LogLevel 368 | , HasNumRetries r Int 369 | , HasObjectKey r ObjectKey 370 | , MonadThrow m 371 | ) 372 | => AWS () 373 | -> m () 374 | runLoggingAWS_ action = runLoggingAWS action (const $ pure (Just LevelError, ())) return 375 | 376 | 377 | -- | General helper for calling AWS and conditionally log the outcome upon a received error. 378 | runLoggingAWS :: 379 | ( MonadReader r m 380 | , MonadIO m 381 | , HasEnv r 382 | , HasLogFunc r 383 | , HasMinLogLevel r LogLevel 384 | , HasNumRetries r Int 385 | , HasObjectKey r ObjectKey 386 | , MonadThrow m 387 | ) 388 | => AWS t 389 | -> (Status -> m (Maybe LogLevel, b)) 390 | -> (t -> m b) 391 | -> m b 392 | runLoggingAWS action onErr onSucc = do 393 | conf <- ask 394 | eResp <- retryWith (liftIO $ runResourceT $ runAWS conf $ trying _Error action) 395 | case eResp of 396 | Left err -> do 397 | (errMsg, status) <- 398 | case err of 399 | TransportError exc -> do 400 | unless ((conf ^. minLogLevel) == LevelDebug) $ 401 | logAWS LevelError $ "Critical HTTPException: " <> toErrorMessage exc 402 | throwM exc 403 | SerializeError serr -> 404 | return (fromString (serr ^. serializeMessage), serr ^. serializeStatus) 405 | ServiceError serr -> do 406 | let status = serr ^. serviceStatus 407 | errMsg = 408 | display $ 409 | maybe 410 | (T.decodeUtf8With T.lenientDecode $ statusMessage status) 411 | toText 412 | (serr ^. serviceMessage) 413 | return (errMsg, status) 414 | (mLevel, def) <- onErr status 415 | case mLevel of 416 | Just level -> logAWS level errMsg 417 | Nothing -> return () 418 | return def 419 | Right suc -> onSucc suc 420 | 421 | -- | Convert an HTTP exception into a readable error message 422 | toErrorMessage :: HttpException -> Utf8Builder 423 | toErrorMessage exc = 424 | case exc of 425 | HttpExceptionRequest _ httpExcContent -> 426 | case httpExcContent of 427 | StatusCodeException resp _ -> "StatusCodeException: " <> displayShow (responseStatus resp) 428 | TooManyRedirects rs -> "TooManyRedirects: " <> display (L.length rs) 429 | InvalidHeader _ -> "InvalidHeader" 430 | InvalidRequestHeader _ -> "InvalidRequestHeader" 431 | InvalidProxyEnvironmentVariable name _ -> 432 | "InvalidProxyEnvironmentVariable: " <> display name 433 | _ -> displayShow httpExcContent 434 | _ -> fromString (displayException exc) 435 | 436 | -- | Retry the provided action 437 | retryWith :: 438 | ( HasNumRetries r Int 439 | , HasLogFunc r 440 | , HasObjectKey r ObjectKey 441 | , MonadIO m 442 | , MonadReader r m 443 | ) 444 | => m (Either Error a) 445 | -> m (Either Error a) 446 | retryWith action = do 447 | conf <- ask 448 | let n = conf ^. numRetries 449 | go i eResp = 450 | case eResp of 451 | Left (TransportError exc) 452 | | i > n -> pure eResp 453 | | otherwise -> do 454 | let s = min 9 (i * i) -- exponential backoff with at most 9 seconds 455 | logAWS LevelWarn $ "TransportError - " <> toErrorMessage exc 456 | logAWS LevelWarn $ 457 | "Retry " <> display i <> "/" <> display n <> ". Waiting for " <> display s <> 458 | " seconds" 459 | liftIO $ threadDelay (s * 1000000) -- microseconds 460 | eResp' <- action 461 | go (i + 1) eResp' 462 | _ -> pure eResp 463 | action >>= go 1 464 | 465 | -- | Logger that will add object info to the entry. 466 | logAWS :: (MonadIO m, MonadReader a m, HasLogFunc a, HasObjectKey a ObjectKey) => 467 | LogLevel -> Utf8Builder -> m () 468 | logAWS ll msg = do 469 | c <- ask 470 | let ObjectKey objKeyTxt = c ^. objectKey 471 | logGeneric "" ll $ "<" <> display objKeyTxt <> "> - " <> msg 472 | 473 | -- | Compute chunk thresholds and report progress. 474 | reportProgress :: 475 | (MonadIO m) 476 | => (Word64 -> Word64 -> m a) 477 | -> ([(Word64, Word64)], Word64, Word64, UTCTime) 478 | -> Word64 479 | -> m ([(Word64, Word64)], Word64, Word64, UTCTime) 480 | reportProgress reporter (thresh, stepSum, prevSum, prevTime) chunkSize 481 | | L.null thresh || curSum < curThresh = return (thresh, stepSum + chunkSize, curSum, prevTime) 482 | | otherwise = do 483 | curTime <- liftIO getCurrentTime 484 | let delta = diffUTCTime curTime prevTime 485 | speed = if delta == 0 486 | then 0 487 | else (toInteger (stepSum + chunkSize) % 1) / toRational delta 488 | _ <- reporter perc $ round (fromRational @Double speed) 489 | return (restThresh, 0, curSum, curTime) 490 | where 491 | curSum = prevSum + chunkSize 492 | (perc, curThresh):restThresh = thresh 493 | 494 | 495 | -- | Creates a conduit that will execute supplied action 10 time each for every 10% of the data is 496 | -- being passed through it. Supplied action will receive `Text` with status and speed of processing. 497 | getProgressReporter :: 498 | (MonadIO m, MonadReader r m, HasLogFunc r) => Word64 -> ConduitM S.ByteString S.ByteString m () 499 | getProgressReporter totalSize = do 500 | let thresh = [(p, (totalSize * p) `div` 100) | p <- [10,20 .. 100]] 501 | reporter perc speed = 502 | logInfo $ 503 | "Progress: " <> display perc <> "%, speed: " <> formatBytes (fromIntegral speed) <> 504 | "/s" 505 | reportProgressAccum chunk acc = do 506 | acc' <- reportProgress reporter acc (fromIntegral (S.length chunk)) 507 | return (acc', chunk) 508 | curTime <- getCurrentTime 509 | void $ CL.mapAccumM reportProgressAccum (thresh, 0, 0, curTime) 510 | -------------------------------------------------------------------------------- /src/Network/AWS/S3/Cache/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | -- | 7 | -- Module : Network.AWS.S3.Cache.Stack 8 | -- Copyright : (c) FP Complete 2017 9 | -- License : BSD3 10 | -- Maintainer : Alexey Kuleshevich 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | module Network.AWS.S3.Cache.Stack where 15 | 16 | import Data.Aeson 17 | import Data.Git 18 | import qualified RIO.HashMap as HM 19 | import Data.String 20 | import qualified RIO.ByteString.Lazy as BL 21 | import qualified RIO.Text as T 22 | import Data.Text.Encoding.Error (strictDecode) 23 | import qualified RIO.Vector as V 24 | import Data.Yaml 25 | import Network.AWS.S3.Cache.Types 26 | import RIO 27 | import RIO.FilePath 28 | import RIO.Process 29 | 30 | getStackRootArg :: Maybe FilePath -> [FilePath] 31 | getStackRootArg = maybe [] (\stackRoot -> ["--stack-root", stackRoot]) 32 | 33 | getStackPath :: (HasProcessContext env, HasLogFunc env) 34 | => [String] -> FilePath -> RIO env FilePath 35 | getStackPath args pName = T.unpack . T.concat . filter (not . T.null) . T.lines . T.decodeUtf8With strictDecode . BL.toStrict . snd <$> p 36 | where 37 | p = proc "stack" ("--no-terminal" : args ++ ["path"] ++ [pName]) 38 | (readProcess_ 39 | #if WINDOWS 40 | -- Ignore stderr due to: https://github.com/commercialhaskell/stack/issues/5038 41 | . setStderr closed 42 | #endif 43 | ) 44 | 45 | 46 | getStackGlobalPaths :: (HasProcessContext env, HasLogFunc env) 47 | => Maybe FilePath -- ^ Stack root directory 48 | -> RIO env [FilePath] 49 | getStackGlobalPaths mStackRoot = 50 | mapM (getStackPath (getStackRootArg mStackRoot)) ["--stack-root", "--programs"] 51 | 52 | 53 | getStackResolver :: (HasProcessContext env, HasLogFunc env) 54 | => StackProject -> RIO env T.Text 55 | getStackResolver StackProject { stackResolver = Just resolver } = pure resolver 56 | getStackResolver StackProject {stackYaml = mStackYaml} = do 57 | yaml <- getStackYaml mStackYaml 58 | eObj <- liftIO $ decodeFileEither yaml 59 | case eObj of 60 | Left exc -> throwIO exc 61 | Right (Object (HM.lookup "resolver" -> mPackages)) 62 | | isJust mPackages -> 63 | case mPackages of 64 | Just (String txt) -> return txt 65 | _ -> error $ "Expected 'resolver' to be a String in the config: " ++ yaml 66 | _ -> error $ "Couldn't find 'resolver' in the config: " ++ yaml 67 | 68 | 69 | 70 | getStackYaml :: (HasProcessContext env, HasLogFunc env) 71 | => Maybe FilePath -> RIO env FilePath 72 | getStackYaml = 73 | \case 74 | Just yaml -> return yaml 75 | Nothing -> maybe "stack.yaml" T.unpack <$> lookupEnv "STACK_YAML" 76 | 77 | 78 | getStackWorkPaths :: (HasProcessContext env, HasLogFunc env) 79 | => Maybe FilePath -- ^ Stack root. It is needed in order to prevent stack from 80 | -- starting to install ghc and the rest in case when root folder 81 | -- is custom. 82 | -> Maybe FilePath -- ^ Path to --stack-yaml 83 | -> Maybe FilePath -- ^ Relative path for --work-dir 84 | -> RIO env [FilePath] 85 | getStackWorkPaths mStackRoot mStackYaml mWorkDir = do 86 | let fromStr (String ".") = Nothing -- Project root will be added separately 87 | fromStr (String str) = Just $ T.unpack str 88 | fromStr _ = Nothing 89 | yaml <- getStackYaml mStackYaml 90 | projectRoot <- 91 | getStackPath (getStackRootArg mStackRoot ++ ["--stack-yaml", yaml]) "--project-root" 92 | workDir <- 93 | case mWorkDir of 94 | Just workDir -> return workDir 95 | Nothing -> maybe ".stack-work" T.unpack <$> lookupEnv "STACK_WORK" 96 | eObj <- liftIO $ decodeFileEither yaml 97 | pathPkgs <- 98 | case eObj of 99 | Left exc -> throwIO exc 100 | Right (Object obj) 101 | | Just (Array packages) <- HM.lookup "packages" obj -> 102 | pure $ V.toList (V.mapMaybe fromStr packages) 103 | _ -> pure [] 104 | return ((projectRoot workDir) : map (\pkg -> projectRoot pkg workDir) pathPkgs) 105 | 106 | -- | Will do its best to find the git repo and get the current branch name, unless GIT_BRANCH env 107 | -- var is set, in which case its value is returned. 108 | getBranchName :: 109 | (HasProcessContext env, HasLogFunc env) 110 | => Maybe FilePath -- ^ Path to @.git@ repo. Current path will be traversed upwards in search for 111 | -- one if `Nothing` is supplied. 112 | -> RIO env (Maybe T.Text) 113 | getBranchName mGitPath = do 114 | mBranchName <- lookupEnv "GIT_BRANCH" 115 | case mBranchName of 116 | Just branchName -> return $ Just branchName 117 | Nothing -> 118 | either (const Nothing) (Just . T.pack . refNameRaw) <$> 119 | case mGitPath of 120 | Nothing -> liftIO $ withCurrentRepo headGet 121 | Just fp -> liftIO $ withRepo (fromString fp) headGet 122 | -------------------------------------------------------------------------------- /src/Network/AWS/S3/Cache/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | -- | 11 | -- Module : Network.AWS.S3.Cache.Types 12 | -- Copyright : (c) FP Complete 2017-2020 13 | -- License : BSD3 14 | -- Maintainer : Alexey Kuleshevich 15 | -- Stability : experimental 16 | -- Portability : non-portable 17 | -- 18 | module Network.AWS.S3.Cache.Types where 19 | 20 | import Conduit (ConduitT, PrimMonad) 21 | import Control.Applicative 22 | import Control.Lens (makeLensesWith, classUnderscoreNoPrefixFields) 23 | import Control.Monad.Trans.Resource (MonadResource) 24 | import Crypto.Hash 25 | import Data.Attoparsec.ByteString.Char8 26 | import Data.ByteString (ByteString) 27 | import Data.ByteString.Char8 as S8 28 | import Data.Char as C (toLower) 29 | import Data.Conduit.Zlib 30 | import Data.Typeable 31 | import Network.AWS.Env 32 | import Network.AWS.S3.Types 33 | import RIO 34 | import RIO.FilePath 35 | import RIO.List as List 36 | import RIO.List.Partial as ListPartial (last) 37 | import qualified RIO.Map as Map 38 | import RIO.Process (HasProcessContext(..), ProcessContext, envVarsL) 39 | import RIO.Text as T 40 | import RIO.Time 41 | import System.IO (Handle) 42 | 43 | #if !WINDOWS 44 | import qualified Data.Conduit.LZ4 as LZ4 45 | #endif 46 | 47 | data Config = Config 48 | { _bucketName :: !BucketName 49 | , _objectKey :: !ObjectKey 50 | , confEnv :: !Env 51 | , _minLogLevel :: !LogLevel 52 | , _isConcise :: !Bool 53 | , _maxAge :: !(Maybe NominalDiffTime) 54 | , _maxSize :: !(Maybe Integer) 55 | , _numRetries :: !Int 56 | , configApp :: !App 57 | } 58 | 59 | -- TODO: Replace with SimpleApp, when constructor becomes available (exported from 60 | -- RIO.Prelude.Simple): https://github.com/commercialhaskell/rio/issues/208 61 | data App = App 62 | { saLogFunc :: !LogFunc 63 | , saProcessContext :: !ProcessContext 64 | } 65 | instance HasLogFunc App where 66 | logFuncL = lens saLogFunc (\x y -> x { saLogFunc = y }) 67 | instance HasProcessContext App where 68 | processContextL = lens saProcessContext (\x y -> x { saProcessContext = y }) 69 | 70 | 71 | makeLensesWith classUnderscoreNoPrefixFields ''Config 72 | 73 | newtype FileOverwrite = 74 | FileOverwrite LogLevel 75 | deriving (Eq, Show) 76 | 77 | instance HasEnv Config where 78 | environment = lens confEnv (\conf env -> conf {confEnv = env}) 79 | 80 | instance HasLogFunc Config where 81 | logFuncL = lens configApp (\conf env -> conf {configApp = env}) . logFuncL 82 | 83 | instance HasProcessContext Config where 84 | processContextL = lens configApp (\conf env -> conf {configApp = env}) . processContextL 85 | 86 | 87 | mkObjectKey :: Maybe Text -- ^ Prefix (eg. project name) 88 | -> Maybe Text -- ^ Git branch name 89 | -> Maybe Text -- ^ Suffix 90 | -> ObjectKey 91 | mkObjectKey mPrefix mBranchName mSuffix = 92 | ObjectKey $ 93 | "cache-s3/" <> maybe "" (<> "/") mPrefix <> fromMaybe "" mBranchName <> maybe "" ("." <>) mSuffix <> 94 | ".cache" 95 | 96 | 97 | data CommonArgs = CommonArgs 98 | { commonBucket :: !BucketName 99 | , commonRegion :: !(Maybe Region) 100 | , commonPrefix :: !(Maybe Text) 101 | , commonGitDir :: !(Maybe FilePath) 102 | , commonGitBranch :: !(Maybe Text) 103 | , commonSuffix :: !(Maybe Text) 104 | , commonVerbosity :: !LogLevel 105 | , commonConcise :: !Bool 106 | , commonMaxBytes :: !(Maybe Integer) 107 | , commonNumRetries :: !Int 108 | } deriving (Show) 109 | 110 | 111 | data SaveArgs = SaveArgs 112 | { savePaths :: ![FilePath] 113 | , saveRelativePaths :: ![FilePath] 114 | , saveHash :: !Text 115 | , saveCompression :: !Compression 116 | , savePublic :: !Bool 117 | } deriving (Show) 118 | 119 | data SaveStackArgs = SaveStackArgs 120 | { saveStackArgs :: !SaveArgs 121 | , saveStackRoot :: !(Maybe FilePath) 122 | , saveStackProject :: !StackProject 123 | } deriving (Show) 124 | 125 | data SaveStackWorkArgs = SaveStackWorkArgs 126 | { saveStackWorkArgs :: !SaveStackArgs 127 | , saveStackWorkDir :: !(Maybe FilePath) 128 | } deriving (Show) 129 | 130 | 131 | data RestoreArgs = RestoreArgs 132 | { restoreBaseBranch :: !(Maybe Text) 133 | , restoreMaxAge :: !(Maybe NominalDiffTime) 134 | , restoreOverwrite :: !FileOverwrite 135 | } deriving (Show) 136 | 137 | 138 | data StackProject = StackProject 139 | { stackYaml :: !(Maybe FilePath) 140 | , stackResolver :: !(Maybe Text) 141 | } deriving (Show) 142 | 143 | 144 | 145 | data RestoreStackArgs = RestoreStackArgs 146 | { restoreStackArgs :: !RestoreArgs 147 | , restoreStackRoot :: !(Maybe FilePath) 148 | , restoreStackProject :: !StackProject 149 | } deriving (Show) 150 | 151 | 152 | 153 | data Action 154 | = Save !SaveArgs 155 | | SaveStack !SaveStackArgs 156 | | SaveStackWork !SaveStackWorkArgs 157 | | Restore !RestoreArgs 158 | | RestoreStack !RestoreStackArgs 159 | | RestoreStackWork !RestoreStackArgs 160 | | Clear 161 | | ClearStack !StackProject 162 | | ClearStackWork !StackProject 163 | deriving (Show) 164 | 165 | 166 | data TempFile = TempFile 167 | { tempFilePath :: !FilePath 168 | , tempFileHandle :: !Handle 169 | , tempFileCompression :: !Compression 170 | } 171 | 172 | makeTempFileNamePattern :: Compression -> FilePath 173 | makeTempFileNamePattern compression = "cache-s3.tar" <.> T.unpack (getCompressionName compression) 174 | 175 | -- | Look into the `ProcessContext` and see if there is environmet variable available there. 176 | lookupEnv :: (MonadReader env m, HasProcessContext env) => Text -> m (Maybe Text) 177 | lookupEnv envName = Map.lookup envName <$> view envVarsL 178 | 179 | 180 | ---------------- 181 | --- Time ------- 182 | ---------------- 183 | 184 | data Interval 185 | = Years Integer 186 | | Days Integer 187 | | Hours Integer 188 | | Minutes Integer 189 | | Seconds Integer 190 | deriving (Show) 191 | 192 | formatDiffTime :: NominalDiffTime -> Utf8Builder 193 | formatDiffTime nd = go True "" (Seconds <$> divMod (round nd) 60) 194 | where 195 | go isAccEmpty acc = 196 | \case 197 | (_, Years y) 198 | | y > 0 -> 199 | showTime isAccEmpty y "year" ", " acc 200 | (n, Days d) 201 | | d > 0 || n > 0 -> 202 | go False (showTime isAccEmpty d "day" ", " acc) (0, Years n) 203 | (n, Hours h) 204 | | h > 0 || n > 0 -> 205 | go False (showTime isAccEmpty h "hour" ", " acc) (Days <$> divMod n 365) 206 | (n, Minutes m) 207 | | m > 0 || n > 0 -> 208 | go False (showTime isAccEmpty m "minute" ", " acc) (Hours <$> divMod n 24) 209 | (n, Seconds s) -> 210 | go False (showTime isAccEmpty s "second" "" acc) (Minutes <$> divMod n 60) 211 | _ -> acc 212 | showTime _ 0 _ _ acc = acc 213 | showTime isAccEmpty t tTxt sep acc = 214 | display t <> " " <> tTxt <> 215 | (if t == 1 216 | then "" 217 | else "s") <> 218 | (if isAccEmpty 219 | then acc 220 | else sep <> acc) 221 | 222 | parseDiffTime :: Text -> Maybe NominalDiffTime 223 | parseDiffTime = 224 | either (const Nothing) (Just . fromInteger . sum . RIO.map toSec) . 225 | parseOnly (intervalParser <* skipSpace <* endOfInput) . T.encodeUtf8 . T.toLower 226 | where 227 | toSec = 228 | \case 229 | Years y -> y * 365 * 24 * 3600 230 | Days d -> d * 24 * 3600 231 | Hours h -> h * 3600 232 | Minutes m -> m * 60 233 | Seconds s -> s 234 | maybePlural = (char 's' $> ()) <|> pure () 235 | intervalParser = 236 | many1 $ 237 | skipSpace *> 238 | choice 239 | [ Years <$> decimal <* skipSpace <* ("year" <* maybePlural <|> "y") 240 | , Days <$> decimal <* skipSpace <* ("day" <* maybePlural <|> "d") 241 | , Hours <$> decimal <* skipSpace <* ("hour" <* maybePlural <|> "h") 242 | , Minutes <$> decimal <* skipSpace <* ("minute" <* maybePlural <|> "min" <|> "m") 243 | , Seconds <$> decimal <* skipSpace <* ("second" <* maybePlural <|> "sec" <|> "s") 244 | ] 245 | 246 | formatRFC822 :: UTCTime -> Utf8Builder 247 | formatRFC822 = fromString . formatTime defaultTimeLocale rfc822DateFormat 248 | 249 | parseISO8601 :: Text -> Maybe UTCTime 250 | parseISO8601 = parseTimeM False defaultTimeLocale iso8601 . T.unpack 251 | 252 | formatISO8601 :: UTCTime -> Utf8Builder 253 | formatISO8601 = fromString . formatTime defaultTimeLocale iso8601 254 | 255 | iso8601 :: String 256 | iso8601 = iso8601DateFormat (Just "%H:%M:%S%Q%z") 257 | 258 | 259 | parseBytes :: Text -> Maybe Integer 260 | parseBytes = 261 | either (const Nothing) Just . 262 | parseOnly ((*) <$> decimal <*> multiplier) . T.encodeUtf8 . T.toLower 263 | where 264 | (mults, abbrs) = List.unzip bytesMult 265 | abbrsParser = 266 | List.zipWith 267 | (<|>) 268 | (List.map (string . S8.pack . List.map C.toLower) abbrs) 269 | ["", "kb", "mb", "gb", "tb", "pb", "eb", "zb", "yb"] 270 | multiplier = skipSpace *> choice [p $> f | (p, f) <- List.reverse $ List.zip abbrsParser mults] 271 | 272 | 273 | formatBytes :: Integer -> Utf8Builder 274 | formatBytes val = 275 | fmt $ fromMaybe (ListPartial.last scaled) $ listToMaybe $ List.dropWhile ((>= 10240) . fst) scaled 276 | where 277 | fmt (sVal10, n) = 278 | (\(d, m) -> display d <> "." <> display m) (sVal10 `divMod` 10) <> " " <> n 279 | val10 = 10 * val 280 | scale (s, r) = 281 | s + 282 | if r < 512 283 | then 0 284 | else 1 285 | scaled = [(scale (val10 `divMod` t), abbr) | (t, abbr) <- bytesMult] 286 | 287 | bytesMult :: IsString s => [(Integer, s)] 288 | bytesMult = 289 | List.zip 290 | [2 ^ (x * 10) | x <- [0 :: Int ..]] 291 | ["B", "KiB", "MiB", "GiB", "TiB", "PiB", "EiB", "ZiB", "YiB"] 292 | 293 | 294 | ---------------- 295 | --- Matadata --- 296 | ---------------- 297 | 298 | metaCreateTimeKey :: Text 299 | metaCreateTimeKey = "created" 300 | 301 | metaHashAlgorithmKey :: Text 302 | metaHashAlgorithmKey = "hash" 303 | 304 | getHashMetaKey :: Typeable h => proxy h -> Text 305 | getHashMetaKey hashProxy = T.toLower (T.pack (showsTypeRep (typeRep hashProxy) "")) 306 | 307 | --------------- 308 | --- Hashing --- 309 | --------------- 310 | 311 | -- | Same as `withHashAlgorithm`, but accepts an extra function to be invoked when unsupported hash 312 | -- algorithm name is supplied that also returns a default value. 313 | withHashAlgorithm_ :: 314 | forall m a. Monad m 315 | => Text -- ^ Name of the hash algorithm (case insensitive) 316 | -> ([Text] -> m a) -- ^ On no hash algorithm name support 317 | -> (forall h. (Show h, Typeable h, HashAlgorithm h) => h -> m a) 318 | -> m a 319 | withHashAlgorithm_ hTxt onErr action = do 320 | eRes <- withHashAlgorithm hTxt action 321 | either onErr return eRes 322 | 323 | -- | Execute an action with Hash algorithm as an argument, while only supplying its textual name. In 324 | -- case when supplied name is not supported, a list of all valid names will be returned. 325 | withHashAlgorithm :: 326 | forall m a. Monad m 327 | => Text -- ^ Name of the hash algorithm (case insensitive) 328 | -> (forall h. (Show h, Typeable h, HashAlgorithm h) => h -> m a) 329 | -- ^ Action to invoke with an argument, which is a type that is an isnatnce of `HashAlgorithm`. 330 | -> m (Either [Text] a) 331 | withHashAlgorithm hTxt action = do 332 | let hTxtLower = T.toLower hTxt 333 | tryH :: (Show h, Typeable h, HashAlgorithm h, Monad m) => h -> m (Either [Text] a) 334 | tryH hAlg = 335 | let key = getHashMetaKey (Just hAlg) 336 | in if hTxtLower == key 337 | then Right <$> action hAlg 338 | else return $ Left [key] 339 | tryH SHA256 ?>> 340 | tryH SHA512 ?>> 341 | tryH Tiger ?>> 342 | tryH Skein512_512 ?>> 343 | tryH Skein512_384 ?>> 344 | tryH Skein512_256 ?>> 345 | tryH Skein512_224 ?>> 346 | tryH Skein256_256 ?>> 347 | tryH Skein256_224 ?>> 348 | tryH SHA512t_256 ?>> 349 | tryH SHA512t_224 ?>> 350 | tryH SHA384 ?>> 351 | tryH SHA3_512 ?>> 352 | tryH SHA3_384 ?>> 353 | tryH SHA3_256 ?>> 354 | tryH SHA3_224 ?>> 355 | tryH SHA224 ?>> 356 | tryH SHA1 ?>> 357 | tryH RIPEMD160 ?>> 358 | tryH MD5 ?>> 359 | tryH MD4 ?>> 360 | tryH MD2 ?>> 361 | tryH Keccak_512 ?>> 362 | tryH Keccak_384 ?>> 363 | tryH Keccak_256 ?>> 364 | tryH Keccak_224 ?>> 365 | tryH Blake2sp_256 ?>> 366 | tryH Blake2sp_224 ?>> 367 | tryH Blake2s_256 ?>> 368 | tryH Blake2s_224 ?>> 369 | tryH Blake2s_160 ?>> 370 | tryH Blake2bp_512 ?>> 371 | tryH Blake2b_512 ?>> 372 | tryH Blake2b_384 ?>> 373 | tryH Blake2b_256 ?>> 374 | tryH Blake2b_224 ?>> 375 | tryH Blake2b_160 376 | 377 | 378 | (?>>) :: (Monoid e, Monad m) => m (Either e a) -> m (Either e a) -> m (Either e a) 379 | (?>>) a1 a2 = do 380 | eRes1 <- a1 381 | case eRes1 of 382 | Left e1 -> do 383 | eRes2 <- a2 384 | case eRes2 of 385 | Left e2 -> return $ Left (e1 <> e2) 386 | Right res -> return $ Right res 387 | Right res -> return $ Right res 388 | 389 | 390 | ------------------- 391 | --- Compression --- 392 | ------------------- 393 | 394 | data Compression 395 | = GZip 396 | #if !WINDOWS 397 | | LZ4 398 | #endif 399 | deriving (Show, Eq, Enum) 400 | 401 | 402 | getCompressionConduit :: (MonadResource m, MonadThrow m, PrimMonad m) => 403 | Compression -> ConduitT ByteString ByteString m () 404 | getCompressionConduit GZip = gzip 405 | #if !WINDOWS 406 | getCompressionConduit LZ4 = LZ4.compress Nothing 407 | #endif 408 | 409 | 410 | getDeCompressionConduit :: (MonadResource m, MonadThrow m, PrimMonad m) => 411 | Compression -> ConduitT ByteString ByteString m () 412 | getDeCompressionConduit GZip = ungzip 413 | #if !WINDOWS 414 | getDeCompressionConduit LZ4 = LZ4.decompress 415 | #endif 416 | 417 | 418 | compressionMetaKey :: Text 419 | compressionMetaKey = "compression" 420 | 421 | getCompressionName :: Compression -> Text 422 | getCompressionName = T.toLower . T.pack . show 423 | 424 | supportedCompression :: Text 425 | supportedCompression = T.intercalate ", " $ getCompressionName <$> [GZip ..] 426 | 427 | readCompression :: Text -> Maybe Compression 428 | readCompression compTxt = 429 | case T.toLower compTxt of 430 | "gzip" -> Just GZip 431 | #if !WINDOWS 432 | "lz4" -> Just LZ4 433 | #endif 434 | _ -> Nothing 435 | 436 | 437 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.4 2 | packages: 3 | - . 4 | extra-deps: 5 | - amazonka-1.6.1@sha256:b2a50a6b87908efa1e1793868495e9b252cbcf99e2d7036b21f9fe1e12dc413d,3420 6 | - amazonka-core-1.6.1@sha256:ad6b06eb5b6847cbfbe4201e78b3fdb7818a42da061c5d0f8af4fdf2494e44b5,4957 7 | - amazonka-s3-1.6.1@sha256:9d07240fca59ad5197fb614ce3051e701e4951e6d4625a2dab4a9c17a1900194,6317 8 | - amazonka-s3-streaming-1.0.0.2@sha256:7e2ed4aed4f1bd59092593c1fa4b2af31d3ed9f0fbf51b730ad1babe943a6f1c,2639 9 | - git-0.3.0@sha256:dc070840ab24792c9664b9e3e69c9d55d30fc36fee41049c548bb0e8ec83c919,3448 10 | - lz4-conduit-0.3@sha256:1e962c6038ba2568a3d6b9a53cfdcd64ed326876012c44f1e65ed34e2aa9677d,1657 11 | - http-client-0.5.14@sha256:4880b27d6741e331454a1d4c887d96ce3d7d625322c8433983a4b1cd08538577,5348 12 | -------------------------------------------------------------------------------- /tests/Network/AWS/S3/Cache/LocalSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.AWS.S3.Cache.LocalSpec (spec) where 2 | 3 | import Data.List as L 4 | import Network.AWS.S3.Cache.Local 5 | import System.FilePath (isDrive, joinPath) 6 | import Test.Hspec 7 | import Test.QuickCheck 8 | 9 | newtype FilePathSplit = FilePathSplit [FilePath] 10 | 11 | instance Show FilePathSplit where 12 | show (FilePathSplit fps) = joinPath fps 13 | 14 | root :: FilePath 15 | root = if isDrive "/" then "/" else "C:\\" 16 | 17 | instance Arbitrary FilePathSplit where 18 | arbitrary = do 19 | Positive (Small depth) <- arbitrary 20 | FilePathSplit <$> vectorOf depth (sublistOf (['a'..'g'] ++ ['A'..'G'])) 21 | 22 | prop_subpathsRemoval :: FilePathSplit -> FilePathSplit -> Property 23 | prop_subpathsRemoval (FilePathSplit fps1) (FilePathSplit fps2) = 24 | removeSubpaths (joinPath fps1withRoot : [joinPath (fps1withRoot ++ fps2)]) === 25 | [joinPath fps1withRoot] .&&. 26 | removeSubpaths (joinPath (fps2withRoot ++ fps1) : [joinPath fps2withRoot]) === 27 | [joinPath fps2withRoot] 28 | where 29 | fps1withRoot = root : fps1 30 | fps2withRoot = root : fps2 31 | 32 | prop_seblingPathsKeeping :: FilePathSplit -> FilePathSplit -> Property 33 | prop_seblingPathsKeeping (FilePathSplit fps1) (FilePathSplit fps2) = 34 | removeSubpaths nonSubpaths1 === L.sort nonSubpaths1 .&&. 35 | removeSubpaths nonSubpaths2 === L.sort nonSubpaths2 36 | where 37 | nonSubpaths1 = joinPath (fps1withRoot ++ ["foo"]) : [joinPath (fps1withRoot ++ fps2)] 38 | nonSubpaths2 = joinPath (fps1modWithRoot) : [joinPath (fps1withRoot ++ fps2)] 39 | fps1withRoot = root : fps1 40 | fps1modWithRoot = root : (init fps1 ++ [last fps1 ++ "foo"]) 41 | 42 | 43 | spec :: Spec 44 | spec = do 45 | describe "Local file collection and archiving" $ do 46 | it "Removal of duplicate subpaths" $ property prop_subpathsRemoval 47 | it "Keeping of sebling paths" $ property prop_seblingPathsKeeping 48 | it "Unit test for discovered issue #9" $ do 49 | removeSubpaths [".ghc", ".ghcjs"] `shouldBe` [".ghc", ".ghcjs"] 50 | removeSubpaths [".ghcjs", ".ghc"] `shouldBe` [".ghc", ".ghcjs"] 51 | removeSubpaths [".ghc", ".ghcjs", ".ghc"] `shouldBe` [".ghc", ".ghcjs"] 52 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------