├── .github └── workflows │ ├── haskell-ci.yml │ └── hlint.yml ├── .gitignore ├── .gitmodules ├── .hindent.yaml ├── .hlint.yaml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── Bench.hs ├── cabal.haskell-ci ├── cabal.project ├── package.yaml ├── src ├── Data │ ├── Store.hs │ └── Store │ │ ├── Impl.hs │ │ ├── Internal.hs │ │ ├── TH.hs │ │ ├── TH │ │ └── Internal.hs │ │ ├── TypeHash.hs │ │ ├── TypeHash │ │ └── Internal.hs │ │ └── Version.hs └── System │ └── IO │ └── ByteBuffer.hs ├── stack-7.10.yaml ├── stack-8.10.yaml ├── stack-8.2.yaml ├── stack-8.8.yaml ├── stack-issue-179.yaml ├── stack.yaml ├── store-core ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── package.yaml ├── src │ └── Data │ │ └── Store │ │ └── Core.hs └── store-core.cabal ├── store-streaming ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── Setup.hs ├── package.yaml ├── src │ └── Data │ │ └── Store │ │ ├── Streaming.hs │ │ └── Streaming │ │ └── Internal.hs ├── stack.yaml ├── store-streaming.cabal └── test │ ├── Data │ └── Store │ │ └── StreamingSpec.hs │ └── Spec.hs ├── store.cabal └── test ├── Allocations.hs ├── Data ├── Store │ └── UntrustedSpec.hs ├── StoreSpec.hs └── StoreSpec │ └── TH.hs ├── Spec.hs └── System └── IO └── ByteBufferSpec.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.16.5 12 | # 13 | # REGENDATA ("0.16.5",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-20.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:bionic 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.4.5 36 | compilerKind: ghc 37 | compilerVersion: 9.4.5 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.2.8 41 | compilerKind: ghc 42 | compilerVersion: 9.2.8 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.0.2 46 | compilerKind: ghc 47 | compilerVersion: 9.0.2 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-8.10.7 51 | compilerKind: ghc 52 | compilerVersion: 8.10.7 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-8.8.4 56 | compilerKind: ghc 57 | compilerVersion: 8.8.4 58 | setup-method: hvr-ppa 59 | allow-failure: false 60 | - compiler: ghc-8.6.5 61 | compilerKind: ghc 62 | compilerVersion: 8.6.5 63 | setup-method: hvr-ppa 64 | allow-failure: false 65 | - compiler: ghc-8.4.4 66 | compilerKind: ghc 67 | compilerVersion: 8.4.4 68 | setup-method: hvr-ppa 69 | allow-failure: false 70 | fail-fast: false 71 | steps: 72 | - name: apt 73 | run: | 74 | apt-get update 75 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 76 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 77 | mkdir -p "$HOME/.ghcup/bin" 78 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" 79 | chmod a+x "$HOME/.ghcup/bin/ghcup" 80 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 81 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 82 | else 83 | apt-add-repository -y 'ppa:hvr/ghc' 84 | apt-get update 85 | apt-get install -y "$HCNAME" 86 | mkdir -p "$HOME/.ghcup/bin" 87 | curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" 88 | chmod a+x "$HOME/.ghcup/bin/ghcup" 89 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 90 | fi 91 | env: 92 | HCKIND: ${{ matrix.compilerKind }} 93 | HCNAME: ${{ matrix.compiler }} 94 | HCVER: ${{ matrix.compilerVersion }} 95 | - name: Set PATH and environment variables 96 | run: | 97 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 98 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 99 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 100 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 101 | HCDIR=/opt/$HCKIND/$HCVER 102 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 103 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 104 | echo "HC=$HC" >> "$GITHUB_ENV" 105 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 106 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 107 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 108 | else 109 | HC=$HCDIR/bin/$HCKIND 110 | echo "HC=$HC" >> "$GITHUB_ENV" 111 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 112 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 113 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 114 | fi 115 | 116 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 117 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 118 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 119 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 120 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 121 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 122 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 123 | env: 124 | HCKIND: ${{ matrix.compilerKind }} 125 | HCNAME: ${{ matrix.compiler }} 126 | HCVER: ${{ matrix.compilerVersion }} 127 | - name: env 128 | run: | 129 | env 130 | - name: write cabal config 131 | run: | 132 | mkdir -p $CABAL_DIR 133 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 166 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 167 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 168 | rm -f cabal-plan.xz 169 | chmod a+x $HOME/.cabal/bin/cabal-plan 170 | cabal-plan --version 171 | - name: checkout 172 | uses: actions/checkout@v3 173 | with: 174 | path: source 175 | - name: initial cabal.project for sdist 176 | run: | 177 | touch cabal.project 178 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 179 | echo "packages: $GITHUB_WORKSPACE/source/store-core" >> cabal.project 180 | echo "packages: $GITHUB_WORKSPACE/source/store-streaming" >> cabal.project 181 | cat cabal.project 182 | - name: sdist 183 | run: | 184 | mkdir -p sdist 185 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 186 | - name: unpack 187 | run: | 188 | mkdir -p unpacked 189 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 190 | - name: generate cabal.project 191 | run: | 192 | PKGDIR_store="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/store-[0-9.]*')" 193 | echo "PKGDIR_store=${PKGDIR_store}" >> "$GITHUB_ENV" 194 | PKGDIR_store_core="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/store-core-[0-9.]*')" 195 | echo "PKGDIR_store_core=${PKGDIR_store_core}" >> "$GITHUB_ENV" 196 | PKGDIR_store_streaming="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/store-streaming-[0-9.]*')" 197 | echo "PKGDIR_store_streaming=${PKGDIR_store_streaming}" >> "$GITHUB_ENV" 198 | rm -f cabal.project cabal.project.local 199 | touch cabal.project 200 | touch cabal.project.local 201 | echo "packages: ${PKGDIR_store}" >> cabal.project 202 | echo "packages: ${PKGDIR_store_core}" >> cabal.project 203 | echo "packages: ${PKGDIR_store_streaming}" >> cabal.project 204 | echo "package store" >> cabal.project 205 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 206 | echo "package store-core" >> cabal.project 207 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 208 | echo "package store-streaming" >> cabal.project 209 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 210 | cat >> cabal.project <> cabal.project.local 213 | cat cabal.project 214 | cat cabal.project.local 215 | - name: dump install plan 216 | run: | 217 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 218 | cabal-plan 219 | - name: restore cache 220 | uses: actions/cache/restore@v3 221 | with: 222 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 223 | path: ~/.cabal/store 224 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 225 | - name: install dependencies 226 | run: | 227 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 228 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 229 | - name: build w/o tests 230 | run: | 231 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 232 | - name: build 233 | run: | 234 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 235 | - name: tests 236 | run: | 237 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 238 | - name: haddock 239 | run: | 240 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 241 | - name: unconstrained build 242 | run: | 243 | rm -f cabal.project.local 244 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 245 | - name: save cache 246 | uses: actions/cache/save@v3 247 | if: always() 248 | with: 249 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 250 | path: ~/.cabal/store 251 | -------------------------------------------------------------------------------- /.github/workflows/hlint.yml: -------------------------------------------------------------------------------- 1 | name: hlint 2 | 3 | on: 4 | pull_request: 5 | push: 6 | 7 | jobs: 8 | build: 9 | name: hlint 10 | runs-on: ubuntu-latest 11 | 12 | steps: 13 | - uses: actions/checkout@v3 14 | with: 15 | submodules: true 16 | 17 | - uses: haskell/actions/hlint-setup@v2 18 | name: Set up HLint 19 | with: 20 | version: "3.5" 21 | 22 | - uses: haskell/actions/hlint-run@v2 23 | name: hlint 24 | with: 25 | path: '["bench/", "src/", "store-core/", "store-streaming/", "test/"]' 26 | fail-on: suggestion 27 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | .stack-work/ 17 | *.yaml.lock 18 | dist-newstyle/ 19 | 20 | stack-9.0.1.yaml 21 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mgsloan/store/d1523267ca12f5bc5c836d6b66f3af8c9bdf51d2/.gitmodules -------------------------------------------------------------------------------- /.hindent.yaml: -------------------------------------------------------------------------------- 1 | indent-size: 4 2 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # Warnings currently triggered by your code 2 | - ignore: {name: "Avoid lambda"} # 2 hints 3 | - ignore: {name: "Eta reduce"} # 2 hints 4 | - ignore: {name: "Evaluate"} # 1 hint 5 | - ignore: {name: "Fuse mapM_/map"} # 1 hint 6 | - ignore: {name: "Redundant $"} # 2 hints 7 | - ignore: {name: "Redundant bang pattern"} # 2 hints 8 | - ignore: {name: "Redundant bracket"} # 9 hints 9 | - ignore: {name: "Redundant where"} # 1 hint 10 | - ignore: {name: "Unused LANGUAGE pragma"} # 5 hints 11 | - ignore: {name: "Use <$>"} # 2 hints 12 | - ignore: {name: "Use const"} # 4 hints 13 | - ignore: {name: "Use infix"} # 1 hint 14 | - ignore: {name: "Use lambda-case"} # 3 hints 15 | - ignore: {name: "Use list comprehension"} # 1 hint 16 | - ignore: {name: "Use uncurry"} # 1 hint 17 | - ignore: {name: "Use zipWith"} # 1 hint -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog 2 | 3 | ## 0.7.20 4 | 5 | * Fixes build of test with `vector-0.13.2.0`. See [#181][]. 6 | 7 | [#181]: https://github.com/mgsloan/store/issues/181 8 | 9 | ## 0.7.19 10 | 11 | * Adds support for `vector-0.13.2.0`. See [#179][]. 12 | 13 | [#174]: https://github.com/mgsloan/store/issues/179 14 | 15 | ## 0.7.16 16 | 17 | * Adds support for `vector-0.13.0.0`. See [#174][]. 18 | 19 | [#174]: https://github.com/mgsloan/store/issues/174 20 | 21 | 22 | ## 0.7.15 23 | 24 | * Adds support for `text >= 2`. See [#170][]. 25 | 26 | [#170]: https://github.com/mgsloan/store/issues/170 27 | 28 | 29 | ## 0.7.14 30 | 31 | * Fixes build with ghc-8.10 (broken in last release due to differences 32 | in TH API). See [#165][]. 33 | 34 | [#165]: https://github.com/mgsloan/store/issues/165 35 | 36 | 37 | ## 0.7.13 38 | 39 | * Fix build with `time >= 1.11`. See [#162][]. 40 | 41 | * Adds missing `liftTyped` method for `Lift TypeHash`. See [#163][]. 42 | 43 | [#162]: https://github.com/mgsloan/store/issues/162 44 | [#163]: https://github.com/mgsloan/store/issues/163 45 | 46 | ## 0.7.12 47 | 48 | * Build with ghc-9.0.1 49 | 50 | ## 0.7.11 51 | 52 | * Fixes testsuite compilation with `network >= 3.1.2`. See [#159][]. 53 | 54 | ## 0.7.10 55 | 56 | * Adds `Store` instances for all serializable datatypes exported by 57 | the `time` library. See [#158][]. 58 | 59 | [#158]: https://github.com/mgsloan/store/issues/158 60 | 61 | ## 0.7.9 62 | 63 | * Attempts to fix build on ghc-7.8.4. See [#157][]. 64 | 65 | [#157]: https://github.com/mgsloan/store/issues/157 66 | 67 | ## 0.7.8 68 | 69 | * Adds a `Store` instance for `Natural`. See [#154][]. 70 | 71 | [#154]: https://github.com/mgsloan/store/issues/154 72 | 73 | ## 0.7.7 74 | 75 | * Test now compiles with `smallcheck >= 1.2` and `base >= 4.14`. 76 | See [#153][]. 77 | 78 | [#153]: https://github.com/fpco/store/issues/153 79 | 80 | ## 0.7.6 81 | 82 | * Now only depends on `fail` / `semigroups` shim for `ghc < 8`. 83 | 84 | ## 0.7.4 85 | 86 | * Fix for compilation with `ghc-8.10` in `0.7.3` did not use enough 87 | CPP, and so broke builds for older versions. This release fixes 88 | that. 89 | 90 | ## 0.7.3 91 | 92 | * Fixes compilation with `ghc-8.10`, particularly 93 | `template-haskell-2.16.0.0`. See [#149][]. 94 | 95 | [#149]: https://github.com/fpco/store/issues/149 96 | 97 | ## 0.7.2 98 | 99 | * Fixes compilation with `vector >= 0.12.1.1` by making 100 | `deriveManyStoreUnboxVector` capable of handling more complex 101 | instance constraints. In particular, it now correctly generates 102 | instances `Store (Vector (f (g a))) => Store (Vector (Compose f g 103 | a))` and `Store (Vector (f a)) => Store (Vector (Alt f a))`. 104 | 105 | ## 0.7.1 106 | 107 | * Fixes compilation with GHC-7.10 due to it not defining `Generic` 108 | instances for `Complex` and `Identity`. See [#142][]. 109 | 110 | * Documents some gotchas about using store vs other libraries 111 | 112 | [#142]: https://github.com/fpco/store/issues/142 113 | 114 | ## 0.7.0 115 | 116 | * Fixes a bug where the `Store` instances for `Identity`, `Const`, and 117 | `Complex` all have `Storable` superclasses instead of `Store. See 118 | [#143][]. 119 | 120 | [#143]: https://github.com/fpco/store/issues/143 121 | 122 | ## 0.6.1 123 | 124 | * Can now optionally be built with `integer-simple` instead of 125 | `integer-gmp`, via the `integer-simple` cabal flag. Note that the 126 | serialization of `Integer` with `integer-simple` differs from what 127 | is used by the GMP default. See [#147][]. 128 | 129 | [#147]: https://github.com/fpco/store/pull/147 130 | 131 | ## 0.6.0.1 132 | 133 | * Now builds with GHC-7.10 - compatibility was broken in 0.6.0 due to 134 | the fix for GHC-8.8. See 135 | [#146][https://github.com/fpco/store/issues/146]. 136 | 137 | ## 0.6.0 138 | 139 | * Now builds with GHC-8.8. This is a major version bump because 140 | MonadFail constraints were added to some functions, which is 141 | potentially a breaking change. 142 | 143 | ## 0.5.1.2 144 | 145 | * Fixes compilation with GHC < 8.0. See 146 | [#142](https://github.com/fpco/store/issues/142). 147 | 148 | ## 0.5.1.1 149 | 150 | * Update to the instances for generics, to improve error messages for 151 | sum types with more than 255 constructors. See 152 | [#141](https://github.com/fpco/store/issues/141) 153 | 154 | ## 0.5.1.0 155 | 156 | * Update to TH to support sum types with more than 62 constructors. 157 | 158 | * Uses TH to derive Either instance, so that it can sometimes have ConstSize #119. 159 | 160 | ## 0.5.0.1 161 | 162 | * Updates to test-suite enabling `store` to build with newer dependencies. 163 | 164 | ## 0.5.0 165 | 166 | * `Data.Store.Streaming` moved to a separate package, `store-streaming`. 167 | 168 | ## 0.4.3.2 169 | 170 | * Buildable with GHC 8.2 171 | 172 | * Fix to haddock formatting of Data.Store.TH code example 173 | 174 | ## 0.4.3.1 175 | 176 | * Fixed compilation on GHC 7.8 177 | 178 | ## 0.4.3 179 | 180 | * Less aggressive inlining, resulting in faster compilation / simplifier 181 | not running out of ticks 182 | 183 | ## 0.4.2 184 | 185 | * Fixed testsuite 186 | 187 | ## 0.4.1 188 | 189 | * Breaking change in the encoding of Map / Set / IntMap / IntSet, 190 | to use ascending key order. Attempting to decode data written by 191 | prior versions of store (and vice versa) will almost always fail 192 | with a decent error message. If you're unlucky enough to have a 193 | collision in the data with a random Word32 magic number, then the 194 | error may not be so clear, or in extremely rare cases, 195 | successfully decode, yielding incorrect results. See 196 | [#97](https://github.com/fpco/store/issues/97) and 197 | [#101](https://github.com/fpco/store/pull/101). 198 | 199 | 200 | * Performance improvement of the 'Peek' monad, by introducing more 201 | strictness. This required a change to the internal API. 202 | 203 | * API and behavior of 'Data.Store.Version' changed. Previously, it 204 | would check the version tag after decoding the contents. It now 205 | also stores a magic Word32 tag at the beginning, so that it fails 206 | more gracefully when decoding input that lacks encoded version 207 | info. 208 | 209 | ## 0.4.0 210 | 211 | Deprecated in favor of 0.4.1 212 | 213 | ## 0.3.1 214 | 215 | * Fix to derivation of primitive vectors, only relevant when built with 216 | primitive-0.6.2.0 or later 217 | 218 | * Removes INLINE pragmas on the generic default methods. This 219 | dramatically improves compilation time on recent GHC versions. 220 | See [#91](https://github.com/fpco/store/issues/91). 221 | 222 | * Adds `instance Contravariant Size` 223 | 224 | ## 0.3 225 | 226 | * Uses store-core-0.3.*, which has support for alignment sensitive 227 | architectures. 228 | 229 | * Adds support for streaming decode from file descriptor, not supported on 230 | windows. As part of this addition, the API for "Data.Store.Streaming" has 231 | changed. 232 | 233 | ## 0.2.1.2 234 | 235 | * Fixes a bug that could could result in attempting to malloc a negative 236 | number of bytes when reading corrupted data. 237 | 238 | ## 0.2.1.1 239 | 240 | * Fixes a bug that could result in segfaults when reading corrupted data. 241 | 242 | ## 0.2.1.0 243 | 244 | Release notes: 245 | 246 | * Adds experimental `Data.Store.Version` and deprecates `Data.Store.TypeHash`. 247 | The new functionality is similar to TypeHash, but there are much fewer false 248 | positives of hashes changing. 249 | 250 | Other enhancements: 251 | 252 | * Now exports types related to generics 253 | 254 | ## 0.2.0.0 255 | 256 | Release notes: 257 | 258 | * Core functionality split into `store-core` package 259 | 260 | Breaking changes: 261 | 262 | * `combineSize'` renamed to `combineSizeWith` 263 | 264 | * Streaming support now prefixes each Message with a magic number, intended to 265 | detect mis-alignment of data frames. This is worth the overhead, because 266 | otherwise serialization errors could be more catastrophic - interpretting some 267 | bytes as a length tag and attempting to consume many bytes from the source. 268 | 269 | Other enhancements: 270 | 271 | * [weigh](https://github.com/fpco/weigh) based allocations benchmark. 272 | 273 | * Addition of `Array` / `UArray` instances 274 | 275 | * Streaming support now has checks for over/undershooting buffer 276 | 277 | Bug fixes: 278 | 279 | 280 | ## 0.1.0.0 281 | 282 | * First public release 283 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 FP Complete 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # store 2 | 3 | The 'store' package provides efficient binary serialization. There are 4 | a couple features that particularly distinguish it from most prior 5 | Haskell serialization libraries: 6 | 7 | * Its primary goal is speed. By default, direct machine 8 | representations are used for things like numeric values (`Int`, 9 | `Double`, `Word32`, etc) and buffers (`Text`, `ByteString`, 10 | `Vector`, etc). This means that much of serialization uses the 11 | equivalent of `memcpy`. 12 | 13 | We have plans for supporting architecture independent 14 | serialization - see [#36](https://github.com/fpco/store/issues/36) 15 | and [#31](https://github.com/fpco/store/issues/31). This plan makes 16 | little endian the default, so that the most common endianness has no 17 | overhead. 18 | 19 | - Another way that the serialization behavior can vary is if 20 | integer-simple is used instead of GHC's default of using 21 | GMP. `Integer` serialized with the `integer-simple` flag enabled 22 | are not compatible with those serialized without the flag enabled. 23 | 24 | * Instead of implementing lazy serialization / deserialization 25 | involving multiple input / output buffers, `peek` and `poke` always 26 | work with a single buffer. This buffer is allocated by asking the 27 | value for its size before encoding. This simplifies the encoding 28 | logic, and allows for highly optimized tight loops. 29 | 30 | * `store` can optimize size computations by knowing when some types 31 | always use the same number of bytes. This allows us to compute the 32 | byte size of a `Vector Int32` by just doing `length v * 4`. 33 | 34 | It also features: 35 | 36 | * Optimized serialization instances for many types from base, vector, 37 | bytestring, text, containers, time, template-haskell, and more. 38 | 39 | * TH and GHC Generics based generation of Store instances for 40 | datatypes. 41 | 42 | * TH generation of testcases. 43 | 44 | * Utilities for streaming encoding / decoding of Store encoded 45 | messages, via the `store-streaming` package. 46 | 47 | ## Gotchas 48 | 49 | Store is best used for communication between trusted processes and 50 | local caches. It can certainly be used for other purposes, but the 51 | builtin set of instances have some gotchas to be aware of: 52 | 53 | * Store's builtin instances serialize in a format which depends on 54 | machine endianness. 55 | 56 | * Store's builtin instances trust the data when deserializing. For 57 | example, the deserialization of `Vector` will read the vector's 58 | length from the first 8 bytes. It will then allocate enough memory 59 | to store all the elements. Malicious or malformed input could cause 60 | allocation of large amounts of memory. See [issue #122][]. 61 | 62 | * Serialization may vary based on the version of datatypes. For 63 | example, `Text` serialized from `text < 2` will not be compatible 64 | with `Text` from `text >= 2`, because the internal representation 65 | switched from UTF-16 to UTF-8. 66 | 67 | [issue #122]: https://github.com/fpco/store/issues/122 68 | 69 | ## Blog posts 70 | 71 | * [Initial release announcement](https://www.fpcomplete.com/blog/2016/05/store-package) 72 | * [Benchmarks of the prototype](https://www.fpcomplete.com/blog/2016/03/efficient-binary-serialization) 73 | * [New 'weigh' allocation benchmark package](https://www.fpcomplete.com/blog/2016/05/weigh-package), 74 | created particularly to aid optimizing `store`. 75 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Bench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | 7 | #if !MIN_VERSION_base(4,8,0) 8 | {-# LANGUAGE DeriveDataTypeable #-} 9 | import Control.Applicative ((<$>), (<*>), (*>)) 10 | #endif 11 | 12 | import Control.DeepSeq 13 | import Criterion.Main 14 | import qualified Data.ByteString as BS 15 | import Data.Int 16 | import qualified Data.IntMap.Strict as IntMap 17 | import qualified Data.IntSet as IntSet 18 | import qualified Data.Map.Strict as Map 19 | import qualified Data.Set as Set 20 | import Data.Store 21 | import Data.Typeable 22 | import qualified Data.Vector as V 23 | import qualified Data.Vector.Storable as SV 24 | import Data.Word 25 | import GHC.Generics 26 | 27 | #if COMPARISON_BENCH 28 | import qualified Data.Binary as Binary 29 | import qualified Data.Serialize as Cereal 30 | import qualified Data.ByteString.Lazy as BL 31 | import Data.Vector.Serialize () 32 | #endif 33 | 34 | data SomeData = SomeData !Int64 !Word8 !Double 35 | deriving (Eq, Show, Generic, Typeable) 36 | instance NFData SomeData where 37 | rnf x = x `seq` () 38 | instance Store SomeData 39 | #if COMPARISON_BENCH 40 | instance Cereal.Serialize SomeData 41 | instance Binary.Binary SomeData 42 | #endif 43 | 44 | main :: IO () 45 | main = do 46 | #if SMALL_BENCH 47 | let is = 0::Int 48 | sds = SomeData 1 1 1 49 | smallprods = (SmallProduct 0 1 2 3) 50 | smallmanualprods = (SmallProductManual 0 1 2 3) 51 | sss = [SS1 1, SS2 2, SS3 3, SS4 4] 52 | ssms = [SSM1 1, SSM2 2, SSM3 3, SSM4 4] 53 | nestedTuples = ((1,2),(3,4)) :: ((Int,Int),(Int,Int)) 54 | #else 55 | let is = V.enumFromTo 1 100 :: V.Vector Int 56 | sds = (\i -> SomeData i (fromIntegral i) (fromIntegral i)) 57 | <$> V.enumFromTo 1 100 58 | smallprods = (\ i -> SmallProduct i (i+1) (i+2) (i+3)) 59 | <$> V.enumFromTo 1 100 60 | smallmanualprods = (\ i -> SmallProductManual i (i+1) (i+2) (i+3)) 61 | <$> V.enumFromTo 1 100 62 | sss = (\i -> case i `mod` 4 of 63 | 0 -> SS1 (fromIntegral i) 64 | 1 -> SS2 (fromIntegral i) 65 | 2 -> SS3 (fromIntegral i) 66 | 3 -> SS4 (fromIntegral i) 67 | _ -> error "This does not compute." 68 | ) <$> V.enumFromTo 1 (100 :: Int) 69 | ssms = (\i -> case i `mod` 4 of 70 | 0 -> SSM1 (fromIntegral i) 71 | 1 -> SSM2 (fromIntegral i) 72 | 2 -> SSM3 (fromIntegral i) 73 | 3 -> SSM4 (fromIntegral i) 74 | _ -> error "This does not compute." 75 | ) <$> V.enumFromTo 1 (100 :: Int) 76 | nestedTuples = (\i -> ((i,i+1),(i+2,i+3))) <$> V.enumFromTo (1::Int) 100 77 | 78 | ints = [1..100] :: [Int] 79 | pairs = map (\x -> (x, x)) ints 80 | strings = show <$> ints 81 | intsSet = Set.fromDistinctAscList ints 82 | intSet = IntSet.fromDistinctAscList ints 83 | intsMap = Map.fromDistinctAscList pairs 84 | intMap = IntMap.fromDistinctAscList pairs 85 | stringsSet = Set.fromList strings 86 | stringsMap = Map.fromList (zip strings ints) 87 | #endif 88 | defaultMain 89 | [ bgroup "encode" 90 | [ benchEncode is 91 | #if !SMALL_BENCH 92 | , benchEncode' "1kb storable" (SV.fromList ([1..256] :: [Int32])) 93 | , benchEncode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32])) 94 | , benchEncode' "1kb normal" (V.fromList ([1..256] :: [Int32])) 95 | , benchEncode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32])) 96 | , benchEncode intsSet 97 | , benchEncode intSet 98 | , benchEncode intsMap 99 | , benchEncode intMap 100 | , benchEncode stringsSet 101 | , benchEncode stringsMap 102 | #endif 103 | , benchEncode smallprods 104 | , benchEncode smallmanualprods 105 | , benchEncode sss 106 | , benchEncode ssms 107 | , benchEncode nestedTuples 108 | , benchEncode sds 109 | ] 110 | , bgroup "decode" 111 | [ benchDecode is 112 | #if !SMALL_BENCH 113 | , benchDecode' "1kb storable" (SV.fromList ([1..256] :: [Int32])) 114 | , benchDecode' "10kb storable" (SV.fromList ([1..(256 * 10)] :: [Int32])) 115 | , benchDecode' "1kb normal" (V.fromList ([1..256] :: [Int32])) 116 | , benchDecode' "10kb normal" (V.fromList ([1..(256 * 10)] :: [Int32])) 117 | , benchDecode intsSet 118 | , benchDecode intSet 119 | , benchDecode intsMap 120 | , benchDecode intMap 121 | , benchDecode stringsSet 122 | , benchDecode stringsMap 123 | #endif 124 | , benchDecode smallprods 125 | , benchDecode smallmanualprods 126 | , benchDecode sss 127 | , benchDecode ssms 128 | , benchDecode nestedTuples 129 | , benchDecode sds 130 | ] 131 | ] 132 | 133 | type Ctx a = 134 | ( Store a, Typeable a, NFData a 135 | #if COMPARISON_BENCH 136 | , Binary.Binary a 137 | , Cereal.Serialize a 138 | #endif 139 | ) 140 | 141 | benchEncode :: Ctx a => a -> Benchmark 142 | benchEncode = benchEncode' "" 143 | 144 | benchEncode' :: Ctx a => String -> a -> Benchmark 145 | benchEncode' msg x0 = 146 | env (return x0) $ \x -> 147 | let label = msg ++ " (" ++ show (typeOf x0) ++ ")" 148 | benchStore name = bench name (nf encode x) in 149 | #if COMPARISON_BENCH 150 | bgroup label 151 | [ benchStore "store" 152 | , bench "cereal" (nf Cereal.encode x) 153 | , bench "binary" (nf Binary.encode x) 154 | ] 155 | #else 156 | benchStore label 157 | #endif 158 | 159 | benchDecode :: Ctx a => a -> Benchmark 160 | benchDecode = benchDecode' "" 161 | 162 | benchDecode' :: forall a. Ctx a => String -> a -> Benchmark 163 | #if COMPARISON_BENCH 164 | benchDecode' prefix x0 = 165 | bgroup label 166 | [ env (return (encode x0)) $ \x -> bench "store" (nf (decodeEx :: BS.ByteString -> a) x) 167 | , env (return (Cereal.encode x0)) $ \x -> bench "cereal" (nf ((ensureRight . Cereal.decode) :: BS.ByteString -> a) x) 168 | , env (return (Binary.encode x0)) $ \x -> bench "binary" (nf (Binary.decode :: BL.ByteString -> a) x) 169 | ] 170 | where 171 | label = prefix ++ " (" ++ show (typeOf x0) ++ ")" 172 | ensureRight (Left x) = error "left!" 173 | ensureRight (Right x) = x 174 | #else 175 | benchDecode' prefix x0 = 176 | env (return (encode x0)) $ \x -> 177 | bench (prefix ++ " (" ++ show (typeOf x0) ++ ")") (nf (decodeEx :: BS.ByteString -> a) x) 178 | #endif 179 | 180 | ------------------------------------------------------------------------ 181 | -- Serialized datatypes 182 | 183 | data SmallProduct = SmallProduct Int32 Int32 Int32 Int32 184 | deriving (Generic, Show, Typeable) 185 | 186 | instance NFData SmallProduct 187 | instance Store SmallProduct 188 | 189 | data SmallProductManual = SmallProductManual Int32 Int32 Int32 Int32 190 | deriving (Generic, Show, Typeable) 191 | 192 | instance NFData SmallProductManual 193 | instance Store SmallProductManual where 194 | size = ConstSize 16 195 | peek = SmallProductManual <$> peek <*> peek <*> peek <*> peek 196 | poke (SmallProductManual a b c d) = poke a *> poke b *> poke c *> poke d 197 | 198 | data SmallSum 199 | = SS1 Int8 200 | | SS2 Int32 201 | | SS3 Int64 202 | | SS4 Word32 203 | deriving (Generic, Show, Typeable) 204 | 205 | instance NFData SmallSum 206 | instance Store SmallSum 207 | 208 | data SmallSumManual 209 | = SSM1 Int8 210 | | SSM2 Int32 211 | | SSM3 Int64 212 | | SSM4 Word32 213 | deriving (Generic, Show, Typeable) 214 | 215 | instance NFData SmallSumManual 216 | instance Store SmallSumManual where 217 | size = VarSize $ \x -> 1 + case x of 218 | SSM1{} -> 1 219 | SSM2{} -> 4 220 | SSM3{} -> 8 221 | SSM4{} -> 4 222 | peek = do 223 | tag <- peek 224 | case tag :: Word8 of 225 | 0 -> SSM1 <$> peek 226 | 1 -> SSM2 <$> peek 227 | 2 -> SSM3 <$> peek 228 | 3 -> SSM4 <$> peek 229 | _ -> fail "Invalid tag" 230 | poke (SSM1 x) = poke (0 :: Word8) >> poke x 231 | poke (SSM2 x) = poke (1 :: Word8) >> poke x 232 | poke (SSM3 x) = poke (2 :: Word8) >> poke x 233 | poke (SSM4 x) = poke (3 :: Word8) >> poke x 234 | 235 | #if COMPARISON_BENCH 236 | instance Binary.Binary SmallProduct 237 | instance Binary.Binary SmallSum 238 | instance Cereal.Serialize SmallProduct 239 | instance Cereal.Serialize SmallSum 240 | 241 | instance Binary.Binary SmallProductManual where 242 | get = SmallProductManual <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get 243 | put (SmallProductManual a b c d) = Binary.put a *> Binary.put b *> Binary.put c *> Binary.put d 244 | 245 | instance Binary.Binary SmallSumManual where 246 | get = do 247 | tag <- Binary.get 248 | case tag :: Word8 of 249 | 0 -> SSM1 <$> Binary.get 250 | 1 -> SSM2 <$> Binary.get 251 | 2 -> SSM3 <$> Binary.get 252 | 3 -> SSM4 <$> Binary.get 253 | _ -> fail "Invalid tag" 254 | put (SSM1 x) = Binary.put (0 :: Word8) *> Binary.put x 255 | put (SSM2 x) = Binary.put (1 :: Word8) *> Binary.put x 256 | put (SSM3 x) = Binary.put (2 :: Word8) *> Binary.put x 257 | put (SSM4 x) = Binary.put (3 :: Word8) *> Binary.put x 258 | 259 | instance Cereal.Serialize SmallProductManual where 260 | get = SmallProductManual <$> Cereal.get <*> Cereal.get <*> Cereal.get <*> Cereal.get 261 | put (SmallProductManual a b c d) = Cereal.put a *> Cereal.put b *> Cereal.put c *> Cereal.put d 262 | 263 | instance Cereal.Serialize SmallSumManual where 264 | get = do 265 | tag <- Cereal.get 266 | case tag :: Word8 of 267 | 0 -> SSM1 <$> Cereal.get 268 | 1 -> SSM2 <$> Cereal.get 269 | 2 -> SSM3 <$> Cereal.get 270 | 3 -> SSM4 <$> Cereal.get 271 | _ -> fail "Invalid tag" 272 | put (SSM1 x) = Cereal.put (0 :: Word8) *> Cereal.put x 273 | put (SSM2 x) = Cereal.put (1 :: Word8) *> Cereal.put x 274 | put (SSM3 x) = Cereal.put (2 :: Word8) *> Cereal.put x 275 | put (SSM4 x) = Cereal.put (3 :: Word8) *> Cereal.put x 276 | #endif 277 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | -- Configuration for haskell-ci 2 | 3 | branches: master 4 | 5 | -- `cabal-check` doesn't like `-O2` 6 | cabal-check: False 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | . 3 | store-core 4 | store-streaming 5 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: store 2 | version: "0.7.20" 3 | synopsis: Fast binary serialization 4 | maintainer: Michael Sloan 5 | license: MIT 6 | copyright: 2016 FP Complete 7 | github: mgsloan/store 8 | category: Serialization, Data 9 | extra-source-files: 10 | - ChangeLog.md 11 | - README.md 12 | tested-with: 13 | - GHC==9.4.5 14 | - GHC==9.2.8 15 | - GHC==9.0.2 16 | - GHC==8.10.7 17 | - GHC==8.8.4 18 | - GHC==8.6.5 19 | - GHC==8.4.4 20 | 21 | flags: 22 | comparison-bench: 23 | default: false 24 | manual: true 25 | 26 | small-bench: 27 | default: false 28 | manual: true 29 | 30 | integer-simple: 31 | description: >- 32 | Use the [simple integer library](http://hackage.haskell.org/package/integer-simple) 33 | instead of [integer-gmp](http://hackage.haskell.org/package/integer-gmp) 34 | default: False 35 | manual: False 36 | 37 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 38 | 39 | dependencies: 40 | # Meaningful constraints. 41 | - base >=4.7 && <5 42 | 43 | # Core package tightly coupled to this package 44 | - store-core >=0.4 && <0.5 45 | 46 | # Utilities package tightly coupled to the TH code 47 | - th-utilities >=0.2 48 | 49 | # Due to removal of 'internal' from MonadPrim in 0.6 50 | - primitive >=0.6 51 | 52 | # Due to behavior change for reification errors 53 | - th-reify-many >=0.1.6 54 | 55 | # Lower bounds based on 7.8 config. 56 | - array >=0.5.0.0 57 | - base-orphans >=0.4.3 58 | - base64-bytestring >= 0.1.1 59 | - bytestring >=0.10.4.0 60 | - containers >=0.5.5.1 61 | - cryptohash-sha1 >=0.11.6 62 | - deepseq >=1.3.0.2 63 | - directory >= 1.2 64 | - filepath >= 1.3 65 | - ghc-prim >=0.3.1.0 66 | - hashable >=1.2.3.1 67 | - hspec >=2.1.2 68 | - hspec-smallcheck >=0.3.0 69 | - lifted-base >=0.2.3.3 70 | - monad-control >=0.3.3.0 71 | - mono-traversable >=0.7.0 72 | - nats >=1 73 | - resourcet >=1.1.3.3 74 | - safe >=0.3.8 75 | - smallcheck >=1.1.1 76 | - syb >=0.4.4 77 | - template-haskell >=2.9.0.0 78 | - text >=1.2.0.4 79 | - th-lift >=0.7.1 80 | - th-lift-instances >=0.1.4 81 | - th-orphans >= 0.13.2 82 | - time >=1.5 83 | - transformers >=0.3.0.0 84 | - unordered-containers >=0.2.5.1 85 | - vector >=0.10.12.3 86 | - void >=0.5.11 87 | - free >=4.11 88 | - network >=2.6.0.2 89 | - async >=2.0.2 90 | - contravariant >=1.3 91 | - bifunctors >=4.0 92 | when: 93 | # NOTE: The serialization of Integer is different when this flag is enabled. 94 | - condition: flag(integer-simple) 95 | then: 96 | dependencies: integer-simple >= 0.1.1.1 97 | else: 98 | dependencies: integer-gmp >= 0.5.1.0 99 | cpp-options: -DINTEGER_GMP 100 | - condition: impl(ghc < 8.0) 101 | dependencies: 102 | - fail >=4.9 103 | - semigroups >=0.8 104 | library: 105 | source-dirs: src 106 | other-modules: 107 | - Data.Store.Impl 108 | 109 | tests: 110 | store-test: 111 | source-dirs: test 112 | main: Spec.hs 113 | other-modules: 114 | - Data.Store.UntrustedSpec 115 | - Data.StoreSpec 116 | - Data.StoreSpec.TH 117 | - System.IO.ByteBufferSpec 118 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 119 | dependencies: 120 | - store 121 | - clock >=0.3 122 | build-tools: hspec-discover:hspec-discover 123 | 124 | benchmarks: 125 | store-bench: 126 | source-dirs: bench 127 | main: Bench.hs 128 | ghc-options: -threaded -rtsopts -with-rtsopts=-N1 -with-rtsopts=-s -with-rtsopts=-qg 129 | dependencies: 130 | - criterion 131 | - store 132 | when: 133 | - condition: flag(comparison-bench) 134 | dependencies: 135 | - cereal 136 | - binary 137 | - vector-binary-instances 138 | - cereal-vector 139 | cpp-options: -DCOMPARISON_BENCH 140 | - condition: flag(small-bench) 141 | cpp-options: -DSMALL_BENCH 142 | store-weigh: 143 | source-dirs: test 144 | main: Allocations.hs 145 | other-modules: [] 146 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -O2 147 | dependencies: 148 | - store 149 | - weigh 150 | - criterion 151 | - cereal 152 | - cereal-vector 153 | - vector-binary-instances 154 | -------------------------------------------------------------------------------- /src/Data/Store.hs: -------------------------------------------------------------------------------- 1 | -- | This is the main public API of the store package. The functions 2 | -- exported here are more likely to be stable between versions. 3 | -- 4 | -- Usually you won't need to write your own 'Store' instances, and 5 | -- instead can rely on either using the 'Generic' deriving approach or 6 | -- "Data.Store.TH" for defining 'Store' instances for your datatypes. 7 | -- There are some tradeoffs here - the generics instances do not require 8 | -- @-XTemplateHaskell@, but they do not optimize as well for sum types 9 | -- that only require a constant number of bytes. 10 | -- 11 | -- If you need streaming encode / decode of multiple store encoded 12 | -- messages, take a look at the @store-streaming@ package. 13 | -- 14 | -- = Gotchas 15 | -- 16 | -- Store is best used for communication between trusted processes and 17 | -- local caches. It can certainly be used for other purposes, but the 18 | -- builtin set of instances have some gotchas to be aware of: 19 | -- 20 | -- * Store's builtin instances serialize in a format which depends on 21 | -- machine endianness. 22 | -- 23 | -- * Store's builtin instances trust the data when deserializing. For 24 | -- example, the deserialization of `Vector` will read the vector's 25 | -- link from the first 8 bytes. It will then allocate enough memory 26 | -- to store all the elements. Malicious or malformed input could 27 | -- cause allocation of large amounts of memory. See 28 | -- https://github.com/fpco/store/issues/122 29 | module Data.Store 30 | ( 31 | -- * Encoding and decoding strict ByteStrings. 32 | encode, 33 | decode, decodeWith, 34 | decodeEx, decodeExWith, decodeExPortionWith, 35 | decodeIO, decodeIOWith, decodeIOPortionWith 36 | -- * Store class and related types. 37 | , Store(..), Size(..), Poke, Peek 38 | , GStoreSize, GStorePoke, GStorePeek 39 | -- ** Exceptions thrown by Peek 40 | , PeekException(..), peekException 41 | ) where 42 | 43 | import Data.Store.Internal 44 | -------------------------------------------------------------------------------- /src/Data/Store/Impl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DefaultSignatures #-} 6 | {-# LANGUAGE DeriveDataTypeable #-} 7 | {-# LANGUAGE EmptyCase #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | 17 | -- This module is not exposed. The reason that it is split out from 18 | -- "Data.Store.Internal" is to allow "Data.Store.TH" to refer to these 19 | -- identifiers. "Data.Store.Internal" must be separate from 20 | -- "Data.Store.TH" due to Template Haskell's stage restriction. 21 | module Data.Store.Impl where 22 | 23 | import Control.Applicative 24 | import Control.Exception (try) 25 | import Control.Monad 26 | import qualified Data.ByteString as BS 27 | import Data.Functor.Contravariant (Contravariant(..)) 28 | import Data.Proxy 29 | import Data.Store.Core 30 | import Data.Typeable (Typeable, typeRep) 31 | import Data.Word 32 | import Foreign.Storable (Storable, sizeOf) 33 | import GHC.Exts (Constraint) 34 | import GHC.Generics 35 | import GHC.TypeLits 36 | import Prelude 37 | import System.IO.Unsafe (unsafePerformIO) 38 | 39 | ------------------------------------------------------------------------ 40 | -- Store class 41 | 42 | -- | The 'Store' typeclass provides efficient serialization and 43 | -- deserialization to raw pointer addresses. 44 | -- 45 | -- The 'peek' and 'poke' methods should be defined such that 46 | -- @ decodeEx (encode x) == x @. 47 | class Store a where 48 | -- | Yields the 'Size' of the buffer, in bytes, required to store 49 | -- the encoded representation of the type. 50 | -- 51 | -- Note that the correctness of this function is crucial for the 52 | -- safety of 'poke', as it does not do any bounds checking. It is 53 | -- the responsibility of the invoker of 'poke' ('encode' and similar 54 | -- functions) to ensure that there's enough space in the output 55 | -- buffer. If 'poke' writes beyond, then arbitrary memory can be 56 | -- overwritten, causing undefined behavior and segmentation faults. 57 | size :: Size a 58 | -- | Serializes a value to bytes. It is the responsibility of the 59 | -- caller to ensure that at least the number of bytes required by 60 | -- 'size' are available. These details are handled by 'encode' and 61 | -- similar utilities. 62 | poke :: a -> Poke () 63 | -- | Serialized a value from bytes, throwing exceptions if it 64 | -- encounters invalid data or runs out of input bytes. 65 | peek :: Peek a 66 | 67 | default size :: (Generic a, GStoreSize (Rep a)) => Size a 68 | size = genericSize 69 | 70 | default poke :: (Generic a, GStorePoke (Rep a)) => a -> Poke () 71 | poke = genericPoke 72 | 73 | default peek :: (Generic a , GStorePeek (Rep a)) => Peek a 74 | peek = genericPeek 75 | 76 | -- NB: Do not INLINE the default implementations of size, poke, or peek! 77 | -- Doing so can lead to enormous memory blowup (a maximum residency of 78 | -- 5.17 GB with GHC 8.0.2 has been observed). For more information, please 79 | -- read issue #91. 80 | 81 | ------------------------------------------------------------------------ 82 | -- Utilities for encoding / decoding strict ByteStrings 83 | 84 | -- | Serializes a value to a 'BS.ByteString'. In order to do this, it 85 | -- first allocates a 'BS.ByteString' of the correct size (based on 86 | -- 'size'), and then uses 'poke' to fill it. 87 | -- 88 | -- Safety of this function depends on correctness of the 'Store' 89 | -- instance. If 'size' returns a. The good news is that this isn't an 90 | -- issue if you use well-tested manual instances (such as those from 91 | -- this package) combined with auomatic definition of instances. 92 | encode :: Store a => a -> BS.ByteString 93 | encode x = unsafeEncodeWith (poke x) (getSize x) 94 | 95 | -- | Decodes a value from a 'BS.ByteString'. Returns an exception if 96 | -- there's an error while decoding, or if decoding undershoots / 97 | -- overshoots the end of the buffer. 98 | decode :: Store a => BS.ByteString -> Either PeekException a 99 | decode = unsafePerformIO . try . decodeIO 100 | 101 | -- | Decodes a value from a 'BS.ByteString', potentially throwing 102 | -- exceptions. It is an exception to not consume all input. 103 | decodeEx :: Store a => BS.ByteString -> a 104 | decodeEx = unsafePerformIO . decodeIO 105 | 106 | -- | Decodes a value from a 'BS.ByteString', potentially throwing 107 | -- exceptions. It is an exception to not consume all input. 108 | decodeIO :: Store a => BS.ByteString -> IO a 109 | decodeIO = decodeIOWith peek 110 | 111 | ------------------------------------------------------------------------ 112 | -- Size 113 | 114 | -- | Info about a type's serialized length. Either the length is known 115 | -- independently of the value, or the length depends on the value. 116 | data Size a 117 | = VarSize (a -> Int) 118 | | ConstSize !Int 119 | deriving Typeable 120 | 121 | instance Contravariant Size where 122 | contramap f sz = case sz of 123 | ConstSize n -> ConstSize n 124 | VarSize g -> VarSize (\x -> g (f x)) 125 | 126 | -- | Get the number of bytes needed to store the given value. See 127 | -- 'size'. 128 | getSize :: Store a => a -> Int 129 | getSize = getSizeWith size 130 | {-# INLINE getSize #-} 131 | 132 | -- | Given a 'Size' value and a value of the type @a@, returns its 'Int' 133 | -- size. 134 | getSizeWith :: Size a -> a -> Int 135 | getSizeWith (VarSize f) x = f x 136 | getSizeWith (ConstSize n) _ = n 137 | {-# INLINE getSizeWith #-} 138 | 139 | -- | Create an aggregate 'Size' by providing functions to split the 140 | -- input into two pieces. 141 | -- 142 | -- If both of the types are 'ConstSize', the result is 'ConstSize' and 143 | -- the functions will not be used. 144 | combineSize :: forall a b c. (Store a, Store b) => (c -> a) -> (c -> b) -> Size c 145 | combineSize toA toB = combineSizeWith toA toB size size 146 | {-# INLINE combineSize #-} 147 | 148 | -- | Create an aggregate 'Size' by providing functions to split the 149 | -- input into two pieces, as well as 'Size' values to use to measure the 150 | -- results. 151 | -- 152 | -- If both of the input 'Size' values are 'ConstSize', the result is 153 | -- 'ConstSize' and the functions will not be used. 154 | combineSizeWith :: forall a b c. (c -> a) -> (c -> b) -> Size a -> Size b -> Size c 155 | combineSizeWith toA toB sizeA sizeB = 156 | case (sizeA, sizeB) of 157 | (VarSize f, VarSize g) -> VarSize (\x -> f (toA x) + g (toB x)) 158 | (VarSize f, ConstSize m) -> VarSize (\x -> f (toA x) + m) 159 | (ConstSize n, VarSize g) -> VarSize (\x -> n + g (toB x)) 160 | (ConstSize n, ConstSize m) -> ConstSize (n + m) 161 | {-# INLINE combineSizeWith #-} 162 | 163 | -- | Adds a constant amount to a 'Size' value. 164 | addSize :: Int -> Size a -> Size a 165 | addSize x (ConstSize n) = ConstSize (x + n) 166 | addSize x (VarSize f) = VarSize ((x +) . f) 167 | {-# INLINE addSize #-} 168 | 169 | -- | A 'size' implementation based on an instance of 'Storable' and 170 | -- 'Typeable'. 171 | sizeStorable :: forall a. (Storable a, Typeable a) => Size a 172 | sizeStorable = sizeStorableTy (show (typeRep (Proxy :: Proxy a))) 173 | {-# INLINE sizeStorable #-} 174 | 175 | -- | A 'size' implementation based on an instance of 'Storable'. Use this 176 | -- if the type is not 'Typeable'. 177 | sizeStorableTy :: forall a. Storable a => String -> Size a 178 | sizeStorableTy ty = ConstSize (sizeOf (error msg :: a)) 179 | where 180 | msg = "In Data.Store.storableSize: " ++ ty ++ "'s sizeOf evaluated its argument." 181 | {-# INLINE sizeStorableTy #-} 182 | 183 | ------------------------------------------------------------------------ 184 | -- Generics 185 | 186 | genericSize :: (Generic a, GStoreSize (Rep a)) => Size a 187 | genericSize = contramap from gsize 188 | {-# INLINE genericSize #-} 189 | 190 | genericPoke :: (Generic a, GStorePoke (Rep a)) => a -> Poke () 191 | genericPoke = gpoke . from 192 | {-# INLINE genericPoke #-} 193 | 194 | genericPeek :: (Generic a , GStorePeek (Rep a)) => Peek a 195 | genericPeek = to <$> gpeek 196 | {-# INLINE genericPeek #-} 197 | 198 | type family SumArity (a :: * -> *) :: Nat where 199 | SumArity (C1 c a) = 1 200 | SumArity (x :+: y) = SumArity x + SumArity y 201 | 202 | -- This could be just one typeclass, but currently compile times are 203 | -- better with things split up. 204 | -- https://github.com/bos/aeson/pull/335 205 | -- 206 | 207 | class GStoreSize f where gsize :: Size (f a) 208 | class GStorePoke f where gpoke :: f a -> Poke () 209 | class GStorePeek f where gpeek :: Peek (f a) 210 | 211 | instance GStoreSize f => GStoreSize (M1 i c f) where 212 | gsize = contramap unM1 gsize 213 | {-# INLINE gsize #-} 214 | instance GStorePoke f => GStorePoke (M1 i c f) where 215 | gpoke = gpoke . unM1 216 | {-# INLINE gpoke #-} 217 | instance GStorePeek f => GStorePeek (M1 i c f) where 218 | gpeek = fmap M1 gpeek 219 | {-# INLINE gpeek #-} 220 | 221 | instance Store a => GStoreSize (K1 i a) where 222 | gsize = contramap unK1 size 223 | {-# INLINE gsize #-} 224 | instance Store a => GStorePoke (K1 i a) where 225 | gpoke = poke . unK1 226 | {-# INLINE gpoke #-} 227 | instance Store a => GStorePeek (K1 i a) where 228 | gpeek = fmap K1 peek 229 | {-# INLINE gpeek #-} 230 | 231 | instance GStoreSize U1 where 232 | gsize = ConstSize 0 233 | {-# INLINE gsize #-} 234 | instance GStorePoke U1 where 235 | gpoke _ = return () 236 | {-# INLINE gpoke #-} 237 | instance GStorePeek U1 where 238 | gpeek = return U1 239 | {-# INLINE gpeek #-} 240 | 241 | instance GStoreSize V1 where 242 | gsize = ConstSize 0 243 | {-# INLINE gsize #-} 244 | instance GStorePoke V1 where 245 | gpoke x = case x of {} 246 | {-# INLINE gpoke #-} 247 | instance GStorePeek V1 where 248 | gpeek = undefined 249 | {-# INLINE gpeek #-} 250 | 251 | instance (GStoreSize a, GStoreSize b) => GStoreSize (a :*: b) where 252 | gsize = combineSizeWith (\(x :*: _) -> x) (\(_ :*: y) -> y) gsize gsize 253 | {-# INLINE gsize #-} 254 | instance (GStorePoke a, GStorePoke b) => GStorePoke (a :*: b) where 255 | gpoke (a :*: b) = gpoke a >> gpoke b 256 | {-# INLINE gpoke #-} 257 | instance (GStorePeek a, GStorePeek b) => GStorePeek (a :*: b) where 258 | gpeek = (:*:) <$> gpeek <*> gpeek 259 | {-# INLINE gpeek #-} 260 | 261 | -- The machinery for sum types is why UndecidableInstances is necessary. 262 | 263 | instance (FitsInByte (SumArity (a :+: b)), GStoreSizeSum 0 (a :+: b)) 264 | => GStoreSize (a :+: b) where 265 | gsize = VarSize $ \x -> sizeOf (undefined :: Word8) + gsizeSum x (Proxy :: Proxy 0) 266 | {-# INLINE gsize #-} 267 | instance (FitsInByte (SumArity (a :+: b)), GStorePokeSum 0 (a :+: b)) 268 | => GStorePoke (a :+: b) where 269 | gpoke x = gpokeSum x (Proxy :: Proxy 0) 270 | {-# INLINE gpoke #-} 271 | instance (FitsInByte (SumArity (a :+: b)), GStorePeekSum 0 (a :+: b)) 272 | => GStorePeek (a :+: b) where 273 | gpeek = do 274 | tag <- peekStorable 275 | gpeekSum tag (Proxy :: Proxy 0) 276 | {-# INLINE gpeek #-} 277 | 278 | -- See https://github.com/fpco/store/issues/141 - this constraint type 279 | -- family machinery improves error messages for generic deriving on 280 | -- sum types with many constructors. 281 | 282 | type FitsInByte n = FitsInByteResult (n <=? 255) 283 | 284 | type family FitsInByteResult (b :: Bool) :: Constraint where 285 | FitsInByteResult 'True = () 286 | FitsInByteResult 'False = TypeErrorMessage 287 | "Generic deriving of Store instances can only be used on datatypes with fewer than 256 constructors." 288 | 289 | type family TypeErrorMessage (a :: Symbol) :: Constraint where 290 | #if MIN_VERSION_base(4,9,0) 291 | TypeErrorMessage a = TypeError ('Text a) 292 | -- GHC < 8.0 does not support empty closed type families 293 | #elif __GLASGOW_HASKELL__ < 800 294 | TypeErrorMessage a = a ~ "" 295 | #endif 296 | 297 | -- Similarly to splitting up the generic class into multiple classes, we 298 | -- also split up the one for sum types. 299 | 300 | class KnownNat n => GStoreSizeSum (n :: Nat) (f :: * -> *) where gsizeSum :: f a -> Proxy n -> Int 301 | class KnownNat n => GStorePokeSum (n :: Nat) (f :: * -> *) where gpokeSum :: f p -> Proxy n -> Poke () 302 | class KnownNat n => GStorePeekSum (n :: Nat) (f :: * -> *) where gpeekSum :: Word8 -> Proxy n -> Peek (f p) 303 | 304 | instance (GStoreSizeSum n a, GStoreSizeSum (n + SumArity a) b, KnownNat n) 305 | => GStoreSizeSum n (a :+: b) where 306 | gsizeSum (L1 l) _ = gsizeSum l (Proxy :: Proxy n) 307 | gsizeSum (R1 r) _ = gsizeSum r (Proxy :: Proxy (n + SumArity a)) 308 | {-# INLINE gsizeSum #-} 309 | instance (GStorePokeSum n a, GStorePokeSum (n + SumArity a) b, KnownNat n) 310 | => GStorePokeSum n (a :+: b) where 311 | gpokeSum (L1 l) _ = gpokeSum l (Proxy :: Proxy n) 312 | gpokeSum (R1 r) _ = gpokeSum r (Proxy :: Proxy (n + SumArity a)) 313 | {-# INLINE gpokeSum #-} 314 | instance (GStorePeekSum n a, GStorePeekSum (n + SumArity a) b, KnownNat n) 315 | => GStorePeekSum n (a :+: b) where 316 | gpeekSum tag proxyL 317 | | tag < sizeL = L1 <$> gpeekSum tag proxyL 318 | | otherwise = R1 <$> gpeekSum tag (Proxy :: Proxy (n + SumArity a)) 319 | where 320 | sizeL = fromInteger (natVal (Proxy :: Proxy (n + SumArity a))) 321 | {-# INLINE gpeekSum #-} 322 | 323 | instance (GStoreSize a, KnownNat n) => GStoreSizeSum n (C1 c a) where 324 | gsizeSum x _ = getSizeWith gsize x 325 | {-# INLINE gsizeSum #-} 326 | instance (GStorePoke a, KnownNat n) => GStorePokeSum n (C1 c a) where 327 | gpokeSum x _ = do 328 | pokeStorable (fromInteger (natVal (Proxy :: Proxy n)) :: Word8) 329 | gpoke x 330 | {-# INLINE gpokeSum #-} 331 | instance (GStorePeek a, KnownNat n) => GStorePeekSum n (C1 c a) where 332 | gpeekSum tag _ 333 | | tag == cur = gpeek 334 | | tag > cur = peekException "Sum tag invalid" 335 | | otherwise = peekException "Error in implementation of Store Generics" 336 | where 337 | cur = fromInteger (natVal (Proxy :: Proxy n)) 338 | {-# INLINE gpeekSum #-} 339 | -------------------------------------------------------------------------------- /src/Data/Store/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | This module exports TH utilities intended to be useful to users. 4 | -- 5 | -- 'makeStore' can be used to generate a 'Store' instance for types, 6 | -- when all the type variables also require 'Store' instances. If some 7 | -- do not, then instead use "TH.Derive" like this: 8 | -- 9 | -- @ 10 | -- \{\-\# LANGUAGE TemplateHaskell \#\-\} 11 | -- \{\-\# LANGUAGE ScopedTypeVariables \#\-\} 12 | -- 13 | -- import TH.Derive 14 | -- import Data.Store 15 | -- 16 | -- data Foo a = Foo a | Bar Int 17 | -- 18 | -- \$($(derive [d| 19 | -- instance Store a => Deriving (Store (Foo a)) 20 | -- |])) 21 | -- @ 22 | -- 23 | -- Note that when used with datatypes that require type variables, the 24 | -- ScopedTypeVariables extension is required. 25 | -- 26 | -- One advantage of using this Template Haskell definition of Store 27 | -- instances is that in some cases they can be faster than the instances 28 | -- defined via Generics. Specifically, sum types which can yield 29 | -- 'ConstSize' from 'size' will be faster when used in array-like types. 30 | -- The instances generated via generics always use 'VarSize' for sum 31 | -- types. 32 | module Data.Store.TH 33 | ( makeStore 34 | -- * Testing Store instances 35 | , smallcheckManyStore 36 | , checkRoundtrip 37 | , assertRoundtrip 38 | ) where 39 | 40 | import qualified Control.Monad.Fail as Fail 41 | import Data.Complex () 42 | import Data.Store.Impl 43 | import Data.Typeable (Typeable, typeOf) 44 | import Debug.Trace (trace) 45 | import Language.Haskell.TH 46 | import Prelude 47 | import Test.Hspec 48 | import Test.Hspec.SmallCheck (property) 49 | import Test.SmallCheck 50 | import Data.Store.TH.Internal (makeStore) 51 | 52 | ------------------------------------------------------------------------ 53 | -- Testing 54 | 55 | -- | Test a 'Store' instance using 'smallcheck' and 'hspec'. 56 | smallcheckManyStore :: Bool -> Int -> [TypeQ] -> ExpQ 57 | smallcheckManyStore verbose depth = smallcheckMany . map testRoundtrip 58 | where 59 | testRoundtrip tyq = do 60 | ty <- tyq 61 | expr <- [e| property $ changeDepth (\_ -> depth) $ \x -> checkRoundtrip verbose (x :: $(return ty)) |] 62 | return ("Roundtrips (" ++ pprint ty ++ ")", expr) 63 | 64 | assertRoundtrip :: (Eq a, Show a, Store a, Fail.MonadFail m, Typeable a) => Bool -> a -> m () 65 | assertRoundtrip verbose x 66 | | checkRoundtrip verbose x = return () 67 | | otherwise = fail $ "Failed to roundtrip " ++ show (typeOf x) 68 | 69 | -- | Check if a given value succeeds in decoding its encoded 70 | -- representation. 71 | checkRoundtrip :: (Eq a, Show a, Store a) => Bool -> a -> Bool 72 | checkRoundtrip verbose x = decoded == Right x 73 | where 74 | encoded = verboseTrace verbose "encoded" (encode x) 75 | decoded = verboseTrace verbose "decoded" (decode encoded) 76 | 77 | smallcheckMany :: [Q (String, Exp)] -> ExpQ 78 | smallcheckMany = doE . map (\f -> f >>= \(name, expr) -> noBindS [e| it name $ $(return expr) |]) 79 | 80 | verboseTrace :: Show a => Bool -> String -> a -> a 81 | verboseTrace True msg x = trace (show (msg, x)) x 82 | verboseTrace False _ x = x 83 | -------------------------------------------------------------------------------- /src/Data/Store/TH/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE ParallelListComp #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | module Data.Store.TH.Internal 11 | ( 12 | -- * TH functions for generating Store instances 13 | deriveManyStoreFromStorable 14 | , deriveTupleStoreInstance 15 | , deriveGenericInstance 16 | , deriveGenericInstanceFromName 17 | , deriveManyStorePrimVector 18 | , deriveManyStoreUnboxVector 19 | , deriveStore 20 | , makeStore 21 | -- * Misc utilties used in Store test 22 | , getAllInstanceTypes1 23 | , isMonoType 24 | ) where 25 | 26 | import Control.Applicative 27 | import Data.Complex () 28 | import Data.Generics.Aliases (extT, mkQ, extQ) 29 | import Data.Generics.Schemes (listify, everywhere, something) 30 | import Data.List (find) 31 | import qualified Data.Map as M 32 | import Data.Maybe (fromMaybe, isJust, mapMaybe) 33 | import Data.Primitive.ByteArray 34 | import Data.Primitive.Types 35 | import Data.Store.Core 36 | import Data.Store.Impl 37 | import qualified Data.Text as T 38 | import Data.Traversable (forM) 39 | import qualified Data.Vector.Primitive as PV 40 | import qualified Data.Vector.Unboxed as UV 41 | import Data.Word 42 | import Foreign.Storable (Storable) 43 | import GHC.Types (Int(..)) 44 | import Language.Haskell.TH 45 | import Language.Haskell.TH.ReifyMany.Internal (TypeclassInstance(..), getInstances, unAppsT) 46 | import Language.Haskell.TH.Syntax (lift) 47 | import Prelude 48 | import Safe (headMay) 49 | import TH.Derive (Deriver(..)) 50 | import TH.ReifySimple 51 | import TH.Utilities (expectTyCon1, dequalify, plainInstanceD, appsT) 52 | 53 | instance Deriver (Store a) where 54 | runDeriver _ preds ty = do 55 | argTy <- expectTyCon1 ''Store ty 56 | dt <- reifyDataTypeSubstituted argTy 57 | (:[]) <$> deriveStore preds argTy (dtCons dt) 58 | 59 | -- | Given the name of a type, generate a Store instance for it, 60 | -- assuming that all type variables also need to be Store instances. 61 | -- 62 | -- Note that when used with datatypes that require type variables, the 63 | -- ScopedTypeVariables extension is required. 64 | makeStore :: Name -> Q [Dec] 65 | makeStore name = do 66 | dt <- reifyDataType name 67 | let preds = map (storePred . VarT) (dtTvs dt) 68 | argTy = appsT (ConT name) (map VarT (dtTvs dt)) 69 | (:[]) <$> deriveStore preds argTy (dtCons dt) 70 | 71 | deriveStore :: Cxt -> Type -> [DataCon] -> Q Dec 72 | deriveStore preds headTy cons0 = 73 | makeStoreInstance preds headTy 74 | <$> sizeExpr 75 | <*> peekExpr 76 | <*> pokeExpr 77 | where 78 | cons :: [(Name, [(Name, Type)])] 79 | cons = 80 | [ ( dcName dc 81 | , [ (mkName ("c" ++ show ixc ++ "f" ++ show ixf), ty) 82 | | ixf <- ints 83 | | (_, ty) <- dcFields dc 84 | ] 85 | ) 86 | | ixc <- ints 87 | | dc <- cons0 88 | ] 89 | -- NOTE: tag code duplicated in th-storable. 90 | (tagType, _, tagSize) = 91 | fromMaybe (error "Too many constructors") $ 92 | find (\(_, maxN, _) -> maxN >= length cons) tagTypes 93 | tagTypes :: [(Name, Int, Int)] 94 | tagTypes = 95 | [ ('(), 1, 0) 96 | , (''Word8, fromIntegral (maxBound :: Word8), 1) 97 | , (''Word16, fromIntegral (maxBound :: Word16), 2) 98 | , (''Word32, fromIntegral (maxBound :: Word32), 4) 99 | , (''Word64, fromIntegral (maxBound :: Word64), 8) 100 | ] 101 | fName ix = mkName ("f" ++ show ix) 102 | ints = [0..] :: [Int] 103 | fNames = map fName ints 104 | sizeNames = zipWith (\_ -> mkName . ("sz" ++) . show) cons ints 105 | tagName = mkName "tag" 106 | valName = mkName "val" 107 | sizeExpr 108 | -- Maximum size of GHC tuples 109 | | length cons <= 62 = 110 | caseE (tupE (concatMap (map sizeAtType . snd) cons)) 111 | (case cons of 112 | -- Avoid overlapping matches when the case expression is () 113 | [] -> [matchConstSize] 114 | [c] | null (snd c) -> [matchConstSize] 115 | _ -> [matchConstSize, matchVarSize]) 116 | | otherwise = varSizeExpr 117 | where 118 | sizeAtType :: (Name, Type) -> ExpQ 119 | sizeAtType (_, ty) = [| size :: Size $(return ty) |] 120 | matchConstSize :: MatchQ 121 | matchConstSize = do 122 | let sz0 = VarE (mkName "sz0") 123 | sizeDecls = 124 | if null sizeNames 125 | then [valD (varP (mkName "sz0")) (normalB [| 0 |]) []] 126 | else zipWith constSizeDec sizeNames cons 127 | sameSizeExpr <- 128 | case sizeNames of 129 | (_ : tailSizeNames) -> 130 | foldl (\l r -> [| $(l) && $(r) |]) [| True |] $ 131 | map (\szn -> [| $(return sz0) == $(varE szn) |]) tailSizeNames 132 | [] -> [| True |] 133 | result <- [| ConstSize (tagSize + $(return sz0)) |] 134 | match (tupP (map (\(n, _) -> conP 'ConstSize [varP n]) 135 | (concatMap snd cons))) 136 | (guardedB [return (NormalG sameSizeExpr, result)]) 137 | sizeDecls 138 | constSizeDec :: Name -> (Name, [(Name, Type)]) -> DecQ 139 | constSizeDec szn (_, []) = 140 | valD (varP szn) (normalB [| 0 |]) [] 141 | constSizeDec szn (_, fields) = 142 | valD (varP szn) body [] 143 | where 144 | body = normalB $ 145 | foldl1 (\l r -> [| $(l) + $(r) |]) $ 146 | map (\(sizeName, _) -> varE sizeName) fields 147 | matchVarSize :: MatchQ 148 | matchVarSize = do 149 | match (tupP (map (\(n, _) -> varP n) (concatMap snd cons))) 150 | (normalB varSizeExpr) 151 | [] 152 | varSizeExpr :: ExpQ 153 | varSizeExpr = 154 | [| VarSize $ \x -> tagSize + $(caseE [| x |] (map matchVar cons)) |] 155 | matchVar :: (Name, [(Name, Type)]) -> MatchQ 156 | matchVar (cname, []) = 157 | match (conP cname []) (normalB [| 0 |]) [] 158 | matchVar (cname, fields) = 159 | match (conP cname (zipWith (\_ fn -> varP fn) fields fNames)) 160 | body 161 | [] 162 | where 163 | body = normalB $ 164 | foldl1 (\l r -> [| $(l) + $(r) |]) 165 | (zipWith (\(sizeName, _) fn -> [| getSizeWith $(varE sizeName) $(varE fn) |]) 166 | fields 167 | fNames) 168 | -- Choose a tag size large enough for this constructor count. 169 | -- Expression used for the definition of peek. 170 | peekExpr = case cons of 171 | [] -> [| error ("Attempting to peek type with no constructors (" ++ $(lift (show headTy)) ++ ")") |] 172 | [con] -> peekCon con 173 | _ -> doE 174 | [ bindS (varP tagName) [| peek |] 175 | , noBindS (caseE (sigE (varE tagName) (conT tagType)) 176 | (map peekMatch (zip [0..] cons) ++ [peekErr])) 177 | ] 178 | peekMatch (ix, con) = match (litP (IntegerL ix)) (normalB (peekCon con)) [] 179 | peekErr = match wildP (normalB 180 | [| peekException $ T.pack $ "Found invalid tag while peeking (" ++ $(lift (show headTy)) ++ ")" |]) [] 181 | peekCon (cname, fields) = 182 | case fields of 183 | [] -> [| pure $(conE cname) |] 184 | _ -> doE $ 185 | map (\(fn, _) -> bindS (varP fn) [| peek |]) fields ++ 186 | [noBindS $ appE (varE 'return) $ appsE $ conE cname : map (\(fn, _) -> varE fn) fields] 187 | pokeExpr = lamE [varP valName] $ caseE (varE valName) $ zipWith pokeCon [0..] cons 188 | pokeCon :: Int -> (Name, [(Name, Type)]) -> MatchQ 189 | pokeCon ix (cname, fields) = 190 | match (conP cname (map (\(fn, _) -> varP fn) fields)) body [] 191 | where 192 | body = normalB $ 193 | case cons of 194 | (_:_:_) -> doE (pokeTag ix : map pokeField fields) 195 | _ -> doE (map pokeField fields) 196 | pokeTag ix = noBindS [| poke (ix :: $(conT tagType)) |] 197 | pokeField (fn, _) = noBindS [| poke $(varE fn) |] 198 | 199 | {- What the generated code looks like 200 | 201 | data Foo = Foo Int Double Float 202 | 203 | instance Store Foo where 204 | size = 205 | case (size :: Size Int, size :: Size Double, size :: Size Float) of 206 | (ConstSize c0f0, ConstSize c0f1, ConstSize c0f2) -> ConstSize (0 + sz0) 207 | where 208 | sz0 = c0f0 + c0f1 + c0f2 209 | (c0f0, c0f1, c0f2) 210 | VarSize $ \(Foo f0 f1 f2) -> 0 + 211 | getSizeWith c0f0 f0 + getSizeWith c0f1 f1 + getSizeWith c0f2 f2 212 | peek = do 213 | f0 <- peek 214 | f1 <- peek 215 | f2 <- peek 216 | return (Foo f0 f1 f2) 217 | poke (Foo f0 f1 f2) = do 218 | poke f0 219 | poke f1 220 | poke f2 221 | 222 | data Bar = Bar Int | Baz Double 223 | 224 | instance Store Bar where 225 | size = 226 | case (size :: Size Int, size :: Size Double) of 227 | (ConstSize c0f0, ConstSize c1f0) | sz0 == sz1 -> ConstSize (1 + sz0) 228 | where 229 | sz0 = c0f0 230 | sz1 = c1f0 231 | (c0f0, c1f0) -> VarSize $ \x -> 1 + 232 | case x of 233 | Bar f0 -> getSizeWith c0f0 f0 234 | Baz f0 -> getSizeWith c1f0 f0 235 | peek = do 236 | tag <- peek 237 | case (tag :: Word8) of 238 | 0 -> do 239 | f0 <- peek 240 | return (Bar f0) 241 | 1 -> do 242 | f0 <- peek 243 | return (Baz f0) 244 | _ -> peekException "Found invalid tag while peeking (Bar)" 245 | poke (Bar f0) = do 246 | poke 0 247 | poke f0 248 | poke (Bar f0) = do 249 | poke 1 250 | poke f0 251 | -} 252 | 253 | ------------------------------------------------------------------------ 254 | -- Generic 255 | 256 | deriveTupleStoreInstance :: Int -> Dec 257 | deriveTupleStoreInstance n = 258 | deriveGenericInstance (map storePred tvs) 259 | (foldl1 AppT (TupleT n : tvs)) 260 | where 261 | tvs = take n (map (VarT . mkName . (:[])) ['a'..'z']) 262 | 263 | deriveGenericInstance :: Cxt -> Type -> Dec 264 | deriveGenericInstance cs ty = plainInstanceD cs (AppT (ConT ''Store) ty) [] 265 | 266 | deriveGenericInstanceFromName :: Name -> Q Dec 267 | deriveGenericInstanceFromName n = do 268 | tvs <- map VarT . dtTvs <$> reifyDataType n 269 | return $ deriveGenericInstance (map storePred tvs) (appsT (ConT n) tvs) 270 | 271 | ------------------------------------------------------------------------ 272 | -- Storable 273 | 274 | -- TODO: Generate inline pragmas? Probably not necessary 275 | 276 | deriveManyStoreFromStorable :: (Type -> Bool) -> Q [Dec] 277 | deriveManyStoreFromStorable p = do 278 | storables <- postprocess . instancesMap <$> getInstances ''Storable 279 | stores <- postprocess . instancesMap <$> getInstances ''Store 280 | return $ M.elems $ flip M.mapMaybe (storables `M.difference` stores) $ 281 | \(TypeclassInstance cs ty _) -> 282 | let argTy = head (tail (unAppsT ty)) 283 | tyNameLit = LitE (StringL (pprint ty)) in 284 | if p argTy && not (superclassHasStorable cs) 285 | then Just $ makeStoreInstance cs argTy 286 | (AppE (VarE 'sizeStorableTy) tyNameLit) 287 | (AppE (VarE 'peekStorableTy) tyNameLit) 288 | (VarE 'pokeStorable) 289 | else Nothing 290 | 291 | -- See #143. Often Storable superclass constraints should instead be 292 | -- Store constraints, so instead it just warns for these. 293 | superclassHasStorable :: Cxt -> Bool 294 | superclassHasStorable = isJust . something (mkQ Nothing justStorable `extQ` ignoreStrings) 295 | where 296 | justStorable :: Type -> Maybe () 297 | justStorable (ConT n) | n == ''Storable = Just () 298 | justStorable _ = Nothing 299 | ignoreStrings :: String -> Maybe () 300 | ignoreStrings _ = Nothing 301 | 302 | ------------------------------------------------------------------------ 303 | -- Vector 304 | 305 | deriveManyStorePrimVector :: Q [Dec] 306 | deriveManyStorePrimVector = do 307 | prims <- postprocess . instancesMap <$> getInstances ''PV.Prim 308 | stores <- postprocess . instancesMap <$> getInstances ''Store 309 | let primInsts = 310 | M.mapKeys (map (AppT (ConT ''PV.Vector))) prims 311 | `M.difference` 312 | stores 313 | forM (M.toList primInsts) $ \primInst -> case primInst of 314 | ([_], TypeclassInstance cs ty _) -> do 315 | let argTy = head (tail (unAppsT ty)) 316 | sizeExpr <- [| 317 | VarSize $ \x -> 318 | I# $(primSizeOfExpr (ConT ''Int)) + 319 | I# $(primSizeOfExpr argTy) * PV.length x 320 | |] 321 | peekExpr <- [| do 322 | len <- peek 323 | let sz = I# $(primSizeOfExpr argTy) 324 | array <- peekToByteArray $(lift ("Primitive Vector (" ++ pprint argTy ++ ")")) 325 | (len * sz) 326 | return (PV.Vector 0 len array) 327 | |] 328 | pokeExpr <- [| \(PV.Vector offset len (ByteArray array)) -> do 329 | let sz = I# $(primSizeOfExpr argTy) 330 | poke len 331 | pokeFromByteArray array (offset * sz) (len * sz) 332 | |] 333 | return $ makeStoreInstance cs (AppT (ConT ''PV.Vector) argTy) sizeExpr peekExpr pokeExpr 334 | _ -> fail "Invariant violated in derivemanyStorePrimVector" 335 | 336 | 337 | primSizeOfExpr :: Type -> ExpQ 338 | primSizeOfExpr ty = [| $(varE 'sizeOf#) (error "sizeOf# evaluated its argument" :: $(return ty)) |] 339 | 340 | deriveManyStoreUnboxVector :: Q [Dec] 341 | deriveManyStoreUnboxVector = do 342 | unboxes <- getUnboxInfo 343 | stores <- postprocess . instancesMap <$> getInstances ''Store 344 | unboxInstances <- postprocess . instancesMap <$> getInstances ''UV.Unbox 345 | let dataFamilyDecls = 346 | M.fromList (map (\(preds, ty, cons) -> ([AppT (ConT ''UV.Vector) ty], (preds, cons))) unboxes) 347 | `M.difference` 348 | stores 349 | #if MIN_VERSION_template_haskell(2,10,0) 350 | substituteConstraint (AppT (ConT n) arg) 351 | | n == ''UV.Unbox = AppT (ConT ''Store) (AppT (ConT ''UV.Vector) arg) 352 | #else 353 | substituteConstraint (ClassP n [arg]) 354 | | n == ''UV.Unbox = ClassP ''Store [AppT (ConT ''UV.Vector) arg] 355 | #endif 356 | substituteConstraint x = x 357 | -- TODO: ideally this would use a variant of 'deriveStore' which 358 | -- assumes VarSize. 359 | forM (M.toList dataFamilyDecls) $ \case 360 | ([ty], (_, cons)) -> do 361 | let headTy = getTyHead (unAppsT ty !! 1) 362 | (preds, ty') <- case M.lookup [headTy] unboxInstances of 363 | Nothing -> do 364 | reportWarning $ "No Unbox instance found for " ++ pprint headTy 365 | return ([], ty) 366 | Just (TypeclassInstance cs (AppT _ ty') _) -> case ty' of 367 | AppT (ConT conName) arg -> 368 | if nameBase conName `elem` doNotUnboxConstructors 369 | then return ([AppT (ConT ''Store) arg], AppT (ConT ''UV.Vector) ty') 370 | else return (map substituteConstraint cs, AppT (ConT ''UV.Vector) ty') 371 | _ -> return (map substituteConstraint cs, AppT (ConT ''UV.Vector) ty') 372 | Just _ -> fail "Impossible case" 373 | deriveStore preds ty' cons 374 | _ -> fail "impossible case in deriveManyStoreUnboxVector" 375 | 376 | -- TODO: Add something for this purpose to TH.ReifyDataType 377 | 378 | getUnboxInfo :: Q [(Cxt, Type, [DataCon])] 379 | getUnboxInfo = do 380 | FamilyI _ insts <- reify ''UV.Vector 381 | return (map (everywhere (id `extT` dequalVarT)) $ mapMaybe go insts) 382 | where 383 | #if MIN_VERSION_template_haskell(2,15,0) 384 | go (NewtypeInstD preds _ lhs _ con _) 385 | | [_, ty] <- unAppsT lhs 386 | = toResult preds ty [con] 387 | go (DataInstD preds _ lhs _ cons _) 388 | | [_, ty] <- unAppsT lhs 389 | = toResult preds ty cons 390 | #elif MIN_VERSION_template_haskell(2,11,0) 391 | go (NewtypeInstD preds _ [ty] _ con _) = toResult preds ty [con] 392 | go (DataInstD preds _ [ty] _ cons _) = toResult preds ty cons 393 | #else 394 | go (NewtypeInstD preds _ [ty] con _) = toResult preds ty [con] 395 | go (DataInstD preds _ [ty] cons _) = toResult preds ty cons 396 | #endif 397 | go x = error ("Unexpected result from reifying Unboxed Vector instances: " ++ pprint x) 398 | toResult :: Cxt -> Type -> [Con] -> Maybe (Cxt, Type, [DataCon]) 399 | toResult _ _ [NormalC conName _] 400 | | nameBase conName `elem` skippedUnboxConstructors = Nothing 401 | toResult preds ty cons 402 | = Just (preds, ty, concatMap conToDataCons cons) 403 | dequalVarT :: Type -> Type 404 | dequalVarT (VarT n) = VarT (dequalify n) 405 | dequalVarT ty = ty 406 | 407 | -- See issue #174 408 | skippedUnboxConstructors :: [String] 409 | skippedUnboxConstructors = ["MV_UnboxAs", "V_UnboxAs", "MV_UnboxViaPrim", "V_UnboxViaPrim"] 410 | 411 | -- See issue #179 412 | doNotUnboxConstructors :: [String] 413 | doNotUnboxConstructors = ["DoNotUnboxLazy","DoNotUnboxStrict","DoNotUnboxNormalForm"] 414 | 415 | ------------------------------------------------------------------------ 416 | -- Utilities 417 | 418 | -- Filters out overlapping instances and instances with more than one 419 | -- type arg (should be impossible). 420 | postprocess :: M.Map [Type] [a] -> M.Map [Type] a 421 | postprocess = 422 | M.mapMaybeWithKey $ \tys xs -> 423 | case (tys, xs) of 424 | ([_ty], [x]) -> Just x 425 | _ -> Nothing 426 | 427 | makeStoreInstance :: Cxt -> Type -> Exp -> Exp -> Exp -> Dec 428 | makeStoreInstance cs ty sizeExpr peekExpr pokeExpr = 429 | plainInstanceD 430 | cs 431 | (AppT (ConT ''Store) ty) 432 | [ ValD (VarP 'size) (NormalB sizeExpr) [] 433 | , ValD (VarP 'peek) (NormalB peekExpr) [] 434 | , ValD (VarP 'poke) (NormalB pokeExpr) [] 435 | ] 436 | 437 | -- TODO: either generate random types that satisfy instances with 438 | -- variables in them, or have a check that there's at least a manual 439 | -- check for polymorphic instances. 440 | 441 | getAllInstanceTypes :: Name -> Q [[Type]] 442 | getAllInstanceTypes n = 443 | map (\(TypeclassInstance _ ty _) -> drop 1 (unAppsT ty)) <$> 444 | getInstances n 445 | 446 | getAllInstanceTypes1 :: Name -> Q [Type] 447 | getAllInstanceTypes1 n = 448 | fmap (fmap (fromMaybe (error "getAllMonoInstances1 expected only one type argument") . headMay)) 449 | (getAllInstanceTypes n) 450 | 451 | isMonoType :: Type -> Bool 452 | isMonoType = null . listify isVarT 453 | 454 | isVarT :: Type -> Bool 455 | isVarT VarT{} = True 456 | isVarT _ = False 457 | 458 | -- TOOD: move these to th-reify-many 459 | 460 | -- | Get a map from the 'getTyHead' type of instances to 461 | -- 'TypeclassInstance'. 462 | instancesMap :: [TypeclassInstance] -> M.Map [Type] [TypeclassInstance] 463 | instancesMap = 464 | M.fromListWith (++) . 465 | map (\ti -> (map getTyHead (instanceArgTypes ti), [ti])) 466 | 467 | instanceArgTypes :: TypeclassInstance -> [Type] 468 | instanceArgTypes (TypeclassInstance _ ty _) = drop 1 (unAppsT ty) 469 | 470 | getTyHead :: Type -> Type 471 | getTyHead (SigT x _) = getTyHead x 472 | getTyHead (ForallT _ _ x) = getTyHead x 473 | getTyHead (AppT l _) = getTyHead l 474 | getTyHead x = x 475 | 476 | storePred :: Type -> Pred 477 | storePred ty = 478 | #if MIN_VERSION_template_haskell(2,10,0) 479 | AppT (ConT ''Store) ty 480 | #else 481 | ClassP ''Store [ty] 482 | #endif 483 | -------------------------------------------------------------------------------- /src/Data/Store/TypeHash.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides utilities for computing hashes based on the 2 | -- structural definitions of datatypes. The purpose of this is to 3 | -- provide a mechanism for tagging serialized data in such a way that 4 | -- deserialization issues can be anticipated. 5 | module Data.Store.TypeHash 6 | ( Tagged(..) 7 | , TypeHash 8 | , HasTypeHash(..) 9 | -- * TH for generating HasTypeHash instances 10 | , mkHasTypeHash 11 | , mkManyHasTypeHash 12 | ) where 13 | 14 | import Data.Store.TypeHash.Internal 15 | -------------------------------------------------------------------------------- /src/Data/Store/TypeHash/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | 10 | module Data.Store.TypeHash.Internal where 11 | 12 | import Control.Applicative 13 | import Control.DeepSeq (NFData) 14 | import Control.Monad (when, unless) 15 | import qualified Crypto.Hash.SHA1 as SHA1 16 | import qualified Data.ByteString as BS 17 | import Data.Char (isUpper, isLower) 18 | import Data.Data (Data) 19 | import Data.Functor.Contravariant 20 | import Data.Generics (listify) 21 | import Data.List (sortBy) 22 | import Data.Monoid ((<>)) 23 | import Data.Ord (comparing) 24 | import Data.Proxy (Proxy(..)) 25 | import Data.Store 26 | import Data.Store.Internal 27 | import Data.Typeable (Typeable) 28 | import GHC.Generics (Generic) 29 | import Language.Haskell.TH 30 | import Language.Haskell.TH.ReifyMany (reifyMany) 31 | import Language.Haskell.TH.Syntax (Lift(..), unsafeTExpCoerce) 32 | import Prelude 33 | 34 | {-# DEPRECATED mkManyHasTypeHash, mkHasTypeHash 35 | "Use of Data.Store.TypeHash isn't recommended, as the hashes are too unstable for most uses. Please instead consider using Data.Store.Version. See https://github.com/fpco/store/issues/53" 36 | #-} 37 | 38 | newtype Tagged a = Tagged { unTagged :: a } 39 | deriving (Eq, Ord, Show, Data, Typeable, Generic) 40 | 41 | instance NFData a => NFData (Tagged a) 42 | 43 | instance (Store a, HasTypeHash a) => Store (Tagged a) where 44 | size = addSize 20 (contramap unTagged size) 45 | peek = do 46 | tag <- peek 47 | let expected = typeHash (Proxy :: Proxy a) 48 | when (tag /= expected) $ fail "Mismatched type hash" 49 | Tagged <$> peek 50 | poke (Tagged x) = do 51 | poke (typeHash (Proxy :: Proxy a)) 52 | poke x 53 | 54 | newtype TypeHash = TypeHash { unTypeHash :: StaticSize 20 BS.ByteString } 55 | deriving (Eq, Ord, Show, Store, Generic) 56 | 57 | #if __GLASGOW_HASKELL__ >= 710 58 | deriving instance Typeable TypeHash 59 | deriving instance Data TypeHash 60 | #endif 61 | 62 | instance NFData TypeHash 63 | 64 | instance Lift TypeHash where 65 | lift = staticByteStringExp . unStaticSize . unTypeHash 66 | #if MIN_VERSION_template_haskell(2,17,0) 67 | liftTyped = Code . unsafeTExpCoerce . lift 68 | #elif MIN_VERSION_template_haskell(2,16,0) 69 | liftTyped = unsafeTExpCoerce . lift 70 | #endif 71 | 72 | reifyManyTyDecls :: ((Name, Info) -> Q (Bool, [Name])) 73 | -> [Name] 74 | -> Q [(Name, Info)] 75 | reifyManyTyDecls f = reifyMany go 76 | where 77 | go x@(_, TyConI{}) = f x 78 | go x@(_, FamilyI{}) = f x 79 | go x@(_, PrimTyConI{}) = f x 80 | go x@(_, DataConI{}) = f x 81 | go (_, ClassI{}) = return (False, []) 82 | go (_, ClassOpI{}) = return (False, []) 83 | go (_, VarI{}) = return (False, []) 84 | go (_, TyVarI{}) = return (False, []) 85 | #if MIN_VERSION_template_haskell(2,12,0) 86 | go (_, PatSynI{}) = return (False, []) 87 | #endif 88 | 89 | -- | At compiletime, this yields a hash of the specified datatypes. 90 | -- Not only does this cover the datatypes themselves, but also all 91 | -- transitive dependencies. 92 | -- 93 | -- The resulting expression is a literal of type 'TypeHash'. 94 | typeHashForNames :: [Name] -> Q Exp 95 | typeHashForNames ns = do 96 | infos <- getTypeInfosRecursively ns 97 | [| TypeHash $(staticByteStringExp (SHA1.hash (encode infos))) |] 98 | 99 | -- | At compiletime, this yields a cryptographic hash of the specified 'Type', 100 | -- including the definition of things it references (transitively). 101 | -- 102 | -- The resulting expression is a literal of type 'TypeHash'. 103 | hashOfType :: Type -> Q Exp 104 | hashOfType ty = do 105 | unless (null (getVarNames ty)) $ fail $ "hashOfType cannot handle polymorphic type " <> pprint ty 106 | infos <- getTypeInfosRecursively (getConNames ty) 107 | [| TypeHash $(staticByteStringExp (SHA1.hash (encode infos))) |] 108 | 109 | getTypeInfosRecursively :: [Name] -> Q [(Name, Info)] 110 | getTypeInfosRecursively names = do 111 | allInfos <- reifyManyTyDecls (\(_, info) -> return (True, getConNames info)) names 112 | -- Sorting step probably unnecessary because this should be 113 | -- deterministic, but hey why not. 114 | return (sortBy (comparing fst) allInfos) 115 | 116 | getConNames :: Data a => a -> [Name] 117 | getConNames = listify (isUpper . head . nameBase) 118 | 119 | getVarNames :: Data a => a -> [Name] 120 | getVarNames = listify (isLower . head . nameBase) 121 | 122 | -- TODO: Generic instance for polymorphic types, or have TH generate 123 | -- polymorphic instances. 124 | 125 | class HasTypeHash a where 126 | typeHash :: Proxy a -> TypeHash 127 | 128 | mkHasTypeHash :: Type -> Q [Dec] 129 | mkHasTypeHash ty = 130 | [d| instance HasTypeHash $(return ty) where 131 | typeHash _ = $(hashOfType ty) 132 | |] 133 | 134 | mkManyHasTypeHash :: [Q Type] -> Q [Dec] 135 | mkManyHasTypeHash qtys = concat <$> mapM (mkHasTypeHash =<<) qtys 136 | 137 | combineTypeHashes :: [TypeHash] -> TypeHash 138 | combineTypeHashes = TypeHash . toStaticSizeEx . SHA1.hash . BS.concat . map (unStaticSize . unTypeHash) 139 | -------------------------------------------------------------------------------- /src/Data/Store/Version.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | -- | This module provides utilities which help ensure that we aren't 10 | -- attempting to de-serialize data that is an older or newer version. 11 | -- The 'WithVersion' utility wraps up a datatype along with a version 12 | -- tag. This version tag can either be provided by the user 13 | -- ('namedVersionConfig'), or use a computed hash 14 | -- ('hashedVersionConfig'). 15 | -- 16 | -- The magic here is using an SYB traversal ('Data') to get the 17 | -- structure of all the data-types involved. This info is rendered to 18 | -- text and hashed to yield a hash which describes it. 19 | -- 20 | -- NOTE that this API is still quite new and so is likely to break 21 | -- compatibility in the future. It should also be expected that the 22 | -- computed hashes may change between major version bumps, though this 23 | -- will be minimized when directly feasible. 24 | module Data.Store.Version 25 | ( StoreVersion(..) 26 | , VersionConfig(..) 27 | , hashedVersionConfig 28 | , namedVersionConfig 29 | , encodeWithVersionQ 30 | , decodeWithVersionQ 31 | ) where 32 | 33 | import Control.Monad 34 | import Control.Monad.Trans.State 35 | import qualified Crypto.Hash.SHA1 as SHA1 36 | import qualified Data.ByteString as BS 37 | import qualified Data.ByteString.Base64.URL as B64Url 38 | import qualified Data.ByteString.Char8 as BS8 39 | import Data.Generics hiding (DataType, Generic) 40 | import qualified Data.Map as M 41 | import qualified Data.Set as S 42 | import Data.Store.Internal 43 | import qualified Data.Text as T 44 | import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) 45 | import Data.Text.Encoding.Error (lenientDecode) 46 | import qualified Data.Text.IO as T 47 | import Data.Word (Word32) 48 | import GHC.Generics (Generic) 49 | import Language.Haskell.TH 50 | import System.Directory 51 | import System.Environment 52 | import System.FilePath 53 | import TH.RelativePaths 54 | import TH.Utilities 55 | 56 | newtype StoreVersion = StoreVersion { unStoreVersion :: BS.ByteString } 57 | deriving (Eq, Show, Ord, Data, Typeable, Generic, Store) 58 | 59 | -- | Configuration for the version checking of a particular type. 60 | data VersionConfig a = VersionConfig 61 | { vcExpectedHash :: Maybe String 62 | -- ^ When set, specifies the hash which is expected to be computed. 63 | , vcManualName :: Maybe String 64 | -- ^ When set, specifies the name to instead use to tag the data. 65 | , vcIgnore :: S.Set String 66 | -- ^ DataTypes to ignore. 67 | , vcRenames :: M.Map String String 68 | -- ^ Allowed renamings of datatypes, useful when they move. 69 | } deriving (Eq, Show, Data, Typeable, Generic) 70 | 71 | hashedVersionConfig :: String -> VersionConfig a 72 | hashedVersionConfig hash = VersionConfig 73 | { vcExpectedHash = Just hash 74 | , vcManualName = Nothing 75 | , vcIgnore = S.empty 76 | , vcRenames = M.empty 77 | } 78 | 79 | namedVersionConfig :: String -> String -> VersionConfig a 80 | namedVersionConfig name hash = VersionConfig 81 | { vcExpectedHash = Just hash 82 | , vcManualName = Just name 83 | , vcIgnore = S.empty 84 | , vcRenames = M.empty 85 | } 86 | 87 | encodeWithVersionQ :: Data a => VersionConfig a -> Q Exp 88 | encodeWithVersionQ = impl Encode 89 | 90 | decodeWithVersionQ :: Data a => VersionConfig a -> Q Exp 91 | decodeWithVersionQ = impl Decode 92 | 93 | data WhichFunc = Encode | Decode 94 | 95 | impl :: forall a. Data a => WhichFunc -> VersionConfig a -> Q Exp 96 | impl wf vc = do 97 | let proxy = Proxy :: Proxy a 98 | info = encodeUtf8 (T.pack (getStructureInfo (vcIgnore vc) (vcRenames vc) proxy)) 99 | hash = SHA1.hash info 100 | hashb64 = BS8.unpack (B64Url.encode hash) 101 | version = case vcManualName vc of 102 | Nothing -> [e| StoreVersion hash |] 103 | Just name -> [e| StoreVersion name |] 104 | case vcExpectedHash vc of 105 | Nothing -> return () 106 | Just expectedHash -> do 107 | let shownType = showsQualTypeRep (vcRenames vc) 0 (typeRep proxy) "" 108 | path <- storeVersionedPath expectedHash 109 | if hashb64 == expectedHash 110 | then writeVersionInfo path shownType info 111 | else do 112 | newPath <- storeVersionedPath hashb64 113 | writeVersionInfo newPath shownType info 114 | exists <- runIO $ doesFileExist path 115 | extraMsg <- if not exists 116 | then return ", but no file found with previously stored structural info." 117 | else return (", use something like the following to compare with the old structural info:\n\n" ++ 118 | "diff -u " ++ show path ++ " " ++ show newPath) 119 | error $ 120 | "For " ++ shownType ++ ",\n" ++ 121 | "Data.Store.Version expected hash " ++ show hashb64 ++ 122 | ", but " ++ show expectedHash ++ " is specified.\n" ++ 123 | "The data used to construct the hash has been written to " ++ show newPath ++ 124 | extraMsg ++ "\n" 125 | let atype = typeRepToType (typeRep proxy) 126 | case wf of 127 | Encode -> [e| \x -> ( getSize markEncodedVersion + getSize $(version) + getSize x 128 | , poke markEncodedVersion >> poke $(version) >> poke (x :: $(atype))) |] 129 | Decode -> [e| do 130 | peekMagic "version tag" markEncodedVersion 131 | gotVersion <- peek 132 | if gotVersion /= $(version) 133 | then fail (displayVersionError $(version) gotVersion) 134 | else peek :: Peek $(atype) |] 135 | 136 | {- 137 | txtWithComments <- runIO $ T.readFile path 138 | let txt = T.unlines $ dropWhile ("--" `T.isPrefixOf`) $ T.lines txtWithComments 139 | storedHash = BS8.unpack (B64Url.encode (SHA1.hash (encodeUtf8 txt))) 140 | if storedHash == expectedHash 141 | then return (", compare with the structural info that matches the hash, found in " ++ show path) 142 | else return (", but the old file found also doesn't match the hash.") 143 | -} 144 | 145 | writeVersionInfo :: FilePath -> String -> BS.ByteString -> Q () 146 | writeVersionInfo path shownType info = runIO $ do 147 | createDirectoryIfMissing True (takeDirectory path) 148 | T.writeFile path $ T.unlines $ 149 | [ T.pack ("-- Structural info for type " ++ shownType) 150 | , "-- Generated by an invocation of functions in Data.Store.Version" 151 | ] ++ T.lines (decodeUtf8 info) 152 | 153 | storeVersionedPath :: String -> Q FilePath 154 | storeVersionedPath filename = do 155 | mstack <- runIO (lookupEnv "STACK_EXE") 156 | let dirName = case mstack of 157 | Just _ -> ".stack-work" 158 | Nothing -> "dist" 159 | pathRelativeToCabalPackage (dirName "store-versioned" filename) 160 | 161 | -- Implementation details 162 | 163 | data S = S 164 | { sResults :: M.Map String String 165 | , sCurResult :: String 166 | , sFieldNames :: [String] 167 | } 168 | 169 | getStructureInfo :: forall a. Data a => S.Set String -> M.Map String String -> Proxy a -> String 170 | getStructureInfo ignore renames = renderResults . sResults . flip execState (S M.empty "" []) . getStructureInfo' ignore renames 171 | where 172 | renderResults = unlines . map (\(k, v) -> k ++ v) . M.toAscList 173 | 174 | getStructureInfo' :: forall a. Data a => S.Set String -> M.Map String String -> Proxy a -> State S () 175 | getStructureInfo' ignore renames _ = do 176 | s0 <- get 177 | when (M.notMember label (sResults s0)) $ 178 | if S.member shownType ignore 179 | then setResult " ignored\n" 180 | else case dataTypeRep (dataTypeOf (undefined :: a)) of 181 | AlgRep cs -> do 182 | setResult "" 183 | mapM_ goConstr (zip (True : repeat False) cs) 184 | result <- gets sCurResult 185 | setResult (if null cs then result ++ "\n" else result) 186 | IntRep -> setResult " has IntRep\n" 187 | FloatRep -> setResult " has FloatRep\n" 188 | CharRep -> setResult " has CharRep\n" 189 | NoRep 190 | | S.member shownType ignore -> setResult " has NoRep\n" 191 | | otherwise -> error $ 192 | "\nNoRep in Data.Store.Version for " ++ show shownType ++ 193 | ".\nIn the future it will be possible to statically " ++ 194 | "declare a global serialization version for this type. " ++ 195 | "\nUntil then you will need to use 'vcIgnore', and " ++ 196 | "understand that serialization changes for affected types " ++ 197 | "will not be detected.\n" 198 | where 199 | setResult x = 200 | modify (\s -> S 201 | { sResults = M.insert label x (sResults s) 202 | , sCurResult = "" 203 | , sFieldNames = [] 204 | }) 205 | label = "data-type " ++ shownType 206 | shownType = showsQualTypeRep renames 0 (typeRep (Proxy :: Proxy a)) "" 207 | goConstr :: (Bool, Constr) -> State S () 208 | goConstr (isFirst, c) = do 209 | modify (\s -> s 210 | { sFieldNames = constrFields c ++ map (\ix -> "slot " ++ show (ix :: Int)) [0..] 211 | , sCurResult = sCurResult s ++ (if isFirst then "\n = " else " | ") ++ showConstr c ++ " {\n" 212 | }) 213 | void (fromConstrM goField c :: State S a) 214 | modify (\s -> s { sCurResult = sCurResult s ++ " }\n" }) 215 | goField :: forall b. Data b => State S b 216 | goField = do 217 | s <- get 218 | case sFieldNames s of 219 | [] -> error "impossible case in getStructureInfo'" 220 | (name:names) -> do 221 | getStructureInfo' ignore renames (Proxy :: Proxy b) 222 | s' <- get 223 | put s 224 | { sResults = sResults s' 225 | , sCurResult = sCurResult s ++ " " ++ name ++ " :: " ++ showsQualTypeRep renames 0 (typeRep (Proxy :: Proxy b)) "\n" 226 | , sFieldNames = names 227 | } 228 | return (error "unexpected evaluation") 229 | 230 | showsQualTypeRep :: M.Map String String -> Int -> TypeRep -> ShowS 231 | showsQualTypeRep renames p tyrep = 232 | let (tycon, tys) = splitTyConApp tyrep 233 | in case tys of 234 | [] -> showsQualTyCon renames tycon 235 | [x] | tycon == tcList -> showChar '[' . showsQualTypeRep renames 0 x . showChar ']' 236 | where 237 | [a,r] | tycon == tcFun -> showParen (p > 8) $ 238 | showsQualTypeRep renames 9 a . 239 | showString " -> " . 240 | showsQualTypeRep renames 8 r 241 | xs | isTupleTyCon tycon -> showTuple renames xs 242 | | otherwise -> 243 | showParen (p > 9) $ 244 | showsQualTyCon renames tycon . 245 | showChar ' ' . 246 | showArgs renames (showChar ' ') tys 247 | 248 | showsQualTyCon :: M.Map String String -> TyCon -> ShowS 249 | showsQualTyCon renames tc = showString (M.findWithDefault name name renames) 250 | where 251 | name = tyConModule tc ++ "." ++ tyConName tc 252 | 253 | isTupleTyCon :: TyCon -> Bool 254 | isTupleTyCon tc 255 | | ('(':',':_) <- tyConName tc = True 256 | | otherwise = False 257 | 258 | showArgs :: M.Map String String -> ShowS -> [TypeRep] -> ShowS 259 | showArgs _ _ [] = id 260 | showArgs renames _ [a] = showsQualTypeRep renames 10 a 261 | showArgs renames sep (a:as) = showsQualTypeRep renames 10 a . sep . showArgs renames sep as 262 | 263 | showTuple :: M.Map String String -> [TypeRep] -> ShowS 264 | showTuple renames args 265 | = showChar '(' 266 | . showArgs renames (showChar ',') args 267 | . showChar ')' 268 | 269 | tcList :: TyCon 270 | tcList = tyConOf (Proxy :: Proxy [()]) 271 | 272 | tcFun :: TyCon 273 | tcFun = tyConOf (Proxy :: Proxy (Int -> Int)) 274 | 275 | tyConOf :: Typeable a => Proxy a -> TyCon 276 | tyConOf = typeRepTyCon . typeRep 277 | 278 | displayVersionError :: StoreVersion -> StoreVersion -> String 279 | displayVersionError expectedVersion receivedVersion = 280 | "Mismatch detected by Data.Store.Version - expected " ++ 281 | T.unpack (decodeUtf8With lenientDecode (unStoreVersion expectedVersion)) ++ " but got " ++ 282 | T.unpack (decodeUtf8With lenientDecode (unStoreVersion receivedVersion)) 283 | 284 | markEncodedVersion :: Word32 285 | markEncodedVersion = 3908297288 286 | -------------------------------------------------------------------------------- /src/System/IO/ByteBuffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-@ LIQUID "--no-termination" @-} 3 | {-@ LIQUID "--short-names" @-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE CPP #-} 9 | {-| 10 | Module: System.IO.ByteBuffer 11 | Description: Provides an efficient buffering abstraction. 12 | 13 | A 'ByteBuffer' is a simple buffer for bytes. It supports two 14 | operations: refilling with the contents of a 'ByteString', and 15 | consuming a fixed number of bytes. 16 | 17 | It is implemented as a pointer, together with counters that keep track 18 | of the offset and the number of bytes in the buffer. Note that the 19 | counters are simple 'IORef's, so 'ByteBuffer's are not thread-safe! 20 | 21 | A 'ByteBuffer' is constructed by 'new' with a given starting length, 22 | and will grow (by repeatedly multiplying its size by 1.5) whenever it 23 | is being fed a 'ByteString' that is too large. 24 | -} 25 | 26 | module System.IO.ByteBuffer 27 | ( ByteBuffer 28 | -- * Allocation and Deallocation 29 | , new, free, with 30 | -- * Query for number of available bytes 31 | , totalSize, isEmpty, availableBytes 32 | -- * Feeding new input 33 | , copyByteString 34 | #ifndef mingw32_HOST_OS 35 | , fillFromFd 36 | #endif 37 | -- * Consuming bytes from the buffer 38 | , consume, unsafeConsume 39 | -- * Exceptions 40 | , ByteBufferException (..) 41 | ) where 42 | 43 | import Control.Applicative 44 | import Control.Exception (SomeException, throwIO) 45 | import Control.Exception.Lifted (Exception, bracket, catch) 46 | import qualified Control.Monad.Fail as Fail 47 | import Control.Monad.IO.Class (MonadIO, liftIO) 48 | import Control.Monad.Trans.Control (MonadBaseControl) 49 | import Data.ByteString (ByteString) 50 | import qualified Data.ByteString.Internal as BS 51 | import Data.IORef 52 | import Data.Maybe (fromMaybe) 53 | import Data.Typeable (Typeable) 54 | import Data.Word 55 | import Foreign.ForeignPtr 56 | import qualified Foreign.Marshal.Alloc as Alloc 57 | import Foreign.Marshal.Utils (copyBytes, moveBytes) 58 | import GHC.Ptr 59 | import Prelude 60 | import qualified Foreign.C.Error as CE 61 | import Foreign.C.Types 62 | import System.Posix.Types (Fd (..)) 63 | 64 | -- | A buffer into which bytes can be written. 65 | -- 66 | -- Invariants: 67 | -- 68 | -- * @size >= containedBytes >= consumedBytes >= 0@ 69 | -- 70 | -- * The range from @ptr@ to @ptr `plusPtr` size@ will be allocated 71 | -- 72 | -- * The range from @ptr@ to @ptr `plusPtr` containedBytes@ will 73 | -- contain bytes previously copied to the buffer 74 | -- 75 | -- * The buffer contains @containedBytes - consumedBytes@ bytes of 76 | -- data that have been copied to it, but not yet read. They are in 77 | -- the range from @ptr `plusPtr` consumedBytes@ to @ptr `plusPtr` 78 | -- containedBytes@. 79 | -- 80 | -- The first two invariants are encoded in Liquid Haskell, and can 81 | -- be statically checked. 82 | -- 83 | -- If an Exception occurs during an operation that modifies a 84 | -- 'ByteBuffer', the 'ByteBuffer' is invalidated and can no longer be 85 | -- used. Trying to access the 'ByteBuffer' subsequently will result 86 | -- in a 'ByteBufferException' being thrown. 87 | {-@ 88 | data BBRef = BBRef 89 | { size :: {v: Int | v >= 0 } 90 | , contained :: { v: Int | v >= 0 && v <= size } 91 | , consumed :: { v: Int | v >= 0 && v <= contained } 92 | , ptr :: { v: Ptr Word8 | (plen v) = size } 93 | } 94 | @-} 95 | 96 | data BBRef = BBRef { 97 | size :: {-# UNPACK #-} !Int 98 | -- ^ The amount of memory allocated. 99 | , contained :: {-# UNPACK #-} !Int 100 | -- ^ The number of bytes that the 'ByteBuffer' currently holds. 101 | , consumed :: {-# UNPACK #-} !Int 102 | -- ^ The number of bytes that have already been consumed. 103 | , ptr :: {-# UNPACK #-} !(Ptr Word8) 104 | -- ^ This points to the beginning of the memory allocated for 105 | -- the 'ByteBuffer' 106 | } 107 | 108 | -- | Exception that is thrown when an invalid 'ByteBuffer' is being used that is no longer valid. 109 | -- 110 | -- A 'ByteBuffer' is considered to be invalid if 111 | -- 112 | -- - it has explicitly been freed 113 | -- - an Exception has occured during an operation that modified it 114 | data ByteBufferException = ByteBufferException 115 | { _bbeLocation :: !String 116 | -- ^ function name that caused the exception 117 | , _bbeException :: !String 118 | -- ^ printed representation of the exception 119 | } 120 | deriving (Typeable, Eq) 121 | instance Show ByteBufferException where 122 | show (ByteBufferException loc e) = concat 123 | ["ByteBufferException: ByteBuffer was invalidated because of Exception thrown in " 124 | , loc , ": ", e] 125 | instance Exception ByteBufferException 126 | 127 | type ByteBuffer = IORef (Either ByteBufferException BBRef) 128 | 129 | -- | On any Exception, this will invalidate the ByteBuffer and re-throw the Exception. 130 | -- 131 | -- Invalidating the 'ByteBuffer' includes freeing the underlying pointer. 132 | bbHandler :: MonadIO m 133 | => String 134 | -- ^ location information: function from which the exception was thrown 135 | -> ByteBuffer 136 | -- ^ this 'ByteBuffer' will be invalidated when an Exception occurs 137 | -> (BBRef -> IO a) 138 | -> m a 139 | bbHandler loc bb f = liftIO $ useBBRef f bb `catch` \(e :: SomeException) -> do 140 | readIORef bb >>= \case 141 | Right bbref -> do 142 | Alloc.free (ptr bbref) 143 | writeIORef bb (Left $ ByteBufferException loc (show e)) 144 | Left _ -> return () 145 | throwIO e 146 | 147 | -- | Try to use the 'BBRef' of a 'ByteBuffer', or throw a 'ByteBufferException' if it's invalid. 148 | useBBRef :: (BBRef -> IO a) -> ByteBuffer -> IO a 149 | useBBRef f bb = readIORef bb >>= either throwIO f 150 | {-# INLINE useBBRef #-} 151 | 152 | totalSize :: MonadIO m => ByteBuffer -> m Int 153 | totalSize = liftIO . useBBRef (return . size) 154 | {-# INLINE totalSize #-} 155 | 156 | isEmpty :: MonadIO m => ByteBuffer -> m Bool 157 | isEmpty bb = liftIO $ (==0) <$> availableBytes bb 158 | {-# INLINE isEmpty #-} 159 | 160 | -- | Number of available bytes in a 'ByteBuffer' (that is, bytes that 161 | -- have been copied to, but not yet read from the 'ByteBuffer'. 162 | {-@ availableBytes :: MonadIO m => ByteBuffer -> m {v: Int | v >= 0} @-} 163 | availableBytes :: MonadIO m => ByteBuffer -> m Int 164 | availableBytes = liftIO . useBBRef (\BBRef{..} -> return (contained - consumed)) 165 | {-# INLINE availableBytes #-} 166 | 167 | -- | Allocates a new ByteBuffer with a given buffer size filling from 168 | -- the given FillBuffer. 169 | -- 170 | -- Note that 'ByteBuffer's created with 'new' have to be deallocated 171 | -- explicitly using 'free'. For automatic deallocation, consider 172 | -- using 'with' instead. 173 | new :: MonadIO m 174 | => Maybe Int 175 | -- ^ Size of buffer to allocate. If 'Nothing', use the default 176 | -- value of 4MB 177 | -> m ByteBuffer 178 | -- ^ The byte buffer. 179 | new ml = liftIO $ do 180 | let l = max 0 . fromMaybe (4*1024*1024) $ ml 181 | newPtr <- Alloc.mallocBytes l 182 | newIORef $ Right BBRef 183 | { ptr = newPtr 184 | , size = l 185 | , contained = 0 186 | , consumed = 0 187 | } 188 | 189 | -- | Free a byte buffer. 190 | free :: MonadIO m => ByteBuffer -> m () 191 | free bb = liftIO $ readIORef bb >>= \case 192 | Right bbref -> do 193 | Alloc.free $ ptr bbref 194 | writeIORef bb $ 195 | Left (ByteBufferException "free" "ByteBuffer has explicitly been freed and is no longer valid.") 196 | Left _ -> return () -- the ByteBuffer is either invalid or has already been freed. 197 | 198 | -- | Perform some action with a bytebuffer, with automatic allocation 199 | -- and deallocation. 200 | with :: (MonadIO m, MonadBaseControl IO m) 201 | => Maybe Int 202 | -- ^ Initial length of the 'ByteBuffer'. If 'Nothing', use the 203 | -- default value of 4MB. 204 | -> (ByteBuffer -> m a) 205 | -> m a 206 | with l action = 207 | bracket 208 | (new l) 209 | free 210 | action 211 | {-# INLINE with #-} 212 | 213 | -- | Reset a 'BBRef', i.e. copy all the bytes that have not yet 214 | -- been consumed to the front of the buffer. 215 | {-@ resetBBRef :: b:BBRef -> IO {v:BBRef | consumed v == 0 && contained v == contained b - consumed b && size v == size b} @-} 216 | resetBBRef :: BBRef -> IO BBRef 217 | resetBBRef bbref = do 218 | let available = contained bbref - consumed bbref 219 | moveBytes (ptr bbref) (ptr bbref `plusPtr` consumed bbref) available 220 | return BBRef { size = size bbref 221 | , contained = available 222 | , consumed = 0 223 | , ptr = ptr bbref 224 | } 225 | 226 | -- | Make sure the buffer is at least @minSize@ bytes long. 227 | -- 228 | -- In order to avoid having to enlarge the buffer too often, we 229 | -- multiply its size by a factor of 1.5 until it is at least @minSize@ 230 | -- bytes long. 231 | {-@ enlargeBBRef :: b:BBRef -> i:Nat -> IO {v:BBRef | size v >= i && contained v == contained b && consumed v == consumed b} @-} 232 | enlargeBBRef :: BBRef -> Int -> IO BBRef 233 | enlargeBBRef bbref minSize = do 234 | let getNewSize s | s >= minSize = s 235 | getNewSize s = getNewSize $ (ceiling . (*(1.5 :: Double)) . fromIntegral) (max 1 s) 236 | newSize = getNewSize (size bbref) 237 | -- possible optimisation: since reallocation might copy the 238 | -- bytes anyway, we could discard the consumed bytes, 239 | -- basically 'reset'ting the buffer on the fly. 240 | ptr' <- Alloc.reallocBytes (ptr bbref) newSize 241 | return BBRef { size = newSize 242 | , contained = contained bbref 243 | , consumed = consumed bbref 244 | , ptr = ptr' 245 | } 246 | 247 | -- | Copy the contents of a 'ByteString' to a 'ByteBuffer'. 248 | -- 249 | -- If necessary, the 'ByteBuffer' is enlarged and/or already consumed 250 | -- bytes are dropped. 251 | copyByteString :: MonadIO m => ByteBuffer -> ByteString -> m () 252 | copyByteString bb bs = 253 | bbHandler "copyByteString" bb go 254 | where 255 | go bbref = do 256 | let (bsFptr, bsOffset, bsSize) = BS.toForeignPtr bs 257 | -- if the byteBuffer is too small, resize it. 258 | let available = contained bbref - consumed bbref -- bytes not yet consumed 259 | bbref' <- if size bbref < bsSize + available 260 | then enlargeBBRef bbref (bsSize + available) 261 | else return bbref 262 | -- if it is currently too full, reset it 263 | bbref'' <- if bsSize + contained bbref' > size bbref' 264 | then resetBBRef bbref' 265 | else return bbref' 266 | -- now we can safely copy. 267 | withForeignPtr bsFptr $ \ bsPtr -> 268 | copyBytes (ptr bbref'' `plusPtr` contained bbref'') 269 | (bsPtr `plusPtr` bsOffset) 270 | bsSize 271 | writeIORef bb $ Right BBRef { 272 | size = size bbref'' 273 | , contained = contained bbref'' + bsSize 274 | , consumed = consumed bbref'' 275 | , ptr = ptr bbref''} 276 | 277 | #ifndef mingw32_HOST_OS 278 | 279 | -- | Will read at most n bytes from the given 'Fd', in a non-blocking 280 | -- fashion. This function is intended to be used with non-blocking 'Socket's, 281 | -- such the ones created by the @network@ package. 282 | -- 283 | -- Returns how many bytes could be read non-blockingly. 284 | fillFromFd :: (MonadIO m, Fail.MonadFail m) => ByteBuffer -> Fd -> Int -> m Int 285 | fillFromFd bb sock maxBytes = if maxBytes < 0 286 | then fail ("fillFromFd: negative argument (" ++ show maxBytes ++ ")") 287 | else bbHandler "fillFromFd" bb go 288 | where 289 | go bbref = do 290 | (bbref', readBytes) <- fillBBRefFromFd sock bbref maxBytes 291 | writeIORef bb $ Right bbref' 292 | return readBytes 293 | 294 | {- 295 | Note: I'd like to use these two definitions: 296 | 297 | {-@ measure _available @-} 298 | _available :: BBRef -> Int 299 | _available BBRef{..} = contained - consumed 300 | 301 | {-@ measure _free @-} 302 | _free :: BBRef -> Int 303 | _free BBRef{..} = size - contained 304 | 305 | but for some reason when I try to do so it does not work. 306 | -} 307 | 308 | {-@ fillBBRefFromFd :: 309 | Fd -> b0: BBRef 310 | -> maxBytes: Nat -> IO {v: (BBRef, Nat) | maxBytes >= snd v && contained (fst v) - consumed (fst v) == contained b0 - consumed b0 + snd v} 311 | @-} 312 | fillBBRefFromFd :: Fd -> BBRef -> Int -> IO (BBRef, Int) 313 | fillBBRefFromFd (Fd sock) bbref0 maxBytes = do 314 | bbref1 <- prepareSpace bbref0 315 | go 0 bbref1 316 | where 317 | -- We enlarge the buffer directly to be able to contain the maximum number 318 | -- of bytes since the common pattern for this function is to know how many 319 | -- bytes we need to read -- so we'll eventually fill the enlarged buffer. 320 | {-@ prepareSpace :: b: BBRef -> IO {v: BBRef | size v - contained v >= maxBytes && contained b - consumed b == contained v - consumed v} @-} 321 | prepareSpace :: BBRef -> IO BBRef 322 | prepareSpace bbref = do 323 | let space = size bbref - contained bbref 324 | if space < maxBytes 325 | then if consumed bbref > 0 326 | then prepareSpace =<< resetBBRef bbref 327 | else enlargeBBRef bbref (contained bbref + maxBytes) 328 | else return bbref 329 | 330 | {-@ go :: 331 | readBytes: {v: Nat | v <= maxBytes} 332 | -> b: {b: BBRef | size b - contained b >= maxBytes - readBytes} 333 | -> IO {v: (BBRef, Nat) | maxBytes >= snd v && snd v >= readBytes && size (fst v) - contained (fst v) >= maxBytes - snd v && contained (fst v) - consumed (fst v) == (contained b - consumed b) + (snd v - readBytes)} 334 | @-} 335 | go :: Int -> BBRef -> IO (BBRef, Int) 336 | go readBytes bbref@BBRef{..} = if readBytes >= maxBytes 337 | then return (bbref, readBytes) 338 | else do 339 | bytes <- fromIntegral <$> c_recv sock (castPtr (ptr `plusPtr` contained)) (fromIntegral (maxBytes - readBytes)) 0 340 | if bytes == -1 341 | then do 342 | err <- CE.getErrno 343 | if err == CE.eAGAIN || err == CE.eWOULDBLOCK 344 | then return (bbref, readBytes) 345 | else throwIO $ CE.errnoToIOError "ByteBuffer.fillBBRefFromFd: " err Nothing Nothing 346 | else do 347 | let bbref' = bbref{ contained = contained + bytes } 348 | go (readBytes + bytes) bbref' 349 | 350 | foreign import ccall unsafe "recv" 351 | -- c_recv returns -1 in the case of errors. 352 | {-@ assume c_recv :: CInt -> Ptr CChar -> size: {v: CSize | v >= 0} -> flags: CInt -> IO {read: CInt | read >= -1 && size >= read} @-} 353 | c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt 354 | 355 | #endif 356 | 357 | -- | Try to get a pointer to @n@ bytes from the 'ByteBuffer'. 358 | -- 359 | -- Note that the pointer should be used before any other actions are 360 | -- performed on the 'ByteBuffer'. It points to some address within the 361 | -- buffer, so operations such as enlarging the buffer or feeding it 362 | -- new data will change the data the pointer points to. This is why 363 | -- this function is called unsafe. 364 | {-@ unsafeConsume :: MonadIO m => ByteBuffer -> n:Nat -> m (Either Int ({v:Ptr Word8 | plen v >= n})) @-} 365 | unsafeConsume :: MonadIO m 366 | => ByteBuffer 367 | -> Int 368 | -- ^ n 369 | -> m (Either Int (Ptr Word8)) 370 | -- ^ Will be @Left missing@ when there are only @n-missing@ 371 | -- bytes left in the 'ByteBuffer'. 372 | unsafeConsume bb n = 373 | bbHandler "unsafeConsume" bb go 374 | where 375 | go bbref = do 376 | let available = contained bbref - consumed bbref 377 | if available < n 378 | then return $ Left (n - available) 379 | else do 380 | writeIORef bb $ Right bbref { consumed = consumed bbref + n } 381 | return $ Right (ptr bbref `plusPtr` consumed bbref) 382 | 383 | -- | As `unsafeConsume`, but instead of returning a `Ptr` into the 384 | -- contents of the `ByteBuffer`, it returns a `ByteString` containing 385 | -- the next @n@ bytes in the buffer. This involves allocating a new 386 | -- 'ByteString' and copying the @n@ bytes to it. 387 | {-@ consume :: MonadIO m => ByteBuffer -> Nat -> m (Either Int ByteString) @-} 388 | consume :: MonadIO m 389 | => ByteBuffer 390 | -> Int 391 | -> m (Either Int ByteString) 392 | consume bb n = do 393 | mPtr <- unsafeConsume bb n 394 | case mPtr of 395 | Right ptr -> do 396 | bs <- liftIO $ createBS ptr n 397 | return (Right bs) 398 | Left missing -> return (Left missing) 399 | 400 | {-@ createBS :: p:(Ptr Word8) -> {v:Nat | v <= plen p} -> IO ByteString @-} 401 | createBS :: Ptr Word8 -> Int -> IO ByteString 402 | createBS ptr n = do 403 | fp <- mallocForeignPtrBytes n 404 | withForeignPtr fp (\p -> copyBytes p ptr n) 405 | return (BS.PS fp 0 n) 406 | 407 | -- below are liquid haskell qualifiers, and specifications for external functions. 408 | 409 | {-@ qualif FPLenPLen(v:Ptr a, fp:ForeignPtr a): fplen fp = plen v @-} 410 | 411 | {-@ Foreign.Marshal.Alloc.mallocBytes :: l:Nat -> IO (PtrN a l) @-} 412 | {-@ Foreign.Marshal.Alloc.reallocBytes :: Ptr a -> l:Nat -> IO (PtrN a l) @-} 413 | {-@ assume mallocForeignPtrBytes :: n:Nat -> IO (ForeignPtrN a n) @-} 414 | {-@ type ForeignPtrN a N = {v:ForeignPtr a | fplen v = N} @-} 415 | {-@ Foreign.Marshal.Utils.copyBytes :: p:Ptr a -> q:Ptr a -> {v:Nat | v <= plen p && v <= plen q} -> IO ()@-} 416 | {-@ Foreign.Marshal.Utils.moveBytes :: p:Ptr a -> q:Ptr a -> {v:Nat | v <= plen p && v <= plen q} -> IO ()@-} 417 | {-@ Foreign.Ptr.plusPtr :: p:Ptr a -> n:Nat -> {v:Ptr b | plen v == (plen p) - n} @-} 418 | 419 | -- writing down the specification for ByteString is not as straightforward as it seems at first: the constructor 420 | -- 421 | -- PS (ForeignPtr Word8) Int Int 422 | -- 423 | -- has actually four arguments after unboxing (the ForeignPtr is an 424 | -- Addr# and ForeignPtrContents), so restriciting the length of the 425 | -- ForeignPtr directly in the specification of the datatype does not 426 | -- work. Instead, I chose to write a specification for toForeignPtr. 427 | -- It seems that the liquidhaskell parser has problems with variables 428 | -- declared in a tuple, so I have to define the following measures to 429 | -- get at the ForeignPtr, offset, and length. 430 | -- 431 | -- This is a bit awkward, maybe there is an easier way. 432 | 433 | _get1 :: (a,b,c) -> a 434 | _get1 (x,_,_) = x 435 | {-@ measure _get1 @-} 436 | _get2 :: (a,b,c) -> b 437 | _get2 (_,x,_) = x 438 | {-@ measure _get2 @-} 439 | _get3 :: (a,b,c) -> c 440 | _get3 (_,_,x) = x 441 | {-@ measure _get3 @-} 442 | 443 | {-@ Data.ByteString.Internal.toForeignPtr :: ByteString -> 444 | {v:(ForeignPtr Word8, Int, Int) | _get2 v >= 0 445 | && _get2 v <= (fplen (_get1 v)) 446 | && _get3 v >= 0 447 | && ((_get3 v) + (_get2 v)) <= (fplen (_get1 v))} @-} 448 | -------------------------------------------------------------------------------- /stack-7.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-6.35 2 | compiler: ghc-7.10.3 3 | packages: 4 | - . 5 | - store-core 6 | - store-streaming 7 | extra-deps: 8 | - th-utilities-0.2.3.0 9 | - th-orphans-0.13.9 10 | -------------------------------------------------------------------------------- /stack-8.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.13 2 | compiler: ghc-8.10 3 | packages: 4 | - . 5 | - store-core 6 | - store-streaming 7 | extra-deps: 8 | - Cabal-3.2.0.0 9 | - bifunctors-5.5.7 10 | - exceptions-0.10.4 11 | - free-5.1.3 12 | - hashable-1.3.0.0 13 | - memory-0.15.0 14 | - primitive-0.7.0.1 15 | - resourcet-1.2.3 16 | - split-0.2.3.4 17 | - splitmix-0.0.4 18 | - th-abstraction-0.3.2.0 19 | - th-expand-syns-0.4.6.0 20 | - th-lift-0.8.1 21 | - unliftio-core-0.2.0.1 22 | - vector-0.12.1.2 23 | - zlib-0.6.2.1 24 | - th-orphans-0.13.12 25 | - th-compat-0.1.3 26 | - th-utilities-0.2.4.3 27 | allow-newer: true 28 | -------------------------------------------------------------------------------- /stack-8.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.6 2 | packages: 3 | - . 4 | - store-core 5 | - store-streaming 6 | -------------------------------------------------------------------------------- /stack-8.8.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.12 2 | packages: 3 | - . 4 | - store-core 5 | - store-streaming 6 | extra-deps: 7 | - th-utilities-0.2.4.0 8 | -------------------------------------------------------------------------------- /stack-issue-179.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.43 2 | packages: 3 | - . 4 | - store-core 5 | - store-streaming 6 | extra-deps: 7 | - vector-0.13.2.0 8 | - git: https://github.com/snoyberg/mono-traversable 9 | commit: 95c991b1bcf4a01b87497f87a578e5204e3ac55d 10 | subdirs: 11 | - mono-traversable 12 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2021-08-16 2 | packages: 3 | - . 4 | - store-core 5 | - store-streaming 6 | -------------------------------------------------------------------------------- /store-core/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog 2 | 3 | ## 0.4.4.4 4 | 5 | * Fixes build of `store-core` with `ghc-prim-0.7.0` 6 | (`ghc-9.0.0-alpha1`). See [#155][]. 7 | 8 | [#155]: https://github.com/mgsloan/store/issues/155 9 | 10 | ## 0.4.4.3 11 | 12 | * Now only depends on `fail` shim for `ghc < 8`. 13 | 14 | ## 0.4.4.2 15 | 16 | * Build fixed for GHC-7.10. See 17 | [#146](https://github.com/fpco/store/issues/146) 18 | 19 | ## 0.4.4.1 20 | 21 | * Now builds with GHC-8.8. 22 | 23 | ## 0.4.4 24 | 25 | * Build fixed with `--flag store-core:force-alignment` / on architectures 26 | like PowerPC. 27 | 28 | ## 0.4.3 29 | 30 | * Now builds with primitive >= 0.6.4.0 31 | 32 | ## 0.4.2 33 | 34 | * Adds `unsafeMakePokeState`, `unsafeMakePeekState`, and 35 | `maybeAlignmentBufferSize`, so that library users can write their own 36 | `encode` / `decode` functions. 37 | See [#126](https://github.com/fpco/store/pull/126) 38 | 39 | ## 0.4.1 40 | 41 | * Less aggressive inlining, resulting in faster compilation / simplifier 42 | not running out of ticks 43 | 44 | ## 0.4 45 | 46 | * Changes result of Peek function to be strict. 47 | (See [#98](https://github.com/fpco/store/pull/98)) 48 | 49 | ## 0.3 50 | 51 | * Adds support for alignment sensitive architectures, by using temporary buffers 52 | when necessary. This required changing the type of both Poke and Peek. Most 53 | user code should be unaffected, but this is still a breaking change. 54 | 55 | ## 0.2.0.1 56 | 57 | * Fixes a bug that could result in segfaults when reading corrupted data. 58 | 59 | ## 0.2.0.0 60 | 61 | * First public release 62 | -------------------------------------------------------------------------------- /store-core/LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 FP Complete 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /store-core/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /store-core/package.yaml: -------------------------------------------------------------------------------- 1 | name: store-core 2 | version: "0.4.4.7" 3 | synopsis: Fast and lightweight binary serialization 4 | maintainer: Michael Sloan 5 | license: MIT 6 | copyright: 2016 FP Complete 7 | github: fpco/store 8 | category: Serialization, Data 9 | extra-source-files: 10 | - ChangeLog.md 11 | tested-with: 12 | - GHC==9.4.5 13 | - GHC==9.2.8 14 | - GHC==9.0.2 15 | - GHC==8.10.7 16 | - GHC==8.8.4 17 | - GHC==8.6.5 18 | - GHC==8.4.4 19 | 20 | flags: 21 | force-alignment: 22 | default: false 23 | manual: true 24 | 25 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 26 | 27 | dependencies: 28 | - base >=4.7 && <5 29 | - primitive >=0.6 && < 1.0 # Due to removal of 'internal' from MonadPrim in 0.6 30 | - bytestring >=0.10.4.0 && < 1.0 # soft 31 | - transformers >=0.3.0.0 && < 1.0 # soft 32 | - ghc-prim >=0.3.1.0 && < 1.0 # soft 33 | - text >=1.2.0.4 && < 1.3 || >= 2.0 && < 2.2 #soft 34 | 35 | library: 36 | source-dirs: src 37 | 38 | when: 39 | - condition: flag(force-alignment) || arch(PPC) || arch(PPC64) || arch(Mips) || arch(Sparc) || arch(Arm) 40 | cpp-options: -DALIGNED_MEMORY 41 | - condition: impl(ghc < 8.0) 42 | dependencies: fail >=4.9 # shim for Control.Monad.Fail on older bases 43 | -------------------------------------------------------------------------------- /store-core/src/Data/Store/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE UnboxedTuples #-} 12 | 13 | module Data.Store.Core 14 | ( -- * Core Types 15 | Poke(..), PokeException(..), pokeException 16 | , Peek(..), PeekResult(..), PeekException(..), peekException, tooManyBytes 17 | , PokeState, pokeStatePtr 18 | , PeekState, peekStateEndPtr 19 | , Offset 20 | -- * Encode ByteString 21 | , unsafeEncodeWith 22 | -- * Decode ByteString 23 | , decodeWith 24 | , decodeExWith, decodeExPortionWith 25 | , decodeIOWith, decodeIOPortionWith 26 | , decodeIOWithFromPtr, decodeIOPortionWithFromPtr 27 | -- * Storable 28 | , pokeStorable, peekStorable, peekStorableTy 29 | -- * ForeignPtr 30 | , pokeFromForeignPtr, peekToPlainForeignPtr, pokeFromPtr 31 | -- * ByteArray 32 | , pokeFromByteArray, peekToByteArray 33 | -- * Creation of PokeState / PeekState 34 | , unsafeMakePokeState, unsafeMakePeekState, maybeAlignmentBufferSize 35 | ) where 36 | 37 | import Control.Applicative 38 | import Control.Exception (Exception(..), throwIO, try) 39 | import Control.Monad (when) 40 | import Control.Monad.IO.Class (MonadIO(..)) 41 | import Control.Monad.Primitive (PrimMonad (..)) 42 | import Data.ByteString (ByteString) 43 | import qualified Data.ByteString.Internal as BS 44 | import Data.Monoid ((<>)) 45 | import Data.Primitive.ByteArray (ByteArray, MutableByteArray(..), newByteArray, unsafeFreezeByteArray) 46 | import qualified Data.Text as T 47 | import Data.Typeable 48 | import Data.Word 49 | import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr) 50 | import Foreign.Ptr 51 | import Foreign.Storable as Storable 52 | import GHC.Exts (unsafeCoerce#) 53 | import GHC.Prim (RealWorld, ByteArray#, copyByteArrayToAddr#, copyAddrToByteArray#) 54 | import GHC.Ptr (Ptr(..)) 55 | import GHC.Types (IO(..), Int(..)) 56 | import Prelude 57 | import System.IO.Unsafe (unsafePerformIO) 58 | 59 | #if MIN_VERSION_base(4,9,0) 60 | import qualified Control.Monad.Fail as Fail 61 | #endif 62 | 63 | #if ALIGNED_MEMORY 64 | import Foreign.Marshal.Alloc (allocaBytesAligned) 65 | #endif 66 | 67 | ------------------------------------------------------------------------ 68 | -- Helpful Type Synonyms 69 | 70 | -- | How far into the given Ptr to look 71 | type Offset = Int 72 | 73 | ------------------------------------------------------------------------ 74 | -- Poke monad 75 | 76 | -- | 'Poke' actions are useful for building sequential serializers. 77 | -- 78 | -- They are actions which write values to bytes into memory specified by 79 | -- a 'Ptr' base. The 'Applicative' and 'Monad' instances make it easy to 80 | -- write serializations, by keeping track of the 'Offset' of the current 81 | -- byte. They allow you to chain 'Poke' action such that subsequent 82 | -- 'Poke's write into subsequent portions of the output. 83 | newtype Poke a = Poke 84 | { runPoke :: PokeState -> Offset -> IO (Offset, a) 85 | -- ^ Run the 'Poke' action, with the 'Ptr' to the buffer where 86 | -- data is poked, and the current 'Offset'. The result is the new 87 | -- offset, along with a return value. 88 | -- 89 | -- May throw a 'PokeException', though this should be avoided when 90 | -- possible. They usually indicate a programming error. 91 | } 92 | deriving Functor 93 | 94 | instance Applicative Poke where 95 | pure x = Poke $ \_ptr offset -> pure (offset, x) 96 | {-# INLINE pure #-} 97 | Poke f <*> Poke g = Poke $ \ptr offset1 -> do 98 | (offset2, f') <- f ptr offset1 99 | (offset3, g') <- g ptr offset2 100 | return (offset3, f' g') 101 | {-# INLINE (<*>) #-} 102 | Poke f *> Poke g = Poke $ \ptr offset1 -> do 103 | (offset2, _) <- f ptr offset1 104 | g ptr offset2 105 | {-# INLINE (*>) #-} 106 | 107 | instance Monad Poke where 108 | return = pure 109 | {-# INLINE return #-} 110 | (>>) = (*>) 111 | {-# INLINE (>>) #-} 112 | Poke x >>= f = Poke $ \ptr offset1 -> do 113 | (offset2, x') <- x ptr offset1 114 | runPoke (f x') ptr offset2 115 | {-# INLINE (>>=) #-} 116 | #if !(MIN_VERSION_base(4,13,0)) 117 | fail = pokeException . T.pack 118 | {-# INLINE fail #-} 119 | #endif 120 | 121 | #if MIN_VERSION_base(4,9,0) 122 | instance Fail.MonadFail Poke where 123 | fail = pokeException . T.pack 124 | {-# INLINE fail #-} 125 | #endif 126 | 127 | instance MonadIO Poke where 128 | liftIO f = Poke $ \_ offset -> (offset, ) <$> f 129 | {-# INLINE liftIO #-} 130 | 131 | -- | Holds a 'pokeStatePtr', which is passed in to each 'Poke' action. 132 | -- If the package is built with the 'force-alignment' flag, this also 133 | -- has a hidden 'Ptr' field, which is used as scratch space during 134 | -- unaligned writes. 135 | #if ALIGNED_MEMORY 136 | data PokeState = PokeState 137 | { pokeStatePtr :: {-# UNPACK #-} !(Ptr Word8) 138 | , pokeStateAlignPtr :: {-# UNPACK #-} !(Ptr Word8) 139 | } 140 | #else 141 | newtype PokeState = PokeState 142 | { pokeStatePtr :: Ptr Word8 143 | } 144 | #endif 145 | 146 | -- | Make a 'PokeState' from a buffer pointer. 147 | -- 148 | -- The first argument is a pointer to the memory to write to. The second 149 | -- argument is an IO action which is invoked if the store-core package 150 | -- was built with the @force-alignment@ flag. The action should yield a 151 | -- pointer to scratch memory as large as 'maybeAlignmentBufferSize'. 152 | -- 153 | -- Since 0.4.2 154 | unsafeMakePokeState :: Ptr Word8 -- ^ pokeStatePtr 155 | -> IO (Ptr Word8) -- ^ action to produce pokeStateAlignPtr 156 | -> IO PokeState 157 | #if ALIGNED_MEMORY 158 | unsafeMakePokeState ptr f = PokeState ptr <$> f 159 | #else 160 | unsafeMakePokeState ptr _ = return $ PokeState ptr 161 | #endif 162 | 163 | -- | Exception thrown while running 'poke'. Note that other types of 164 | -- exceptions could also be thrown. Invocations of 'fail' in the 'Poke' 165 | -- monad causes this exception to be thrown. 166 | -- 167 | -- 'PokeException's are not expected to occur in ordinary circumstances, 168 | -- and usually indicate a programming error. 169 | data PokeException = PokeException 170 | { pokeExByteIndex :: Offset 171 | , pokeExMessage :: T.Text 172 | } 173 | deriving (Eq, Show, Typeable) 174 | 175 | instance Exception PokeException where 176 | #if MIN_VERSION_base(4,8,0) 177 | displayException (PokeException offset msg) = 178 | "Exception while poking, at byte index " ++ 179 | show offset ++ 180 | " : " ++ 181 | T.unpack msg 182 | #endif 183 | 184 | -- | Throws a 'PokeException'. These should be avoided when possible, 185 | -- they usually indicate a programming error. 186 | pokeException :: T.Text -> Poke a 187 | pokeException msg = Poke $ \_ off -> throwIO (PokeException off msg) 188 | 189 | ------------------------------------------------------------------------ 190 | -- Peek monad 191 | 192 | -- | 'Peek' actions are useful for building sequential deserializers. 193 | -- 194 | -- They are actions which read from memory and construct values from it. 195 | -- The 'Applicative' and 'Monad' instances make it easy to chain these 196 | -- together to get more complicated deserializers. This machinery keeps 197 | -- track of the current 'Ptr' and end-of-buffer 'Ptr'. 198 | newtype Peek a = Peek 199 | { runPeek :: PeekState -> Ptr Word8 -> IO (PeekResult a) 200 | -- ^ Run the 'Peek' action, with a 'Ptr' to the end of the buffer 201 | -- where data is poked, and a 'Ptr' to the current position. The 202 | -- result is the 'Ptr', along with a return value. 203 | -- 204 | -- May throw a 'PeekException' if the memory contains invalid 205 | -- values. 206 | } deriving (Functor) 207 | 208 | -- | A result of a 'Peek' action containing the current 'Ptr' and a return value. 209 | data PeekResult a = PeekResult {-# UNPACK #-} !(Ptr Word8) !a 210 | deriving (Functor) 211 | 212 | instance Applicative Peek where 213 | pure x = Peek (\_ ptr -> return $ PeekResult ptr x) 214 | {-# INLINE pure #-} 215 | Peek f <*> Peek g = Peek $ \end ptr1 -> do 216 | PeekResult ptr2 f' <- f end ptr1 217 | PeekResult ptr3 g' <- g end ptr2 218 | return $ PeekResult ptr3 (f' g') 219 | {-# INLINE (<*>) #-} 220 | Peek f *> Peek g = Peek $ \end ptr1 -> do 221 | PeekResult ptr2 _ <- f end ptr1 222 | g end ptr2 223 | {-# INLINE (*>) #-} 224 | 225 | instance Monad Peek where 226 | return = pure 227 | {-# INLINE return #-} 228 | (>>) = (*>) 229 | {-# INLINE (>>) #-} 230 | Peek x >>= f = Peek $ \end ptr1 -> do 231 | PeekResult ptr2 x' <- x end ptr1 232 | runPeek (f x') end ptr2 233 | {-# INLINE (>>=) #-} 234 | #if !(MIN_VERSION_base(4,13,0)) 235 | fail = peekException . T.pack 236 | {-# INLINE fail #-} 237 | #endif 238 | 239 | #if MIN_VERSION_base(4,9,0) 240 | instance Fail.MonadFail Peek where 241 | fail = peekException . T.pack 242 | {-# INLINE fail #-} 243 | #endif 244 | 245 | instance PrimMonad Peek where 246 | type PrimState Peek = RealWorld 247 | primitive action = Peek $ \_ ptr -> do 248 | x <- primitive (unsafeCoerce# action) 249 | return $ PeekResult ptr x 250 | {-# INLINE primitive #-} 251 | 252 | instance MonadIO Peek where 253 | liftIO f = Peek $ \_ ptr -> PeekResult ptr <$> f 254 | {-# INLINE liftIO #-} 255 | 256 | -- | Holds a 'peekStatePtr', which is passed in to each 'Peek' action. 257 | -- If the package is built with the 'force-alignment' flag, this also 258 | -- has a hidden 'Ptr' field, which is used as scratch space during 259 | -- unaligned reads. 260 | #if ALIGNED_MEMORY 261 | data PeekState = PeekState 262 | { peekStateEndPtr :: {-# UNPACK #-} !(Ptr Word8) 263 | , peekStateAlignPtr :: {-# UNPACK #-} !(Ptr Word8) 264 | } 265 | #else 266 | newtype PeekState = PeekState 267 | { peekStateEndPtr :: Ptr Word8 } 268 | #endif 269 | 270 | -- | Make a 'PeekState' from a buffer pointer. 271 | -- 272 | -- The first argument is a pointer to the memory to write to. The second 273 | -- argument is an IO action which is invoked if the store-core package 274 | -- was built with the @force-alignment@ flag. The action should yield a 275 | -- pointer to scratch memory as large as 'maybeAlignmentBufferSize'. 276 | -- 277 | -- Since 0.4.2 278 | unsafeMakePeekState :: Ptr Word8 -- ^ peekStateEndPtr 279 | -> IO (Ptr Word8) -- ^ action to produce peekStateAlignPtr 280 | -> IO PeekState 281 | #if ALIGNED_MEMORY 282 | unsafeMakePeekState ptr f = PeekState ptr <$> f 283 | #else 284 | unsafeMakePeekState ptr _ = return $ PeekState ptr 285 | #endif 286 | 287 | -- | Exception thrown while running 'peek'. Note that other types of 288 | -- exceptions can also be thrown. Invocations of 'fail' in the 'Poke' 289 | -- monad causes this exception to be thrown. 290 | -- 291 | -- 'PeekException' is thrown when the data being decoded is invalid. 292 | data PeekException = PeekException 293 | { peekExBytesFromEnd :: Offset 294 | , peekExMessage :: T.Text 295 | } deriving (Eq, Show, Typeable) 296 | 297 | instance Exception PeekException where 298 | #if MIN_VERSION_base(4,8,0) 299 | displayException (PeekException offset msg) = 300 | "Exception while peeking, " ++ 301 | show offset ++ 302 | " bytes from end: " ++ 303 | T.unpack msg 304 | #endif 305 | 306 | -- | Throws a 'PeekException'. 307 | peekException :: T.Text -> Peek a 308 | peekException msg = Peek $ \ps ptr -> throwIO (PeekException (peekStateEndPtr ps `minusPtr` ptr) msg) 309 | 310 | -- | Throws a 'PeekException' about an attempt to read too many bytes. 311 | tooManyBytes :: Int -> Int -> String -> IO void 312 | tooManyBytes needed remaining ty = 313 | throwIO $ PeekException remaining $ T.pack $ 314 | "Attempted to read too many bytes for " ++ 315 | ty ++ 316 | ". Needed " ++ 317 | show needed ++ ", but only " ++ 318 | show remaining ++ " remain." 319 | 320 | -- | Throws a 'PeekException' about an attempt to read a negative number of bytes. 321 | -- 322 | -- This can happen when we read invalid data -- the length tag is 323 | -- basically random in this case. 324 | negativeBytes :: Int -> Int -> String -> IO void 325 | negativeBytes needed remaining ty = 326 | throwIO $ PeekException remaining $ T.pack $ 327 | "Attempted to read negative number of bytes for " ++ 328 | ty ++ 329 | ". Tried to read " ++ 330 | show needed ++ ". This probably means that we're trying to read invalid data." 331 | 332 | ------------------------------------------------------------------------ 333 | -- Decoding and encoding ByteStrings 334 | 335 | 336 | -- | Given a 'Poke' and its length, uses it to fill a 'ByteString' 337 | -- 338 | -- This function is unsafe because the provided length must exactly 339 | -- match the number of bytes used by the 'Poke'. It will throw 340 | -- 'PokeException' errors when the buffer is under or overshot. However, 341 | -- in the case of overshooting the buffer, memory corruption and 342 | -- segfaults may occur. 343 | unsafeEncodeWith :: Poke () -> Int -> ByteString 344 | unsafeEncodeWith f l = 345 | BS.unsafeCreate l $ \ptr -> do 346 | #if ALIGNED_MEMORY 347 | allocaBytesAligned alignBufferSize 8 $ \aptr -> do 348 | #endif 349 | let ps = PokeState 350 | { pokeStatePtr = ptr 351 | #if ALIGNED_MEMORY 352 | , pokeStateAlignPtr = aptr 353 | #endif 354 | } 355 | (o, ()) <- runPoke f ps 0 356 | checkOffset o l 357 | 358 | #if ALIGNED_MEMORY 359 | alignBufferSize :: Int 360 | alignBufferSize = 32 361 | #endif 362 | 363 | -- | If store-core is built with the @force-alignment@ flag, then this 364 | -- will be a 'Just' value indicating the amount of memory that is 365 | -- expected in the alignment buffer used by 'PeekState' and 'PokeState'. 366 | -- Currently this will either be @Just 32@ or @Nothing@. 367 | maybeAlignmentBufferSize :: Maybe Int 368 | maybeAlignmentBufferSize = 369 | #if ALIGNED_MEMORY 370 | Just alignBufferSize 371 | #else 372 | Nothing 373 | #endif 374 | 375 | -- | Checks if the offset matches the expected length, and throw a 376 | -- 'PokeException' otherwise. 377 | checkOffset :: Int -> Int -> IO () 378 | checkOffset o l 379 | | o > l = throwIO $ PokeException o $ T.pack $ 380 | "encode overshot end of " ++ 381 | show l ++ 382 | " byte long buffer" 383 | | o < l = throwIO $ PokeException o $ T.pack $ 384 | "encode undershot end of " <> 385 | show l <> 386 | " byte long buffer" 387 | | otherwise = return () 388 | 389 | -- | Decodes a value from a 'ByteString', potentially throwing 390 | -- exceptions, and taking a 'Peek' to run. It is an exception to not 391 | -- consume all input. 392 | decodeWith :: Peek a -> ByteString -> Either PeekException a 393 | decodeWith mypeek = unsafePerformIO . try . decodeIOWith mypeek 394 | 395 | -- | Decodes a value from a 'ByteString', potentially throwing 396 | -- exceptions, and taking a 'Peek' to run. It is an exception to not 397 | -- consume all input. 398 | decodeExWith :: Peek a -> ByteString -> a 399 | decodeExWith f = unsafePerformIO . decodeIOWith f 400 | 401 | -- | Similar to 'decodeExWith', but it allows there to be more of the 402 | -- buffer remaining. The 'Offset' of the buffer contents immediately 403 | -- after the decoded value is returned. 404 | decodeExPortionWith :: Peek a -> ByteString -> (Offset, a) 405 | decodeExPortionWith f = unsafePerformIO . decodeIOPortionWith f 406 | 407 | -- | Decodes a value from a 'ByteString', potentially throwing 408 | -- exceptions, and taking a 'Peek' to run. It is an exception to not 409 | -- consume all input. 410 | decodeIOWith :: Peek a -> ByteString -> IO a 411 | decodeIOWith mypeek (BS.PS x s len) = 412 | withForeignPtr x $ \ptr0 -> 413 | let ptr = ptr0 `plusPtr` s 414 | in decodeIOWithFromPtr mypeek ptr len 415 | 416 | -- | Similar to 'decodeExPortionWith', but runs in the 'IO' monad. 417 | decodeIOPortionWith :: Peek a -> ByteString -> IO (Offset, a) 418 | decodeIOPortionWith mypeek (BS.PS x s len) = 419 | withForeignPtr x $ \ptr0 -> 420 | let ptr = ptr0 `plusPtr` s 421 | in decodeIOPortionWithFromPtr mypeek ptr len 422 | 423 | -- | Like 'decodeIOWith', but using 'Ptr' and length instead of a 424 | -- 'ByteString'. 425 | decodeIOWithFromPtr :: Peek a -> Ptr Word8 -> Int -> IO a 426 | decodeIOWithFromPtr mypeek ptr len = do 427 | (offset, x) <- decodeIOPortionWithFromPtr mypeek ptr len 428 | if len /= offset 429 | then throwIO $ PeekException (len - offset) "Didn't consume all input." 430 | else return x 431 | 432 | -- | Like 'decodeIOPortionWith', but using 'Ptr' and length instead of a 'ByteString'. 433 | decodeIOPortionWithFromPtr :: Peek a -> Ptr Word8 -> Int -> IO (Offset, a) 434 | decodeIOPortionWithFromPtr mypeek ptr len = 435 | let end = ptr `plusPtr` len 436 | remaining = end `minusPtr` ptr 437 | in do PeekResult ptr2 x' <- 438 | #if ALIGNED_MEMORY 439 | allocaBytesAligned alignBufferSize 8 $ \aptr -> do 440 | runPeek mypeek (PeekState end aptr) ptr 441 | #else 442 | runPeek mypeek (PeekState end) ptr 443 | #endif 444 | if len > remaining -- Do not perform the check on the new pointer, since it could have overflowed 445 | then throwIO $ PeekException (end `minusPtr` ptr2) "Overshot end of buffer" 446 | else return (ptr2 `minusPtr` ptr, x') 447 | 448 | ------------------------------------------------------------------------ 449 | -- Utilities for defining 'Store' instances based on 'Storable' 450 | 451 | -- | A 'poke' implementation based on an instance of 'Storable'. 452 | pokeStorable :: Storable a => a -> Poke () 453 | pokeStorable x = Poke $ \ps offset -> do 454 | let targetPtr = pokeStatePtr ps `plusPtr` offset 455 | #if ALIGNED_MEMORY 456 | -- If necessary, poke into the scratch buffer, and copy the results 457 | -- to the output buffer. 458 | let bufStart = pokeStateAlignPtr ps 459 | alignStart = alignPtr (pokeStateAlignPtr ps) (alignment x) 460 | sz = sizeOf x 461 | if targetPtr == alignPtr targetPtr (alignment x) 462 | -- If we luck out and the output is already aligned, just poke it 463 | -- directly. 464 | then poke targetPtr x 465 | else (if (alignStart `plusPtr` sz) < (bufStart `plusPtr` alignBufferSize) 466 | then do 467 | poke (castPtr alignStart) x 468 | BS.memcpy (castPtr targetPtr) alignStart sz 469 | else do 470 | allocaBytesAligned sz (alignment x) $ \tempPtr -> do 471 | poke tempPtr x 472 | BS.memcpy (castPtr targetPtr) (castPtr tempPtr) sz) 473 | #else 474 | poke targetPtr x 475 | #endif 476 | let !newOffset = offset + sizeOf x 477 | return (newOffset, ()) 478 | {-# INLINE pokeStorable #-} 479 | 480 | -- | A 'peek' implementation based on an instance of 'Storable' and 481 | -- 'Typeable'. 482 | peekStorable :: forall a. (Storable a, Typeable a) => Peek a 483 | peekStorable = peekStorableTy (show (typeRep (Proxy :: Proxy a))) 484 | {-# INLINE peekStorable #-} 485 | 486 | -- | A 'peek' implementation based on an instance of 'Storable'. Use 487 | -- this if the type is not 'Typeable'. 488 | peekStorableTy :: forall a. Storable a => String -> Peek a 489 | peekStorableTy ty = Peek $ \ps ptr -> do 490 | let ptr' = ptr `plusPtr` sz 491 | sz = sizeOf (undefined :: a) 492 | remaining = peekStateEndPtr ps `minusPtr` ptr 493 | when (sz > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed 494 | tooManyBytes sz remaining ty 495 | #if ALIGNED_MEMORY 496 | let bufStart = peekStateAlignPtr ps 497 | alignStart = alignPtr (peekStateAlignPtr ps) alignAmount 498 | alignAmount = alignment (undefined :: a) 499 | x <- if ptr == alignPtr ptr alignAmount 500 | then Storable.peek (castPtr ptr) 501 | else (if (alignStart `plusPtr` sz) < (bufStart `plusPtr` alignBufferSize) 502 | then do 503 | BS.memcpy (castPtr alignStart) ptr sz 504 | Storable.peek (castPtr alignStart) 505 | else do 506 | allocaBytesAligned sz alignAmount $ \tempPtr -> do 507 | BS.memcpy tempPtr (castPtr ptr) sz 508 | Storable.peek (castPtr tempPtr)) 509 | #else 510 | x <- Storable.peek (castPtr ptr) 511 | #endif 512 | return $ PeekResult ptr' x 513 | {-# INLINE peekStorableTy #-} 514 | 515 | ------------------------------------------------------------------------ 516 | -- Utilities for implementing 'Store' instances via memcpy 517 | 518 | -- | Copy a section of memory, based on a 'ForeignPtr', to the output. 519 | -- Note that this operation is unsafe, the offset and length parameters 520 | -- are not checked. 521 | pokeFromForeignPtr :: ForeignPtr a -> Int -> Int -> Poke () 522 | pokeFromForeignPtr sourceFp sourceOffset len = 523 | Poke $ \targetState targetOffset -> do 524 | let targetPtr = pokeStatePtr targetState 525 | withForeignPtr sourceFp $ \sourcePtr -> 526 | BS.memcpy (targetPtr `plusPtr` targetOffset) 527 | (sourcePtr `plusPtr` sourceOffset) 528 | len 529 | let !newOffset = targetOffset + len 530 | return (newOffset, ()) 531 | 532 | -- | Allocate a plain ForeignPtr (no finalizers), of the specified 533 | -- length and fill it with bytes from the input. 534 | peekToPlainForeignPtr :: String -> Int -> Peek (ForeignPtr a) 535 | peekToPlainForeignPtr ty len = 536 | Peek $ \ps sourcePtr -> do 537 | let ptr2 = sourcePtr `plusPtr` len 538 | remaining = peekStateEndPtr ps `minusPtr` sourcePtr 539 | when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed 540 | tooManyBytes len remaining ty 541 | when (len < 0) $ 542 | negativeBytes len remaining ty 543 | fp <- BS.mallocByteString len 544 | withForeignPtr fp $ \targetPtr -> 545 | BS.memcpy targetPtr (castPtr sourcePtr) len 546 | return $ PeekResult ptr2 (castForeignPtr fp) 547 | 548 | -- | Copy a section of memory, based on a 'Ptr', to the output. Note 549 | -- that this operation is unsafe, because the offset and length 550 | -- parameters are not checked. 551 | pokeFromPtr :: Ptr a -> Int -> Int -> Poke () 552 | pokeFromPtr sourcePtr sourceOffset len = 553 | Poke $ \targetState targetOffset -> do 554 | let targetPtr = pokeStatePtr targetState 555 | BS.memcpy (targetPtr `plusPtr` targetOffset) 556 | (sourcePtr `plusPtr` sourceOffset) 557 | len 558 | let !newOffset = targetOffset + len 559 | return (newOffset, ()) 560 | 561 | -- | Copy a section of memory, based on a 'ByteArray#', to the output. 562 | -- Note that this operation is unsafe, because the offset and length 563 | -- parameters are not checked. 564 | pokeFromByteArray :: ByteArray# -> Int -> Int -> Poke () 565 | pokeFromByteArray sourceArr sourceOffset len = 566 | Poke $ \targetState targetOffset -> do 567 | let target = (pokeStatePtr targetState) `plusPtr` targetOffset 568 | copyByteArrayToAddr sourceArr sourceOffset target len 569 | let !newOffset = targetOffset + len 570 | return (newOffset, ()) 571 | 572 | -- | Allocate a ByteArray of the specified length and fill it with bytes 573 | -- from the input. 574 | peekToByteArray :: String -> Int -> Peek ByteArray 575 | peekToByteArray ty len = 576 | Peek $ \ps sourcePtr -> do 577 | let ptr2 = sourcePtr `plusPtr` len 578 | remaining = peekStateEndPtr ps `minusPtr` sourcePtr 579 | when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed 580 | tooManyBytes len remaining ty 581 | when (len < 0) $ 582 | negativeBytes len remaining ty 583 | marr <- newByteArray len 584 | copyAddrToByteArray sourcePtr marr 0 len 585 | x <- unsafeFreezeByteArray marr 586 | return $ PeekResult ptr2 x 587 | 588 | -- | Wrapper around @copyByteArrayToAddr#@ primop. 589 | copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO () 590 | copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) = 591 | IO (\s -> (# copyByteArrayToAddr# arr offset addr len s, () #)) 592 | {-# INLINE copyByteArrayToAddr #-} 593 | 594 | -- | Wrapper around @copyAddrToByteArray#@ primop. 595 | copyAddrToByteArray :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO () 596 | copyAddrToByteArray (Ptr addr) (MutableByteArray arr) (I# offset) (I# len) = 597 | IO (\s -> (# copyAddrToByteArray# addr arr offset len s, () #)) 598 | {-# INLINE copyAddrToByteArray #-} 599 | -------------------------------------------------------------------------------- /store-core/store-core.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.36.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: store-core 8 | version: 0.4.4.7 9 | synopsis: Fast and lightweight binary serialization 10 | category: Serialization, Data 11 | homepage: https://github.com/fpco/store#readme 12 | bug-reports: https://github.com/fpco/store/issues 13 | maintainer: Michael Sloan 14 | copyright: 2016 FP Complete 15 | license: MIT 16 | license-file: LICENSE 17 | build-type: Simple 18 | tested-with: 19 | GHC==9.4.5 20 | , GHC==9.2.8 21 | , GHC==9.0.2 22 | , GHC==8.10.7 23 | , GHC==8.8.4 24 | , GHC==8.6.5 25 | , GHC==8.4.4 26 | extra-source-files: 27 | ChangeLog.md 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/fpco/store 32 | 33 | flag force-alignment 34 | manual: True 35 | default: False 36 | 37 | library 38 | exposed-modules: 39 | Data.Store.Core 40 | other-modules: 41 | Paths_store_core 42 | hs-source-dirs: 43 | src 44 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 45 | build-depends: 46 | base >=4.7 && <5 47 | , bytestring >=0.10.4.0 && <1.0 48 | , ghc-prim >=0.3.1.0 && <1.0 49 | , primitive >=0.6 && <1.0 50 | , text >=1.2.0.4 && <1.3 || >=2.0 && <2.2 51 | , transformers >=0.3.0.0 && <1.0 52 | default-language: Haskell2010 53 | if flag(force-alignment) || arch(PPC) || arch(PPC64) || arch(Mips) || arch(Sparc) || arch(Arm) 54 | cpp-options: -DALIGNED_MEMORY 55 | if impl(ghc < 8.0) 56 | build-depends: 57 | fail >=4.9 58 | -------------------------------------------------------------------------------- /store-streaming/.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /.cabal-sandbox/ 3 | /cabal.sandbox.config 4 | /.stack-work/ 5 | -------------------------------------------------------------------------------- /store-streaming/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog 2 | 3 | ## 0.2.0.3 4 | 5 | * Test compilation fixed with `network >= 3`. 6 | 7 | ## 0.2.0.2 8 | 9 | * Now only depends on `fail` / `semigroups` shim for `ghc < 8`. 10 | 11 | ## 0.2.0.1 12 | 13 | * Now builds with GHC-7.10 - compatibility was broken in 0.6.0 due to 14 | the fix for GHC-8.8. See 15 | [#146][https://github.com/fpco/store/issues/146]. 16 | 17 | ## 0.2.0.0 18 | 19 | * Now builds with GHC-8.8. This is a major version bump because 20 | MonadFail constraints were added to some functions, which is 21 | potentially a breaking change. 22 | 23 | ## 0.1.0.0 24 | 25 | * `Data.Store.Streaming` forked from `store-0.4.3.2` 26 | -------------------------------------------------------------------------------- /store-streaming/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2016-2018 FP Complete 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /store-streaming/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /store-streaming/package.yaml: -------------------------------------------------------------------------------- 1 | name: store-streaming 2 | version: "0.2.0.5" 3 | synopsis: Streaming interfaces for `store` 4 | maintainer: Michael Sloan 5 | license: MIT 6 | copyright: 2016 FP Complete 7 | github: fpco/store 8 | category: Serialization, Data 9 | extra-source-files: 10 | - ChangeLog.md 11 | tested-with: 12 | - GHC==9.4.5 13 | - GHC==9.2.8 14 | - GHC==9.0.2 15 | - GHC==8.10.7 16 | - GHC==8.8.4 17 | - GHC==8.6.5 18 | - GHC==8.4.4 19 | 20 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 21 | 22 | dependencies: 23 | - async >=2.0.2 24 | - base >=4.7 && <5 25 | - bytestring >=0.10.4.0 26 | - conduit >=1.2.3.1 27 | - free >=4.11 28 | - resourcet >=1.1.3.3 29 | - store >=0.4.3.4 30 | - store-core >=0.4.1 31 | - streaming-commons >=0.1.10.0 32 | - text >=1.2.0.4 33 | - transformers >=0.3.0.0 34 | 35 | when: 36 | - condition: impl(ghc < 8.0) 37 | dependencies: fail >=4.9 38 | 39 | library: 40 | source-dirs: src 41 | 42 | tests: 43 | store-test: 44 | source-dirs: test 45 | main: Spec.hs 46 | other-modules: 47 | - Data.Store.StreamingSpec 48 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 49 | dependencies: 50 | - hspec 51 | - hspec-smallcheck 52 | - network 53 | - smallcheck 54 | - store 55 | - store-streaming 56 | - void 57 | build-tools: hspec-discover:hspec-discover 58 | -------------------------------------------------------------------------------- /store-streaming/src/Data/Store/Streaming.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | {-# LANGUAGE CPP #-} 6 | {-| 7 | Module: Data.Store.Streaming 8 | Description: A thin streaming layer that uses 'Store' for serialisation. 9 | 10 | For efficiency reasons, 'Store' does not provide facilities for 11 | incrementally consuming input. In order to avoid partial input, this 12 | module introduces 'Message's that wrap values of instances of 'Store'. 13 | 14 | In addition to the serialisation of a value, the serialised message 15 | also contains the length of the serialisation. This way, instead of 16 | consuming input incrementally, more input can be demanded before 17 | serialisation is attempted in the first place. 18 | 19 | Each message starts with a fixed magic number, in order to detect 20 | (randomly) invalid data. 21 | 22 | -} 23 | module Data.Store.Streaming 24 | ( -- * 'Message's to stream data using 'Store' for serialisation. 25 | Message (..) 26 | -- * Encoding 'Message's 27 | , encodeMessage 28 | -- * Decoding 'Message's 29 | , PeekMessage 30 | , FillByteBuffer 31 | , peekMessage 32 | , decodeMessage 33 | , peekMessageBS 34 | , decodeMessageBS 35 | #ifndef mingw32_HOST_OS 36 | , ReadMoreData(..) 37 | , peekMessageFd 38 | , decodeMessageFd 39 | #endif 40 | -- * Conduits for encoding and decoding 41 | , conduitEncode 42 | , conduitDecode 43 | ) where 44 | 45 | import Control.Exception (throwIO) 46 | import Control.Monad (unless) 47 | import Control.Monad.Fail (MonadFail) 48 | import Control.Monad.IO.Class 49 | import Control.Monad.Trans.Resource (MonadResource) 50 | import Data.ByteString (ByteString) 51 | import qualified Data.Conduit as C 52 | import qualified Data.Conduit.List as C 53 | import Data.Store 54 | import Data.Store.Core (decodeIOWithFromPtr, unsafeEncodeWith) 55 | import Data.Store.Internal (getSize) 56 | import qualified Data.Text as T 57 | import Data.Word 58 | import Foreign.Ptr 59 | import Prelude 60 | import System.IO.ByteBuffer (ByteBuffer) 61 | import qualified System.IO.ByteBuffer as BB 62 | import Control.Monad.Trans.Free.Church (FT, iterTM, wrap) 63 | import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) 64 | import Control.Monad.Trans.Class (lift) 65 | import System.Posix.Types (Fd(..)) 66 | import GHC.Conc (threadWaitRead) 67 | import Data.Store.Streaming.Internal 68 | 69 | -- | If @a@ is an instance of 'Store', @Message a@ can be serialised 70 | -- and deserialised in a streaming fashion. 71 | newtype Message a = Message { fromMessage :: a } deriving (Eq, Show) 72 | 73 | -- | Encode a 'Message' to a 'ByteString'. 74 | encodeMessage :: Store a => Message a -> ByteString 75 | encodeMessage (Message x) = 76 | unsafeEncodeWith pokeFunc totalLength 77 | where 78 | bodyLength = getSize x 79 | totalLength = headerLength + bodyLength 80 | pokeFunc = do 81 | poke messageMagic 82 | poke bodyLength 83 | poke x 84 | 85 | -- | The result of peeking at the next message can either be a 86 | -- successfully deserialised object, or a request for more input. 87 | type PeekMessage i m a = FT ((->) i) m a 88 | 89 | needMoreInput :: PeekMessage i m i 90 | needMoreInput = wrap return 91 | 92 | -- | Given some sort of input, fills the 'ByteBuffer' with it. 93 | -- 94 | -- The 'Int' is how many bytes we'd like: this is useful when the filling 95 | -- function is 'fillFromFd', where we can specify a max size. 96 | type FillByteBuffer i m = ByteBuffer -> Int -> i -> m () 97 | 98 | -- | Decode a value, given a 'Ptr' and the number of bytes that make 99 | -- up the encoded message. 100 | decodeFromPtr :: (MonadIO m, Store a) => Ptr Word8 -> Int -> m a 101 | decodeFromPtr ptr n = liftIO $ decodeIOWithFromPtr peek ptr n 102 | 103 | peekSized :: (MonadIO m, Store a) => FillByteBuffer i m -> ByteBuffer -> Int -> PeekMessage i m a 104 | peekSized fill bb n = go 105 | where 106 | go = do 107 | mbPtr <- BB.unsafeConsume bb n 108 | case mbPtr of 109 | Left needed -> do 110 | inp <- needMoreInput 111 | lift (fill bb needed inp) 112 | go 113 | Right ptr -> decodeFromPtr ptr n 114 | 115 | -- | Read and check the magic number from a 'ByteBuffer' 116 | peekMessageMagic :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m () 117 | peekMessageMagic fill bb = 118 | peekSized fill bb magicLength >>= \case 119 | mm | mm == messageMagic -> return () 120 | mm -> liftIO . throwIO $ PeekException 0 . T.pack $ 121 | "Wrong message magic, " ++ show mm 122 | 123 | -- | Decode a 'SizeTag' from a 'ByteBuffer'. 124 | peekMessageSizeTag :: MonadIO m => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m SizeTag 125 | peekMessageSizeTag fill bb = peekSized fill bb sizeTagLength 126 | 127 | -- | Decode some object from a 'ByteBuffer', by first reading its 128 | -- header, and then the actual data. 129 | peekMessage :: (MonadIO m, Store a) => FillByteBuffer i m -> ByteBuffer -> PeekMessage i m (Message a) 130 | peekMessage fill bb = 131 | fmap Message $ do 132 | peekMessageMagic fill bb 133 | peekMessageSizeTag fill bb >>= peekSized fill bb 134 | 135 | -- | Decode a 'Message' from a 'ByteBuffer' and an action that can get 136 | -- additional inputs to refill the buffer when necessary. 137 | -- 138 | -- The only conditions under which this function will give 'Nothing', 139 | -- is when the 'ByteBuffer' contains zero bytes, and refilling yields 140 | -- 'Nothing'. If there is some data available, but not enough to 141 | -- decode the whole 'Message', a 'PeekException' will be thrown. 142 | decodeMessage :: (Store a, MonadIO m) => FillByteBuffer i m -> ByteBuffer -> m (Maybe i) -> m (Maybe (Message a)) 143 | decodeMessage fill bb getInp = 144 | maybeDecode (peekMessageMagic fill bb) >>= \case 145 | Just () -> maybeDecode (peekMessageSizeTag fill bb >>= peekSized fill bb) >>= \case 146 | Just x -> return (Just (Message x)) 147 | Nothing -> do 148 | -- We have already read the message magic, so a failure to 149 | -- read the whole message means we have an incomplete message. 150 | available <- BB.availableBytes bb 151 | liftIO $ throwIO $ PeekException available $ T.pack 152 | "Data.Store.Streaming.decodeMessage: could not get enough bytes to decode message" 153 | Nothing -> do 154 | available <- BB.availableBytes bb 155 | -- At this point, we have not consumed anything yet, so if bb is 156 | -- empty, there simply was no message to read. 157 | unless (available == 0) $ liftIO $ throwIO $ PeekException available $ T.pack 158 | "Data.Store.Streaming.decodeMessage: could not get enough bytes to decode message" 159 | return Nothing 160 | where 161 | maybeDecode m = runMaybeT (iterTM (\consumeInp -> consumeInp =<< MaybeT getInp) m) 162 | 163 | -- | Decode some 'Message' from a 'ByteBuffer', by first reading its 164 | -- header, and then the actual 'Message'. 165 | peekMessageBS :: (MonadIO m, Store a) => ByteBuffer -> PeekMessage ByteString m (Message a) 166 | peekMessageBS = peekMessage (\bb _ bs -> BB.copyByteString bb bs) 167 | 168 | decodeMessageBS :: (MonadIO m, Store a) 169 | => ByteBuffer -> m (Maybe ByteString) -> m (Maybe (Message a)) 170 | decodeMessageBS = decodeMessage (\bb _ bs -> BB.copyByteString bb bs) 171 | 172 | #ifndef mingw32_HOST_OS 173 | 174 | -- | We use this type as a more descriptive unit to signal that more input 175 | -- should be read from the Fd. 176 | -- 177 | -- This data-type is only available on POSIX systems (essentially, non-windows) 178 | data ReadMoreData = ReadMoreData 179 | deriving (Eq, Show) 180 | 181 | -- | Peeks a message from a _non blocking_ 'Fd'. 182 | -- 183 | -- This function is only available on POSIX systems (essentially, non-windows) 184 | peekMessageFd :: (MonadIO m, MonadFail m, Store a) => ByteBuffer -> Fd -> PeekMessage ReadMoreData m (Message a) 185 | peekMessageFd bb fd = 186 | peekMessage (\bb_ needed ReadMoreData -> do _ <- BB.fillFromFd bb_ fd needed; return ()) bb 187 | 188 | -- | Decodes all the message using 'registerFd' to find out when a 'Socket' is 189 | -- ready for reading. 190 | -- 191 | -- This function is only available on POSIX systems (essentially, non-windows) 192 | decodeMessageFd :: (MonadIO m, MonadFail m, Store a) => ByteBuffer -> Fd -> m (Message a) 193 | decodeMessageFd bb fd = do 194 | mbMsg <- decodeMessage 195 | (\bb_ needed ReadMoreData -> do _ <- BB.fillFromFd bb_ fd needed; return ()) bb 196 | (liftIO (threadWaitRead fd) >> return (Just ReadMoreData)) 197 | case mbMsg of 198 | Just msg -> return msg 199 | Nothing -> liftIO (fail "decodeMessageFd: impossible: got Nothing") 200 | 201 | #endif 202 | 203 | -- | Conduit for encoding 'Message's to 'ByteString's. 204 | conduitEncode 205 | :: (Monad m, Store a) 206 | => C.Conduit (Message a) m ByteString 207 | -- ^ NOTE: ignore the conduit deprecation warning. Otherwise 208 | -- incompatible with old conduit versions 209 | conduitEncode = C.map encodeMessage 210 | 211 | -- | Conduit for decoding 'Message's from 'ByteString's. 212 | conduitDecode :: (MonadResource m, Store a) 213 | => Maybe Int 214 | -- ^ Initial length of the 'ByteBuffer' used for 215 | -- buffering the incoming 'ByteString's. If 'Nothing', 216 | -- use the default value of 4MB. 217 | -> C.Conduit ByteString m (Message a) 218 | -- ^ NOTE: ignore the conduit deprecation 219 | -- warning. Otherwise incompatible with old conduit 220 | -- versions. 221 | conduitDecode bufSize = 222 | C.bracketP 223 | (BB.new bufSize) 224 | BB.free 225 | go 226 | where 227 | go buffer = do 228 | mmessage <- decodeMessageBS buffer C.await 229 | case mmessage of 230 | Nothing -> return () 231 | Just message -> C.yield message >> go buffer 232 | -------------------------------------------------------------------------------- /store-streaming/src/Data/Store/Streaming/Internal.hs: -------------------------------------------------------------------------------- 1 | module Data.Store.Streaming.Internal 2 | ( messageMagic 3 | , magicLength 4 | , sizeTagLength 5 | , headerLength 6 | , SizeTag 7 | ) where 8 | 9 | import Data.Word (Word64) 10 | import qualified Foreign.Storable as Storable 11 | 12 | -- | Type used to store the length of a 'Message'. 13 | type SizeTag = Int 14 | 15 | -- | Some fixed arbitrary magic number that precedes every 'Message'. 16 | messageMagic :: Word64 17 | messageMagic = 18205256374652458875 18 | 19 | magicLength :: Int 20 | magicLength = Storable.sizeOf messageMagic 21 | 22 | sizeTagLength :: Int 23 | sizeTagLength = Storable.sizeOf (undefined :: SizeTag) 24 | 25 | headerLength :: Int 26 | headerLength = sizeTagLength + magicLength -------------------------------------------------------------------------------- /store-streaming/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.13 2 | packages: 3 | - . 4 | # - .. 5 | -------------------------------------------------------------------------------- /store-streaming/store-streaming.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: store-streaming 8 | version: 0.2.0.5 9 | synopsis: Streaming interfaces for `store` 10 | category: Serialization, Data 11 | homepage: https://github.com/fpco/store#readme 12 | bug-reports: https://github.com/fpco/store/issues 13 | maintainer: Michael Sloan 14 | copyright: 2016 FP Complete 15 | license: MIT 16 | license-file: LICENSE 17 | build-type: Simple 18 | tested-with: 19 | GHC==9.4.5 20 | , GHC==9.2.8 21 | , GHC==9.0.2 22 | , GHC==8.10.7 23 | , GHC==8.8.4 24 | , GHC==8.6.5 25 | , GHC==8.4.4 26 | extra-source-files: 27 | ChangeLog.md 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/fpco/store 32 | 33 | library 34 | exposed-modules: 35 | Data.Store.Streaming 36 | Data.Store.Streaming.Internal 37 | other-modules: 38 | Paths_store_streaming 39 | hs-source-dirs: 40 | src 41 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 42 | build-depends: 43 | async >=2.0.2 44 | , base >=4.7 && <5 45 | , bytestring >=0.10.4.0 46 | , conduit >=1.2.3.1 47 | , free >=4.11 48 | , resourcet >=1.1.3.3 49 | , store >=0.4.3.4 50 | , store-core >=0.4.1 51 | , streaming-commons >=0.1.10.0 52 | , text >=1.2.0.4 53 | , transformers >=0.3.0.0 54 | default-language: Haskell2010 55 | if impl(ghc < 8.0) 56 | build-depends: 57 | fail >=4.9 58 | 59 | test-suite store-test 60 | type: exitcode-stdio-1.0 61 | main-is: Spec.hs 62 | other-modules: 63 | Data.Store.StreamingSpec 64 | hs-source-dirs: 65 | test 66 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N 67 | build-tool-depends: 68 | hspec-discover:hspec-discover 69 | build-depends: 70 | async >=2.0.2 71 | , base >=4.7 && <5 72 | , bytestring >=0.10.4.0 73 | , conduit >=1.2.3.1 74 | , free >=4.11 75 | , hspec 76 | , hspec-smallcheck 77 | , network 78 | , resourcet >=1.1.3.3 79 | , smallcheck 80 | , store 81 | , store-core >=0.4.1 82 | , store-streaming 83 | , streaming-commons >=0.1.10.0 84 | , text >=1.2.0.4 85 | , transformers >=0.3.0.0 86 | , void 87 | default-language: Haskell2010 88 | if impl(ghc < 8.0) 89 | build-depends: 90 | fail >=4.9 91 | -------------------------------------------------------------------------------- /store-streaming/test/Data/Store/StreamingSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE CPP #-} 5 | module Data.Store.StreamingSpec where 6 | 7 | import Control.Concurrent (threadDelay) 8 | import Control.Concurrent.Async (race, concurrently) 9 | import Control.Concurrent.MVar 10 | import Control.Exception (try) 11 | import Control.Monad (void, (<=<), forM_) 12 | import Control.Monad.Trans.Free (runFreeT, FreeF(..)) 13 | import Control.Monad.Trans.Free.Church (fromFT) 14 | import Control.Monad.Trans.Resource 15 | import qualified Data.ByteString as BS 16 | import Data.Conduit ((=$=), ($$)) 17 | import qualified Data.Conduit.List as C 18 | import Data.List (unfoldr) 19 | import Data.Monoid 20 | import Data.Store.Internal 21 | import Data.Store.Streaming 22 | import Data.Store.Streaming.Internal 23 | import Data.Streaming.Network (runTCPServer, runTCPClient, clientSettingsTCP, serverSettingsTCP, setAfterBind) 24 | import Data.Streaming.Network.Internal (AppData(..)) 25 | import Data.Void (absurd, Void) 26 | import Network.Socket.ByteString (send) 27 | import qualified System.IO.ByteBuffer as BB 28 | import System.Posix.Types (Fd(..)) 29 | import Test.Hspec 30 | import Test.Hspec.SmallCheck 31 | import Test.SmallCheck 32 | 33 | #if MIN_VERSION_network(3,0,0) 34 | import Network.Socket (Socket, socketPort, withFdSocket) 35 | #else 36 | import Network.Socket (Socket(..), socketPort) 37 | import Foreign.C.Types (CInt) 38 | #endif 39 | 40 | spec :: Spec 41 | spec = do 42 | describe "conduitEncode and conduitDecode" $ do 43 | it "Roundtrips ([Int])." $ property roundtrip 44 | it "Roundtrips ([Int]), with chunked transfer." $ property roundtripChunked 45 | it "Throws an Exception on incomplete messages." conduitIncomplete 46 | it "Throws an Exception on excess input." $ property conduitExcess 47 | describe "peekMessage" $ do 48 | describe "ByteString" $ do 49 | it "demands more input when needed." $ property (askMoreBS (headerLength + 1)) 50 | it "demands more input on incomplete message magic." $ property (askMoreBS 1) 51 | it "demands more input on incomplete SizeTag." $ property (askMoreBS (headerLength - 1)) 52 | it "successfully decodes valid input." $ property canPeekBS 53 | describe "decodeMessage" $ do 54 | describe "ByteString" $ do 55 | it "Throws an Exception on incomplete messages." decodeIncomplete 56 | it "Throws an Exception on messages that are shorter than indicated." decodeTooShort 57 | #ifndef mingw32_HOST_OS 58 | describe "Socket" $ do 59 | it "Decodes data trickling through a socket." $ property decodeTricklingMessageFd 60 | #endif 61 | 62 | roundtrip :: [Int] -> Property IO 63 | roundtrip xs = monadic $ do 64 | xs' <- runResourceT $ C.sourceList xs 65 | =$= C.map Message 66 | =$= conduitEncode 67 | =$= conduitDecode Nothing 68 | =$= C.map fromMessage 69 | $$ C.consume 70 | return $ xs' == xs 71 | 72 | roundtripChunked :: [Int] -> Property IO 73 | roundtripChunked input = monadic $ do 74 | let (xs, chunkLengths) = splitAt (length input `div` 2) input 75 | bs <- C.sourceList xs 76 | =$= C.map Message 77 | =$= conduitEncode 78 | $$ C.fold (<>) mempty 79 | let chunks = unfoldr takeChunk (bs, chunkLengths) 80 | xs' <- runResourceT $ C.sourceList chunks 81 | =$= conduitDecode (Just 10) 82 | =$= C.map fromMessage 83 | $$ C.consume 84 | return $ xs' == xs 85 | where 86 | takeChunk (x, _) | BS.null x = Nothing 87 | takeChunk (x, []) = Just (x, (BS.empty, [])) 88 | takeChunk (x, l:ls) = 89 | let (chunk, rest) = BS.splitAt l x 90 | in Just (chunk, (rest, ls)) 91 | 92 | conduitIncomplete :: Expectation 93 | conduitIncomplete = 94 | (runResourceT (C.sourceList [incompleteInput] 95 | =$= conduitDecode (Just 10) 96 | $$ C.consume) 97 | :: IO [Message Integer]) `shouldThrow` \PeekException{} -> True 98 | 99 | conduitExcess :: [Int] -> Property IO 100 | conduitExcess xs = monadic $ do 101 | bs <- C.sourceList xs 102 | =$= C.map Message 103 | =$= conduitEncode 104 | $$ C.fold (<>) mempty 105 | res <- try (runResourceT (C.sourceList [bs `BS.append` "excess bytes"] 106 | =$= conduitDecode (Just 10) 107 | $$ C.consume) :: IO [Message Int]) 108 | case res of 109 | Right _ -> return False 110 | Left (PeekException _ _) -> return True 111 | 112 | -- splits an encoded message after n bytes. Feeds the first part to 113 | -- peekResult, expecting it to require more input. Then, feeds the 114 | -- second part and checks if the decoded result is the original 115 | -- message. 116 | askMoreBS :: Int -> Integer -> Property IO 117 | askMoreBS n x = monadic $ BB.with (Just 10) $ \ bb -> do 118 | let bs = encodeMessage (Message x) 119 | (start, end) = BS.splitAt n $ bs 120 | BB.copyByteString bb start 121 | peekResult <- runFreeT (fromFT (peekMessageBS bb)) 122 | case peekResult of 123 | Free cont -> 124 | runFreeT (cont end) >>= \case 125 | Pure (Message x') -> return $ x' == x 126 | Free _ -> return False 127 | Pure _ -> return False 128 | 129 | canPeekBS :: Integer -> Property IO 130 | canPeekBS x = monadic $ BB.with (Just 10) $ \ bb -> do 131 | let bs = encodeMessage (Message x) 132 | BB.copyByteString bb bs 133 | peekResult <- runFreeT (fromFT (peekMessageBS bb)) 134 | case peekResult of 135 | Free _ -> return False 136 | Pure (Message x') -> return $ x' == x 137 | 138 | #ifndef mingw32_HOST_OS 139 | #if !MIN_VERSION_network(3,0,0) 140 | withFdSocket :: Socket -> (CInt -> IO r) -> IO r 141 | withFdSocket (MkSocket fd _ _ _ _) f = f fd 142 | #endif 143 | 144 | withServer :: (Socket -> Socket -> IO a) -> IO a 145 | withServer cont = do 146 | sock1Var :: MVar Socket <- newEmptyMVar 147 | sock2Var :: MVar Socket <- newEmptyMVar 148 | portVar :: MVar Int <- newEmptyMVar 149 | doneVar :: MVar Void <- newEmptyMVar 150 | let adSocket ad = case appRawSocket' ad of 151 | Nothing -> error "withServer.adSocket: no raw socket in AppData" 152 | Just sock -> sock 153 | let ss = setAfterBind 154 | (putMVar portVar . fromIntegral <=< socketPort) 155 | (serverSettingsTCP 0 "127.0.0.1") 156 | x <- fmap (either (either absurd absurd) id) $ race 157 | (race 158 | (runTCPServer ss $ \ad -> do 159 | putMVar sock1Var (adSocket ad) 160 | void (readMVar doneVar)) 161 | (do port <- takeMVar portVar 162 | runTCPClient (clientSettingsTCP port "127.0.0.1") $ \ad -> do 163 | putMVar sock2Var (adSocket ad) 164 | readMVar doneVar)) 165 | (do sock1 <- takeMVar sock1Var 166 | sock2 <- takeMVar sock2Var 167 | cont sock1 sock2) 168 | putMVar doneVar (error "withServer: impossible: read from doneVar") 169 | return x 170 | 171 | decodeTricklingMessageFd :: Integer -> Property IO 172 | decodeTricklingMessageFd v = monadic $ do 173 | let bs = encodeMessage (Message v) 174 | BB.with Nothing $ \bb -> 175 | withServer $ \sock1 sock2 -> do 176 | let generateChunks :: [Int] -> BS.ByteString -> [BS.ByteString] 177 | generateChunks xs0 bs_ = case xs0 of 178 | [] -> generateChunks [1,3,10] bs_ 179 | x : xs -> if BS.null bs_ 180 | then [] 181 | else BS.take x bs_ : generateChunks xs (BS.drop x bs_) 182 | let chunks = generateChunks [] bs 183 | ((), Message v') <- concurrently 184 | (forM_ chunks $ \chunk -> do 185 | void (send sock1 chunk) 186 | threadDelay (10 * 1000)) 187 | (withFdSocket sock2 (decodeMessageFd bb . Fd)) 188 | return (v == v') 189 | 190 | #endif 191 | 192 | decodeIncomplete :: IO () 193 | decodeIncomplete = BB.with (Just 0) $ \ bb -> do 194 | BB.copyByteString bb (BS.take 1 incompleteInput) 195 | (decodeMessageBS bb (return Nothing) :: IO (Maybe (Message Integer))) 196 | `shouldThrow` \PeekException{} -> True 197 | 198 | incompleteInput :: BS.ByteString 199 | incompleteInput = 200 | let bs = encodeMessage (Message (42 :: Integer)) 201 | in BS.take (BS.length bs - 1) bs 202 | 203 | decodeTooShort :: IO () 204 | decodeTooShort = BB.with Nothing $ \bb -> do 205 | BB.copyByteString bb (encodeMessageTooShort . Message $ (1 :: Int)) 206 | (decodeMessageBS bb (return Nothing) :: IO (Maybe (Message Int))) 207 | `shouldThrow` \PeekException{} -> True 208 | 209 | encodeMessageTooShort :: Message Int -> BS.ByteString 210 | encodeMessageTooShort msg = 211 | BS.take (BS.length encoded - (getSize (0 :: Int))) encoded 212 | where 213 | encoded = encodeMessage msg 214 | -------------------------------------------------------------------------------- /store-streaming/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /store.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.37.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: store 8 | version: 0.7.20 9 | synopsis: Fast binary serialization 10 | category: Serialization, Data 11 | homepage: https://github.com/mgsloan/store#readme 12 | bug-reports: https://github.com/mgsloan/store/issues 13 | maintainer: Michael Sloan 14 | copyright: 2016 FP Complete 15 | license: MIT 16 | license-file: LICENSE 17 | build-type: Simple 18 | tested-with: 19 | GHC==9.4.5 20 | , GHC==9.2.8 21 | , GHC==9.0.2 22 | , GHC==8.10.7 23 | , GHC==8.8.4 24 | , GHC==8.6.5 25 | , GHC==8.4.4 26 | extra-source-files: 27 | ChangeLog.md 28 | README.md 29 | 30 | source-repository head 31 | type: git 32 | location: https://github.com/mgsloan/store 33 | 34 | flag comparison-bench 35 | manual: True 36 | default: False 37 | 38 | flag integer-simple 39 | description: Use the [simple integer library](http://hackage.haskell.org/package/integer-simple) instead of [integer-gmp](http://hackage.haskell.org/package/integer-gmp) 40 | manual: False 41 | default: False 42 | 43 | flag small-bench 44 | manual: True 45 | default: False 46 | 47 | library 48 | exposed-modules: 49 | Data.Store 50 | Data.Store.Internal 51 | Data.Store.TH 52 | Data.Store.TH.Internal 53 | Data.Store.TypeHash 54 | Data.Store.TypeHash.Internal 55 | Data.Store.Version 56 | System.IO.ByteBuffer 57 | other-modules: 58 | Data.Store.Impl 59 | hs-source-dirs: 60 | src 61 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 62 | build-depends: 63 | array >=0.5.0.0 64 | , async >=2.0.2 65 | , base >=4.7 && <5 66 | , base-orphans >=0.4.3 67 | , base64-bytestring >=0.1.1 68 | , bifunctors >=4.0 69 | , bytestring >=0.10.4.0 70 | , containers >=0.5.5.1 71 | , contravariant >=1.3 72 | , cryptohash-sha1 >=0.11.6 73 | , deepseq >=1.3.0.2 74 | , directory >=1.2 75 | , filepath >=1.3 76 | , free >=4.11 77 | , ghc-prim >=0.3.1.0 78 | , hashable >=1.2.3.1 79 | , hspec >=2.1.2 80 | , hspec-smallcheck >=0.3.0 81 | , lifted-base >=0.2.3.3 82 | , monad-control >=0.3.3.0 83 | , mono-traversable >=0.7.0 84 | , nats >=1 85 | , network >=2.6.0.2 86 | , primitive >=0.6 87 | , resourcet >=1.1.3.3 88 | , safe >=0.3.8 89 | , smallcheck >=1.1.1 90 | , store-core ==0.4.* 91 | , syb >=0.4.4 92 | , template-haskell >=2.9.0.0 93 | , text >=1.2.0.4 94 | , th-lift >=0.7.1 95 | , th-lift-instances >=0.1.4 96 | , th-orphans >=0.13.2 97 | , th-reify-many >=0.1.6 98 | , th-utilities >=0.2 99 | , time >=1.5 100 | , transformers >=0.3.0.0 101 | , unordered-containers >=0.2.5.1 102 | , vector >=0.10.12.3 103 | , void >=0.5.11 104 | default-language: Haskell2010 105 | if flag(integer-simple) 106 | build-depends: 107 | integer-simple >=0.1.1.1 108 | else 109 | cpp-options: -DINTEGER_GMP 110 | build-depends: 111 | integer-gmp >=0.5.1.0 112 | if impl(ghc < 8.0) 113 | build-depends: 114 | fail >=4.9 115 | , semigroups >=0.8 116 | 117 | test-suite store-test 118 | type: exitcode-stdio-1.0 119 | main-is: Spec.hs 120 | other-modules: 121 | Data.Store.UntrustedSpec 122 | Data.StoreSpec 123 | Data.StoreSpec.TH 124 | System.IO.ByteBufferSpec 125 | hs-source-dirs: 126 | test 127 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N 128 | build-tool-depends: 129 | hspec-discover:hspec-discover 130 | build-depends: 131 | array >=0.5.0.0 132 | , async >=2.0.2 133 | , base >=4.7 && <5 134 | , base-orphans >=0.4.3 135 | , base64-bytestring >=0.1.1 136 | , bifunctors >=4.0 137 | , bytestring >=0.10.4.0 138 | , clock >=0.3 139 | , containers >=0.5.5.1 140 | , contravariant >=1.3 141 | , cryptohash-sha1 >=0.11.6 142 | , deepseq >=1.3.0.2 143 | , directory >=1.2 144 | , filepath >=1.3 145 | , free >=4.11 146 | , ghc-prim >=0.3.1.0 147 | , hashable >=1.2.3.1 148 | , hspec >=2.1.2 149 | , hspec-smallcheck >=0.3.0 150 | , lifted-base >=0.2.3.3 151 | , monad-control >=0.3.3.0 152 | , mono-traversable >=0.7.0 153 | , nats >=1 154 | , network >=2.6.0.2 155 | , primitive >=0.6 156 | , resourcet >=1.1.3.3 157 | , safe >=0.3.8 158 | , smallcheck >=1.1.1 159 | , store 160 | , store-core ==0.4.* 161 | , syb >=0.4.4 162 | , template-haskell >=2.9.0.0 163 | , text >=1.2.0.4 164 | , th-lift >=0.7.1 165 | , th-lift-instances >=0.1.4 166 | , th-orphans >=0.13.2 167 | , th-reify-many >=0.1.6 168 | , th-utilities >=0.2 169 | , time >=1.5 170 | , transformers >=0.3.0.0 171 | , unordered-containers >=0.2.5.1 172 | , vector >=0.10.12.3 173 | , void >=0.5.11 174 | default-language: Haskell2010 175 | if flag(integer-simple) 176 | build-depends: 177 | integer-simple >=0.1.1.1 178 | else 179 | cpp-options: -DINTEGER_GMP 180 | build-depends: 181 | integer-gmp >=0.5.1.0 182 | if impl(ghc < 8.0) 183 | build-depends: 184 | fail >=4.9 185 | , semigroups >=0.8 186 | 187 | benchmark store-bench 188 | type: exitcode-stdio-1.0 189 | main-is: Bench.hs 190 | other-modules: 191 | Paths_store 192 | hs-source-dirs: 193 | bench 194 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N1 -with-rtsopts=-s -with-rtsopts=-qg 195 | build-depends: 196 | array >=0.5.0.0 197 | , async >=2.0.2 198 | , base >=4.7 && <5 199 | , base-orphans >=0.4.3 200 | , base64-bytestring >=0.1.1 201 | , bifunctors >=4.0 202 | , bytestring >=0.10.4.0 203 | , containers >=0.5.5.1 204 | , contravariant >=1.3 205 | , criterion 206 | , cryptohash-sha1 >=0.11.6 207 | , deepseq >=1.3.0.2 208 | , directory >=1.2 209 | , filepath >=1.3 210 | , free >=4.11 211 | , ghc-prim >=0.3.1.0 212 | , hashable >=1.2.3.1 213 | , hspec >=2.1.2 214 | , hspec-smallcheck >=0.3.0 215 | , lifted-base >=0.2.3.3 216 | , monad-control >=0.3.3.0 217 | , mono-traversable >=0.7.0 218 | , nats >=1 219 | , network >=2.6.0.2 220 | , primitive >=0.6 221 | , resourcet >=1.1.3.3 222 | , safe >=0.3.8 223 | , smallcheck >=1.1.1 224 | , store 225 | , store-core ==0.4.* 226 | , syb >=0.4.4 227 | , template-haskell >=2.9.0.0 228 | , text >=1.2.0.4 229 | , th-lift >=0.7.1 230 | , th-lift-instances >=0.1.4 231 | , th-orphans >=0.13.2 232 | , th-reify-many >=0.1.6 233 | , th-utilities >=0.2 234 | , time >=1.5 235 | , transformers >=0.3.0.0 236 | , unordered-containers >=0.2.5.1 237 | , vector >=0.10.12.3 238 | , void >=0.5.11 239 | default-language: Haskell2010 240 | if flag(integer-simple) 241 | build-depends: 242 | integer-simple >=0.1.1.1 243 | else 244 | cpp-options: -DINTEGER_GMP 245 | build-depends: 246 | integer-gmp >=0.5.1.0 247 | if impl(ghc < 8.0) 248 | build-depends: 249 | fail >=4.9 250 | , semigroups >=0.8 251 | if flag(comparison-bench) 252 | cpp-options: -DCOMPARISON_BENCH 253 | build-depends: 254 | binary 255 | , cereal 256 | , cereal-vector 257 | , vector-binary-instances 258 | if flag(small-bench) 259 | cpp-options: -DSMALL_BENCH 260 | 261 | benchmark store-weigh 262 | type: exitcode-stdio-1.0 263 | main-is: Allocations.hs 264 | hs-source-dirs: 265 | test 266 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T -O2 267 | build-depends: 268 | array >=0.5.0.0 269 | , async >=2.0.2 270 | , base >=4.7 && <5 271 | , base-orphans >=0.4.3 272 | , base64-bytestring >=0.1.1 273 | , bifunctors >=4.0 274 | , bytestring >=0.10.4.0 275 | , cereal 276 | , cereal-vector 277 | , containers >=0.5.5.1 278 | , contravariant >=1.3 279 | , criterion 280 | , cryptohash-sha1 >=0.11.6 281 | , deepseq >=1.3.0.2 282 | , directory >=1.2 283 | , filepath >=1.3 284 | , free >=4.11 285 | , ghc-prim >=0.3.1.0 286 | , hashable >=1.2.3.1 287 | , hspec >=2.1.2 288 | , hspec-smallcheck >=0.3.0 289 | , lifted-base >=0.2.3.3 290 | , monad-control >=0.3.3.0 291 | , mono-traversable >=0.7.0 292 | , nats >=1 293 | , network >=2.6.0.2 294 | , primitive >=0.6 295 | , resourcet >=1.1.3.3 296 | , safe >=0.3.8 297 | , smallcheck >=1.1.1 298 | , store 299 | , store-core ==0.4.* 300 | , syb >=0.4.4 301 | , template-haskell >=2.9.0.0 302 | , text >=1.2.0.4 303 | , th-lift >=0.7.1 304 | , th-lift-instances >=0.1.4 305 | , th-orphans >=0.13.2 306 | , th-reify-many >=0.1.6 307 | , th-utilities >=0.2 308 | , time >=1.5 309 | , transformers >=0.3.0.0 310 | , unordered-containers >=0.2.5.1 311 | , vector >=0.10.12.3 312 | , vector-binary-instances 313 | , void >=0.5.11 314 | , weigh 315 | default-language: Haskell2010 316 | if flag(integer-simple) 317 | build-depends: 318 | integer-simple >=0.1.1.1 319 | else 320 | cpp-options: -DINTEGER_GMP 321 | build-depends: 322 | integer-gmp >=0.5.1.0 323 | if impl(ghc < 8.0) 324 | build-depends: 325 | fail >=4.9 326 | , semigroups >=0.8 327 | -------------------------------------------------------------------------------- /test/Allocations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | 6 | -- | Weigh Store's operations. 7 | 8 | module Main where 9 | 10 | import Control.DeepSeq 11 | import qualified Data.IntMap.Strict as IntMap 12 | import qualified Data.IntSet as IntSet 13 | import qualified Data.Serialize as Cereal 14 | import qualified Data.Set as Set 15 | import qualified Data.Map.Strict as Map 16 | import qualified Data.Store as Store 17 | import qualified Data.Vector as Boxed 18 | #if MIN_VERSION_vector(0,13,2) 19 | import qualified Data.Vector as BoxedStrict 20 | #endif 21 | import qualified Data.Vector.Serialize () 22 | import qualified Data.Vector.Storable as Storable 23 | import Text.Printf 24 | import Weigh 25 | 26 | -- | Main entry point. 27 | main :: IO () 28 | main = 29 | mainWith weighing 30 | 31 | -- | Weigh weighing with Store vs Cereal. 32 | weighing :: Weigh () 33 | weighing = 34 | do fortype "[Int]" (\n -> replicate n 0 :: [Int]) 35 | fortype "Boxed Vector Int" (\n -> Boxed.replicate n 0 :: Boxed.Vector Int) 36 | #if MIN_VERSION_vector(0,13,2) 37 | fortype "Boxed Strict Vector Int" (\n -> BoxedStrict.replicate n 0 :: BoxedStrict.Vector Int) 38 | #endif 39 | fortype "Storable Vector Int" 40 | (\n -> Storable.replicate n 0 :: Storable.Vector Int) 41 | fortype "Set Int" (Set.fromDistinctAscList . ints) 42 | fortype "IntSet" (IntSet.fromDistinctAscList . ints) 43 | fortype "Map Int Int" (Map.fromDistinctAscList . intpairs) 44 | fortype "IntMap Int" (IntMap.fromDistinctAscList . intpairs) 45 | where fortype label make = 46 | scale (\(n,nstr) -> 47 | do let title :: String -> String 48 | title for = printf "%12s %-20s %s" nstr (label :: String) for 49 | encodeDecode en de = 50 | (return . (`asTypeOf` make n) . de . force . en . make) n 51 | action (title "Allocate") 52 | (return (make n)) 53 | action (title "Encode: Store") 54 | (return (Store.encode (force (make n)))) 55 | action (title "Encode: Cereal") 56 | (return (Cereal.encode (force (make n)))) 57 | action (title "Encode/Decode: Store") 58 | (encodeDecode Store.encode Store.decodeEx) 59 | action (title "Encode/Decode: Cereal") 60 | (encodeDecode Cereal.encode (fromRight . Cereal.decode))) 61 | scale f = 62 | mapM_ f 63 | (map (\x -> (x,commas x)) 64 | [1000000,2000000,10000000]) 65 | ints n = [1..n] :: [Int] 66 | intpairs = map (\x -> (x, x)) . ints 67 | fromRight = either (error "Left") id 68 | -------------------------------------------------------------------------------- /test/Data/Store/UntrustedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | -- | Tests for untrusted data. 7 | 8 | module Data.Store.UntrustedSpec where 9 | 10 | import Test.Hspec 11 | 12 | spec :: Spec 13 | spec = return () 14 | 15 | {- Untrusted data spec is disabled for now. See #122 / #123 for details 16 | 17 | import Data.Bifunctor 18 | import Data.ByteString (ByteString) 19 | import qualified Data.ByteString as S 20 | import qualified Data.ByteString.Lazy as L 21 | import Data.Int 22 | import Data.IntMap (IntMap) 23 | import qualified Data.IntMap as IM 24 | import Data.Map.Strict (Map) 25 | import qualified Data.Map.Strict as M 26 | import Data.Monoid 27 | import Data.Proxy 28 | import qualified Data.Sequence as Seq 29 | import Data.Store 30 | import Data.Store.Internal 31 | import Data.String 32 | import Data.Text (Text) 33 | import qualified Data.Vector as V 34 | 35 | -- | Test suite. 36 | actualSpec :: Spec 37 | actualSpec = 38 | describe 39 | "Untrusted input throws error" 40 | (do describe 41 | "Array-like length prefixes" 42 | (do let sample 43 | :: IsString s 44 | => s 45 | sample = "abc" 46 | list :: [Int] 47 | list = [1, 2, 3] 48 | it 49 | "ByteString" 50 | (shouldBeRightWrong huge (sample :: ByteString)) 51 | it 52 | "Lazy ByteString" 53 | (shouldBeRightWrong huge (sample :: L.ByteString)) 54 | it "Text" (shouldBeRightWrong huge (sample :: Text)) 55 | it "String" (shouldBeRightWrong huge (sample :: String)) 56 | it "Vector Int" (shouldBeRightWrong huge (V.fromList list)) 57 | it 58 | "Vector Char" 59 | (shouldBeRightWrong huge (V.fromList (sample :: [Char]))) 60 | it 61 | "Vector unit" 62 | (shouldBeRightWrong 63 | huge 64 | (V.fromList (replicate 1000 ()))) 65 | it "Seq Int" (shouldBeRightWrong huge (Seq.fromList (sample :: [Char])))) 66 | describe 67 | "Maps are consistent" 68 | (do it 69 | "Map Int Int: with duplicates" 70 | (shouldBeFail 71 | (DuplicatedMap 72 | (M.fromList [(1, 2), (4, 5)] :: Map Int Int)) 73 | (Proxy :: Proxy (Map Int Int))) 74 | it 75 | "Map Int Int: wrong order" 76 | (shouldBeFail 77 | (ReversedMap 78 | (M.fromList [(1, 2), (4, 5)] :: Map Int Int)) 79 | (Proxy :: Proxy (Map Int Int))) 80 | it 81 | "IntMap Int Int: with duplicates" 82 | (shouldBeFail 83 | (DuplicatedIntMap 84 | (IM.fromList [(1, 2), (4, 5)] :: IntMap Int)) 85 | (Proxy :: Proxy (IntMap Int))) 86 | it 87 | "IntMap Int Int: wrong order" 88 | (shouldBeFail 89 | (ReversedIntMap 90 | (IM.fromList [(1, 2), (4, 5)] :: IntMap Int)) 91 | (Proxy :: Proxy (IntMap Int)))) 92 | describe 93 | "Constructor tags" 94 | (do it 95 | "Invalid constructor tag" 96 | (shouldBe 97 | (first 98 | (const ()) 99 | (decode "\2" :: Either PeekException (Maybe ()))) 100 | (Left ())) 101 | it 102 | "Missing slots" 103 | (shouldBe 104 | (first 105 | (const ()) 106 | (decode "\1" :: Either PeekException (Maybe Char))) 107 | (Left ())))) 108 | 109 | huge :: Int64 110 | huge = 2^(62::Int) 111 | 112 | -- | Check decode.encode==id and then check decode.badencode=>error. 113 | shouldBeRightWrong 114 | :: forall i. 115 | (Store i, Eq i, Show i) 116 | => Int64 -> i -> IO () 117 | shouldBeRightWrong len input = do 118 | shouldBe (decode (encode input) :: Either PeekException i) (Right input) 119 | shouldBe 120 | (first 121 | (const ()) 122 | (decode (encodeWrongPrefix len input) :: Either PeekException i)) 123 | (Left ()) 124 | 125 | -- | Check decode.encode==id and then check decode.badencode=>error. 126 | shouldBeFail 127 | :: forall o i. 128 | (Store i, Eq o, Show o, Store o) 129 | => i -> Proxy o -> IO () 130 | shouldBeFail input _ = 131 | shouldBe 132 | (first 133 | (const ()) 134 | (decode (encode input) :: Either PeekException o)) 135 | (Left ()) 136 | 137 | -- | Encode a thing with the wrong length prefix. 138 | encodeWrongPrefix :: Store thing => Int64 -> thing -> ByteString 139 | encodeWrongPrefix len thing = encode len <> encodeThingNoPrefix thing 140 | 141 | -- | Encode the thing and drop the length prefix. 142 | encodeThingNoPrefix :: Store thing => thing -> ByteString 143 | encodeThingNoPrefix = S.drop (S.length (encode (1 :: Int64))) . encode 144 | 145 | -------------------------------------------------------------------------------- 146 | -- Map variants 147 | 148 | newtype ReversedIntMap = ReversedIntMap (IntMap Int) 149 | deriving (Show, Eq) 150 | instance Store ReversedIntMap where 151 | poke (ReversedIntMap m) = do 152 | poke markMapPokedInAscendingOrder 153 | poke (reverse (IM.toList m)) 154 | peek = error "ReversedIntMap.peek" 155 | size = VarSize (\(ReversedIntMap m) -> getSize m) 156 | 157 | newtype DuplicatedIntMap = DuplicatedIntMap (IntMap Int) 158 | deriving (Show, Eq) 159 | instance Store DuplicatedIntMap where 160 | poke (DuplicatedIntMap m) = do 161 | poke markMapPokedInAscendingOrder 162 | poke (let xs = IM.toList m 163 | in take (length xs) (cycle (take 1 xs))) 164 | peek = error "DuplicatedIntMap.peek" 165 | size = VarSize (\(DuplicatedIntMap m) -> getSize m) 166 | 167 | newtype ReversedMap = ReversedMap (Map Int Int) 168 | deriving (Show, Eq) 169 | instance Store ReversedMap where 170 | poke (ReversedMap m) = do 171 | poke markMapPokedInAscendingOrder 172 | poke (reverse (M.toList m)) 173 | peek = error "ReversedMap.peek" 174 | size = VarSize (\(ReversedMap m) -> getSize m) 175 | 176 | newtype DuplicatedMap = DuplicatedMap (Map Int Int) 177 | deriving (Show, Eq) 178 | instance Store DuplicatedMap where 179 | poke (DuplicatedMap m) = do 180 | poke markMapPokedInAscendingOrder 181 | poke (let xs = M.toList m 182 | in take (length xs) (cycle (take 1 xs))) 183 | peek = error "DuplicatedMap.peek" 184 | size = VarSize (\(DuplicatedMap m) -> getSize m) 185 | 186 | -} 187 | -------------------------------------------------------------------------------- /test/Data/StoreSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE CPP #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | {-# LANGUAGE MonoLocalBinds #-} 14 | module Data.StoreSpec where 15 | 16 | import Control.Applicative 17 | import Control.Exception (evaluate) 18 | import Control.Monad (unless) 19 | import Control.Monad.Fail (MonadFail) 20 | import qualified Data.Array.Unboxed as A 21 | import qualified Data.ByteString as BS 22 | import qualified Data.ByteString.Lazy as LBS 23 | import qualified Data.ByteString.Short as SBS 24 | import Data.Complex (Complex(..)) 25 | import Data.Containers (mapFromList, setFromList) 26 | import Data.Fixed (Pico) 27 | import Data.Generics (listify) 28 | import Data.HashMap.Strict (HashMap) 29 | import Data.HashSet (HashSet) 30 | import Data.Hashable (Hashable) 31 | import Data.Int 32 | import Data.IntMap (IntMap) 33 | import Data.IntSet (IntSet) 34 | import qualified Data.List.NonEmpty as NE 35 | import Data.Map (Map) 36 | import Data.Monoid 37 | import Data.Proxy (Proxy(..)) 38 | import Data.Sequence (Seq) 39 | import Data.Sequences (fromList) 40 | import Data.Set (Set) 41 | import Data.Store 42 | import Data.Store.Internal 43 | import Data.Store.TH 44 | import Data.Store.TH.Internal 45 | import Data.Store.TypeHash 46 | import Data.StoreSpec.TH 47 | import Data.Text (Text) 48 | import qualified Data.Text as T 49 | import qualified Data.Time as Time 50 | import qualified Data.Time.Clock.TAI as Time 51 | import Data.Typeable (Typeable) 52 | import qualified Data.Vector as V 53 | import qualified Data.Vector.Primitive as PV 54 | import qualified Data.Vector.Storable as SV 55 | import qualified Data.Vector.Unboxed as UV 56 | #if MIN_VERSION_vector(0,13,2) 57 | import qualified Data.Vector.Strict as SCV 58 | #endif 59 | import Data.Word 60 | import Foreign.C.Types 61 | import Foreign.Ptr 62 | import Foreign.Storable (Storable, sizeOf) 63 | import GHC.Fingerprint.Type (Fingerprint(..)) 64 | import GHC.Generics 65 | import GHC.Real (Ratio(..)) 66 | #if MIN_VERSION_base(4,15,0) 67 | import GHC.RTS.Flags (IoSubSystem(..)) 68 | #endif 69 | import Language.Haskell.TH 70 | import Language.Haskell.TH.Syntax 71 | import Network.Socket 72 | import Numeric.Natural (Natural) 73 | import Prelude 74 | import System.Clock (TimeSpec(..)) 75 | import System.Posix.Types 76 | import Test.Hspec hiding (runIO) 77 | import Test.SmallCheck.Series 78 | import TH.Utilities (unAppsT) 79 | 80 | #if !MIN_VERSION_primitive(0,7,0) 81 | import Data.Primitive.Types (Addr) 82 | #endif 83 | 84 | #if MIN_VERSION_time(1,8,0) 85 | import qualified Data.Time.Clock.System as Time 86 | #endif 87 | #if MIN_VERSION_time(1,9,0) 88 | import qualified Data.Time.Format.ISO8601 as Time 89 | #endif 90 | #if MIN_VERSION_time(1,11,0) 91 | import qualified Data.Time.Calendar.Quarter as Time 92 | import qualified Data.Time.Calendar.WeekDate as Time 93 | #endif 94 | 95 | #if !MIN_VERSION_smallcheck(1,2,0) 96 | import Data.Void (Void) 97 | #endif 98 | 99 | ------------------------------------------------------------------------ 100 | -- Instances for base types 101 | 102 | addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a] 103 | addMinAndMaxBounds xs = 104 | (if (minBound :: a) `notElem` xs then [minBound] else []) ++ 105 | (if (maxBound :: a) `notElem` xs && (maxBound :: a) /= minBound then maxBound : xs else xs) 106 | 107 | $(mkManyHasTypeHash [ [t| Int32 |] ]) 108 | 109 | -- Serial instances for (Num a, Bounded a) types. Only really 110 | -- appropriate for the use here. 111 | 112 | #if !MIN_VERSION_network(3,1,2) 113 | instance Bounded PortNumber where 114 | minBound = 0 115 | maxBound = 65535 116 | #endif 117 | 118 | $(do let ns = [ ''PortNumber 119 | 120 | #if !MIN_VERSION_smallcheck(1,2,0) 121 | , ''CWchar, ''CUShort, ''CULong, ''CULLong, ''CIntMax 122 | , ''CUIntMax, ''CPtrdiff, ''CSChar, ''CShort, ''CUInt, ''CLLong 123 | , ''CLong, ''CInt, ''CChar 124 | #endif 125 | , ''CSsize, ''CPid 126 | , ''COff, ''CMode, ''CIno, ''CDev 127 | #if !MIN_VERSION_smallcheck(1,1,4) 128 | , ''Word8, ''Word16, ''Word32, ''Word64 129 | , ''Int8, ''Int16, ''Int32, ''Int64 130 | #endif 131 | #if !MIN_VERSION_smallcheck(1,1,3) 132 | , ''Word 133 | #endif 134 | #if MIN_VERSION_base(4,10,0) 135 | #if !MIN_VERSION_smallcheck(1,2,0) 136 | , ''CBool 137 | #endif 138 | , ''CClockId, ''CKey, ''CId 139 | , ''CBlkSize, ''CFsBlkCnt, ''CFsFilCnt, ''CBlkCnt 140 | #endif 141 | #if MIN_VERSION_base(4,14,0) 142 | , ''CSocklen, ''CNfds 143 | #endif 144 | #ifndef mingw32_HOST_OS 145 | , ''CUid, ''CTcflag, ''CRLim, ''CNlink, ''CGid 146 | #endif 147 | ] 148 | f n = [d| instance Monad m => Serial m $(conT n) where 149 | series = generate (\_ -> addMinAndMaxBounds [0, 1]) |] 150 | concat <$> mapM f ns) 151 | 152 | 153 | -- Serial instances for (Num a) types. Only really appropriate for the 154 | -- use here. 155 | 156 | $(do let ns = 157 | #if !MIN_VERSION_smallcheck(1,2,0) 158 | [ ''CUSeconds, ''CClock, ''CTime, ''CUChar, ''CSize, ''CSigAtomic 159 | , ''CSUSeconds, ''CFloat, ''CDouble 160 | ] ++ 161 | #endif 162 | #if !MIN_VERSION_smallcheck(1,1,3) 163 | [ ''Natural ] ++ 164 | #endif 165 | #ifndef mingw32_HOST_OS 166 | [ ''CSpeed, ''CCc ] ++ 167 | #endif 168 | [] 169 | f n = [d| instance Monad m => Serial m $(conT n) where 170 | series = generate (\_ -> [0, 1]) |] 171 | concat <$> mapM f ns) 172 | 173 | -- Serial instances for Primitive vectors 174 | 175 | $(do tys <- getAllInstanceTypes1 ''PV.Prim 176 | let f ty = [d| instance (Serial m $(return ty), Monad m) => Serial m (PV.Vector $(return ty)) where 177 | series = fmap PV.fromList series |] 178 | concat <$> mapM f (filter (\ty -> length (unAppsT ty) == 1) tys)) 179 | 180 | $(do let ns = [ ''Dual, ''Sum, ''Product, ''First, ''Last ] 181 | f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |] 182 | concat <$> mapM f ns) 183 | 184 | -- Instances for DoNotUnbox types introduced in vector-0.13.2.0 185 | #if MIN_VERSION_vector(0,13,2) 186 | $(do let ns = [ ''UV.DoNotUnboxLazy, ''UV.DoNotUnboxStrict, ''UV.DoNotUnboxNormalForm ] 187 | f n = [d| instance (Monad m, Serial m a) => Serial m ($(conT n) a) |] 188 | concat <$> mapM f ns) 189 | 190 | deriving instance Generic (UV.DoNotUnboxLazy a) 191 | deriving instance Generic (UV.DoNotUnboxNormalForm a) 192 | deriving instance Generic (UV.DoNotUnboxStrict a) 193 | 194 | deriving instance Eq a => Eq (UV.DoNotUnboxLazy a) 195 | deriving instance Eq a => Eq (UV.DoNotUnboxNormalForm a) 196 | deriving instance Eq a => Eq (UV.DoNotUnboxStrict a) 197 | 198 | deriving instance Show a => Show (UV.DoNotUnboxLazy a) 199 | deriving instance Show a => Show (UV.DoNotUnboxNormalForm a) 200 | deriving instance Show a => Show (UV.DoNotUnboxStrict a) 201 | #endif 202 | 203 | instance Monad m => Serial m Any where 204 | series = fmap Any series 205 | 206 | instance Monad m => Serial m All where 207 | series = fmap All series 208 | 209 | instance Monad m => Serial m Fingerprint where 210 | series = generate (\_ -> [Fingerprint 0 0, Fingerprint maxBound maxBound]) 211 | 212 | instance Monad m => Serial m BS.ByteString where 213 | series = fmap BS.pack series 214 | 215 | instance Monad m => Serial m LBS.ByteString where 216 | series = fmap LBS.pack series 217 | 218 | instance Monad m => Serial m SBS.ShortByteString where 219 | series = fmap SBS.pack series 220 | 221 | instance (Monad m, Serial m a, Storable a) => Serial m (SV.Vector a) where 222 | series = fmap SV.fromList series 223 | 224 | instance (Monad m, Serial m a) => Serial m (V.Vector a) where 225 | series = fmap V.fromList series 226 | 227 | #if MIN_VERSION_vector(0,13,2) 228 | instance (Monad m, Serial m a) => Serial m (SCV.Vector a) where 229 | series = fmap SCV.fromList series 230 | #endif 231 | 232 | instance (Monad m, Serial m k, Serial m a, Ord k) => Serial m (Map k a) where 233 | series = fmap mapFromList series 234 | 235 | instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where 236 | series = fmap setFromList series 237 | 238 | instance (Monad m, Serial m a) => Serial m (IntMap a) where 239 | series = fmap mapFromList series 240 | 241 | instance Monad m => Serial m IntSet where 242 | series = fmap setFromList series 243 | 244 | instance Monad m => Serial m Text where 245 | series = fmap fromList series 246 | 247 | instance (Monad m, Serial m a) => Serial m (Seq a) where 248 | series = fmap fromList series 249 | 250 | 251 | instance (Monad m, Serial m a, UV.Unbox a) => Serial m (UV.Vector a) where 252 | series = fmap fromList series 253 | 254 | instance (Monad m, Serial m k, Serial m a, Hashable k, Eq k) => Serial m (HashMap k a) where 255 | series = fmap mapFromList series 256 | 257 | instance (Monad m, Serial m a, Hashable a, Eq a) => Serial m (HashSet a) where 258 | series = fmap setFromList series 259 | 260 | instance (Monad m, A.Ix i, Serial m i, Serial m e) => Serial m (A.Array i e) where 261 | series = seriesArray 262 | 263 | instance (Monad m, A.IArray A.UArray e, A.Ix i, Serial m i, Serial m e) => Serial m (A.UArray i e) where 264 | series = seriesArray 265 | 266 | seriesArray :: (Monad m, A.Ix i, A.IArray a e, Serial m i, Serial m e) => Series m (a i e) 267 | seriesArray = cons2 $ \bounds (NonEmpty xs) -> 268 | A.listArray bounds (take (A.rangeSize bounds) (cycle xs)) 269 | 270 | instance Monad m => Serial m Time.Day where 271 | series = Time.ModifiedJulianDay <$> series 272 | 273 | instance Monad m => Serial m Time.DiffTime where 274 | series = Time.picosecondsToDiffTime <$> series 275 | 276 | instance Monad m => Serial m Time.NominalDiffTime where 277 | series = (realToFrac :: Integer -> Time.NominalDiffTime) <$> series 278 | 279 | instance Monad m => Serial m Time.UTCTime where 280 | series = uncurry Time.UTCTime <$> (series >< series) 281 | 282 | instance (Monad m, Serial m a) => Serial m (Tagged a) 283 | 284 | #if MIN_VERSION_base(4,15,0) 285 | instance Monad m => Serial m IoSubSystem where 286 | series = cons0 IoPOSIX \/ cons0 IoNative 287 | #endif 288 | 289 | #if !MIN_VERSION_smallcheck(1,2,0) 290 | instance (Monad m, Serial m a) => Serial m (Complex a) where 291 | series = uncurry (:+) <$> (series >< series) 292 | 293 | instance (Monad m, Serial m a) => Serial m (NE.NonEmpty a) 294 | 295 | instance Monad m => Serial m Void where 296 | series = generate (\_ -> []) 297 | #endif 298 | 299 | instance Monad m => Serial m TimeSpec where 300 | series = uncurry TimeSpec <$> (series >< series) 301 | 302 | -- We define our own Serial instance for 'Ratio' because of 303 | 304 | newtype SerialRatio a = SerialRatio (Ratio a) 305 | deriving (Store, Eq, Show) 306 | 307 | instance (Integral i, Serial m i) => Serial m (SerialRatio i) where 308 | series = pairToRatio <$> series 309 | where 310 | pairToRatio (n, Positive d) = SerialRatio (n :% d) 311 | 312 | ------------------------------------------------------------------------ 313 | -- Test datatypes for generics support 314 | 315 | data Test 316 | = TestA Int64 Word32 317 | | TestB Bool 318 | | TestC 319 | | TestD BS.ByteString 320 | deriving (Eq, Show, Generic) 321 | -- $(return . (:[]) =<< deriveStore [] (ConT ''Test) . dtCons =<< reifyDataType ''Test) 322 | instance Store Test 323 | instance Monad m => Serial m Test 324 | 325 | data X = X 326 | deriving (Eq, Show, Generic) 327 | instance Monad m => Serial m X 328 | instance Store X 329 | 330 | 331 | -- Datatypes with faulty instances 332 | newtype BadIdea = BadIdea Int64 333 | instance Store BadIdea where 334 | poke (BadIdea x) = poke x 335 | peek = BadIdea <$> peek 336 | size = ConstSize 1 -- too small 337 | 338 | newtype BadIdea2 = BadIdea2 Int64 339 | instance Store BadIdea2 where 340 | poke (BadIdea2 x) = poke x 341 | peek = BadIdea2 <$> peek 342 | size = ConstSize 12 -- too large 343 | 344 | spec :: Spec 345 | spec = do 346 | describe "Store on all monomorphic instances" 347 | $(do insts <- getAllInstanceTypes1 ''Store 348 | omitTys0 <- sequence $ 349 | #if !MIN_VERSION_primitive(0,7,0) 350 | [t| Addr |] : 351 | #endif 352 | [ [t| CUIntPtr |] 353 | , [t| CIntPtr |] 354 | , [t| IntPtr |] 355 | , [t| WordPtr |] 356 | , [t| TypeHash |] 357 | , [t| Fd |] 358 | , [t| NameFlavour |] 359 | #if MIN_VERSION_base(4,10,0) 360 | , [t| CTimer |] 361 | #endif 362 | 363 | -- Assume the TH generated instances for Time work, to avoid defining 364 | -- Serial instances. Also some lack Show / Eq. 365 | 366 | , [t| Time.AbsoluteTime |] 367 | , [t| Time.Day |] 368 | , [t| Time.LocalTime |] 369 | , [t| Time.TimeOfDay |] 370 | , [t| Time.TimeZone |] 371 | , [t| Time.UTCTime |] 372 | , [t| Time.UniversalTime |] 373 | , [t| Time.ZonedTime |] 374 | , [t| Time.TimeLocale |] 375 | #if MIN_VERSION_time(1,8,0) 376 | , [t| Time.SystemTime |] 377 | #endif 378 | #if MIN_VERSION_time(1,9,0) 379 | , [t| Time.FormatExtension |] 380 | , [t| Time.CalendarDiffDays |] 381 | , [t| Time.CalendarDiffTime |] 382 | #endif 383 | #if MIN_VERSION_time(1,11,0) 384 | , [t| Time.DayOfWeek |] 385 | , [t| Time.FirstWeekType |] 386 | , [t| Time.Quarter |] 387 | , [t| Time.QuarterOfYear |] 388 | #endif 389 | 390 | ] 391 | omitTys <- (omitTys0 ++) <$> mapM (\ty -> [t| PV.Vector $(pure ty) |]) omitTys0 392 | let f ty = isMonoType ty && ty `notElem` omitTys && null (listify isThName ty) 393 | filtered = filter f insts 394 | -- Roundtrip testing of TH instances is disabled - see issue #150 395 | isThName n = nameModule n == Just "Language.Haskell.TH.Syntax" 396 | smallcheckManyStore verbose 2 $ map return filtered) 397 | it "Store on non-numeric Float/Double values" $ do 398 | let testNonNumeric :: forall a m. (RealFloat a, Eq a, Show a, Typeable a, Store a, Monad m, MonadFail m) => Proxy a -> m () 399 | testNonNumeric _proxy = do 400 | assertRoundtrip verbose ((1/0) :: a) 401 | assertRoundtrip verbose ((-1/0) :: a) 402 | -- -0 == 0, so we check if the infinity sign is the same 403 | case decode (encode ((-0) :: a)) of 404 | Right (x :: a) -> unless (-1/0 == 1/x) (fail "Could not roundtrip negative 0") 405 | _ -> fail "Could not roundtrip negative 0" 406 | assertRoundtrip verbose ((-0) :: a) 407 | -- 0/0 /= 0/0, so we check for NaN explicitly 408 | case decode (encode ((0/0) :: a)) of 409 | Right (x :: a) -> unless (isNaN x) (fail "Could not roundtrip NaN") 410 | _ -> fail "Could not roundtrip NaN" 411 | testNonNumeric (Proxy :: Proxy Double) 412 | testNonNumeric (Proxy :: Proxy Float) 413 | testNonNumeric (Proxy :: Proxy CDouble) 414 | testNonNumeric (Proxy :: Proxy CFloat) 415 | (return () :: IO ()) 416 | describe "Store on all custom generic instances" 417 | $(smallcheckManyStore verbose 2 418 | [ [t| Test |] 419 | , [t| X |] 420 | ]) 421 | describe "Manually listed polymorphic store instances" 422 | $(smallcheckManyStore verbose 4 423 | [ [t| SV.Vector Int8 |] 424 | , [t| V.Vector Int8 |] 425 | #if MIN_VERSION_vector(0,13,2) 426 | , [t| SCV.Vector Int8 |] 427 | , [t| UV.DoNotUnboxLazy Int8 |] 428 | , [t| UV.DoNotUnboxStrict Int8 |] 429 | , [t| UV.DoNotUnboxNormalForm Int8 |] 430 | #endif 431 | , [t| SerialRatio Int8 |] 432 | , [t| Complex Int8 |] 433 | , [t| Dual Int8 |] 434 | , [t| Sum Int8 |] 435 | , [t| Product Int8 |] 436 | , [t| First Int8 |] 437 | , [t| Last Int8 |] 438 | , [t| Maybe Int8 |] 439 | , [t| Either Int8 Int8 |] 440 | , [t| SV.Vector Int64 |] 441 | , [t| V.Vector Int64 |] 442 | #if MIN_VERSION_vector(0,13,2) 443 | , [t| SCV.Vector Int64 |] 444 | , [t| UV.DoNotUnboxLazy Int64 |] 445 | , [t| UV.DoNotUnboxStrict Int64 |] 446 | , [t| UV.DoNotUnboxNormalForm Int64 |] 447 | #endif 448 | , [t| SerialRatio Int64 |] 449 | , [t| Complex Int64 |] 450 | , [t| Dual Int64 |] 451 | , [t| Sum Int64 |] 452 | , [t| Product Int64 |] 453 | , [t| First Int64 |] 454 | , [t| Last Int64 |] 455 | , [t| Maybe Int64 |] 456 | , [t| Either Int64 Int64 |] 457 | , [t| (Int8, Int16) |] 458 | , [t| (Int8, Int16, Bool) |] 459 | , [t| (Bool, (), (), ()) |] 460 | , [t| (Bool, (), Int8, ()) |] 461 | -- Container-ey types 462 | , [t| [Int8] |] 463 | , [t| [Int64] |] 464 | , [t| Seq Int8 |] 465 | , [t| Seq Int64 |] 466 | , [t| Set Int8 |] 467 | , [t| Set Int64 |] 468 | , [t| IntMap Int8 |] 469 | , [t| IntMap Int64 |] 470 | , [t| Map Int8 Int8 |] 471 | , [t| Map Int64 Int64 |] 472 | , [t| HashMap Int8 Int8 |] 473 | , [t| HashMap Int64 Int64 |] 474 | , [t| HashSet Int8 |] 475 | , [t| HashSet Int64 |] 476 | , [t| NE.NonEmpty Int8 |] 477 | , [t| NE.NonEmpty Int64 |] 478 | , [t| Tagged Int32 |] 479 | , [t| A.Array (Int, Integer) Integer |] 480 | , [t| A.UArray Char Bool |] 481 | ]) 482 | it "Slices roundtrip" $ do 483 | assertRoundtrip False $ T.drop 3 $ T.take 3 "Hello world!" 484 | assertRoundtrip False $ BS.drop 3 $ BS.take 3 "Hello world!" 485 | assertRoundtrip False $ SV.drop 3 $ SV.take 3 (SV.fromList [1..10] :: SV.Vector Int32) 486 | assertRoundtrip False $ UV.drop 3 $ UV.take 3 (UV.fromList [1..10] :: UV.Vector Word8) 487 | #if MIN_VERSION_vector(0,13,2) 488 | assertRoundtrip False $ SCV.drop 3 $ SCV.take 3 (SCV.fromList [1..10] :: SCV.Vector Word8) 489 | #endif 490 | (return () :: IO ()) 491 | it "StaticSize roundtrips" $ do 492 | let x :: StaticSize 17 BS.ByteString 493 | x = toStaticSizeEx (BS.replicate 17 255) 494 | unless (checkRoundtrip False x) $ 495 | (fail "Failed to roundtrip StaticSize ByteString" :: IO ()) 496 | it "Size of generic instance for single fieldless constructor is 0" $ do 497 | case size :: Size X of 498 | ConstSize 0 -> (return () :: IO ()) 499 | _ -> fail "Empty datatype takes up space" 500 | it "Printing out polymorphic store instances" $ do 501 | putStrLn "" 502 | putStrLn "Not really a test - printing out known polymorphic store instances (which should all be tested above)" 503 | putStrLn "" 504 | mapM_ putStrLn 505 | $(do insts <- getAllInstanceTypes1 ''Store 506 | lift $ map pprint $ filter (not . isMonoType) insts) 507 | it "Faulty implementations of size lead to PokeExceptions" $ do 508 | evaluate (encode (BadIdea 0)) `shouldThrow` isPokeException 509 | evaluate (encode (BadIdea2 0)) `shouldThrow` isPokeException 510 | it "Avoids reading data with a negative size" $ do 511 | let bs = encode (SV.fromList [1..10::Int]) 512 | bs' = BS.concat [encode (-1 :: Int) 513 | , BS.drop (sizeOf (10 :: Int)) bs 514 | ] 515 | evaluate (decodeEx bs' :: SV.Vector Int) `shouldThrow` isNegativeBytesException 516 | it "Avoids overflow in bounds checks" $ do 517 | let bs = encode ("some random bytestring" :: BS.ByteString) 518 | bs' = BS.concat [encode (maxBound :: Int) 519 | , BS.drop (sizeOf (10 :: Int)) bs 520 | ] 521 | evaluate (decodeEx bs' :: BS.ByteString) `shouldThrow` isTooManyBytesException 522 | it "Handles unaligned access" $ do 523 | assertRoundtrip verbose (250 :: Word8, 40918 :: Word16, 120471416 :: Word32) 524 | assertRoundtrip verbose (250 :: Word8, 10.1 :: Float, 8697.65 :: Double) 525 | (return () :: IO ()) 526 | it "Expects the right marker when deserializing ordered maps (#97)" $ do 527 | let m = mapFromList [(1, ()), (2, ()), (3, ())] :: HashMap Int () 528 | bs = encode m 529 | (decodeEx bs :: HashMap Int ()) `shouldBe` m 530 | evaluate (decodeEx bs :: Map Int ()) `shouldThrow` isUnexpectedMarkerException 531 | evaluate (decodeEx bs :: IntMap ()) `shouldThrow` isUnexpectedMarkerException 532 | it "Expects decode of negative integer as a natural to throw PeekException" $ do 533 | evaluate (decodeEx (encode ((-5) :: Integer)) :: Natural) 534 | `shouldThrow` isNegativeNaturalException 535 | 536 | 537 | isPokeException :: Test.Hspec.Selector PokeException 538 | isPokeException = const True 539 | 540 | isNegativeBytesException :: Test.Hspec.Selector PeekException 541 | isNegativeBytesException (PeekException _ t) = "Attempted to read negative number of bytes" `T.isPrefixOf` t 542 | 543 | isTooManyBytesException :: Test.Hspec.Selector PeekException 544 | isTooManyBytesException (PeekException _ t) = "Attempted to read too many bytes" `T.isPrefixOf` t 545 | 546 | isUnexpectedMarkerException :: Test.Hspec.Selector PeekException 547 | isUnexpectedMarkerException (PeekException _ t) = 548 | "Expected marker for ascending Map / IntMap: " `T.isPrefixOf` t 549 | 550 | isNegativeNaturalException :: Test.Hspec.Selector PeekException 551 | isNegativeNaturalException (PeekException _ t) = 552 | "Encountered negative integer when expecting a Natural" `T.isPrefixOf` t 553 | -------------------------------------------------------------------------------- /test/Data/StoreSpec/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- Just exists due to TH stage restriction... The actual testing TH code 4 | -- is in "Data.Store.TH". 5 | module Data.StoreSpec.TH where 6 | 7 | verbose :: Bool 8 | verbose = 9 | #if VERBOSE_TEST 10 | True 11 | #else 12 | False 13 | #endif 14 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/System/IO/ByteBufferSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module System.IO.ByteBufferSpec where 4 | 5 | import Control.Exception 6 | import qualified Data.ByteString as BS 7 | import Data.Typeable (Typeable) 8 | import qualified System.IO.ByteBuffer as BB 9 | import Test.Hspec 10 | 11 | data MyException = MyException 12 | deriving (Eq, Show, Typeable) 13 | instance Exception MyException 14 | 15 | spec :: Spec 16 | spec = describe "ByteBuffer" $ do 17 | it "can grow to store a value and return it." $ BB.with (Just 0) $ \ bb -> do 18 | let bs = "some bytestring" 19 | BB.copyByteString bb bs 20 | bs' <- BB.consume bb (BS.length bs) 21 | bs' `shouldBe` Right bs 22 | bbIsEmpty bb 23 | it "should request more input when needed." $ BB.with (Just 0) $ \ bb -> do 24 | let bs = "some bytestring" 25 | BB.copyByteString bb bs 26 | bs' <- BB.consume bb (2 * BS.length bs) 27 | bs' `shouldBe` Left (BS.length bs) 28 | BB.copyByteString bb bs 29 | bs'' <- BB.consume bb (2 * BS.length bs) 30 | bs'' `shouldBe` Right (BS.concat [bs, bs]) 31 | bbIsEmpty bb 32 | it "should not grow if bytes can be freed." $ 33 | let bs1 = "12345" 34 | bs2 = "67810" -- what about nine? 7 8 9! 35 | in BB.with (Just $ BS.length bs1) $ \ bb -> do 36 | BB.copyByteString bb bs1 37 | bs1' <- BB.consume bb (BS.length bs1) 38 | BB.copyByteString bb bs2 39 | bs2' <- BB.consume bb (BS.length bs2) 40 | bs1' `shouldBe` Right bs1 41 | bs2' `shouldBe` Right bs2 42 | bbSize <- BB.totalSize bb 43 | bbSize `shouldBe` BS.length bs1 44 | bbIsEmpty bb 45 | it "should raise a ByteBufferException when used after freed" $ BB.with Nothing $ \bb -> do 46 | BB.free bb 47 | BB.totalSize bb `shouldThrow` \(BB.ByteBufferException loc e) -> 48 | loc == "free" && e == "ByteBuffer has explicitly been freed and is no longer valid." 49 | it "should raise a ByteBufferException after a failed operation" $ BB.with Nothing $ \bb -> do 50 | BB.copyByteString bb (throw MyException) `shouldThrow` (\MyException -> True) 51 | BB.consume bb 10 `shouldThrow` \(BB.ByteBufferException loc e) -> 52 | loc == "copyByteString" && e == show MyException 53 | bbIsEmpty :: BB.ByteBuffer -> Expectation 54 | bbIsEmpty bb = BB.isEmpty bb >>= (`shouldBe` True) 55 | --------------------------------------------------------------------------------