├── .gitattributes ├── .github ├── ISSUE_TEMPLATE │ ├── bug_report.md │ └── feature_request.md ├── actions │ ├── generate-readme │ │ └── action.yml │ ├── print-cpu-info │ │ └── action.yml │ ├── setup-actionlint │ │ └── action.yml │ ├── setup-cabal-docspec │ │ └── action.yml │ ├── setup-cabal-fmt │ │ └── action.yml │ ├── setup-shellcheck │ │ └── action.yaml │ └── setup-stylish-haskell │ │ └── action.yml ├── dependabot.yml ├── pull_request_template.md └── workflows │ └── ci.yml ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── CHANGELOG.md ├── CODEOWNERS ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE ├── NOTICE ├── README.md ├── SECURITY.md ├── bench ├── macro │ ├── lsm-tree-bench-bloomfilter.hs │ ├── lsm-tree-bench-lookups.hs │ ├── lsm-tree-bench-wp8.hs │ └── rocksdb-bench-wp8.hs └── micro │ ├── Bench │ └── Database │ │ ├── LSMTree.hs │ │ └── LSMTree │ │ └── Internal │ │ ├── BloomFilter.hs │ │ ├── Index.hs │ │ ├── Index │ │ └── Compact.hs │ │ ├── Lookup.hs │ │ ├── Merge.hs │ │ ├── RawPage.hs │ │ ├── Serialise.hs │ │ └── WriteBuffer.hs │ └── Main.hs ├── blockio ├── CHANGELOG.md ├── LICENSE ├── NOTICE ├── README.md ├── blockio.cabal ├── src-linux │ └── System │ │ └── FS │ │ └── BlockIO │ │ ├── Async.hs │ │ └── Internal.hs ├── src-macos │ └── System │ │ └── FS │ │ └── BlockIO │ │ └── Internal.hs ├── src-sim │ └── System │ │ └── FS │ │ └── BlockIO │ │ └── Sim.hs ├── src-windows │ └── System │ │ └── FS │ │ └── BlockIO │ │ └── Internal.hs ├── src │ └── System │ │ └── FS │ │ └── BlockIO │ │ ├── API.hs │ │ ├── IO.hs │ │ └── Serial.hs ├── test-sim │ └── Main.hs └── test │ └── Main.hs ├── bloomfilter ├── LICENSE-bloomfilter ├── README.markdown ├── bench │ └── bloomfilter-bench.hs ├── examples │ └── spell.hs ├── fpr.blocked.gnuplot.data ├── fpr.classic.gnuplot.data ├── fpr.gnuplot ├── fpr.png ├── src │ └── Data │ │ ├── BloomFilter.hs │ │ └── BloomFilter │ │ ├── Blocked.hs │ │ ├── Blocked │ │ ├── BitArray.hs │ │ ├── Calc.hs │ │ └── Internal.hs │ │ ├── Classic.hs │ │ ├── Classic │ │ ├── BitArray.hs │ │ ├── Calc.hs │ │ └── Internal.hs │ │ └── Hash.hs └── tests │ ├── bloomfilter-tests.hs │ └── fpr-calc.hs ├── cabal.project ├── cabal.project.blockio-uring ├── cabal.project.debug ├── cabal.project.release ├── doc ├── final-report │ └── integration-notes.md ├── format-directory.md ├── format-page.md └── format-run.md ├── lsm-tree.cabal ├── scripts ├── format-cabal-fmt.sh ├── format-stylish-haskell.sh ├── generate-haddock-prologue.hs ├── generate-haddock.sh ├── generate-readme-header.md ├── generate-readme.hs ├── lint-actionlint.sh ├── lint-cabal.sh ├── lint-diskio-complexities.hs ├── lint-diskio-complexities │ ├── dump-from-package-description.hs │ └── dump-from-source.sh ├── lint-hlint.sh ├── lint-io-specialisations.sh ├── lint-io-specialisations │ ├── absence-allowed │ ├── find-absent.sh │ └── find-absent.tests │ │ ├── Animals.Sheep.fake-hs │ │ ├── Misc.fake-hs │ │ └── output ├── lint-shellcheck.sh ├── pre-commit.sh └── test-cabal-docspec.sh ├── src-control └── Control │ ├── ActionRegistry.hs │ ├── Concurrent │ └── Class │ │ └── MonadSTM │ │ └── RWVar.hs │ └── RefCount.hs ├── src-extras └── Database │ └── LSMTree │ ├── Extras.hs │ └── Extras │ ├── Generators.hs │ ├── Index.hs │ ├── MergingRunData.hs │ ├── MergingTreeData.hs │ ├── NoThunks.hs │ ├── Orphans.hs │ ├── Random.hs │ ├── ReferenceImpl.hs │ ├── RunData.hs │ └── UTxO.hs ├── src-kmerge └── KMerge │ ├── Heap.hs │ └── LoserTree.hs ├── src-mcg └── MCG.hs ├── src-prototypes ├── FormatPage.hs └── ScheduledMerges.hs ├── src-rocksdb ├── RocksDB.hs └── RocksDB │ └── FFI.hs ├── src └── Database │ ├── LSMTree.hs │ └── LSMTree │ ├── Internal │ ├── Arena.hs │ ├── Assertions.hs │ ├── BitMath.hs │ ├── BlobFile.hs │ ├── BlobRef.hs │ ├── BloomFilter.hs │ ├── ByteString.hs │ ├── CRC32C.hs │ ├── ChecksumHandle.hs │ ├── Chunk.hs │ ├── Config.hs │ ├── Config │ │ └── Override.hs │ ├── Cursor.hs │ ├── Entry.hs │ ├── IncomingRun.hs │ ├── Index.hs │ ├── Index │ │ ├── Compact.hs │ │ ├── CompactAcc.hs │ │ ├── Ordinary.hs │ │ └── OrdinaryAcc.hs │ ├── Lookup.hs │ ├── Map │ │ └── Range.hs │ ├── Merge.hs │ ├── MergeSchedule.hs │ ├── MergingRun.hs │ ├── MergingTree.hs │ ├── MergingTree │ │ └── Lookup.hs │ ├── Page.hs │ ├── PageAcc.hs │ ├── PageAcc1.hs │ ├── Paths.hs │ ├── Primitive.hs │ ├── Range.hs │ ├── RawBytes.hs │ ├── RawOverflowPage.hs │ ├── RawPage.hs │ ├── Readers.hs │ ├── Run.hs │ ├── RunAcc.hs │ ├── RunBuilder.hs │ ├── RunNumber.hs │ ├── RunReader.hs │ ├── Serialise.hs │ ├── Serialise │ │ └── Class.hs │ ├── Snapshot.hs │ ├── Snapshot │ │ └── Codec.hs │ ├── StrictArray.hs │ ├── Types.hs │ ├── UniqCounter.hs │ ├── Unsafe.hs │ ├── Unsliced.hs │ ├── Vector.hs │ ├── Vector │ │ └── Growing.hs │ ├── WriteBuffer.hs │ ├── WriteBufferBlobs.hs │ ├── WriteBufferReader.hs │ └── WriteBufferWriter.hs │ └── Simple.hs ├── test-control ├── Main.hs └── Test │ └── Control │ ├── ActionRegistry.hs │ ├── Concurrent │ └── Class │ │ └── MonadSTM │ │ └── RWVar.hs │ └── RefCount.hs ├── test-prototypes ├── Main.hs └── Test │ ├── FormatPage.hs │ ├── ScheduledMerges.hs │ ├── ScheduledMerges │ └── RunSizes.hs │ └── ScheduledMergesQLS.hs ├── test ├── Database │ └── LSMTree │ │ ├── Class.hs │ │ ├── Class │ │ └── Common.hs │ │ ├── Model.hs │ │ └── Model │ │ ├── IO.hs │ │ ├── Session.hs │ │ └── Table.hs ├── Main.hs ├── Test │ ├── Database │ │ └── LSMTree │ │ │ ├── Class.hs │ │ │ ├── Generators.hs │ │ │ ├── Internal.hs │ │ │ ├── Internal │ │ │ ├── Arena.hs │ │ │ ├── BlobFile │ │ │ │ └── FS.hs │ │ │ ├── BloomFilter.hs │ │ │ ├── CRC32C.hs │ │ │ ├── Chunk.hs │ │ │ ├── Entry.hs │ │ │ ├── Index │ │ │ │ ├── Compact.hs │ │ │ │ └── Ordinary.hs │ │ │ ├── Lookup.hs │ │ │ ├── Merge.hs │ │ │ ├── MergingRun.hs │ │ │ ├── MergingTree.hs │ │ │ ├── PageAcc.hs │ │ │ ├── PageAcc1.hs │ │ │ ├── RawBytes.hs │ │ │ ├── RawOverflowPage.hs │ │ │ ├── RawPage.hs │ │ │ ├── Readers.hs │ │ │ ├── Run.hs │ │ │ ├── RunAcc.hs │ │ │ ├── RunBloomFilterAlloc.hs │ │ │ ├── RunBuilder.hs │ │ │ ├── RunReader.hs │ │ │ ├── Serialise.hs │ │ │ ├── Serialise │ │ │ │ └── Class.hs │ │ │ ├── Snapshot │ │ │ │ ├── Codec.hs │ │ │ │ ├── Codec │ │ │ │ │ └── Golden.hs │ │ │ │ └── FS.hs │ │ │ ├── Unsliced.hs │ │ │ ├── Vector.hs │ │ │ ├── Vector │ │ │ │ └── Growing.hs │ │ │ ├── WriteBufferBlobs │ │ │ │ └── FS.hs │ │ │ └── WriteBufferReader │ │ │ │ └── FS.hs │ │ │ ├── Model │ │ │ └── Table.hs │ │ │ ├── Resolve.hs │ │ │ ├── StateMachine.hs │ │ │ ├── StateMachine │ │ │ ├── DL.hs │ │ │ └── Op.hs │ │ │ └── UnitTests.hs │ ├── FS.hs │ └── Util │ │ ├── Arbitrary.hs │ │ ├── FS.hs │ │ ├── FS │ │ └── Error.hs │ │ ├── Orphans.hs │ │ ├── PrettyProxy.hs │ │ ├── QC.hs │ │ ├── QLS.hs │ │ ├── RawPage.hs │ │ └── TypeFamilyWrappers.hs ├── golden-file-data │ └── snapshot-codec │ │ ├── BloomFilterAlloc.A.snapshot.golden │ │ ├── BloomFilterAlloc.B.snapshot.golden │ │ ├── DiskCachePolicy.A.snapshot.golden │ │ ├── DiskCachePolicy.B.snapshot.golden │ │ ├── DiskCachePolicy.C.snapshot.golden │ │ ├── FencePointerIndexType.A.snapshot.golden │ │ ├── FencePointerIndexType.B.snapshot.golden │ │ ├── IndexType.A.snapshot.golden │ │ ├── IndexType.B.snapshot.golden │ │ ├── LevelMergeType.A.snapshot.golden │ │ ├── LevelMergeType.B.snapshot.golden │ │ ├── MergeCredits.A.snapshot.golden │ │ ├── MergeDebt.A.snapshot.golden │ │ ├── MergePolicy.A.snapshot.golden │ │ ├── MergePolicyForLevel.A.snapshot.golden │ │ ├── MergePolicyForLevel.B.snapshot.golden │ │ ├── MergeSchedule.A.snapshot.golden │ │ ├── MergeSchedule.B.snapshot.golden │ │ ├── NominalCredits.A.snapshot.golden │ │ ├── NominalDebt.A.snapshot.golden │ │ ├── RunBloomFilterAlloc.A.snapshot.golden │ │ ├── RunBloomFilterAlloc.B.snapshot.golden │ │ ├── RunDataCaching.A.snapshot.golden │ │ ├── RunDataCaching.B.snapshot.golden │ │ ├── RunNumber.A.snapshot.golden │ │ ├── RunParams.A.snapshot.golden │ │ ├── SizeRatio.A.snapshot.golden │ │ ├── SnapIncomingRun_SnapshotRun.A.snapshot.golden │ │ ├── SnapIncomingRun_SnapshotRun.B.snapshot.golden │ │ ├── SnapLevel_SnapshotRun.A.snapshot.golden │ │ ├── SnapLevels_SnapshotRun.A.snapshot.golden │ │ ├── SnapMergingRun_LevelMergeType_SnapshotRun.A.snapshot.golden │ │ ├── SnapMergingRun_LevelMergeType_SnapshotRun.B.snapshot.golden │ │ ├── SnapMergingRun_TreeMergeType_SnapshotRun.A.snapshot.golden │ │ ├── SnapMergingRun_TreeMergeType_SnapshotRun.B.snapshot.golden │ │ ├── SnapMergingTreeState_SnapshotRun.A.snapshot.golden │ │ ├── SnapMergingTreeState_SnapshotRun.B.snapshot.golden │ │ ├── SnapMergingTreeState_SnapshotRun.C.snapshot.golden │ │ ├── SnapMergingTree_SnapshotRun.A.snapshot.golden │ │ ├── SnapPendingMerge_SnapshotRun.A.snapshot.golden │ │ ├── SnapPendingMerge_SnapshotRun.B.snapshot.golden │ │ ├── SnapPreExistingRun_SnapshotRun.A.snapshot.golden │ │ ├── SnapPreExistingRun_SnapshotRun.B.snapshot.golden │ │ ├── SnapshotLabel.A.snapshot.golden │ │ ├── SnapshotLabel.B.snapshot.golden │ │ ├── SnapshotMetaData.A.snapshot.golden │ │ ├── SnapshotRun.A.snapshot.golden │ │ ├── TableConfig.A.snapshot.golden │ │ ├── TreeMergeType.A.snapshot.golden │ │ ├── TreeMergeType.B.snapshot.golden │ │ ├── Vector_SnapshotRun.A.snapshot.golden │ │ ├── Vector_SnapshotRun.B.snapshot.golden │ │ ├── Vector_SnapshotRun.C.snapshot.golden │ │ └── WriteBufferAlloc.A.snapshot.golden ├── kmerge-test.hs └── map-range-test.hs └── xxhash ├── include └── HsXXHash.h ├── src ├── FFI.hs └── XXH3.hs ├── tests └── xxhash-tests.hs └── xxHash-0.8.2 ├── LICENSE-xxHash └── xxhash.h /.gitattributes: -------------------------------------------------------------------------------- 1 | *.golden -text 2 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | title: '[BUG] ' 5 | labels: 'bug' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Describe the bug** 11 | A clear and concise description of what the bug is. 12 | 13 | **To Reproduce** 14 | Steps to reproduce the behavior: 15 | 1. Go to '...' 16 | 2. Click on '....' 17 | 3. Scroll down to '....' 18 | 4. See error 19 | 20 | **Expected behavior** 21 | A clear and concise description of what you expected to happen. 22 | 23 | **Output** 24 | If applicable, add log excerpts, screenshots or other files to help explain your problem. 25 | 26 | **Desktop (please complete the following information):** 27 | - OS: [e.g. Ubuntu, MacOS, Windows] 28 | - OS version: [e.g. 22.04] 29 | - GHC: [e.g. ghc-9.6.6, ghc-9.8.2] 30 | 31 | **Additional context** 32 | Add any other context about the problem here. 33 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | title: '[FEATURE] ' 5 | labels: 'enhancement' 6 | assignees: '' 7 | 8 | --- 9 | 10 | **Is your feature request related to a problem? Please describe.** 11 | A clear and concise description of what the problem is. Ex. I'm always frustrated when [...] 12 | 13 | **Describe the solution you'd like** 14 | A clear and concise description of what you want to happen. 15 | 16 | **Describe alternatives you've considered** 17 | A clear and concise description of any alternative solutions or features you've considered. 18 | 19 | **Additional context** 20 | Add any other context or files/screenshots about the feature request here. 21 | -------------------------------------------------------------------------------- /.github/actions/generate-readme/action.yml: -------------------------------------------------------------------------------- 1 | name: "Generate README.md" 2 | description: "Generate README.md from the Cabal package description" 3 | inputs: 4 | ghc-version: 5 | required: true 6 | description: "Version of GHC" 7 | cabal-version: 8 | required: true 9 | description: "Version of cabal" 10 | hackage-index-state: 11 | required: false 12 | description: "Timestamp for Hackage index" 13 | runs: 14 | using: composite 15 | steps: 16 | - name: 🛠️ Install Haskell 17 | uses: haskell-actions/setup@v2 18 | id: setup-haskell 19 | with: 20 | ghc-version: ${{ inputs.ghc-version }} 21 | cabal-version: ${{ inputs.cabal-version }} 22 | 23 | - name: 💾 Restore Cabal dependencies 24 | uses: actions/cache/restore@v4 25 | id: cache-cabal 26 | with: 27 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 28 | key: generate-readme-${{ runner.os }}-ghc-${{ steps.setup-haskell.outputs.ghc-version }}-cabal-${{ steps.setup-haskell.outputs.cabal-version }} 29 | 30 | - name: 🛠️ Generate README.md 31 | run: ./scripts/generate-readme.hs 32 | shell: sh 33 | 34 | - name: 💾 Save Cabal dependencies 35 | uses: actions/cache/save@v4 36 | if: ${{ !env.ACT && steps.cache-cabal.outputs.cache-hit != 'true' }} 37 | with: 38 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 39 | key: ${{ steps.cache-cabal.outputs.cache-primary-key }} 40 | -------------------------------------------------------------------------------- /.github/actions/print-cpu-info/action.yml: -------------------------------------------------------------------------------- 1 | name: "Print CPU info" 2 | description: "Prints CPU info" 3 | runs: 4 | using: "composite" 5 | steps: 6 | - if: ${{ runner.os == 'macOS' }} 7 | run: sysctl -a machdep.cpu 8 | shell: sh 9 | 10 | - if: ${{ runner.os == 'Linux' }} 11 | run: cat /proc/cpuinfo 12 | shell: sh 13 | 14 | - if: ${{ runner.os == 'Windows' }} 15 | run: wmic cpu get caption, deviceid, name, numberofcores, maxclockspeed, status 16 | shell: cmd 17 | -------------------------------------------------------------------------------- /.github/actions/setup-actionlint/action.yml: -------------------------------------------------------------------------------- 1 | name: "Setup actionlint" 2 | description: "Install a specific actionlint version" 3 | inputs: 4 | actionlint-version: 5 | required: true 6 | description: "Version of actionlint" 7 | runs: 8 | using: composite 9 | steps: 10 | - name: 🛠️ Install actionlint 11 | if: ${{ env.ACT || steps.cache-actionlint.outputs.cache-hit != 'true' }} 12 | run: | 13 | mkdir --parents "${{ github.workspace }}/.actionlint/bin" 14 | bash <(curl https://raw.githubusercontent.com/rhysd/actionlint/main/scripts/download-actionlint.bash) ${{ inputs.actionlint-version }} "${{ github.workspace }}/.actionlint/bin" 15 | shell: bash 16 | 17 | - name: 🛠️ Add actionlint to PATH 18 | run: echo "${{ github.workspace }}/.actionlint/bin" >> "$GITHUB_PATH" 19 | shell: sh 20 | -------------------------------------------------------------------------------- /.github/actions/setup-cabal-docspec/action.yml: -------------------------------------------------------------------------------- 1 | name: "Setup cabal-docspec" 2 | description: "Setup cabal-docspec" 3 | runs: 4 | using: composite 5 | steps: 6 | - name: 🛠️ Install cabal-docspec (Linux) 7 | if: ${{ runner.os == 'Linux' }} 8 | run: | 9 | mkdir -p "${{ github.workspace }}/.cabal-docspec/bin" 10 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > "${{ runner.temp }}/cabal-docspec.xz" 11 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 ${{ runner.temp }}/cabal-docspec.xz' | sha256sum -c - 12 | xz -d < "${{ runner.temp }}/cabal-docspec.xz" > "${{ github.workspace }}/.cabal-docspec/bin/cabal-docspec" 13 | chmod a+x "${{ github.workspace }}/.cabal-docspec/bin/cabal-docspec" 14 | shell: sh 15 | 16 | - name: 🛠️ Add cabal-docspec to PATH 17 | run: echo "${{ github.workspace }}/.cabal-docspec/bin" >> "$GITHUB_PATH" 18 | shell: sh 19 | -------------------------------------------------------------------------------- /.github/actions/setup-cabal-fmt/action.yml: -------------------------------------------------------------------------------- 1 | name: "Setup cabal-fmt" 2 | description: "Install a specific cabal-fmt version" 3 | inputs: 4 | cabal-fmt-version: 5 | required: true 6 | description: "Version of cabal-fmt" 7 | ghc-version: 8 | required: true 9 | description: "Version of GHC" 10 | cabal-version: 11 | required: true 12 | description: "Version of cabal" 13 | hackage-index-state: 14 | required: false 15 | description: "Timestamp for Hackage index" 16 | runs: 17 | using: composite 18 | steps: 19 | - name: 💾 Restore cache 20 | uses: actions/cache/restore@v4 21 | if: ${{ !env.ACT }} 22 | id: cache-cabal-fmt 23 | with: 24 | path: "${{ github.workspace }}/.cabal-fmt/bin" 25 | key: ${{ runner.os }}-cabal-fmt-${{ inputs.cabal-fmt-version }}-input-state-${{ inputs.hackage-index-state }} 26 | 27 | - name: 🛠️ Install Haskell 28 | if: ${{ env.ACT || steps.cache-cabal-fmt.outputs.cache-hit != 'true' }} 29 | uses: haskell-actions/setup@v2 30 | id: setup-haskell 31 | with: 32 | ghc-version: ${{ inputs.ghc-version }} 33 | cabal-version: ${{ inputs.cabal-version }} 34 | 35 | - name: 🛠️ Install cabal-fmt 36 | if: ${{ env.ACT || steps.cache-cabal-fmt.outputs.cache-hit != 'true' }} 37 | run: | 38 | mkdir --parents "${{ github.workspace }}/.cabal-fmt/bin" 39 | cabal install cabal-fmt-${{ inputs.cabal-fmt-version }} \ 40 | ${{ inputs.hackage-index-state && format('--index-state={0}', inputs.hackage-index-state) }} \ 41 | --overwrite-policy=always \ 42 | --install-method=copy \ 43 | --installdir="${{ github.workspace }}/.cabal-fmt/bin" 44 | shell: sh 45 | 46 | - name: 🛠️ Add cabal-fmt to PATH 47 | run: echo "${{ github.workspace }}/.cabal-fmt/bin" >> "$GITHUB_PATH" 48 | shell: sh 49 | 50 | - name: 💾 Save cache 51 | uses: actions/cache/save@v4 52 | if: ${{ !env.ACT && steps.cache-cabal-fmt.outputs.cache-hit != 'true' }} 53 | with: 54 | path: "${{ github.workspace }}/.cabal-fmt/bin" 55 | key: ${{ steps.cache-cabal-fmt.outputs.cache-primary-key }} 56 | -------------------------------------------------------------------------------- /.github/actions/setup-shellcheck/action.yaml: -------------------------------------------------------------------------------- 1 | name: "Setup ShellCheck" 2 | description: "Install a specific ShellCheck version" 3 | inputs: 4 | shellcheck-version: 5 | required: true 6 | description: "Version of ShellCheck" 7 | runs: 8 | using: composite 9 | steps: 10 | - name: 💾 Restore cache 11 | uses: actions/cache/restore@v4 12 | if: ${{ !env.ACT }} 13 | with: 14 | path: "${{ github.workspace }}/.shellcheck/bin" 15 | key: ${{ runner.os }}-shellcheck-${{ inputs.shellcheck-version }} 16 | id: cache-shellcheck 17 | 18 | - name: 🛠️ Install ShellCheck (Linux) 19 | if: ${{ runner.os == 'Linux' && (env.ACT || steps.cache-actionlint.outputs.cache-hit != 'true') }} 20 | env: 21 | SHELLCHECK_URL: "https://github.com/koalaman/shellcheck/releases/download/v${{ inputs.shellcheck-version }}/shellcheck-v${{ inputs.shellcheck-version }}.linux.x86_64.tar.xz" 22 | run: | 23 | mkdir --parents "${{ github.workspace }}/.shellcheck/bin" 24 | curl --silent --location "$SHELLCHECK_URL" | tar --extract --xz --directory="${{ github.workspace }}/.shellcheck/bin" --strip-components=1 shellcheck-v${{ inputs.shellcheck-version }}/shellcheck 25 | shell: sh 26 | 27 | - name: 🛠️ Install ShellCheck (macOS) 28 | if: ${{ runner.os == 'macOS' && (env.ACT || steps.cache-actionlint.outputs.cache-hit != 'true') }} 29 | env: 30 | SHELLCHECK_URL: "https://github.com/koalaman/shellcheck/releases/download/v${{ inputs.shellcheck-version }}/shellcheck-v${{ inputs.shellcheck-version }}.darwin.aarch64.tar.xz" 31 | run: | 32 | mkdir --parents "${{ github.workspace }}/.shellcheck/bin" 33 | curl --silent --location "$SHELLCHECK_URL" | tar --extract --xz --directory="${{ github.workspace }}/.shellcheck/bin" --strip-components=1 shellcheck-v${{ inputs.shellcheck-version }}/shellcheck 34 | shell: sh 35 | 36 | - name: 🛠️ Install ShellCheck (Windows) 37 | if: ${{ runner.os == 'Windows' && (env.ACT || steps.cache-actionlint.outputs.cache-hit != 'true') }} 38 | run: | 39 | echo "Windows is unsupported" 40 | exit 1 41 | shell: sh 42 | 43 | - name: 🛠️ Add ShellCheck to PATH 44 | run: echo "${{ github.workspace }}/.shellcheck/bin" >> "$GITHUB_PATH" 45 | shell: sh 46 | 47 | - name: 💾 Save cache 48 | if: ${{ !env.ACT && steps.cache-shellcheck.outputs.cache-hit != 'true' }} 49 | uses: actions/cache/save@v4 50 | with: 51 | path: "${{ github.workspace }}/.shellcheck/bin" 52 | key: ${{ steps.cache-shellcheck.outputs.cache-primary-key }} 53 | -------------------------------------------------------------------------------- /.github/actions/setup-stylish-haskell/action.yml: -------------------------------------------------------------------------------- 1 | 2 | name: "Setup stylish-haskell" 3 | description: "Install a specific stylish-haskell version" 4 | inputs: 5 | stylish-haskell-version: 6 | required: true 7 | description: "Version of stylish-haskell" 8 | ghc-version: 9 | required: true 10 | description: "Version of GHC" 11 | cabal-version: 12 | required: true 13 | description: "Version of cabal" 14 | hackage-index-state: 15 | required: false 16 | description: "Timestamp for Hackage index" 17 | default: "" 18 | runs: 19 | using: composite 20 | steps: 21 | - name: 💾 Restore cache 22 | uses: actions/cache/restore@v4 23 | if: ${{ !env.ACT }} 24 | id: cache-stylish-haskell 25 | with: 26 | path: "${{ github.workspace }}/.stylish-haskell/bin" 27 | key: ${{ runner.os }}-stylish-haskell-${{ inputs.stylish-haskell-version }}-input-state-${{ inputs.hackage-index-state }} 28 | 29 | - name: 🛠️ Install Haskell 30 | if: ${{ env.ACT || steps.cache-stylish-haskell.outputs.cache-hit != 'true' }} 31 | uses: haskell-actions/setup@v2 32 | id: setup-haskell 33 | with: 34 | ghc-version: ${{ inputs.ghc-version }} 35 | cabal-version: ${{ inputs.cabal-version }} 36 | 37 | - name: 🛠️ Install stylish-haskell 38 | if: ${{ env.ACT || steps.cache-stylish-haskell.outputs.cache-hit != 'true' }} 39 | run: | 40 | mkdir --parents "${{ github.workspace }}/.stylish-haskell/bin" 41 | cabal install stylish-haskell-${{ inputs.stylish-haskell-version }} \ 42 | ${{ inputs.hackage-index-state && format('--index-state={0}', inputs.hackage-index-state) }} \ 43 | --overwrite-policy=always \ 44 | --install-method=copy \ 45 | --installdir="${{ github.workspace }}/.stylish-haskell/bin" 46 | shell: sh 47 | 48 | - name: 🛠️ Add stylish-haskell to PATH 49 | run: echo "${{ github.workspace }}/.stylish-haskell/bin" >> "$GITHUB_PATH" 50 | shell: sh 51 | 52 | - name: 💾 Save cache 53 | uses: actions/cache/save@v4 54 | if: ${{ !env.ACT && steps.cache-stylish-haskell.outputs.cache-hit != 'true' }} 55 | with: 56 | path: "${{ github.workspace }}/.stylish-haskell/bin" 57 | key: ${{ steps.cache-stylish-haskell.outputs.cache-primary-key }} 58 | -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | # Enable version updates for GitHub Actions 4 | - package-ecosystem: "github-actions" 5 | # Workflow files stored in the default location of `.github/workflows` 6 | # You don't need to specify `/.github/workflows` for `directory`. You can use `directory: "/"`. 7 | directory: "/" 8 | schedule: 9 | interval: "weekly" 10 | commit-message: 11 | prefix: "[CI] " -------------------------------------------------------------------------------- /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | # Description 2 | 3 | Add your description here, if it fixes a particular issue please provide a 4 | [link](https://docs.github.com/en/issues/tracking-your-work-with-issues/linking-a-pull-request-to-an-issue#linking-a-pull-request-to-an-issue-using-a-keyword=) 5 | to the issue. 6 | 7 | # Checklist 8 | 9 | - [ ] Read our contribution guidelines at [CONTRIBUTING.md](https://github.com/IntersectMBO/lsm-tree/blob/main/CONTRIBUTING.md), and make sure that this PR complies with the guidelines. 10 | 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Haskell / GHC 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.hie 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .hpc 13 | .hsenv 14 | .cabal-sandbox/ 15 | cabal.sandbox.config 16 | *.prof 17 | *.aux 18 | *.hp 19 | *.eventlog 20 | .stack-work/ 21 | cabal.project.local 22 | cabal.project.local~ 23 | .HTF/ 24 | .ghc.environment.* 25 | 26 | # Visual Studio Code 27 | .vscode/ 28 | 29 | # Documentation 30 | haddocks/ 31 | 32 | # Benchmarks 33 | _bench_* 34 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: "Avoid lambda"} # 2 hints 2 | - ignore: {name: "Avoid lambda using `infix`"} # 1 hint 3 | - ignore: {name: "Eta reduce"} # 1 hint 4 | - ignore: {name: "Functor law"} # 5 hints 5 | - ignore: {name: "Redundant $"} # 7 hints 6 | - ignore: {name: "Redundant bracket"} # 2 hints 7 | - ignore: {name: "Redundant guard"} # 1 hint 8 | - ignore: {name: "Redundant lambda"} # 4 hints 9 | - ignore: {name: "Unused LANGUAGE pragma"} # 14 hints 10 | - ignore: {name: "Use <$>"} # 1 hint 11 | - ignore: {name: "Use camelCase"} # 8 hints 12 | - ignore: {name: "Use isAsciiLower"} # 1 hint 13 | - ignore: {name: "Use isDigit"} # 2 hints 14 | - ignore: {name: "Use newtype instead of data"} # 3 hints 15 | - ignore: {name: "Use uncurry"} # 1 hint 16 | - ignore: {name: "Use underscore"} # 2 hints 17 | - ignore: {name: "Use &&"} # 1 hint 18 | - ignore: {name: "Use list literal"} # 1 hint 19 | - ignore: {name: "Use tuple-section"} 20 | - ignore: {name: "Use const"} 21 | - ignore: {name: "Use :"} 22 | - ignore: {name: "Redundant <$>"} 23 | - ignore: {name: "Use zipWithM"} 24 | - ignore: {name: "Redundant return"} 25 | - ignore: {name: "Use section"} 26 | - ignore: {name: "Redundant $!"} 27 | - ignore: {name: "Use shows"} 28 | - ignore: {name: "Use fmap"} 29 | - ignore: {name: "Use <=<"} 30 | - ignore: {name: "Use void"} 31 | - ignore: {name: "Use zipWith"} 32 | - ignore: {name: "Evaluate"} 33 | - ignore: {name: "Redundant if"} 34 | - ignore: {name: "Use catMaybes"} 35 | - ignore: {name: "Replace case with maybe"} 36 | - ignore: {name: "Redundant =="} 37 | - ignore: {name: "Hoist not"} 38 | - ignore: {name: "Use /="} 39 | - ignore: {name: "Use unless"} 40 | - ignore: {name: "Use notElem"} 41 | - ignore: {name: "Use elem"} 42 | - ignore: {name: "Use infix"} 43 | 44 | # Specify additional command line arguments 45 | # 46 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 47 | 48 | # Control which extensions/flags/modules/functions can be used 49 | # 50 | # - extensions: 51 | # - default: false # all extension are banned by default 52 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 53 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 54 | # 55 | # - flags: 56 | # - {name: -w, within: []} # -w is allowed nowhere 57 | # 58 | - modules: 59 | # vector 60 | - { name: "Data.Vector", as: "V" } 61 | - { name: "Data.Vector.Generic", as: "VG" } 62 | - { name: "Data.Vector.Generic.Mutable", as: "VGM" } 63 | - { name: "Data.Vector.Mutable", as: "VM" } 64 | - { name: "Data.Vector.Unboxed", as: "VU" } 65 | - { name: "Data.Vector.Unboxed.Mutable", as: "VUM" } 66 | - { name: "Data.Vector.Primitive", as: "VP" } 67 | - { name: "Data.Vector.Primitive.Mutable", as: "VPM" } 68 | # others 69 | - { name: "Database.LSMTree.Internal.RawBytes", as: "RB"} # if you import Database.LSMTree.Internal.RawByes qualified, it must be as 'RB' 70 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 71 | # 72 | # - functions: 73 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 74 | 75 | # Add custom hints for this project 76 | # 77 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 78 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 79 | - error: 80 | { note: Prefer pure to reduce Monad constraint 81 | , lhs: return x 82 | , rhs: pure x 83 | } 84 | 85 | - error: 86 | name: "Use mkPrimVector" 87 | lhs: "Data.Vector.Primitive.Vector" 88 | rhs: "mkPrimVector" 89 | 90 | - ignore: { name: "Use mkPrimVector", within: "Database.LSMTree.Internal.Vector" } 91 | 92 | # Define some custom infix operators 93 | # - fixity: infixr 3 ~^#^~ 94 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for lsm-tree 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /CODEOWNERS: -------------------------------------------------------------------------------- 1 | # Note: later rules override earlier rules. 2 | 3 | # Default 4 | * @dcoutts @jorisdral @mheinzel @recursion-ninja @wenkokke 5 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of conduct 2 | 3 | See the [code of conduct file in the Cardano engineering handbook](https://github.com/input-output-hk/cardano-engineering-handbook/blob/main/CODE-OF-CONDUCT.md). 4 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | ## Installation requirements 4 | 5 | Different OS distributions have different installation requirements. 6 | 7 | ### Linux: 8 | We recommend installing the `pkgconfig` and `liburing` systems packages, though 9 | they are not required. However, one would not get the performance benefits of 10 | performing I/O asynchronously. 11 | 12 | * Ubuntu: 13 | ``` 14 | apt-get install pkg-config liburing-dev 15 | ``` 16 | 17 | If these packages are not installed, then the `serialblockio` cabal package flag 18 | has to be enabled, either by setting the flag in 19 | `cabal.project`/`cabal.project.local`, or by passing the flag to the `cabal` 20 | executable using `--flag=+serialblockio`. 21 | 22 | > :warning: **When enabling `serialblockio`, disable the 23 | > `cabal.project.blockio-uring` import in `cabal.project`!** Unfortunately, this 24 | > line has to be removed/commented out manually (for now), or the project won't 25 | > build. 26 | 27 | Installing `rocksdb` is entirely optional, and only required if one wants to 28 | build or run the `rocksdb-bench-wp8` comparison macro-benchmark. 29 | 30 | * Ubuntu: 31 | ``` 32 | apt-get install librocksdb-dev 33 | ``` 34 | 35 | If this package is not installed, then the `rocksdb` cabal package flag has to 36 | be disabled, either by setting the flag in 37 | `cabal.project`/`cabal.project.local`, or by passing the flag to the cabal 38 | executable using `--flag=-rocksdb` 39 | 40 | ### MacOS 41 | 42 | There are no installation requirements. 43 | 44 | ### Windows 45 | 46 | There are no installation requirements. 47 | 48 | ## Building 49 | 50 | The project is built using `ghc` and `cabal`. 51 | 52 | ``` 53 | cabal update 54 | cabal build all 55 | ``` 56 | 57 | ## Testing 58 | 59 | Tests are run using `cabal`. 60 | 61 | ``` 62 | cabal build all 63 | cabal test all 64 | ``` 65 | 66 | ## Code style 67 | 68 | There is no strict code style, but try to keep the code style consistent 69 | throughout the repository and favour readability. Code should be well-documented 70 | and well-tested. 71 | 72 | ## Formatting 73 | 74 | We use `stylish-haskell` to format Haskell files, and we use `cabal-fmt` to 75 | format `*.cabal` files. We also use `cabal check` to sanity check our cabal 76 | files. See the helpful scripts in the [scripts folder](./scripts/), and the 77 | [`stylish-haskell` configuration file](./.stylish-haskell.yaml). 78 | 79 | To perform a pre-commit code formatting pass, run one of the following: 80 | 81 | * If you prefer `fd` and have it installed on your system: 82 | ``` 83 | ./format-stylish-fd.sh 84 | ./format-cabal-fd.sh 85 | ./check-cabal.sh 86 | ./haddocks.sh 87 | ``` 88 | 89 | * Otherwise using Unix `find`: 90 | ``` 91 | ./format-stylish-find.sh 92 | ./format-cabal-find.sh 93 | ./check-cabal.sh 94 | ./haddocks.sh 95 | 96 | ## Pull requests 97 | 98 | The following are requirements for merging a PR into `main`: 99 | * Each commit should be small and should preferably address one thing. Commit 100 | messages should be useful. 101 | * Document and test your changes. 102 | * The PR should have a useful description, and it should link issues that it 103 | resolves (if any). 104 | * Changes introduced by the PR should be recorded in the relevant changelog 105 | files. 106 | * PRs should not bundle many unrelated changes. 107 | * PRs should be approved by at least 1 code owner. 108 | * The PR should pass all CI checks. 109 | 110 | ## Releases 111 | 112 | Releases follow the [Haskell Package Versioning 113 | Policy](https://pvp.haskell.org/). We use version numbers consisting of 4 parts, 114 | like `A.B.C.D`. 115 | * `A.B` is the *major* version number. A bump indicates a breaking change. 116 | * `C` is the *minor* version number. A bump indicates a non-breaking change. 117 | * `D` is the *patch* version number. A bump indicates a small, non-breaking 118 | patch. 119 | -------------------------------------------------------------------------------- /NOTICE: -------------------------------------------------------------------------------- 1 | Copyright 2023 Input Output Global, Inc. (IOG), 2023-2025 INTERSECT. 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /SECURITY.md: -------------------------------------------------------------------------------- 1 | # Security Policy 2 | 3 | ## Reporting a Vulnerability 4 | 5 | Please report (suspected) security vulnerabilities to security@intersectmbo.org. You will receive a 6 | response from us within 48 hours. If the issue is confirmed, we will release a patch as soon 7 | as possible. 8 | 9 | Please provide a clear and concise description of the vulnerability, including: 10 | 11 | * the affected version(s) of lsm-tree, 12 | * steps that can be followed to exercise the vulnerability, 13 | * any workarounds or mitigations 14 | 15 | If you have developed any code or utilities that can help demonstrate the suspected 16 | vulnerability, please mention them in your email but ***DO NOT*** attempt to include them as 17 | attachments as this may cause your Email to be blocked by spam filters. 18 | See the security file in the [Cardano engineering handbook](https://github.com/input-output-hk/cardano-engineering-handbook/blob/main/SECURITY.md). -------------------------------------------------------------------------------- /bench/micro/Bench/Database/LSMTree/Internal/BloomFilter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | 5 | module Bench.Database.LSMTree.Internal.BloomFilter ( 6 | benchmarks 7 | -- * Benchmarked functions 8 | , elems 9 | ) where 10 | 11 | import Criterion.Main 12 | import qualified Data.Bifoldable as BiFold 13 | import Data.BloomFilter (Bloom) 14 | import qualified Data.BloomFilter as Bloom 15 | import Data.BloomFilter.Hash (Hashable) 16 | import qualified Data.Foldable as Fold 17 | import Data.Map.Strict (Map) 18 | import qualified Data.Map.Strict as Map 19 | import Database.LSMTree.Extras.Random 20 | import Database.LSMTree.Extras.UTxO (UTxOKey) 21 | import Database.LSMTree.Internal.Serialise (SerialisedKey, 22 | serialiseKey) 23 | import System.Random as R 24 | 25 | -- See 'utxoNumPages'. 26 | benchmarks :: Benchmark 27 | benchmarks = bgroup "Bench.Database.LSMTree.Internal.BloomFilter" [ 28 | bgroup "elems" [ 29 | env (elemEnv 0.1 2_500_000 1_000_000 0) $ \ ~(b, xs) -> 30 | bench "onlyTruePositives 0.1" $ whnf (elems b) xs 31 | , env (elemEnv 0.9 2_500_000 1_000_000 0) $ \ ~(b, xs) -> 32 | bench "onlyTruePositives 0.9" $ whnf (elems b) xs 33 | , env (elemEnv 0.1 2_500_000 0 1_000_000) $ \ ~(b, xs) -> 34 | bench "onlyNegatives 0.1" $ whnf (elems b) xs 35 | , env (elemEnv 0.9 2_500_000 0 1_000_000) $ \ ~(b, xs) -> 36 | bench "onlyNegatives 0.9" $ whnf (elems b) xs 37 | ] 38 | , env (constructionEnv 2_500_000) $ \ m -> 39 | bgroup "construction" [ 40 | bench "FPR = 0.1" $ 41 | whnf (constructBloom 0.1) m 42 | 43 | , bench "FPR = 0.9" $ 44 | whnf (constructBloom 0.9) m 45 | ] 46 | ] 47 | 48 | -- | Input environment for benchmarking 'Bloom.elem'. 49 | elemEnv :: 50 | Double -- ^ False positive rate 51 | -> Int -- ^ Number of entries in the bloom filter 52 | -> Int -- ^ Number of positive lookups 53 | -> Int -- ^ Number of negative lookups 54 | -> IO (Bloom SerialisedKey, [SerialisedKey]) 55 | elemEnv fpr nbloom nelemsPositive nelemsNegative = do 56 | let g = mkStdGen 100 57 | (g1, g') = R.splitGen g 58 | (g2, g3) = R.splitGen g' 59 | 60 | let (xs, ys1) = splitAt nbloom 61 | $ uniformWithoutReplacement @UTxOKey g1 (nbloom + nelemsNegative) 62 | ys2 = sampleUniformWithReplacement @UTxOKey g2 nelemsPositive xs 63 | zs = shuffle (ys1 ++ ys2) g3 64 | pure ( Bloom.fromList (Bloom.policyForFPR fpr) (fmap serialiseKey xs) 65 | , fmap serialiseKey zs 66 | ) 67 | 68 | -- | Used for benchmarking 'Bloom.elem'. 69 | elems :: Hashable a => Bloom a -> [a] -> () 70 | elems b xs = Fold.foldl' (\acc x -> Bloom.elem x b `seq` acc) () xs 71 | 72 | -- | Input environment for benchmarking 'constructBloom'. 73 | constructionEnv :: Int -> IO (Map SerialisedKey SerialisedKey) 74 | constructionEnv n = do 75 | stdgen <- newStdGen 76 | stdgen' <- newStdGen 77 | let ks = uniformWithoutReplacement @UTxOKey stdgen n 78 | vs = uniformWithReplacement @UTxOKey stdgen' n 79 | pure $ Map.fromList (zipWith (\k v -> (serialiseKey k, serialiseKey v)) ks vs) 80 | 81 | -- | Used for benchmarking the construction of bloom filters from write buffers. 82 | constructBloom :: 83 | Double 84 | -> Map SerialisedKey SerialisedKey 85 | -> Bloom SerialisedKey 86 | constructBloom fpr m = 87 | -- For faster construction, avoid going via lists and use Bloom.create, 88 | -- traversing the map inserting the keys 89 | Bloom.create (Bloom.sizeForFPR fpr (Map.size m)) $ \b -> 90 | BiFold.bifoldMap (\k -> Bloom.insert b k) (\_v -> pure ()) m 91 | -------------------------------------------------------------------------------- /bench/micro/Bench/Database/LSMTree/Internal/RawPage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 5 | 6 | module Bench.Database.LSMTree.Internal.RawPage ( 7 | benchmarks 8 | -- * Benchmarked functions 9 | ) where 10 | 11 | import Control.DeepSeq (deepseq) 12 | import qualified Data.ByteString as BS 13 | 14 | import Database.LSMTree.Extras.ReferenceImpl 15 | import qualified Database.LSMTree.Internal.RawBytes as RB 16 | import Database.LSMTree.Internal.RawPage 17 | import Database.LSMTree.Internal.Serialise 18 | 19 | import Criterion.Main 20 | import Test.QuickCheck 21 | import Test.QuickCheck.Gen (Gen (..)) 22 | import Test.QuickCheck.Random (mkQCGen) 23 | 24 | benchmarks :: Benchmark 25 | benchmarks = rawpage `deepseq` bgroup "Bench.Database.LSMTree.Internal.RawPage" 26 | [ bRawPageFindKey 27 | , bRawPageLookup 28 | ] 29 | where 30 | bRawPageFindKey = bgroup "rawPageFindKey" 31 | [ bench "missing" $ whnf (rawPageFindKey rawpage) missing 32 | , bench "existing-head" $ whnf (rawPageFindKey rawpage) existingHead 33 | , bench "existing-last" $ whnf (rawPageFindKey rawpage) existingLast 34 | ] 35 | 36 | bRawPageLookup = bgroup "rawPageLookup" 37 | [ bench "missing" $ whnf (rawPageLookup rawpage) missing 38 | , bench "existing-head" $ whnf (rawPageLookup rawpage) existingHead 39 | , bench "existing-last" $ whnf (rawPageLookup rawpage) existingLast 40 | ] 41 | 42 | kops :: [(Key, Operation)] 43 | kops = unGen genPage (mkQCGen 42) 200 44 | where 45 | genPage = orderdKeyOps <$> 46 | genPageContentNearFull DiskPage4k genSmallKey genSmallValue 47 | 48 | rawpage :: RawPage 49 | rawpage = fst $ toRawPage (PageContentFits kops) 50 | 51 | genSmallKey :: Gen Key 52 | genSmallKey = Key . BS.pack <$> vectorOf 8 arbitrary 53 | 54 | genSmallValue :: Gen Value 55 | genSmallValue = Value . BS.pack <$> vectorOf 8 arbitrary 56 | 57 | missing :: SerialisedKey 58 | missing = SerialisedKey $ RB.pack [1, 2, 3] 59 | 60 | keys :: [Key] 61 | keys = map fst kops 62 | 63 | existingHead :: SerialisedKey 64 | existingHead = SerialisedKey $ RB.fromByteString $ unKey $ head keys 65 | 66 | existingLast :: SerialisedKey 67 | existingLast = SerialisedKey $ RB.fromByteString $ unKey $ last keys 68 | 69 | -------------------------------------------------------------------------------- /bench/micro/Bench/Database/LSMTree/Internal/Serialise.hs: -------------------------------------------------------------------------------- 1 | module Bench.Database.LSMTree.Internal.Serialise ( 2 | benchmarks 3 | ) where 4 | 5 | import Criterion.Main 6 | import Database.LSMTree.Extras.UTxO 7 | import Database.LSMTree.Internal.Serialise.Class 8 | import System.Random 9 | 10 | benchmarks :: Benchmark 11 | benchmarks = bgroup "Bench.Database.LSMTree.Internal.Serialise" [ 12 | env (pure $ fst $ uniform (mkStdGen 12)) $ \(k :: UTxOKey) -> 13 | bgroup "UTxOKey" [ 14 | bench "serialiseKey" $ whnf serialiseKey k 15 | , bench "serialiseKeyRoundtrip" $ whnf serialiseKeyRoundtrip k 16 | ] 17 | ] 18 | 19 | serialiseKeyRoundtrip :: SerialiseKey k => k -> k 20 | serialiseKeyRoundtrip k = deserialiseKey (serialiseKey k) 21 | -------------------------------------------------------------------------------- /bench/micro/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | Micro-benchmarks for the @lsm-tree@ library. 4 | module Main (main) where 5 | 6 | import qualified Bench.Database.LSMTree 7 | import qualified Bench.Database.LSMTree.Internal.BloomFilter 8 | import qualified Bench.Database.LSMTree.Internal.Index 9 | import qualified Bench.Database.LSMTree.Internal.Index.Compact 10 | import qualified Bench.Database.LSMTree.Internal.Lookup 11 | import qualified Bench.Database.LSMTree.Internal.Merge 12 | import qualified Bench.Database.LSMTree.Internal.RawPage 13 | import qualified Bench.Database.LSMTree.Internal.Serialise 14 | import qualified Bench.Database.LSMTree.Internal.WriteBuffer 15 | import Criterion.Main (defaultMain) 16 | 17 | main :: IO () 18 | main = do 19 | #ifdef NO_IGNORE_ASSERTS 20 | putStrLn "WARNING: BENCHMARKING A BUILD IN DEBUG MODE" 21 | #endif 22 | defaultMain [ 23 | Bench.Database.LSMTree.Internal.BloomFilter.benchmarks 24 | , Bench.Database.LSMTree.Internal.Index.benchmarks 25 | , Bench.Database.LSMTree.Internal.Index.Compact.benchmarks 26 | , Bench.Database.LSMTree.Internal.Lookup.benchmarks 27 | , Bench.Database.LSMTree.Internal.Merge.benchmarks 28 | , Bench.Database.LSMTree.Internal.RawPage.benchmarks 29 | , Bench.Database.LSMTree.Internal.Serialise.benchmarks 30 | , Bench.Database.LSMTree.Internal.WriteBuffer.benchmarks 31 | , Bench.Database.LSMTree.benchmarks 32 | ] 33 | -------------------------------------------------------------------------------- /blockio/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for blockio 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /blockio/NOTICE: -------------------------------------------------------------------------------- 1 | Copyright 2023 Input Output Global, Inc. (IOG), 2023-2025 INTERSECT. 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /blockio/README.md: -------------------------------------------------------------------------------- 1 | # blockio 2 | 3 | This packages defines an abstract interface for batched, asynchronous I\/O, 4 | for use with the abstract interface for file system I\/O defined by the 5 | [fs-api](https://hackage.haskell.org/package/fs-api) package. 6 | 7 | The /sim/ sub-library of this package defines /simulated/ batched, asynchronous I\/O 8 | for use with the [fs-sim](https://hackage.haskell.org/package/fs-sim) package. 9 | -------------------------------------------------------------------------------- /blockio/src-linux/System/FS/BlockIO/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module System.FS.BlockIO.Internal ( 4 | ioHasBlockIO 5 | ) where 6 | 7 | import qualified System.FS.API as FS 8 | import System.FS.API (FsPath, Handle (..), HasFS) 9 | import qualified System.FS.BlockIO.API as FS 10 | import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO, 11 | IOCtxParams) 12 | import System.FS.IO (HandleIO) 13 | import qualified System.FS.IO.Handle as FS 14 | import qualified System.Posix.Fcntl as Fcntl 15 | import qualified System.Posix.Files as Unix 16 | import qualified System.Posix.Unistd as Unix 17 | 18 | #if SERIALBLOCKIO 19 | import qualified System.FS.BlockIO.Serial as Serial 20 | #else 21 | import qualified System.FS.BlockIO.Async as Async 22 | #endif 23 | 24 | ioHasBlockIO :: 25 | HasFS IO HandleIO 26 | -> IOCtxParams 27 | -> IO (HasBlockIO IO HandleIO) 28 | #if SERIALBLOCKIO 29 | ioHasBlockIO hfs _params = 30 | Serial.serialHasBlockIO 31 | hSetNoCache 32 | hAdvise 33 | hAllocate 34 | (FS.tryLockFileIO hfs) 35 | hSynchronise 36 | (synchroniseDirectory hfs) 37 | (FS.createHardLinkIO hfs Unix.createLink) 38 | hfs 39 | #else 40 | ioHasBlockIO hfs params = 41 | Async.asyncHasBlockIO 42 | hSetNoCache 43 | hAdvise 44 | hAllocate 45 | (FS.tryLockFileIO hfs) 46 | hSynchronise 47 | (synchroniseDirectory hfs) 48 | (FS.createHardLinkIO hfs Unix.createLink) 49 | hfs 50 | params 51 | #endif 52 | 53 | hSetNoCache :: Handle HandleIO -> Bool -> IO () 54 | hSetNoCache h b = 55 | FS.withOpenHandle "hSetNoCache" (handleRaw h) (flip Fcntl.fileSetCaching (not b)) 56 | 57 | hAdvise :: Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO () 58 | hAdvise h off len advice = FS.withOpenHandle "hAdvise" (handleRaw h) $ \fd -> 59 | Fcntl.fileAdvise fd off len advice' 60 | where 61 | advice' = case advice of 62 | AdviceNormal -> Fcntl.AdviceNormal 63 | AdviceRandom -> Fcntl.AdviceRandom 64 | AdviceSequential -> Fcntl.AdviceSequential 65 | AdviceWillNeed -> Fcntl.AdviceWillNeed 66 | AdviceDontNeed -> Fcntl.AdviceDontNeed 67 | AdviceNoReuse -> Fcntl.AdviceNoReuse 68 | 69 | hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO () 70 | hAllocate h off len = FS.withOpenHandle "hAllocate" (handleRaw h) $ \fd -> 71 | Fcntl.fileAllocate fd off len 72 | 73 | hSynchronise :: Handle HandleIO -> IO () 74 | hSynchronise h = FS.withOpenHandle "hSynchronise" (handleRaw h) $ \fd -> 75 | Unix.fileSynchronise fd 76 | 77 | synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO () 78 | synchroniseDirectory hfs path = 79 | FS.withFile hfs path FS.ReadMode $ hSynchronise 80 | -------------------------------------------------------------------------------- /blockio/src-macos/System/FS/BlockIO/Internal.hs: -------------------------------------------------------------------------------- 1 | module System.FS.BlockIO.Internal ( 2 | ioHasBlockIO 3 | ) where 4 | 5 | import qualified System.FS.API as FS 6 | import System.FS.API (FsPath, Handle (..), HasFS) 7 | import qualified System.FS.BlockIO.API as FS 8 | import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO, 9 | IOCtxParams) 10 | import qualified System.FS.BlockIO.Serial as Serial 11 | import System.FS.IO (HandleIO) 12 | import qualified System.FS.IO.Handle as FS 13 | import qualified System.Posix.Fcntl as Unix 14 | import qualified System.Posix.Files as Unix 15 | import qualified System.Posix.Unistd as Unix 16 | 17 | -- | For now we use the portable serial implementation of HasBlockIO. If you 18 | -- want to provide a proper async I/O implementation for OSX, then this is where 19 | -- you should put it. 20 | -- 21 | -- The recommended choice would be to use the POSIX AIO API. 22 | ioHasBlockIO :: 23 | HasFS IO HandleIO 24 | -> IOCtxParams 25 | -> IO (HasBlockIO IO HandleIO) 26 | ioHasBlockIO hfs _params = 27 | Serial.serialHasBlockIO 28 | hSetNoCache 29 | hAdvise 30 | hAllocate 31 | (FS.tryLockFileIO hfs) 32 | hSynchronise 33 | (synchroniseDirectory hfs) 34 | (FS.createHardLinkIO hfs Unix.createLink) 35 | hfs 36 | 37 | hSetNoCache :: Handle HandleIO -> Bool -> IO () 38 | hSetNoCache h b = 39 | FS.withOpenHandle "hSetNoCache" (handleRaw h) (flip Unix.fileSetCaching (not b)) 40 | 41 | -- TODO: it is unclear if MacOS supports @posix_fadvise(2)@, and it's hard to 42 | -- check because there are no manual pages online. For now, it's just hardcoded 43 | -- to be a no-op. 44 | hAdvise :: Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO () 45 | hAdvise _h _off _len _advice = pure () 46 | 47 | hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO () 48 | hAllocate _h _off _len = pure () 49 | 50 | hSynchronise :: Handle HandleIO -> IO () 51 | hSynchronise h = FS.withOpenHandle "hSynchronise" (handleRaw h) $ \fd -> 52 | Unix.fileSynchronise fd 53 | 54 | synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO () 55 | synchroniseDirectory hfs path = 56 | FS.withFile hfs path FS.ReadMode $ hSynchronise 57 | -------------------------------------------------------------------------------- /blockio/src-windows/System/FS/BlockIO/Internal.hs: -------------------------------------------------------------------------------- 1 | module System.FS.BlockIO.Internal ( 2 | ioHasBlockIO 3 | ) where 4 | 5 | import Control.Exception (throwIO) 6 | import Control.Monad (unless) 7 | import qualified System.FS.API as FS 8 | import System.FS.API (FsPath, Handle (..), HasFS) 9 | import qualified System.FS.BlockIO.API as FS 10 | import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO, 11 | IOCtxParams) 12 | import qualified System.FS.BlockIO.Serial as Serial 13 | import System.FS.IO (HandleIO) 14 | import qualified System.FS.IO.Handle as FS 15 | import System.IO.Error (doesNotExistErrorType, ioeSetErrorString, 16 | mkIOError) 17 | import qualified System.Win32.File as Windows 18 | import qualified System.Win32.HardLink as Windows 19 | 20 | -- | For now we use the portable serial implementation of HasBlockIO. If you 21 | -- want to provide a proper async I/O implementation for Windows, then this is 22 | -- where you should put it. 23 | -- 24 | -- The recommended choice would be to use the Win32 IOCP API. 25 | ioHasBlockIO :: 26 | HasFS IO HandleIO 27 | -> IOCtxParams 28 | -> IO (HasBlockIO IO HandleIO) 29 | ioHasBlockIO hfs _params = 30 | Serial.serialHasBlockIO 31 | hSetNoCache 32 | hAdvise 33 | hAllocate 34 | (FS.tryLockFileIO hfs) 35 | hSynchronise 36 | (synchroniseDirectory hfs) 37 | (FS.createHardLinkIO hfs Windows.createHardLink) 38 | hfs 39 | 40 | hSetNoCache :: Handle HandleIO -> Bool -> IO () 41 | hSetNoCache _h _b = pure () 42 | 43 | hAdvise :: Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO () 44 | hAdvise _h _off _len _advice = pure () 45 | 46 | hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO () 47 | hAllocate _h _off _len = pure () 48 | 49 | hSynchronise :: Handle HandleIO -> IO () 50 | hSynchronise h = FS.withOpenHandle "hAdvise" (handleRaw h) $ \fd -> 51 | Windows.flushFileBuffers fd 52 | 53 | synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO () 54 | synchroniseDirectory hfs path = do 55 | b <- FS.doesDirectoryExist hfs path 56 | unless b $ 57 | throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs (FS.mkFsPath [])) ioerr 58 | where 59 | ioerr = 60 | ioeSetErrorString 61 | (mkIOError doesNotExistErrorType "synchroniseDirectory" Nothing Nothing) 62 | ("synchroniseDirectory: directory does not exist") 63 | -------------------------------------------------------------------------------- /blockio/src/System/FS/BlockIO/IO.hs: -------------------------------------------------------------------------------- 1 | module System.FS.BlockIO.IO ( 2 | ioHasBlockIO 3 | , withIOHasBlockIO 4 | ) where 5 | 6 | import Control.Exception (bracket) 7 | import System.FS.API (HasFS) 8 | import System.FS.BlockIO.API (HasBlockIO (..), IOCtxParams) 9 | import qualified System.FS.BlockIO.Internal as I 10 | import System.FS.IO (HandleIO) 11 | 12 | -- | Platform-dependent IO instantiation of 'HasBlockIO'. 13 | ioHasBlockIO :: 14 | HasFS IO HandleIO 15 | -> IOCtxParams 16 | -> IO (HasBlockIO IO HandleIO) 17 | ioHasBlockIO = I.ioHasBlockIO 18 | 19 | withIOHasBlockIO :: 20 | HasFS IO HandleIO 21 | -> IOCtxParams 22 | -> (HasBlockIO IO HandleIO -> IO a) 23 | -> IO a 24 | withIOHasBlockIO hfs params action = 25 | bracket (ioHasBlockIO hfs params) (\HasBlockIO{close} -> close) action 26 | -------------------------------------------------------------------------------- /blockio/src/System/FS/BlockIO/Serial.hs: -------------------------------------------------------------------------------- 1 | module System.FS.BlockIO.Serial ( 2 | serialHasBlockIO 3 | ) where 4 | 5 | import Control.Concurrent.Class.MonadMVar 6 | import Control.Monad (unless) 7 | import Control.Monad.Class.MonadThrow 8 | import Control.Monad.Primitive (PrimMonad, PrimState, RealWorld) 9 | import qualified Data.Vector as V 10 | import qualified Data.Vector.Unboxed as VU 11 | import qualified Data.Vector.Unboxed.Mutable as VUM 12 | import System.FS.API 13 | import qualified System.FS.BlockIO.API as API 14 | import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode (..)) 15 | 16 | {-# SPECIALISE serialHasBlockIO :: 17 | Eq h 18 | => (Handle h -> Bool -> IO ()) 19 | -> (Handle h -> API.FileOffset -> API.FileOffset -> API.Advice -> IO ()) 20 | -> (Handle h -> API.FileOffset -> API.FileOffset -> IO ()) 21 | -> (FsPath -> LockMode -> IO (Maybe (API.LockFileHandle IO))) 22 | -> (Handle h -> IO ()) 23 | -> (FsPath -> IO ()) 24 | -> (FsPath -> FsPath -> IO ()) 25 | -> HasFS IO h 26 | -> IO (API.HasBlockIO IO h) 27 | #-} 28 | -- | IO instantiation of 'HasBlockIO', using an existing 'HasFS'. Thus this 29 | -- implementation does not take advantage of parallel I/O. 30 | serialHasBlockIO :: 31 | (MonadThrow m, MonadMVar m, PrimMonad m, Eq h) 32 | => (Handle h -> Bool -> m ()) 33 | -> (Handle h -> API.FileOffset -> API.FileOffset -> API.Advice -> m ()) 34 | -> (Handle h -> API.FileOffset -> API.FileOffset -> m ()) 35 | -> (FsPath -> LockMode -> m (Maybe (API.LockFileHandle m))) 36 | -> (Handle h -> m ()) 37 | -> (FsPath -> m ()) 38 | -> (FsPath -> FsPath -> m ()) 39 | -> HasFS m h 40 | -> m (API.HasBlockIO m h) 41 | serialHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hSynchronise synchroniseDirectory createHardLink hfs = do 42 | ctx <- initIOCtx (SomeHasFS hfs) 43 | pure $ API.HasBlockIO { 44 | API.close = close ctx 45 | , API.submitIO = submitIO hfs ctx 46 | , API.hSetNoCache 47 | , API.hAdvise 48 | , API.hAllocate 49 | , API.tryLockFile 50 | , API.hSynchronise 51 | , API.synchroniseDirectory 52 | , API.createHardLink 53 | } 54 | 55 | data IOCtx m = IOCtx { ctxFS :: SomeHasFS m, openVar :: MVar m Bool } 56 | 57 | {-# SPECIALISE guardIsOpen :: IOCtx IO -> IO () #-} 58 | guardIsOpen :: (MonadMVar m, MonadThrow m) => IOCtx m -> m () 59 | guardIsOpen ctx = readMVar (openVar ctx) >>= \b -> 60 | unless b $ throwIO (API.mkClosedError (ctxFS ctx) "submitIO") 61 | 62 | {-# SPECIALISE initIOCtx :: SomeHasFS IO -> IO (IOCtx IO) #-} 63 | initIOCtx :: MonadMVar m => SomeHasFS m -> m (IOCtx m) 64 | initIOCtx someHasFS = IOCtx someHasFS <$> newMVar True 65 | 66 | {-# SPECIALISE close :: IOCtx IO -> IO () #-} 67 | close :: MonadMVar m => IOCtx m -> m () 68 | close ctx = modifyMVar_ (openVar ctx) $ const (pure False) 69 | 70 | {-# SPECIALISE submitIO :: 71 | HasFS IO h 72 | -> IOCtx IO -> V.Vector (IOOp RealWorld h) 73 | -> IO (VU.Vector IOResult) #-} 74 | submitIO :: 75 | (MonadMVar m, MonadThrow m, PrimMonad m) 76 | => HasFS m h 77 | -> IOCtx m 78 | -> V.Vector (IOOp (PrimState m) h) 79 | -> m (VU.Vector IOResult) 80 | submitIO hfs ctx ioops = do 81 | guardIsOpen ctx 82 | hmapM (ioop hfs) ioops 83 | 84 | {-# SPECIALISE ioop :: HasFS IO h -> IOOp RealWorld h -> IO IOResult #-} 85 | -- | Perform the IOOp using synchronous I\/O. 86 | ioop :: 87 | MonadThrow m 88 | => HasFS m h 89 | -> IOOp (PrimState m) h 90 | -> m IOResult 91 | ioop hfs (IOOpRead h off buf bufOff c) = 92 | IOResult <$> hGetBufExactlyAt hfs h buf bufOff c (fromIntegral off) 93 | ioop hfs (IOOpWrite h off buf bufOff c) = 94 | IOResult <$> hPutBufExactlyAt hfs h buf bufOff c (fromIntegral off) 95 | 96 | {-# SPECIALISE hmapM :: 97 | VUM.Unbox b 98 | => (a -> IO b) 99 | -> V.Vector a 100 | -> IO (VU.Vector b) #-} 101 | -- | Heterogeneous blend of 'V.mapM' and 'VU.mapM'. 102 | -- 103 | -- The @vector@ package does not provide functions that take distinct vector 104 | -- containers as arguments, so we write it by hand to prevent having to convert 105 | -- one vector type to the other. 106 | hmapM :: 107 | forall m a b. (PrimMonad m, VUM.Unbox b) 108 | => (a -> m b) 109 | -> V.Vector a 110 | -> m (VU.Vector b) 111 | hmapM f v = do 112 | res <- VUM.unsafeNew n 113 | loop res 0 114 | where 115 | !n = V.length v 116 | loop !res !i 117 | | i == n = VU.unsafeFreeze res 118 | | otherwise = do 119 | let !x = v `V.unsafeIndex` i 120 | !z <- f x 121 | VUM.unsafeWrite res i z 122 | loop res (i+1) 123 | -------------------------------------------------------------------------------- /blockio/test-sim/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Main (main) where 4 | 5 | import qualified System.FS.API as FS 6 | import System.FS.BlockIO.API 7 | import System.FS.BlockIO.Sim (simHasBlockIO) 8 | import qualified System.FS.Sim.MockFS as MockFS 9 | import Test.QuickCheck 10 | import Test.Tasty 11 | import Test.Tasty.QuickCheck (testProperty) 12 | 13 | import Control.Concurrent.Class.MonadSTM.Strict 14 | 15 | main :: IO () 16 | main = defaultMain tests 17 | 18 | tests :: TestTree 19 | tests = testGroup "blockio:test-sim" [ 20 | testProperty "prop_tryLockFileTwice" prop_tryLockFileTwice 21 | ] 22 | 23 | {------------------------------------------------------------------------------- 24 | File locks 25 | -------------------------------------------------------------------------------} 26 | 27 | instance Arbitrary LockMode where 28 | arbitrary = elements [SharedLock, ExclusiveLock] 29 | shrink SharedLock = [] 30 | shrink ExclusiveLock = [] 31 | 32 | -- TODO: belongs in base 33 | deriving stock instance Show LockMode 34 | 35 | prop_tryLockFileTwice :: LockMode -> LockMode -> Property 36 | prop_tryLockFileTwice mode1 mode2 = ioProperty $ do 37 | fsvar <- newTMVarIO MockFS.empty 38 | (_hfs, hbio) <- simHasBlockIO fsvar 39 | let path = FS.mkFsPath ["lockfile"] 40 | 41 | let expected@(x1, y1) = case (mode1, mode2) of 42 | (ExclusiveLock, ExclusiveLock) -> (True, False) 43 | (ExclusiveLock, SharedLock ) -> (True, False) 44 | (SharedLock , ExclusiveLock) -> (True, False) 45 | (SharedLock , SharedLock ) -> (True, True) 46 | 47 | before <- atomically (readTMVar fsvar) 48 | x2 <- tryLockFile hbio path mode1 49 | after1 <- atomically (readTMVar fsvar) 50 | y2 <- tryLockFile hbio path mode2 51 | after2 <- atomically (readTMVar fsvar) 52 | 53 | let addLabel = tabulate "modes" [show (mode1, mode2)] 54 | 55 | let addCounterexample = counterexample 56 | ( "Expecting: " <> showExpected expected <> 57 | "\nbut got: " <> showReal (x2, y2) ) 58 | . counterexample 59 | ( "FS before: " ++ show before ++ "\n" 60 | <> "FS after1: " ++ show after1 ++ "\n" 61 | <> "FS after2: " ++ show after2) 62 | 63 | pure $ addCounterexample $ addLabel $ 64 | cmpBoolMaybeConstructor x1 x2 .&&. cmpBoolMaybeConstructor y1 y2 65 | 66 | cmpBoolMaybeConstructor :: Bool -> Maybe a -> Bool 67 | cmpBoolMaybeConstructor True (Just _) = True 68 | cmpBoolMaybeConstructor False Nothing = True 69 | cmpBoolMaybeConstructor _ _ = False 70 | 71 | showExpected :: (Bool, Bool) -> String 72 | showExpected (x, y) = 73 | "(" <> showBoolAsMaybeConstructor x <> 74 | ", " <> showBoolAsMaybeConstructor y <> 75 | ")" 76 | 77 | showBoolAsMaybeConstructor :: Bool -> String 78 | showBoolAsMaybeConstructor b 79 | | b = "Just _" 80 | | otherwise = "Nothing" 81 | 82 | showReal :: (Maybe a, Maybe a) -> String 83 | showReal (x, y) = 84 | "(" <> showMaybeConstructor x <> 85 | ", " <> showMaybeConstructor y <> 86 | ")" 87 | 88 | showMaybeConstructor :: Maybe a -> String 89 | showMaybeConstructor Nothing = "Nothing" 90 | showMaybeConstructor (Just _) = "Just _" 91 | -------------------------------------------------------------------------------- /bloomfilter/LICENSE-bloomfilter: -------------------------------------------------------------------------------- 1 | Copyright 2008 Bryan O'Sullivan . 2 | Copyright (c) 2023 IOG Singapore Pte. Ltd. 3 | Copyright (c) 2024 Cardano Development Foundation 4 | 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 11 | 1. Redistributions of source code must retain the above copyright 12 | notice, this list of conditions and the following disclaimer. 13 | 14 | 2. Redistributions in binary form must reproduce the above copyright 15 | notice, this list of conditions and the following disclaimer in the 16 | documentation and/or other materials provided with the distribution. 17 | 18 | 3. Neither the name of the author nor the names of his contributors 19 | may be used to endorse or promote products derived from this software 20 | without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 23 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 26 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 28 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 29 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 30 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 | POSSIBILITY OF SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /bloomfilter/README.markdown: -------------------------------------------------------------------------------- 1 | # A fast, space efficient Bloom filter implementation 2 | 3 | Copyright 2008, 2009, 2010, 2011 Bryan O'Sullivan . 4 | 5 | This package provides both mutable and immutable Bloom filter data 6 | types, along with a family of hash function and an easy-to-use 7 | interface. 8 | 9 | To build: 10 | 11 | cabal install bloomfilter 12 | 13 | For examples of usage, see the Haddock documentation and the files in 14 | the examples directory. 15 | 16 | 17 | # Get involved! 18 | 19 | Please report bugs via the 20 | [github issue tracker](https://github.com/haskell-pkg-janitors/bloomfilter). 21 | 22 | Master [git repository](https://github.com/haskell-pkg-janitors/bloomfilter): 23 | 24 | * `git clone git://github.com/haskell-pkg-janitors/bloomfilter.git` 25 | 26 | 27 | # Authors 28 | 29 | This library is written by Bryan O'Sullivan, . 30 | -------------------------------------------------------------------------------- /bloomfilter/bench/bloomfilter-bench.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Data.BloomFilter.Blocked as B.Blocked 4 | import qualified Data.BloomFilter.Classic as B.Classic 5 | import Data.BloomFilter.Hash (Hashable (..), hash64) 6 | 7 | import Data.Word (Word64) 8 | import System.Random 9 | 10 | import Criterion.Main 11 | 12 | main :: IO () 13 | main = 14 | defaultMain [ 15 | bgroup "Data.BloomFilter.Classic" [ 16 | env newStdGen $ \g0 -> 17 | bench "construct m=1e6 fpr=1%" $ 18 | whnf (constructBloom_classic 1_000_000 0.01) g0 19 | 20 | , env newStdGen $ \g0 -> 21 | bench "construct m=1e6 fpr=0.1%" $ 22 | whnf (constructBloom_classic 1_000_000 0.001) g0 23 | 24 | , env newStdGen $ \g0 -> 25 | bench "construct m=1e7 fpr=0.1%" $ 26 | whnf (constructBloom_classic 10_000_000 0.001) g0 27 | ] 28 | , bgroup "Data.BloomFilter.Blocked" [ 29 | env newStdGen $ \g0 -> 30 | bench "construct m=1e6 fpr=1%" $ 31 | whnf (constructBloom_blocked 1_000_000 0.01) g0 32 | 33 | , env newStdGen $ \g0 -> 34 | bench "construct m=1e6 fpr=0.1%" $ 35 | whnf (constructBloom_blocked 1_000_000 0.001) g0 36 | 37 | , env newStdGen $ \g0 -> 38 | bench "construct m=1e7 fpr=0.1%" $ 39 | whnf (constructBloom_blocked 10_000_000 0.001) g0 40 | ] 41 | ] 42 | 43 | constructBloom_classic :: Int -> Double -> StdGen -> B.Classic.Bloom Word64 44 | constructBloom_classic n fpr g0 = 45 | B.Classic.unfold (B.Classic.sizeForFPR fpr n) (nextElement n) (g0, 0) 46 | 47 | constructBloom_blocked :: Int -> Double -> StdGen -> B.Blocked.Bloom Word64 48 | constructBloom_blocked n fpr g0 = 49 | B.Blocked.unfold (B.Blocked.sizeForFPR fpr n) (nextElement n) (g0, 0) 50 | 51 | {-# INLINE nextElement #-} 52 | nextElement :: Int -> (StdGen, Int) -> Maybe (Word64, (StdGen, Int)) 53 | nextElement !n (!g, !i) 54 | | i >= n = Nothing 55 | | otherwise = Just (x, (g', i+1)) 56 | where 57 | (!x, !g') = uniform g 58 | 59 | -------------------------------------------------------------------------------- /bloomfilter/examples/spell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Main (main) where 3 | 4 | import Control.Monad (forM_, when) 5 | import System.Environment (getArgs) 6 | 7 | import qualified Data.BloomFilter as B 8 | 9 | main :: IO () 10 | main = do 11 | files <- getArgs 12 | dictionary <- readFile "/usr/share/dict/words" 13 | let !bloom = B.fromList (B.policyForFPR 0.01) (words dictionary) 14 | forM_ files $ \file -> 15 | putStrLn . unlines . filter (`B.notElem` bloom) . words 16 | =<< readFile file 17 | -------------------------------------------------------------------------------- /bloomfilter/fpr.gnuplot: -------------------------------------------------------------------------------- 1 | set term png size 1800, 1200 2 | set output "fpr.png" 3 | set title "Bloom filter false positive rates (FPR) vs bits per entry\nclassic and block-structured implementations" 4 | # set subtitle "blah" 5 | 6 | set xlabel "Bits per entry" 7 | set xrange [1:25] 8 | set grid xtics 9 | set xtics 0,2,24 10 | 11 | set ylabel "False Positive Rate (FPR), log scale" 12 | set yrange [1e-5:1] 13 | set logscale y 14 | set format y "10^{%L}" 15 | set grid ytics 16 | 17 | plot "fpr.classic.gnuplot.data" using 1 : 3 title "Classic, actual FPR" with points pointtype 1 pointsize 2, \ 18 | "fpr.classic.gnuplot.data" using 1 : 2 title "Classic, calculated FPR" with lines linewidth 2, \ 19 | "fpr.blocked.gnuplot.data" using 1 : 3 title "Blocked, actual FPR" with points pointtype 1 pointsize 2, \ 20 | "fpr.blocked.gnuplot.data" using 1 : 2 title "Blocked, calculated FPR" with lines linewidth 3 21 | -------------------------------------------------------------------------------- /bloomfilter/fpr.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/bloomfilter/fpr.png -------------------------------------------------------------------------------- /bloomfilter/src/Data/BloomFilter.hs: -------------------------------------------------------------------------------- 1 | module Data.BloomFilter ( 2 | module Data.BloomFilter.Classic 3 | ) where 4 | 5 | import Data.BloomFilter.Classic 6 | -------------------------------------------------------------------------------- /bloomfilter/src/Data/BloomFilter/Blocked/Calc.hs: -------------------------------------------------------------------------------- 1 | -- | Various formulas for working with bloomfilters. 2 | module Data.BloomFilter.Blocked.Calc ( 3 | NumEntries, 4 | BloomSize (..), 5 | FPR, 6 | sizeForFPR, 7 | BitsPerEntry, 8 | sizeForBits, 9 | sizeForPolicy, 10 | BloomPolicy (..), 11 | policyFPR, 12 | policyForFPR, 13 | policyForBits, 14 | ) where 15 | 16 | import Data.BloomFilter.Classic.Calc (BitsPerEntry, BloomPolicy (..), 17 | BloomSize (..), FPR, NumEntries) 18 | 19 | {- 20 | Calculating the relationship between bits and FPR for the blocked 21 | implementation: 22 | 23 | While in principle there's a principled approach to this, it's complex to 24 | calculate numerically. So instead we compute a regression from samples of bits 25 | & FPR. The fpr-calc.hs program in this package does this for a range of bits, 26 | and outputs out both graph data (to feed into gnuplot) and it also a regression 27 | fit. The exact fit one gets depends on the PRNG seed used. 28 | 29 | We calculate the regression two ways, one for FPR -> bits, and bits -> FPR. 30 | We use a quadratic regression, with the FPR in log space. 31 | 32 | The following is the sample of the regression fit output that we end up using 33 | in the functions 'policyForFPR' and 'policyForBits'. 34 | 35 | Blocked bloom filter quadratic regressions: 36 | bits independent, FPR dependent: 37 | Fit { 38 | fitParams = V3 (-5.03623760876204e-3) 0.5251544487138062 (-0.10110451821280719), 39 | fitErrors = V3 3.344945010267228e-5 8.905631581753235e-4 5.102181306816477e-3, 40 | fitNDF = 996, fitWSSR = 1.5016403117905384 41 | } 42 | 43 | FPR independent, bits dependent: 44 | Fit { 45 | fitParams = V3 8.079418894776325e-2 1.6462569292513933 0.5550062950289885, 46 | fitErrors = V3 7.713375250014809e-4 8.542261871094414e-3 2.0678969159415226e-2, 47 | fitNDF = 996, fitWSSR = 19.00125036371992 48 | } 49 | 50 | -} 51 | 52 | policyForFPR :: FPR -> BloomPolicy 53 | policyForFPR fpr | fpr <= 0 || fpr >= 1 = 54 | error "bloomPolicyForFPR: fpr out of range (0,1)" 55 | 56 | policyForFPR fpr = 57 | BloomPolicy { 58 | policyBits = c, 59 | policyHashes = k 60 | } 61 | where 62 | k :: Int 63 | k = max 1 (round (recip_log2 * log_fpr)) 64 | c = log_fpr * log_fpr * f2 65 | + log_fpr * f1 66 | + f0 67 | log_fpr = negate (log fpr) 68 | 69 | -- These parameters are from a (quadratic) linear regression in log space 70 | -- of samples of the actual FPR between 1 and 20 bits. This is with log FPR 71 | -- as the independent variable and bits as the dependent variable. 72 | f2,f1,f0 :: Double 73 | f2 = 8.079418894776325e-2 74 | f1 = 1.6462569292513933 75 | f0 = 0.5550062950289885 76 | 77 | policyForBits :: BitsPerEntry -> BloomPolicy 78 | policyForBits c | c < 0 = 79 | error "policyForBits: bits per entry must be > 0" 80 | 81 | policyForBits c = 82 | BloomPolicy { 83 | policyBits = c, 84 | policyHashes = k 85 | } 86 | where 87 | k = max 1 (round (c * log2)) 88 | 89 | policyFPR :: BloomPolicy -> FPR 90 | policyFPR BloomPolicy { 91 | policyBits = c 92 | } = 93 | exp (0 `min` negate (c*c*f2 + c*f1 + f0)) 94 | where 95 | -- These parameters are from a (quadratic) linear regression in log space 96 | -- of samples of the actual FPR between 2 and 24 bits. This is with bits as 97 | -- the independent variable and log FPR as the dependent variable. We have to 98 | -- clamp the result to keep the FPR within sanity bounds, otherwise extreme 99 | -- bits per element (<0.1 or >104) give FPRs > 1. This is because it's 100 | -- just a regression, not a principled approach. 101 | f2,f1,f0 :: Double 102 | f2 = -5.03623760876204e-3 103 | f1 = 0.5251544487138062 104 | f0 = -0.10110451821280719 105 | 106 | sizeForFPR :: FPR -> NumEntries -> BloomSize 107 | sizeForFPR = sizeForPolicy . policyForFPR 108 | 109 | sizeForBits :: BitsPerEntry -> NumEntries -> BloomSize 110 | sizeForBits = sizeForPolicy . policyForBits 111 | 112 | sizeForPolicy :: BloomPolicy -> NumEntries -> BloomSize 113 | sizeForPolicy BloomPolicy { 114 | policyBits = c, 115 | policyHashes = k 116 | } n = 117 | BloomSize { 118 | sizeBits = max 1 (ceiling (fromIntegral n * c)), 119 | sizeHashes = max 1 k 120 | } 121 | 122 | log2, recip_log2 :: Double 123 | log2 = log 2 124 | recip_log2 = recip log2 125 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | cabal.project.debug -------------------------------------------------------------------------------- /cabal.project.blockio-uring: -------------------------------------------------------------------------------- 1 | if(os(linux)) 2 | source-repository-package 3 | type: git 4 | location: https://github.com/well-typed/blockio-uring 5 | tag: c7b550063b5ce2c859db50b2ebf66d41a4f24844 -------------------------------------------------------------------------------- /cabal.project.debug: -------------------------------------------------------------------------------- 1 | -- Import release project configuration 2 | import: cabal.project.release 3 | 4 | package lsm-tree 5 | -- apply this to all components 6 | -- relevant mostly only for development & testing 7 | ghc-options: -fno-ignore-asserts 8 | 9 | -- there are no cpp-options in cabal.project files 10 | ghc-options: -optP -DNO_IGNORE_ASSERTS -DDEBUG_TRACES 11 | 12 | package blockio 13 | -- apply this to all components 14 | -- relevant mostly only for development & testing 15 | ghc-options: -fno-ignore-asserts 16 | 17 | -- there are no cpp-options in cabal.project files 18 | ghc-options: -optP -DNO_IGNORE_ASSERTS 19 | 20 | -- Enable -fcheck-prim-bounds 21 | -- https://gitlab.haskell.org/ghc/ghc/-/issues/21054 22 | if impl(ghc >=9.4.6 && <9.5 || >=9.6.3) 23 | package lsm-tree 24 | ghc-options: -fcheck-prim-bounds 25 | 26 | package blockio 27 | ghc-options: -fcheck-prim-bounds 28 | 29 | package primitive 30 | ghc-options: -fcheck-prim-bounds 31 | 32 | package vector 33 | ghc-options: -fcheck-prim-bounds 34 | 35 | package fs-api 36 | ghc-options: -fcheck-prim-bounds 37 | 38 | package fs-sim 39 | ghc-options: -fcheck-prim-bounds 40 | 41 | -------------------------------------------------------------------------------- /cabal.project.release: -------------------------------------------------------------------------------- 1 | index-state: 2 | -- Bump this if you need newer packages from Hackage 3 | -- unix-2.8.7.0 4 | , hackage.haskell.org 2025-06-11T07:49:45Z 5 | 6 | packages: 7 | . 8 | ./blockio 9 | 10 | tests: True 11 | benchmarks: True 12 | 13 | -- this prevents occurence of Hackage bloomfilter anywhere in the install plan 14 | -- that is overconstraining, as we'd only need to make sure lsm-tree 15 | -- doesn't depend on Hackage bloomfilter. 16 | -- Luckily, bloomfilter is not commonly used package, so this is good enough. 17 | constraints: bloomfilter <0 18 | 19 | -- regression-simple is used by the bloomfilter-fpr-calc test executable 20 | allow-newer: regression-simple:base 21 | 22 | -- comment me if you don't have liburing installed 23 | -- 24 | -- TODO: it is slightly unfortunate that one has to manually remove this file 25 | -- import in case they don't have liburing installed... Currently, it is not 26 | -- possible to have conditionals on package flags in a project file. Otherwise, 27 | -- we could add a conditional on (+serialblockio) to remove this import automatically. 28 | import: cabal.project.blockio-uring 29 | 30 | -- bugfix hGetBufExactly and hGetBufExactlyAt, io-classes-1.8.0.1 31 | source-repository-package 32 | type: git 33 | location: https://github.com/input-output-hk/fs-sim 34 | tag: 77e4809fe897330397ddbeaf88ef4bb47477b543 35 | subdir: 36 | fs-api 37 | fs-sim 38 | -------------------------------------------------------------------------------- /scripts/format-cabal-fmt.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | export LC_ALL=C.UTF-8 4 | 5 | # POSIX compliant method for 'pipefail': 6 | warn=$(mktemp) 7 | 8 | # Check cabal-fmt version 9 | cabal_fmt_expect_version="0.1.12" 10 | if [ "${cabal_fmt}" = "" ]; then 11 | cabal_fmt=$(which "cabal-fmt") 12 | if [ "${cabal_fmt}" = "" ]; then 13 | echo "Requires cabal-fmt ${cabal_fmt_expect_version}; no version found" 14 | exit 1 15 | fi 16 | fi 17 | cabal_fmt_actual_version="$($cabal_fmt --version | head -n 1 | cut -d' ' -f2)" 18 | if [ ! "${cabal_fmt_actual_version}" = "${cabal_fmt_expect_version}" ]; then 19 | echo "Expected cabal-fmt ${cabal_fmt_expect_version}; version ${cabal_fmt_actual_version} found" 20 | echo > "$warn" 21 | fi 22 | 23 | # Format Cabal files with cabal-fmt 24 | echo "Formatting Cabal source files with cabal-fmt version ${cabal_fmt_actual_version}" 25 | # shellcheck disable=SC2016 26 | if ! git ls-files --exclude-standard --no-deleted --deduplicate '*.cabal' | xargs -L 1 sh -c 'echo "$0" && cabal-fmt -c "$0" 2>/dev/null || (cabal-fmt -i "$0" && exit 1)'; then 27 | exit 1 28 | fi 29 | 30 | # Check whether any warning was issued; on CI, warnings are errors 31 | if [ "${CI}" = "true" ] && [ -s "$warn" ]; then 32 | rm "$warn" 33 | exit 1 34 | else 35 | rm "$warn" 36 | exit 0 37 | fi 38 | -------------------------------------------------------------------------------- /scripts/format-stylish-haskell.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | export LC_ALL=C.UTF-8 4 | 5 | # POSIX compliant method for 'pipefail': 6 | warn=$(mktemp) 7 | 8 | # Check stylish-haskell version 9 | stylish_haskell_expect_version="0.15.1.0" 10 | if [ "${stylish_haskell}" = "" ]; then 11 | stylish_haskell=$(which "stylish-haskell") 12 | if [ "${stylish_haskell}" = "" ]; then 13 | echo "Requires stylish-haskell ${stylish_haskell_expect_version}; no version found" 14 | exit 1 15 | fi 16 | fi 17 | stylish_haskell_actual_version="$($stylish_haskell --version | head -n 1 | cut -d' ' -f2)" 18 | if [ ! "${stylish_haskell_actual_version}" = "${stylish_haskell_expect_version}" ]; then 19 | echo "Expected stylish-haskell ${stylish_haskell_expect_version}; version ${stylish_haskell_actual_version} found" 20 | echo > "$warn" 21 | fi 22 | 23 | # Format Haskell files with stylish-haskell 24 | echo "Formatting Haskell source files with stylish-haskell version ${stylish_haskell_actual_version}..." 25 | # shellcheck disable=SC2016 26 | if ! git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 50 stylish-haskell -i -c .stylish-haskell.yaml; then 27 | exit 1 28 | fi 29 | 30 | # Check whether any warning was issued; on CI, warnings are errors 31 | if [ "${CI}" = "true" ] && [ -s "$warn" ]; then 32 | rm "$warn" 33 | exit 1 34 | else 35 | rm "$warn" 36 | exit 0 37 | fi 38 | -------------------------------------------------------------------------------- /scripts/generate-haddock-prologue.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env cabal 2 | {- cabal: 3 | build-depends: 4 | , base >=4.16 5 | , bytestring >=0.11 6 | , Cabal-syntax ^>=3.10 || ^>=3.12 7 | , pandoc ^>=3.6.4 8 | , text >=2.1 9 | -} 10 | {-# LANGUAGE LambdaCase #-} 11 | 12 | module Main (main) where 13 | 14 | import qualified Data.ByteString as BS 15 | import Data.Text (Text) 16 | import qualified Data.Text as T 17 | import qualified Data.Text.IO as TIO 18 | import Distribution.PackageDescription.Parsec 19 | (parseGenericPackageDescriptionMaybe) 20 | import qualified Distribution.Types.GenericPackageDescription as GenericPackageDescription 21 | import qualified Distribution.Types.PackageDescription as PackageDescription 22 | import Distribution.Utils.ShortText (fromShortText) 23 | import System.IO (hPutStrLn, stderr) 24 | import Text.Pandoc (runIOorExplode) 25 | import Text.Pandoc.Extensions (githubMarkdownExtensions) 26 | import Text.Pandoc.Options (ReaderOptions (..), WriterOptions (..), 27 | def) 28 | import Text.Pandoc.Readers (readHaddock, readMarkdown) 29 | import Text.Pandoc.Transforms (headerShift) 30 | import Text.Pandoc.Writers (writeHaddock) 31 | 32 | main :: IO () 33 | main = do 34 | putStrLn "Generating prologue.haddock from package description..." 35 | let readmeHeaderFile = "scripts/generate-readme-header.md" 36 | readmeHeaderContent <- TIO.readFile readmeHeaderFile 37 | let lsmTreeCabalFile = "lsm-tree.cabal" 38 | lsmTreeCabalContent <- BS.readFile lsmTreeCabalFile 39 | case parseGenericPackageDescriptionMaybe lsmTreeCabalContent of 40 | Nothing -> hPutStrLn stderr $ "error: Could not parse '" <> lsmTreeCabalFile <> "'" 41 | Just genericPackageDescription -> do 42 | let packageDescription = GenericPackageDescription.packageDescription genericPackageDescription 43 | let description = T.pack . fromShortText $ PackageDescription.description packageDescription 44 | header <- 45 | runIOorExplode $ do 46 | doc <- readMarkdown def{readerExtensions = githubMarkdownExtensions} readmeHeaderContent 47 | writeHaddock def doc 48 | let prologue = T.unlines [header, description] 49 | TIO.writeFile "prologue.haddock" prologue 50 | -------------------------------------------------------------------------------- /scripts/generate-haddock.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Check for cabal 4 | cabal="$(which cabal)" 5 | if [ "${cabal}" = "" ]; then 6 | echo "Requires cabal; no version found" 7 | exit 1 8 | fi 9 | 10 | # Extract the prologue from the package description 11 | # shellcheck disable=SC1007 12 | SCRIPTS_DIR="$(CDPATH= cd -- "$(dirname -- "$0")" && pwd -P)" 13 | "${SCRIPTS_DIR}/generate-haddock-prologue.hs" || exit 1 14 | 15 | # Build haddock-project documentation 16 | cabal haddock-project --prologue="prologue.haddock" 17 | 18 | # Clean up prologue 19 | if [ -f "./prologue.haddock" ]; then 20 | rm ./prologue.haddock 21 | fi 22 | -------------------------------------------------------------------------------- /scripts/generate-readme-header.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # lsm-tree 4 | 5 | [![Cardano Handbook](https://img.shields.io/badge/policy-Cardano%20Engineering%20Handbook-informational)](https://input-output-hk.github.io/cardano-engineering-handbook) 6 | [![Build](https://img.shields.io/github/actions/workflow/status/IntersectMBO/lsm-tree/ci.yml?label=Build)](https://github.com/IntersectMBO/lsm-tree/actions/workflows/ci.yml) 7 | [![Haddocks](https://img.shields.io/badge/documentation-Haddocks-purple)](https://IntersectMBO.github.io/lsm-tree/) 8 | 9 | > :warning: **This library is in active development**: there is currently no release schedule! 10 | 11 | This package is developed by Well-Typed LLP on behalf of Input Output Global, Inc. (IOG) and INTERSECT. 12 | The main contributors are Duncan Coutts, Joris Dral, Matthias Heinzel, Wolfgang Jeltsch, Wen Kokke, and Alex Washburn. 13 | 14 | ## Description 15 | -------------------------------------------------------------------------------- /scripts/generate-readme.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env cabal 2 | {- cabal: 3 | build-depends: 4 | , base >=4.16 5 | , bytestring >=0.11 6 | , Cabal-syntax ^>=3.10 || ^>=3.12 7 | , pandoc ^>=3.6.4 8 | , text >=2.1 9 | -} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | module Main (main) where 14 | 15 | import qualified Data.ByteString as BS 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.IO as TIO 19 | import Distribution.PackageDescription.Parsec 20 | (parseGenericPackageDescriptionMaybe) 21 | import qualified Distribution.Types.GenericPackageDescription as GenericPackageDescription 22 | import qualified Distribution.Types.PackageDescription as PackageDescription 23 | import Distribution.Utils.ShortText (fromShortText) 24 | import System.IO (hPutStrLn, stderr) 25 | import Text.Pandoc (runIOorExplode) 26 | import Text.Pandoc.Extensions (getDefaultExtensions) 27 | import Text.Pandoc.Options (ReaderOptions (..), WriterOptions (..), 28 | def) 29 | import Text.Pandoc.Readers (readHaddock) 30 | import Text.Pandoc.Transforms (headerShift) 31 | import Text.Pandoc.Writers (writeMarkdown) 32 | 33 | main :: IO () 34 | main = do 35 | putStrLn "Generating README.md from package description..." 36 | let readmeHeaderFile = "scripts/generate-readme-header.md" 37 | readmeHeaderContent <- TIO.readFile readmeHeaderFile 38 | let lsmTreeCabalFile = "lsm-tree.cabal" 39 | lsmTreeCabalContent <- BS.readFile lsmTreeCabalFile 40 | case parseGenericPackageDescriptionMaybe lsmTreeCabalContent of 41 | Nothing -> hPutStrLn stderr $ "error: Could not parse '" <> lsmTreeCabalFile <> "'" 42 | Just genericPackageDescription -> do 43 | let packageDescription = GenericPackageDescription.packageDescription genericPackageDescription 44 | let description = T.pack . fromShortText $ PackageDescription.description packageDescription 45 | body <- 46 | runIOorExplode $ do 47 | doc1 <- readHaddock def description 48 | let doc2 = headerShift 1 doc1 49 | writeMarkdown def{writerExtensions = getDefaultExtensions "gfm"} doc2 50 | let readme = T.unlines [readmeHeaderContent, body] 51 | TIO.writeFile "README.md" readme 52 | -------------------------------------------------------------------------------- /scripts/lint-actionlint.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | export LC_ALL=C.UTF-8 4 | 5 | # POSIX compliant method for 'pipefail': 6 | warn=$(mktemp) 7 | 8 | # Check for actionlint 9 | actionlint_expect_version="1.7.7" 10 | if [ "${actionlint}" = "" ]; then 11 | actionlint=$(which "actionlint") 12 | if [ "${actionlint}" = "" ]; then 13 | echo "Requires actionlint ${actionlint_expect_version}; no version found" 14 | exit 1 15 | fi 16 | fi 17 | actionlint_actual_version="$(${actionlint} --version | head -n 1)" 18 | if [ ! "${actionlint_actual_version}" = "${actionlint_expect_version}" ]; then 19 | echo "Expected actionlint ${actionlint_expect_version}; version ${actionlint_actual_version} found" 20 | echo > "$warn" 21 | fi 22 | 23 | # Run actionlint: 24 | echo "Lint GitHub Actions workflows with actionlint ${actionlint_actual_version}..." 25 | # shellcheck disable=SC2086 26 | git ls-files --exclude-standard --no-deleted --deduplicate '.github/workflows/*.yml' | xargs -L50 ${actionlint} 27 | 28 | # Check whether any warning was issued; on CI, warnings are errors 29 | if [ "${CI}" = "true" ] && [ -s "$warn" ]; then 30 | rm "$warn" 31 | exit 1 32 | else 33 | rm "$warn" 34 | exit 0 35 | fi 36 | -------------------------------------------------------------------------------- /scripts/lint-cabal.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Check for cabal 4 | cabal="$(which cabal)" 5 | if [ "${cabal}" = "" ]; then 6 | echo "Requires cabal; no version found" 7 | exit 1 8 | fi 9 | cabal_actual_version="$(${cabal} --numeric-version | head -n 1)" 10 | 11 | # Lint Cabal files with cabal 12 | echo "Linting Cabal source files with cabal version ${cabal_actual_version}..." 13 | # shellcheck disable=SC2016 14 | if ! git ls-files --exclude-standard --no-deleted --deduplicate '*.cabal' | xargs -L 1 sh -c 'echo "$0" && cd "$(dirname "$0")" && cabal check'; then 15 | exit 1 16 | fi 17 | -------------------------------------------------------------------------------- /scripts/lint-hlint.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | export LC_ALL=C.UTF-8 4 | 5 | # POSIX compliant method for 'pipefail': 6 | warn=$(mktemp) 7 | 8 | # Check for hlint 9 | hlint_expect_version="3.10" 10 | if [ "${hlint}" = "" ]; then 11 | hlint=$(which "hlint") 12 | if [ "${hlint}" = "" ]; then 13 | echo "Requires hlint ${hlint_expect_version}; no version found" 14 | exit 1 15 | fi 16 | fi 17 | hlint_actual_version="$(${hlint} --version | head -n 1 | cut -d' ' -f 2 | sed -E 's/v(.*),/\1/')" 18 | if [ ! "${hlint_actual_version}" = "${hlint_expect_version}" ]; then 19 | echo "Expected hlint ${hlint_expect_version}; version ${hlint_actual_version} found" 20 | echo > "$warn" 21 | fi 22 | 23 | # Lint Haskell files with HLint 24 | echo "Linting Haskell files with HLint version ${hlint_actual_version}..." 25 | # shellcheck disable=SC2086 26 | git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L50 ${hlint} 27 | 28 | # Check whether any warning was issued; on CI, warnings are errors 29 | if [ "${CI}" = "true" ] && [ -s "$warn" ]; then 30 | rm "$warn" 31 | exit 1 32 | else 33 | rm "$warn" 34 | exit 0 35 | fi 36 | -------------------------------------------------------------------------------- /scripts/lint-io-specialisations.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env sh 2 | 3 | absence_allowed_file=scripts/lint-io-specialisations/absence-allowed 4 | absence_finder=scripts/lint-io-specialisations/find-absent.sh 5 | 6 | set -e 7 | 8 | IFS=' 9 | ' 10 | 11 | export LC_COLLATE=C LC_TYPE=C 12 | 13 | printf 'Linting the main library for missing `IO` specialisations\n' 14 | 15 | if ! [ -f "$absence_allowed_file" ] 16 | then 17 | printf 'There is no regular file `%s`.\n' "$absence_allowed_file" 18 | exit 2 19 | fi >&2 20 | if ! sort -C "$absence_allowed_file" 21 | then 22 | printf 'The entries in `%s` are not sorted.\n' "$absence_allowed_file" 23 | exit 2 24 | fi >&2 25 | 26 | hs_files=$( 27 | git ls-files \ 28 | --exclude-standard --no-deleted --deduplicate \ 29 | 'src/*.hs' 'src/**/*.hs' 30 | ) 31 | absent=$( 32 | "$absence_finder" $hs_files 33 | ) 34 | missing=$( 35 | printf '%s\n' "$absent" | sort | comm -23 - "$absence_allowed_file" 36 | ) 37 | if [ -n "$missing" ] 38 | then 39 | printf '`IO` specialisations for the following operations are ' 40 | printf 'missing:\n' 41 | printf '%s\n' "$missing" | sed -e 's/.*/ * `&`/' 42 | exit 1 43 | fi 44 | printf 'All required `IO` specialisations are present.\n' 45 | -------------------------------------------------------------------------------- /scripts/lint-io-specialisations/absence-allowed: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/scripts/lint-io-specialisations/absence-allowed -------------------------------------------------------------------------------- /scripts/lint-io-specialisations/find-absent.tests/Animals.Sheep.fake-hs: -------------------------------------------------------------------------------- 1 | {- 2 | Pronunciation note: 3 | 4 | The identifiers in this module are somehow considered to be German. They 5 | used to contain the German ä and ö, but since the script only treats English 6 | letters as letters eligible to be part of identifiers, ä and ö were replaced 7 | by their standard alternatives ae and oe. This all should give some 8 | indication regarding how to pronounce the identifiers. The author of this 9 | module thought this note to be necessary, not least to justify the choice of 10 | module name. 😉 11 | -} 12 | module Animals.Sheep where 13 | 14 | {-# SPECIALISE 15 | boerk 16 | :: 17 | Show a => a -> m () 18 | #-} 19 | boerk :: 20 | (Monad m, Show a) -- ^ The general way of constraining 21 | => a -- ^ A value 22 | -> m a -- ^ An effectful computation 23 | {-# SPECIALISE 24 | schnoerk 25 | :: 26 | Show a => m a 27 | #-} 28 | schnoerk 29 | :: (Monad, m, Show a) -- ^ The general way of constraining 30 | => m a -- ^ An effectful computation 31 | 32 | {-# SPECIALISE 33 | bloek 34 | :: 35 | IO a 36 | #-} 37 | bloek :: 38 | IO a 39 | 40 | lamb :: m a -> m a 41 | lamb = id 42 | 43 | {-# INLINE baeh 44 | #-} 45 | baeh :: Monad m => m a -> m a 46 | baeh = id 47 | 48 | {-# INLINE 49 | boo #-} -- maybe too large for inlining 50 | boo :: MonadSheep m => Scissors -> m Wool 51 | boo scissors = withScissors scissors $ \ capability -> cut capability (fur Boo) 52 | 53 | maeh :: a -> (b -> IO (a, b)) 54 | maeh = curry return 55 | 56 | moeh :: Monad m => a -> (b -> m (a, b)) 57 | moeh = curry return 58 | -------------------------------------------------------------------------------- /scripts/lint-io-specialisations/find-absent.tests/Misc.fake-hs: -------------------------------------------------------------------------------- 1 | module Misc 2 | ( 3 | conv, 4 | first 5 | ) 6 | where 7 | 8 | yield :: Monad m => a -> m a 9 | yield = return 10 | 11 | {-# SPECIALISE first :: [a] -> IO (WeakPtr a) #-} 12 | -- | Get a weak pointer to the first element of a list. 13 | first :: MonadWeak m => [a] -> m (WeakPtr a) 14 | first = _ 15 | 16 | {-# SPECIALISE last :: [a] -> IO (WeakPtr a) #-} 17 | last :: [a] -> IO (WeakPtr a) 18 | last _ = _ 19 | 20 | {-# SPECIALISE conv :: MonadIO m => [a] -> m a #-} 21 | conv :: (Functor f, Monad m) => f a -> m a 22 | conv = id 23 | 24 | {-# SPECIALISE mis :: MonadIO m => [a] -> IO a #-} 25 | match :: (Functor f, Monad m) => f a -> m a 26 | match = id 27 | -------------------------------------------------------------------------------- /scripts/lint-io-specialisations/find-absent.tests/output: -------------------------------------------------------------------------------- 1 | Animals.Sheep.boerk 2 | Animals.Sheep.schnoerk 3 | Animals.Sheep.moeh 4 | Misc.yield 5 | Misc.conv 6 | Misc.match 7 | -------------------------------------------------------------------------------- /scripts/lint-shellcheck.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | export LC_ALL=C.UTF-8 4 | 5 | # POSIX compliant method for 'pipefail': 6 | warn=$(mktemp) 7 | 8 | # Check for shellcheck 9 | shellcheck_expect_version="0.10.0" 10 | if [ "${shellcheck}" = "" ]; then 11 | shellcheck=$(which "shellcheck") 12 | if [ "${shellcheck}" = "" ]; then 13 | echo "Requires shellcheck ${shellcheck_expect_version}; no version found" 14 | exit 1 15 | fi 16 | fi 17 | shellcheck_actual_version="$(${shellcheck} --version | head -n2 | tail -n1 | cut -d' ' -f2)" 18 | if [ ! "${shellcheck_actual_version}" = "${shellcheck_expect_version}" ]; then 19 | echo "Expected shellcheck ${shellcheck_expect_version}; version ${shellcheck_actual_version} found" 20 | echo > "$warn" 21 | fi 22 | 23 | # Run shellcheck: 24 | echo "Lint GitHub Actions workflows with shellcheck ${shellcheck_actual_version}..." 25 | # shellcheck disable=SC2086 26 | git ls-files --exclude-standard --no-deleted --deduplicate '*.sh' | xargs -L50 ${shellcheck} 27 | 28 | # Check whether any warning was issued; on CI, warnings are errors 29 | if [ "${CI}" = "true" ] && [ -s "$warn" ]; then 30 | rm "$warn" 31 | exit 1 32 | else 33 | rm "$warn" 34 | exit 0 35 | fi 36 | -------------------------------------------------------------------------------- /scripts/pre-commit.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # To install as a Git pre-commit hook, run: 4 | # 5 | # > ln scripts/pre-commit.sh .git/hooks/pre-commit.sh 6 | # 7 | 8 | # POSIX compliant method for 'pipefail': 9 | warn=$(mktemp) 10 | 11 | # Check for unstaged changes in Haskell files 12 | unstaged_haskell_files="$(git ls-files --exclude-standard --no-deleted --deduplicate --modified '*.hs' || echo > "$warn")" 13 | if [ ! "${unstaged_haskell_files}" = "" ]; then 14 | echo "Found unstaged Haskell files" 15 | echo "${unstaged_haskell_files}" 16 | fi 17 | 18 | # Check for unstaged changes in Cabal files 19 | unstaged_cabal_files="$(git ls-files --exclude-standard --no-deleted --deduplicate --modified '*.cabal' || echo > "$warn")" 20 | if [ ! "${unstaged_cabal_files}" = "" ]; then 21 | echo "Found unstaged Cabal files" 22 | echo "${unstaged_cabal_files}" 23 | fi 24 | 25 | # Lint GitHub Actions workflows with actionlint 26 | ./scripts/lint-actionlint.sh || echo > "$warn" 27 | echo 28 | 29 | # Format Cabal files with cabal-fmt 30 | ./scripts/format-cabal-fmt.sh || echo > "$warn" 31 | echo 32 | 33 | # Format Haskell files with stylish-haskell 34 | ./scripts/format-stylish-haskell.sh || echo > "$warn" 35 | echo 36 | 37 | # Lint GitHub Actions workflows with actionlint 38 | ./scripts/lint-actionlint.sh || echo > "$warn" 39 | echo 40 | 41 | # Lint Cabal files with cabal 42 | ./scripts/lint-cabal.sh || echo > "$warn" 43 | echo 44 | 45 | # Lint Haskell files files with HLint 46 | ./scripts/lint-hlint.sh || echo > "$warn" 47 | echo 48 | 49 | # Lint shell scripts files with ShellCheck 50 | ./scripts/lint-shellcheck.sh || echo > "$warn" 51 | echo 52 | 53 | # Generate README.md from package description 54 | ./scripts/generate-readme.hs || echo > "$warn" 55 | echo 56 | 57 | # Check whether any warning was issued; on CI, warnings are errors 58 | if [ "${CI}" = "true" ] && [ -s "$warn" ]; then 59 | rm "$warn" 60 | exit 1 61 | else 62 | rm "$warn" 63 | exit 0 64 | fi 65 | -------------------------------------------------------------------------------- /scripts/test-cabal-docspec.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | export LC_ALL=C.UTF-8 4 | 5 | # POSIX compliant method for 'pipefail': 6 | warn=$(mktemp) 7 | 8 | # Check cabal-docspec version 9 | cabal_docspec_expect_version="0.0.0.20240703" 10 | if [ "${cabal_docspec}" = "" ]; then 11 | cabal_docspec=$(which "cabal-docspec") 12 | if [ "${cabal_docspec}" = "" ]; then 13 | echo "Requires cabal-docspec ${cabal_docspec_expect_version}; no version found" 14 | exit 1 15 | fi 16 | fi 17 | cabal_docspec_actual_version="$(${cabal_docspec} --version | head -n 1)" 18 | if [ ! "${cabal_docspec_actual_version}" = "${cabal_docspec_expect_version}" ]; then 19 | echo "Expected cabal-docspec ${cabal_docspec_expect_version}; version ${cabal_docspec_actual_version} found" 20 | echo > "$warn" 21 | fi 22 | 23 | # Test Haskell files with cabal-docspec 24 | echo "Testing Haskell files with cabal-docspec version ${cabal_docspec_actual_version}..." 25 | # shellcheck disable=SC2016 26 | if [ "${SKIP_CABAL_BUILD}" = "" ]; then 27 | if ! cabal build all; then 28 | exit 1 29 | fi 30 | fi 31 | ${cabal_docspec} \ 32 | -Wno-cpphs \ 33 | -Wno-missing-module-file \ 34 | -Wno-skipped-property \ 35 | -XDerivingStrategies \ 36 | -XDerivingVia \ 37 | -XGeneralisedNewtypeDeriving \ 38 | -XOverloadedStrings \ 39 | -XRankNTypes \ 40 | -XTypeApplications \ 41 | -XTypeFamilies \ 42 | -XNumericUnderscores \ 43 | -XInstanceSigs \ 44 | --extra-package blockio \ 45 | --extra-package blockio:sim \ 46 | --extra-package directory \ 47 | --extra-package lsm-tree:prototypes \ 48 | --extra-package process \ 49 | || exit 1 50 | 51 | # Check whether any warning was issued; on CI, warnings are errors 52 | if [ "${CI}" = "true" ] && [ -s "$warn" ]; then 53 | rm "$warn" 54 | exit 1 55 | else 56 | rm "$warn" 57 | exit 0 58 | fi 59 | -------------------------------------------------------------------------------- /src-extras/Database/LSMTree/Extras.hs: -------------------------------------------------------------------------------- 1 | module Database.LSMTree.Extras ( 2 | showPowersOf10 3 | , showPowersOf 4 | , groupsOfN 5 | , vgroupsOfN 6 | ) where 7 | 8 | import Data.List (find) 9 | import qualified Data.List as List 10 | import Data.List.NonEmpty (NonEmpty) 11 | import qualified Data.List.NonEmpty as NE 12 | import Data.Maybe (fromJust) 13 | import qualified Data.Vector as V 14 | import Text.Printf 15 | 16 | showPowersOf10 :: Int -> String 17 | showPowersOf10 = showPowersOf 10 18 | 19 | showPowersOf :: Int -> Int -> String 20 | showPowersOf factor n 21 | | factor <= 1 = error "showPowersOf: factor must be larger than 1" 22 | | n < 0 = "n < 0" 23 | | n == 0 = "n == 0" 24 | | otherwise = printf "%d <= n < %d" lb ub 25 | where 26 | ub = fromJust (find (n <) (iterate (* factor) factor)) 27 | lb = ub `div` factor 28 | 29 | -- | Make groups of @n@ elements from a list @xs@ 30 | groupsOfN :: Int -> [a] -> [NonEmpty a] 31 | groupsOfN n 32 | | n <= 0 = error "groupsOfN: n <= 0" 33 | | otherwise = List.unfoldr f 34 | where f xs = let (ys, zs) = List.splitAt n xs 35 | in (,zs) <$> NE.nonEmpty ys 36 | 37 | -- | Make groups of @n@ elements from a vector @xs@ 38 | vgroupsOfN :: Int -> V.Vector a -> V.Vector (V.Vector a) 39 | vgroupsOfN n 40 | | n <= 0 = error "groupsOfN: n <= 0" 41 | | otherwise = V.unfoldr f 42 | where 43 | f xs 44 | | V.null xs 45 | = Nothing 46 | | otherwise 47 | = Just $ V.splitAt n xs 48 | -------------------------------------------------------------------------------- /src-extras/Database/LSMTree/Extras/Index.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Provides additional support for working with fence pointer indexes and their 3 | accumulators. 4 | -} 5 | module Database.LSMTree.Extras.Index 6 | ( 7 | Append (AppendSinglePage, AppendMultiPage), 8 | appendToCompact, 9 | appendToOrdinary, 10 | append 11 | ) 12 | where 13 | 14 | import Control.DeepSeq (NFData (rnf)) 15 | import Control.Monad.ST.Strict (ST) 16 | import Data.Foldable (toList) 17 | import Data.Word (Word32) 18 | import Database.LSMTree.Internal.Chunk (Chunk) 19 | import Database.LSMTree.Internal.Index (IndexAcc) 20 | import qualified Database.LSMTree.Internal.Index as Index (appendMulti, 21 | appendSingle) 22 | import Database.LSMTree.Internal.Index.CompactAcc (IndexCompactAcc) 23 | import qualified Database.LSMTree.Internal.Index.CompactAcc as IndexCompact 24 | (appendMulti, appendSingle) 25 | import Database.LSMTree.Internal.Index.OrdinaryAcc (IndexOrdinaryAcc) 26 | import qualified Database.LSMTree.Internal.Index.OrdinaryAcc as IndexOrdinary 27 | (appendMulti, appendSingle) 28 | import Database.LSMTree.Internal.Serialise (SerialisedKey) 29 | 30 | -- | Instruction for appending pages, to be used in conjunction with indexes. 31 | data Append 32 | = {-| 33 | Append a single page that fully comprises one or more key–value pairs. 34 | -} 35 | AppendSinglePage 36 | SerialisedKey -- ^ Minimum key 37 | SerialisedKey -- ^ Maximum key 38 | | {-| 39 | Append multiple pages that together comprise a single key–value pair. 40 | -} 41 | AppendMultiPage 42 | SerialisedKey -- ^ Sole key 43 | Word32 -- ^ Number of overflow pages 44 | 45 | instance NFData Append where 46 | 47 | rnf (AppendSinglePage minKey maxKey) 48 | = rnf minKey `seq` rnf maxKey 49 | rnf (AppendMultiPage key overflowPageCount) 50 | = rnf key `seq` rnf overflowPageCount 51 | 52 | {-| 53 | Adds information about appended pages to an index and outputs newly 54 | available chunks, using primitives specific to the type of the index. 55 | 56 | See the documentation of the 'IndexAcc' type for constraints to adhere to. 57 | -} 58 | appendWith :: ((SerialisedKey, SerialisedKey) -> j s -> ST s (Maybe Chunk)) 59 | -> ((SerialisedKey, Word32) -> j s -> ST s [Chunk]) 60 | -> Append 61 | -> j s 62 | -> ST s [Chunk] 63 | appendWith appendSingle appendMulti instruction indexAcc = case instruction of 64 | AppendSinglePage minKey maxKey 65 | -> toList <$> appendSingle (minKey, maxKey) indexAcc 66 | AppendMultiPage key overflowPageCount 67 | -> appendMulti (key, overflowPageCount) indexAcc 68 | {-# INLINABLE appendWith #-} 69 | 70 | {-| 71 | Adds information about appended pages to a compact index and outputs newly 72 | available chunks. 73 | 74 | See the documentation of the 'IndexAcc' type for constraints to adhere to. 75 | -} 76 | appendToCompact :: Append -> IndexCompactAcc s -> ST s [Chunk] 77 | appendToCompact = appendWith IndexCompact.appendSingle 78 | IndexCompact.appendMulti 79 | {-# INLINE appendToCompact #-} 80 | 81 | {-| 82 | Adds information about appended pages to an ordinary index and outputs newly 83 | available chunks. 84 | 85 | See the documentation of the 'IndexAcc' type for constraints to adhere to. 86 | -} 87 | appendToOrdinary :: Append -> IndexOrdinaryAcc s -> ST s [Chunk] 88 | appendToOrdinary = appendWith IndexOrdinary.appendSingle 89 | IndexOrdinary.appendMulti 90 | {-# INLINE appendToOrdinary #-} 91 | 92 | {-| 93 | Adds information about appended pages to an index and outputs newly 94 | available chunks. 95 | 96 | See the documentation of the 'IndexAcc' type for constraints to adhere to. 97 | -} 98 | append :: Append -> IndexAcc s -> ST s [Chunk] 99 | append = appendWith Index.appendSingle 100 | Index.appendMulti 101 | {-# INLINE append #-} 102 | -------------------------------------------------------------------------------- /src-mcg/MCG.hs: -------------------------------------------------------------------------------- 1 | module MCG ( 2 | MCG, 3 | make, 4 | period, 5 | next, 6 | reject, 7 | ) where 8 | 9 | import Data.Bits (countLeadingZeros, unsafeShiftR) 10 | import Data.List (nub) 11 | import Data.Numbers.Primes (isPrime, primeFactors) 12 | import Data.Word (Word64) 13 | 14 | -- $setup 15 | -- >>> import Data.List (unfoldr, nub) 16 | 17 | -- | https://en.wikipedia.org/wiki/Lehmer_random_number_generator 18 | data MCG = MCG { m :: !Word64, a :: !Word64, x :: !Word64 } 19 | deriving stock Show 20 | 21 | -- invariants: m is a prime 22 | -- a is a primitive element of Z_m 23 | -- x is in [1..m-1] 24 | 25 | -- | Create a MCG 26 | -- 27 | -- >>> make 20 04 28 | -- MCG {m = 23, a = 11, x = 5} 29 | -- 30 | -- >>> make 101_000_000 20240429 31 | -- MCG {m = 101000023, a = 197265, x = 20240430} 32 | -- 33 | make :: 34 | Word64 -- ^ a lower bound for the period 35 | -> Word64 -- ^ initial seed. 36 | -> MCG 37 | make (max 4 -> period_) seed = MCG m a (mod (seed + 1) m) 38 | where 39 | -- start prime search from an odd number larger than asked period. 40 | m = findM (if odd period_ then period_ + 2 else period_ + 1) 41 | m' = m - 1 42 | qs = nub $ primeFactors m' 43 | 44 | a = findA (guessA m) 45 | 46 | findM p = if isPrime p then p else findM (p + 2) 47 | 48 | -- we find `a` using "brute-force" approach. 49 | -- luckily, many elements a prime factors, so we don't need to try too hard. 50 | -- and we only need to check prime factors of m - 1. 51 | findA x 52 | | all (\q -> mod (x ^ div m' q) m /= 1) qs 53 | = x 54 | 55 | | otherwise 56 | = findA (x + 1) 57 | 58 | -- | Period of the MCG. 59 | -- 60 | -- Period is usually a bit larger than asked for, we look for the next prime: 61 | -- 62 | -- >>> let g = make 9 04 63 | -- >>> period g 64 | -- 10 65 | -- 66 | -- >>> take 22 (unfoldr (Just . next) g) 67 | -- [4,7,3,1,0,5,2,6,8,9,4,7,3,1,0,5,2,6,8,9,4,7] 68 | -- 69 | period :: MCG -> Word64 70 | period (MCG m _ _) = m - 1 71 | 72 | -- | Generate next number. 73 | next :: MCG -> (Word64, MCG) 74 | next (MCG m a x) = (x - 1, MCG m a (mod (x * a) m)) 75 | 76 | -- | Generate next numbers until one less than given bound is generated. 77 | -- 78 | -- Replacing 'next' with @'reject' n@ effectively cuts the period to @n@: 79 | -- 80 | -- >>> let g = make 9 04 81 | -- >>> period g 82 | -- 10 83 | -- 84 | -- >>> take 22 (unfoldr (Just . reject 9) g) 85 | -- [4,7,3,1,0,5,2,6,8,4,7,3,1,0,5,2,6,8,4,7,3,1] 86 | -- 87 | -- if @n@ is close enough to actual period of 'MCG', the rejection ratio 88 | -- is very small. 89 | -- 90 | reject :: Word64 -> MCG -> (Word64, MCG) 91 | reject ub g = case next g of 92 | (x, g') -> if x < ub then (x, g') else reject ub g' 93 | 94 | ------------------------------------------------------------------------------- 95 | -- guessing some initial a 96 | ------------------------------------------------------------------------------- 97 | 98 | -- | calculate x -> log2 (x + 1) i.e. approximate how large the number is in bits. 99 | word64Log2m1 :: Word64 -> Int 100 | word64Log2m1 x = 64 - countLeadingZeros x 101 | 102 | -- | we guess a such that a*a is larger than m: 103 | -- we shift a number a little. 104 | guessA :: Word64 -> Word64 105 | guessA x = unsafeShiftR x (div (word64Log2m1 x) 3) 106 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/Assertions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | 5 | module Database.LSMTree.Internal.Assertions ( 6 | assert, 7 | isValidSlice, 8 | sameByteArray, 9 | fromIntegralChecked, 10 | ) where 11 | 12 | #if MIN_VERSION_base(4,17,0) 13 | import GHC.Exts (isTrue#, sameByteArray#) 14 | #else 15 | import GHC.Exts (ByteArray#, MutableByteArray#, isTrue#, 16 | sameMutableByteArray#, unsafeCoerce#) 17 | #endif 18 | 19 | import Control.Exception (assert) 20 | import Data.Primitive.ByteArray (ByteArray (..), sizeofByteArray) 21 | import GHC.Stack (HasCallStack) 22 | import Text.Printf 23 | 24 | isValidSlice :: Int -> Int -> ByteArray -> Bool 25 | isValidSlice off len ba = 26 | off >= 0 && 27 | len >= 0 && 28 | (off + len) >= 0 && -- sum doesn't overflow 29 | (off + len) <= sizeofByteArray ba 30 | 31 | sameByteArray :: ByteArray -> ByteArray -> Bool 32 | sameByteArray (ByteArray ba1#) (ByteArray ba2#) = 33 | #if MIN_VERSION_base(4,17,0) 34 | isTrue# (sameByteArray# ba1# ba2#) 35 | #else 36 | isTrue# (sameMutableByteArray# (unsafeCoerceByteArray# ba1#) 37 | (unsafeCoerceByteArray# ba2#)) 38 | where 39 | unsafeCoerceByteArray# :: ByteArray# -> MutableByteArray# s 40 | unsafeCoerceByteArray# = unsafeCoerce# 41 | #endif 42 | 43 | {-# INLINABLE fromIntegralChecked #-} 44 | -- | Like 'fromIntegral', but throws an error when @(x :: a) /= fromIntegral 45 | -- (fromIntegral x :: b)@. 46 | fromIntegralChecked :: (HasCallStack, Integral a, Integral b, Show a) => a -> b 47 | fromIntegralChecked x 48 | | x'' == x 49 | = x' 50 | | otherwise 51 | = error $ printf "fromIntegralChecked: conversion failed, %s /= %s" (show x) (show x'') 52 | where 53 | x' = fromIntegral x 54 | x'' = fromIntegral x' 55 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/Map/Range.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# OPTIONS_HADDOCK not-home #-} 5 | module Database.LSMTree.Internal.Map.Range ( 6 | Bound (.., BoundExclusive, BoundInclusive) 7 | , Clusive (..) 8 | , rangeLookup 9 | ) where 10 | 11 | import Data.Map (Map) 12 | import qualified Data.Map as Map 13 | import Data.Map.Internal (Map (..)) 14 | 15 | data Clusive = Exclusive | Inclusive deriving stock Show 16 | data Bound k = NoBound | Bound !k !Clusive deriving stock Show 17 | 18 | {-# COMPLETE BoundExclusive, BoundInclusive #-} 19 | 20 | pattern BoundExclusive :: k -> Bound k 21 | pattern BoundExclusive k = Bound k Exclusive 22 | 23 | pattern BoundInclusive :: k -> Bound k 24 | pattern BoundInclusive k = Bound k Inclusive 25 | 26 | -- | Find all the keys in the given range and return the corresponding 27 | -- (key, value) pairs (in ascending order). 28 | -- 29 | rangeLookup :: 30 | forall k v. Ord k 31 | => Bound k -- ^ lower bound 32 | -> Bound k -- ^ upper bound 33 | -> Map k v 34 | -> [(k, v)] 35 | rangeLookup NoBound NoBound m = Map.toList m 36 | rangeLookup (Bound lb lc) NoBound m = rangeLookupLo lb lc m [] 37 | rangeLookup NoBound (Bound ub uc) m = rangeLookupHi ub uc m [] 38 | rangeLookup (Bound lb lc) (Bound ub uc) m = rangeLookupBoth lb lc ub uc m [] 39 | 40 | toDList :: Map k v -> [(k, v)] -> [(k, v)] 41 | toDList Tip = id 42 | toDList (Bin _ k v l r) = toDList l . ((k,v):) . toDList r 43 | 44 | rangeLookupLo :: Ord k => k -> Clusive -> Map k v -> [(k, v)] -> [(k, v)] 45 | rangeLookupLo !_ !_ Tip = id 46 | rangeLookupLo lb lc (Bin _ k v l r) 47 | -- ... | --- k ----- 48 | | evalLowerBound lb lc k 49 | = rangeLookupLo lb lc l . ((k, v) :) . toDList r 50 | 51 | -- ... k ... |-------- 52 | | otherwise 53 | = rangeLookupLo lb lc r 54 | 55 | rangeLookupHi :: Ord k => k -> Clusive -> Map k v -> [(k, v)] -> [(k, v)] 56 | rangeLookupHi !_ !_ Tip = id 57 | rangeLookupHi ub uc (Bin _ k v l r) 58 | -- --- k --- | ... 59 | | evalUpperBound ub uc k 60 | = toDList l . ((k, v) :) . rangeLookupHi ub uc r 61 | 62 | -- --------- | ... k ... 63 | | otherwise 64 | = rangeLookupHi ub uc l 65 | 66 | rangeLookupBoth :: Ord k => k -> Clusive -> k -> Clusive -> Map k v -> [(k, v)] -> [(k, v)] 67 | rangeLookupBoth !_ !_ !_ !_ Tip = id 68 | rangeLookupBoth lb lc ub uc (Bin _ k v l r) 69 | -- ... |--- k ---| ... 70 | | evalLowerBound lb lc k 71 | , evalUpperBound ub uc k 72 | = rangeLookupLo lb lc l . ((k,v):) . rangeLookupHi ub uc r 73 | 74 | -- ... |-------| ... k ... 75 | | evalLowerBound lb lc k 76 | = rangeLookupBoth lb lc ub uc l 77 | 78 | -- ... k ... |-------| ... 79 | | evalUpperBound ub uc k 80 | = rangeLookupBoth lb lc ub uc r 81 | 82 | | otherwise 83 | = id 84 | 85 | evalLowerBound :: Ord k => k -> Clusive -> k -> Bool 86 | evalLowerBound b Exclusive k = b < k 87 | evalLowerBound b Inclusive k = b <= k 88 | 89 | evalUpperBound :: Ord k => k -> Clusive -> k -> Bool 90 | evalUpperBound b Exclusive k = k < b 91 | evalUpperBound b Inclusive k = k <= b 92 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/Page.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Utilities related to pages. 4 | -- 5 | module Database.LSMTree.Internal.Page ( 6 | PageNo (..) 7 | , nextPageNo 8 | , NumPages (..) 9 | , getNumPages 10 | , PageSpan (..) 11 | , singlePage 12 | , multiPage 13 | , pageSpanSize 14 | ) where 15 | 16 | import Control.DeepSeq (NFData (..)) 17 | 18 | -- | A 0-based number identifying a disk page. 19 | newtype PageNo = PageNo { unPageNo :: Int } 20 | deriving stock (Show, Eq, Ord) 21 | deriving newtype NFData 22 | 23 | -- | Increment the page number. 24 | -- 25 | -- Note: This does not ensure that the incremented page number exists within a given page span. 26 | {-# INLINE nextPageNo #-} 27 | nextPageNo :: PageNo -> PageNo 28 | nextPageNo = PageNo . succ . unPageNo 29 | 30 | -- | The number of pages contained by an index or other paging data-structure. 31 | -- 32 | -- Note: This is a 0-based number; take care to ensure arithmetic underflow 33 | -- does not occur during subtraction operations! 34 | newtype NumPages = NumPages Word 35 | deriving stock (Eq, Ord, Show) 36 | deriving newtype (NFData) 37 | 38 | -- | A type-safe "unwrapper" for 'NumPages'. Use this accessor whenever you want 39 | -- to convert 'NumPages' to a more versatile number type. 40 | {-# INLINE getNumPages #-} 41 | getNumPages :: Integral i => NumPages -> i 42 | getNumPages (NumPages w) = fromIntegral w 43 | 44 | -- | A span of pages, representing an inclusive interval of page numbers. 45 | -- 46 | -- Typlically used to denote the contiguous page span for a database entry. 47 | data PageSpan = PageSpan { 48 | pageSpanStart :: {-# UNPACK #-} !PageNo 49 | , pageSpanEnd :: {-# UNPACK #-} !PageNo 50 | } 51 | deriving stock (Show, Eq) 52 | 53 | instance NFData PageSpan where 54 | rnf (PageSpan x y) = rnf x `seq` rnf y 55 | 56 | {-# INLINE singlePage #-} 57 | singlePage :: PageNo -> PageSpan 58 | singlePage i = PageSpan i i 59 | 60 | {-# INLINE multiPage #-} 61 | multiPage :: PageNo -> PageNo -> PageSpan 62 | multiPage i j = PageSpan i j 63 | 64 | {-# INLINE pageSpanSize #-} 65 | pageSpanSize :: PageSpan -> NumPages 66 | pageSpanSize pspan = NumPages . toEnum $ 67 | unPageNo (pageSpanEnd pspan) - unPageNo (pageSpanStart pspan) + 1 68 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/Range.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | 4 | module Database.LSMTree.Internal.Range ( 5 | Range (..) 6 | ) where 7 | 8 | import Control.DeepSeq (NFData (..)) 9 | 10 | {------------------------------------------------------------------------------- 11 | Small auxiliary types 12 | -------------------------------------------------------------------------------} 13 | 14 | -- | A range of keys. 15 | data Range k = 16 | {- | 17 | @'FromToExcluding' i j@ is the range from @i@ (inclusive) to @j@ (exclusive). 18 | -} 19 | FromToExcluding k k 20 | {- | 21 | @'FromToIncluding' i j@ is the range from @i@ (inclusive) to @j@ (inclusive). 22 | -} 23 | | FromToIncluding k k 24 | deriving stock (Show, Eq, Functor) 25 | 26 | instance NFData k => NFData (Range k) where 27 | rnf (FromToExcluding k1 k2) = rnf k1 `seq` rnf k2 28 | rnf (FromToIncluding k1 k2) = rnf k1 `seq` rnf k2 29 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/RunNumber.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | module Database.LSMTree.Internal.RunNumber ( 4 | RunNumber (..), 5 | TableId (..), 6 | CursorId (..), 7 | ) where 8 | 9 | import Control.DeepSeq (NFData) 10 | 11 | newtype RunNumber = RunNumber Int 12 | deriving stock (Eq, Ord, Show) 13 | deriving newtype (NFData) 14 | 15 | newtype TableId = TableId Int 16 | deriving stock (Eq, Ord, Show) 17 | deriving newtype (NFData) 18 | 19 | newtype CursorId = CursorId Int 20 | deriving stock (Eq, Ord, Show) 21 | deriving newtype (NFData) 22 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/StrictArray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE UnboxedTuples #-} 5 | {-# OPTIONS_HADDOCK not-home #-} 6 | 7 | module Database.LSMTree.Internal.StrictArray ( 8 | StrictArray, 9 | vectorToStrictArray, 10 | indexStrictArray, 11 | sizeofStrictArray, 12 | ) where 13 | 14 | import Data.Elevator (Strict (Strict)) 15 | import qualified Data.Vector as V 16 | import GHC.Exts ((+#)) 17 | import qualified GHC.Exts as GHC 18 | import GHC.ST (ST (ST), runST) 19 | import Unsafe.Coerce (unsafeCoerce) 20 | 21 | data StrictArray a = StrictArray !(GHC.Array# (Strict a)) 22 | 23 | vectorToStrictArray :: forall a. V.Vector a -> StrictArray a 24 | vectorToStrictArray v = 25 | runST $ ST $ \s0 -> 26 | case GHC.newArray# (case V.length v of GHC.I# l# -> l#) 27 | (Strict (unsafeCoerce ())) s0 of 28 | -- initialise with (), will be overwritten. 29 | (# s1, a# #) -> 30 | case go a# 0# s1 of 31 | s2 -> case GHC.unsafeFreezeArray# a# s2 of 32 | (# s3, a'# #) -> (# s3, StrictArray a'# #) 33 | where 34 | go :: forall s. 35 | GHC.MutableArray# s (Strict a) 36 | -> GHC.Int# 37 | -> GHC.State# s 38 | -> GHC.State# s 39 | go a# i# s 40 | | GHC.I# i# < V.length v 41 | = let x = V.unsafeIndex v (GHC.I# i#) 42 | -- We have to use seq# here to force the array element to WHNF 43 | -- before putting it into the strict array. This should not be 44 | -- necessary. https://github.com/sgraf812/data-elevator/issues/4 45 | in case GHC.seq# x s of 46 | (# s', x' #) -> 47 | case GHC.writeArray# a# i# (Strict x') s' of 48 | s'' -> go a# (i# +# 1#) s'' 49 | | otherwise = s 50 | 51 | {-# INLINE indexStrictArray #-} 52 | indexStrictArray :: StrictArray a -> Int -> a 53 | indexStrictArray (StrictArray a#) (GHC.I# i#) = 54 | case GHC.indexArray# a# i# of 55 | (# Strict x #) -> x 56 | 57 | {-# INLINE sizeofStrictArray #-} 58 | sizeofStrictArray :: StrictArray a -> Int 59 | sizeofStrictArray (StrictArray a#) = 60 | GHC.I# (GHC.sizeofArray# a#) 61 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/UniqCounter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | module Database.LSMTree.Internal.UniqCounter ( 4 | UniqCounter (..), 5 | newUniqCounter, 6 | incrUniqCounter, 7 | Unique, 8 | uniqueToInt, 9 | uniqueToRunNumber, 10 | uniqueToTableId, 11 | uniqueToCursorId, 12 | ) where 13 | 14 | import Control.Monad.Primitive (PrimMonad, PrimState) 15 | import Data.Primitive.PrimVar as P 16 | import Database.LSMTree.Internal.RunNumber 17 | 18 | -- | A unique value derived from a 'UniqCounter'. 19 | newtype Unique = Unique Int 20 | 21 | -- | Use specialised versions like 'uniqueToRunNumber' where possible. 22 | uniqueToInt :: Unique -> Int 23 | uniqueToInt (Unique n) = n 24 | 25 | uniqueToRunNumber :: Unique -> RunNumber 26 | uniqueToRunNumber (Unique n) = RunNumber n 27 | 28 | uniqueToTableId :: Unique -> TableId 29 | uniqueToTableId (Unique n) = TableId n 30 | 31 | uniqueToCursorId :: Unique -> CursorId 32 | uniqueToCursorId (Unique n) = CursorId n 33 | 34 | -- | An atomic counter for producing 'Unique' values. 35 | -- 36 | newtype UniqCounter m = UniqCounter (PrimVar (PrimState m) Int) 37 | 38 | {-# INLINE newUniqCounter #-} 39 | newUniqCounter :: PrimMonad m => Int -> m (UniqCounter m) 40 | newUniqCounter = fmap UniqCounter . P.newPrimVar 41 | 42 | {-# INLINE incrUniqCounter #-} 43 | -- | Atomically, return the current state of the counter, and increment the 44 | -- counter. 45 | incrUniqCounter :: PrimMonad m => UniqCounter m -> m Unique 46 | incrUniqCounter (UniqCounter uniqVar) = 47 | Unique <$> P.fetchAddInt uniqVar 1 48 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/Unsliced.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralisedNewtypeDeriving #-} 5 | {-# LANGUAGE RoleAnnotations #-} 6 | {-# OPTIONS_HADDOCK not-home #-} 7 | 8 | module Database.LSMTree.Internal.Unsliced ( 9 | -- * Unsliced raw bytes 10 | Unsliced 11 | -- * Unsliced keys 12 | , makeUnslicedKey 13 | , unsafeMakeUnslicedKey 14 | , fromUnslicedKey 15 | ) where 16 | 17 | import Control.DeepSeq (NFData) 18 | import Control.Exception (assert) 19 | import Data.ByteString.Short (ShortByteString (SBS)) 20 | import Data.Primitive.ByteArray 21 | import qualified Data.Vector.Primitive as VP 22 | import Database.LSMTree.Internal.RawBytes (RawBytes (..)) 23 | import qualified Database.LSMTree.Internal.RawBytes as RB 24 | import Database.LSMTree.Internal.Serialise (SerialisedKey (..)) 25 | import Database.LSMTree.Internal.Vector (mkPrimVector, 26 | noRetainedExtraMemory) 27 | 28 | -- | Unsliced string of bytes 29 | type role Unsliced nominal 30 | newtype Unsliced a = Unsliced ByteArray 31 | deriving newtype NFData 32 | 33 | getByteArray :: RawBytes -> ByteArray 34 | getByteArray (RawBytes (VP.Vector _ _ ba)) = ba 35 | 36 | precondition :: RawBytes -> Bool 37 | precondition (RawBytes pvec) = noRetainedExtraMemory pvec 38 | 39 | makeUnsliced :: RawBytes -> Unsliced RawBytes 40 | makeUnsliced bytes 41 | | precondition bytes = Unsliced (getByteArray bytes) 42 | | otherwise = Unsliced (getByteArray $ RB.copy bytes) 43 | 44 | unsafeMakeUnsliced :: RawBytes -> Unsliced RawBytes 45 | unsafeMakeUnsliced bytes = assert (precondition bytes) (Unsliced (getByteArray bytes)) 46 | 47 | fromUnsliced :: Unsliced RawBytes -> RawBytes 48 | fromUnsliced (Unsliced ba) = RawBytes (mkPrimVector 0 (sizeofByteArray ba) ba) 49 | 50 | {------------------------------------------------------------------------------- 51 | Unsliced keys 52 | -------------------------------------------------------------------------------} 53 | 54 | from :: Unsliced RawBytes -> Unsliced SerialisedKey 55 | from (Unsliced ba) = Unsliced ba 56 | 57 | to :: Unsliced SerialisedKey -> Unsliced RawBytes 58 | to (Unsliced ba) = Unsliced ba 59 | 60 | makeUnslicedKey :: SerialisedKey -> Unsliced SerialisedKey 61 | makeUnslicedKey (SerialisedKey rb) = from (makeUnsliced rb) 62 | 63 | unsafeMakeUnslicedKey :: SerialisedKey -> Unsliced SerialisedKey 64 | unsafeMakeUnslicedKey (SerialisedKey rb) = from (unsafeMakeUnsliced rb) 65 | 66 | fromUnslicedKey :: Unsliced SerialisedKey -> SerialisedKey 67 | fromUnslicedKey x = SerialisedKey (fromUnsliced (to x)) 68 | 69 | instance Show (Unsliced SerialisedKey) where 70 | show x = show (fromUnslicedKey x) 71 | 72 | instance Eq (Unsliced SerialisedKey) where 73 | Unsliced ba1 == Unsliced ba2 = SBS ba1' == SBS ba2' 74 | where 75 | !(ByteArray ba1') = ba1 76 | !(ByteArray ba2') = ba2 77 | 78 | instance Ord (Unsliced SerialisedKey) where 79 | compare (Unsliced ba1) (Unsliced ba2) = compare (SBS ba1') (SBS ba2') 80 | where 81 | !(ByteArray ba1') = ba1 82 | !(ByteArray ba2') = ba2 83 | -------------------------------------------------------------------------------- /src/Database/LSMTree/Internal/WriteBuffer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralisedNewtypeDeriving #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | 5 | -- | The in-memory LSM level 0. 6 | -- 7 | module Database.LSMTree.Internal.WriteBuffer ( 8 | WriteBuffer, 9 | empty, 10 | numEntries, 11 | fromMap, 12 | toMap, 13 | fromList, 14 | toList, 15 | addEntry, 16 | null, 17 | lookups, 18 | lookup, 19 | rangeLookups, 20 | ) where 21 | 22 | import Control.DeepSeq (NFData (..)) 23 | import Data.Map.Strict (Map) 24 | import qualified Data.Map.Strict as Map 25 | import qualified Data.Vector as V 26 | import Database.LSMTree.Internal.BlobRef (BlobSpan) 27 | import Database.LSMTree.Internal.Entry 28 | import qualified Database.LSMTree.Internal.Map.Range as Map.R 29 | import Database.LSMTree.Internal.Range (Range (..)) 30 | import Database.LSMTree.Internal.Serialise 31 | import qualified Database.LSMTree.Internal.Vector as V 32 | import Prelude hiding (lookup, null) 33 | 34 | {------------------------------------------------------------------------------- 35 | Writebuffer type 36 | -------------------------------------------------------------------------------} 37 | 38 | newtype WriteBuffer = 39 | WB { unWB :: Map SerialisedKey (Entry SerialisedValue BlobSpan) } 40 | deriving stock (Eq, Show) 41 | deriving newtype NFData 42 | 43 | empty :: WriteBuffer 44 | empty = WB Map.empty 45 | 46 | -- | \( O(1) \) 47 | numEntries :: WriteBuffer -> NumEntries 48 | numEntries (WB m) = NumEntries (Map.size m) 49 | 50 | -- | \( O(1)) \) 51 | fromMap :: 52 | Map SerialisedKey (Entry SerialisedValue BlobSpan) 53 | -> WriteBuffer 54 | fromMap m = WB m 55 | 56 | -- | \( O(1) \) 57 | toMap :: WriteBuffer -> Map SerialisedKey (Entry SerialisedValue BlobSpan) 58 | toMap = unWB 59 | 60 | -- | \( O(n \log n) \) 61 | fromList :: 62 | ResolveSerialisedValue -- ^ merge function 63 | -> [(SerialisedKey, Entry SerialisedValue BlobSpan)] 64 | -> WriteBuffer 65 | fromList f es = WB $ Map.fromListWith (combine f) es 66 | 67 | -- | \( O(n) \) 68 | toList :: WriteBuffer -> [(SerialisedKey, Entry SerialisedValue BlobSpan)] 69 | toList (WB m) = Map.assocs m 70 | 71 | {------------------------------------------------------------------------------- 72 | Updates 73 | -------------------------------------------------------------------------------} 74 | 75 | addEntry :: 76 | ResolveSerialisedValue -- ^ merge function 77 | -> SerialisedKey 78 | -> Entry SerialisedValue BlobSpan 79 | -> WriteBuffer 80 | -> WriteBuffer 81 | addEntry f k e (WB wb) = 82 | WB (Map.insertWith (combine f) k e wb) 83 | 84 | {------------------------------------------------------------------------------- 85 | Querying 86 | -------------------------------------------------------------------------------} 87 | 88 | null :: WriteBuffer -> Bool 89 | null (WB m) = Map.null m 90 | 91 | -- We return an 'Entry' with serialised values, so it can be properly combined 92 | -- with the lookups in other runs. Deserialisation only occurs afterwards. 93 | -- 94 | -- Note: the entry may be 'Delete'. 95 | -- 96 | lookups :: 97 | WriteBuffer 98 | -> V.Vector SerialisedKey 99 | -> V.Vector (Maybe (Entry SerialisedValue BlobSpan)) 100 | lookups (WB !m) !ks = V.mapStrict (`Map.lookup` m) ks 101 | 102 | lookup :: 103 | WriteBuffer 104 | -> SerialisedKey 105 | -> Maybe (Entry SerialisedValue BlobSpan) 106 | lookup (WB !m) !k = Map.lookup k m 107 | 108 | {------------------------------------------------------------------------------- 109 | RangeQueries 110 | -------------------------------------------------------------------------------} 111 | 112 | -- | We return 'Entry' so we can properly combine lookup results. 113 | -- 114 | -- Note: 'Delete's are not filtered out. 115 | -- 116 | rangeLookups :: 117 | WriteBuffer 118 | -> Range SerialisedKey 119 | -> [(SerialisedKey, Entry SerialisedValue BlobSpan)] 120 | rangeLookups (WB m) r = 121 | [ (k, e) 122 | | let (lb, ub) = convertRange r 123 | , (k, e) <- Map.R.rangeLookup lb ub m 124 | ] 125 | 126 | convertRange :: Range k -> (Map.R.Bound k, Map.R.Bound k) 127 | convertRange (FromToExcluding lb ub) = 128 | ( Map.R.Bound lb Map.R.Inclusive 129 | , Map.R.Bound ub Map.R.Exclusive ) 130 | convertRange (FromToIncluding lb ub) = 131 | ( Map.R.Bound lb Map.R.Inclusive 132 | , Map.R.Bound ub Map.R.Inclusive ) 133 | -------------------------------------------------------------------------------- /test-control/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified Test.Control.ActionRegistry 4 | import qualified Test.Control.Concurrent.Class.MonadSTM.RWVar 5 | import qualified Test.Control.RefCount 6 | import Test.Tasty 7 | 8 | main :: IO () 9 | main = defaultMain $ testGroup "control" 10 | [ Test.Control.ActionRegistry.tests 11 | , Test.Control.Concurrent.Class.MonadSTM.RWVar.tests 12 | , Test.Control.RefCount.tests 13 | ] 14 | -------------------------------------------------------------------------------- /test-control/Test/Control/ActionRegistry.hs: -------------------------------------------------------------------------------- 1 | module Test.Control.ActionRegistry (tests) where 2 | 3 | import Control.ActionRegistry 4 | import Control.Monad.Class.MonadThrow 5 | import Test.Tasty (TestTree, testGroup) 6 | import Test.Tasty.QuickCheck 7 | 8 | tests :: TestTree 9 | tests = testGroup "Test.Control.ActionRegistry" [ 10 | testProperty "prop_commitActionRegistryError" prop_commitActionRegistryError 11 | , testProperty "prop_abortActionRegistryError" prop_abortActionRegistryError 12 | ] 13 | 14 | -- | An example where an exception happens while an action registry is being 15 | -- committed. 16 | prop_commitActionRegistryError :: Property 17 | prop_commitActionRegistryError = once $ ioProperty $ do 18 | eith <- 19 | try @_ @CommitActionRegistryError $ 20 | withActionRegistry $ \reg -> do 21 | delayedCommit reg 22 | (throwIO (userError "delayed action failed")) 23 | pure $ case eith of 24 | Left e -> 25 | tabulate "displayException" [displayExceptionNewline e] $ property True 26 | Right () -> property False 27 | 28 | -- | An example where an exception happens while an action registry is being 29 | -- aborted. 30 | prop_abortActionRegistryError :: Property 31 | prop_abortActionRegistryError = once $ ioProperty $ do 32 | eith <- 33 | try @_ @AbortActionRegistryError $ 34 | withActionRegistry $ \reg -> do 35 | withRollback reg 36 | (pure ()) 37 | (\_ -> throwIO (userError "rollback action failed")) 38 | throwIO (userError "error in withActionRegistry scope") 39 | pure $ case eith of 40 | Left e -> 41 | tabulate "displayException" [displayExceptionNewline e] $ property True 42 | Right () -> property False 43 | 44 | displayExceptionNewline :: Exception e => e -> String 45 | displayExceptionNewline e = '\n':displayException e 46 | -------------------------------------------------------------------------------- /test-control/Test/Control/Concurrent/Class/MonadSTM/RWVar.hs: -------------------------------------------------------------------------------- 1 | module Test.Control.Concurrent.Class.MonadSTM.RWVar (tests) where 2 | 3 | import qualified Control.Concurrent.Class.MonadSTM.RWVar as RW 4 | import Control.Monad.Class.MonadAsync 5 | import Control.Monad.Class.MonadSay (MonadSay (say)) 6 | import Control.Monad.Class.MonadTest (MonadTest (exploreRaces)) 7 | import Control.Monad.Class.MonadThrow 8 | import Control.Monad.IOSim 9 | import Test.QuickCheck 10 | import Test.Tasty 11 | import Test.Tasty.QuickCheck 12 | 13 | tests :: TestTree 14 | tests = testGroup "Test.Control.Concurrent.Class.MonadSTM.RWVar" [ 15 | testProperty "prop_noRace" prop_noRace 16 | ] 17 | 18 | data Action a = Read a | Incr a 19 | deriving stock (Show, Eq, Read) 20 | 21 | instance Arbitrary a => Arbitrary (Action a) where 22 | arbitrary = oneof [ 23 | Read <$> arbitrary 24 | , Incr <$> arbitrary 25 | ] 26 | shrink (Read x) = [Read x' | x' <- shrink x] 27 | shrink (Incr x) = [Incr x' | x' <- shrink x] 28 | 29 | -- | Performing reads and increments on an @'RWVar' Int@ in parallel should not 30 | -- lead to races. We let IOSimPOR check that there are no deadlocks. We also 31 | -- look at the trace to see if the value inside the 'RWVar' increases 32 | -- monotonically. 33 | prop_noRace :: 34 | Action () 35 | -> Action () 36 | -> Action () 37 | -> Property 38 | prop_noRace a1 a2 a3 = exploreSimTrace modifyOpts prop $ \_ tr -> 39 | case traceResult False tr of 40 | Left e -> counterexample (show e) (property False) 41 | _ -> propSayMonotonic tr 42 | where 43 | modifyOpts = id 44 | 45 | prop :: IOSim s () 46 | prop = do 47 | exploreRaces 48 | var <- RW.new (0 :: Int) 49 | let g = \case 50 | Read () -> 51 | RW.withReadAccess var $ \x -> do 52 | say (show (Read x)) 53 | Incr () -> 54 | RW.withWriteAccess_ var $ \x -> do 55 | let x' = x + 1 56 | say (show (Incr x')) 57 | pure x' 58 | t1 <- async (g a1) 59 | t2 <- async (g a2) 60 | t3 <- async (g a3) 61 | async (cancel t1) >>= wait 62 | (_ :: Either AsyncCancelled ()) <- try (wait t1) 63 | (_ :: Either AsyncCancelled ()) <- try (wait t2) 64 | (_ :: Either AsyncCancelled ()) <- try (wait t3) 65 | pure () 66 | 67 | propSayMonotonic :: SimTrace () -> Property 68 | propSayMonotonic simTrace = propResultsMonotonic (actionResults simTrace) 69 | 70 | propResultsMonotonic :: [Action Int] -> Property 71 | propResultsMonotonic as = 72 | counterexample 73 | ("Action results are not monotonic: " ++ show as) 74 | (resultsMonotonic as) 75 | 76 | resultsMonotonic :: [Action Int] -> Bool 77 | resultsMonotonic = go 0 78 | where 79 | go _ [] = True 80 | go prev (Read x : as) = prev == x && go x as 81 | go prev (Incr x : as) = prev + 1 == x && go x as 82 | 83 | actionResults :: SimTrace () -> [Action Int] 84 | actionResults = map read . selectTraceEventsSay 85 | -------------------------------------------------------------------------------- /test-prototypes/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | 5 | import qualified Test.FormatPage 6 | import qualified Test.ScheduledMerges 7 | import qualified Test.ScheduledMerges.RunSizes 8 | import qualified Test.ScheduledMergesQLS 9 | 10 | main :: IO () 11 | main = defaultMain $ testGroup "prototypes" [ 12 | Test.FormatPage.tests 13 | , Test.ScheduledMerges.tests 14 | , Test.ScheduledMerges.RunSizes.tests 15 | , Test.ScheduledMergesQLS.tests 16 | ] 17 | -------------------------------------------------------------------------------- /test/Database/LSMTree/Class/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Database.LSMTree.Class.Common ( 4 | C, CK, CV, CB, C_ 5 | , IsSession (..) 6 | , SessionArgs (..) 7 | , withSession 8 | , module Types 9 | ) where 10 | 11 | import Control.Monad.Class.MonadThrow (MonadThrow (..)) 12 | import Control.Tracer (nullTracer) 13 | import Data.Kind (Constraint, Type) 14 | import Data.Typeable (Typeable) 15 | import Database.LSMTree (ResolveValue) 16 | import Database.LSMTree as Types (IOLike, Range (..), SerialiseKey, 17 | SerialiseValue, SnapshotLabel (..), SnapshotName, 18 | UnionCredits (..), UnionDebt (..)) 19 | import qualified Database.LSMTree as R 20 | import System.FS.API (FsPath, HasFS) 21 | import System.FS.BlockIO.API (HasBlockIO) 22 | 23 | {------------------------------------------------------------------------------- 24 | Constraints 25 | -------------------------------------------------------------------------------} 26 | 27 | -- | Constraints for keys, values, and blobs 28 | type C k v b = (CK k, CV v, CB b) 29 | 30 | -- | Constraints for keys 31 | type CK k = (C_ k, SerialiseKey k) 32 | 33 | -- | Constraints for values 34 | type CV v = (C_ v, SerialiseValue v, ResolveValue v) 35 | 36 | -- | Constraints for blobs 37 | type CB b = (C_ b, SerialiseValue b) 38 | 39 | -- | Model-specific constraints for keys, values, and blobs 40 | type C_ a = (Show a, Eq a, Typeable a) 41 | 42 | {------------------------------------------------------------------------------- 43 | Session 44 | -------------------------------------------------------------------------------} 45 | 46 | -- | Class abstracting over session operations. 47 | -- 48 | type IsSession :: ((Type -> Type) -> Type) -> Constraint 49 | class IsSession s where 50 | data SessionArgs s :: (Type -> Type) -> Type 51 | 52 | openSession :: 53 | IOLike m 54 | => SessionArgs s m 55 | -> m (s m) 56 | 57 | closeSession :: 58 | IOLike m 59 | => s m 60 | -> m () 61 | 62 | deleteSnapshot :: 63 | IOLike m 64 | => s m 65 | -> SnapshotName 66 | -> m () 67 | 68 | listSnapshots :: 69 | IOLike m 70 | => s m 71 | -> m [SnapshotName] 72 | 73 | withSession :: (IOLike m, IsSession s) => SessionArgs s m -> (s m -> m a) -> m a 74 | withSession seshArgs = bracket (openSession seshArgs) closeSession 75 | 76 | {------------------------------------------------------------------------------- 77 | Real instance 78 | -------------------------------------------------------------------------------} 79 | 80 | instance IsSession R.Session where 81 | data SessionArgs R.Session m where 82 | SessionArgs :: 83 | forall m h. Typeable h 84 | => HasFS m h -> HasBlockIO m h -> FsPath 85 | -> SessionArgs R.Session m 86 | 87 | openSession (SessionArgs hfs hbio dir) = do 88 | R.openSession nullTracer hfs hbio dir 89 | closeSession = R.closeSession 90 | deleteSnapshot = R.deleteSnapshot 91 | listSnapshots = R.listSnapshots 92 | -------------------------------------------------------------------------------- /test/Database/LSMTree/Model.hs: -------------------------------------------------------------------------------- 1 | -- | The are three kinds of model, each depending on the previous one: 2 | -- 3 | -- * [@Model.Table@]: 4 | -- Pure model of a single table. 5 | -- @ 6 | -- updates :: [_] -> Table k v b -> Table k v b 7 | -- @ 8 | -- 9 | -- * [@Model.Session@]: 10 | -- Pure model of a session (containing multiple tables). 11 | -- @ 12 | -- updates :: MonadState Model m => [_] -> Table k v b -> m () 13 | -- @ 14 | -- 15 | -- * [@Model.IO@]: 16 | -- STM-based model allowing multiple (potentially closed) sessions. 17 | -- @ 18 | -- updates :: MonadSTM m => MSession m -> [_] -> Table k v b -> m () 19 | -- @ 20 | -- 21 | module Database.LSMTree.Model () where 22 | -------------------------------------------------------------------------------- /test/Database/LSMTree/Model/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | -- | An instance of `Class.IsTable`, modelling potentially closed sessions in 4 | -- @IO@ by lifting the pure session model from "Database.LSMTree.Model.Session". 5 | module Database.LSMTree.Model.IO ( 6 | Err (..) 7 | , Session (..) 8 | , Class.SessionArgs (NoSessionArgs) 9 | , Table (..) 10 | , TableConfig (..) 11 | , BlobRef (..) 12 | , Cursor (..) 13 | -- * helpers 14 | , runInOpenSession 15 | ) where 16 | 17 | import Control.Concurrent.Class.MonadSTM.Strict 18 | import Control.Exception (Exception) 19 | import Control.Monad.Class.MonadThrow (MonadThrow (..)) 20 | import qualified Data.List.NonEmpty as NE 21 | import qualified Database.LSMTree.Class as Class 22 | import Database.LSMTree.Model.Session (TableConfig (..)) 23 | import qualified Database.LSMTree.Model.Session as Model 24 | 25 | newtype Session m = Session (StrictTVar m (Maybe Model.Model)) 26 | 27 | data Table m k v b = Table { 28 | thSession :: !(Session m) 29 | , thTable :: !(Model.Table k v b) 30 | } 31 | 32 | data BlobRef m b = BlobRef { 33 | brSession :: !(Session m) 34 | , brBlobRef :: !(Model.BlobRef b) 35 | } 36 | 37 | data Cursor m k v b = Cursor { 38 | cSession :: !(Session m) 39 | , cCursor :: !(Model.Cursor k v b) 40 | } 41 | 42 | newtype Err = Err (Model.Err) 43 | deriving stock Show 44 | deriving anyclass Exception 45 | 46 | runInOpenSession :: (MonadSTM m, MonadThrow (STM m)) => Session m -> Model.ModelM a -> m a 47 | runInOpenSession (Session var) action = atomically $ do 48 | readTVar var >>= \case 49 | Nothing -> error "session closed" 50 | Just m -> do 51 | let (r, m') = Model.runModelM action m 52 | case r of 53 | Left e -> throwSTM (Err e) 54 | Right x -> writeTVar var (Just m') >> pure x 55 | 56 | instance Class.IsSession Session where 57 | data SessionArgs Session m = NoSessionArgs 58 | openSession NoSessionArgs = Session <$> newTVarIO (Just $! Model.initModel) 59 | closeSession (Session var) = atomically $ writeTVar var Nothing 60 | deleteSnapshot s x = runInOpenSession s $ Model.deleteSnapshot x 61 | listSnapshots s = runInOpenSession s $ Model.listSnapshots 62 | 63 | instance Class.IsTable Table where 64 | type Session Table = Session 65 | type TableConfig Table = Model.TableConfig 66 | type BlobRef Table = BlobRef 67 | type Cursor Table = Cursor 68 | 69 | newTableWith x s = Table s <$> runInOpenSession s (Model.new x) 70 | closeTable (Table s t) = runInOpenSession s (Model.close t) 71 | lookups (Table s t) x1 = fmap (fmap (BlobRef s)) <$> 72 | runInOpenSession s (Model.lookups x1 t) 73 | updates (Table s t) x1 = runInOpenSession s (Model.updates Model.getResolve x1 t) 74 | inserts (Table s t) x1 = runInOpenSession s (Model.inserts Model.getResolve x1 t) 75 | deletes (Table s t) x1 = runInOpenSession s (Model.deletes Model.getResolve x1 t) 76 | upserts (Table s t) x1 = runInOpenSession s (Model.upserts Model.getResolve x1 t) 77 | 78 | rangeLookup (Table s t) x1 = fmap (fmap (BlobRef s)) <$> 79 | runInOpenSession s (Model.rangeLookup x1 t) 80 | retrieveBlobs _ s x1 = runInOpenSession s (Model.retrieveBlobs (fmap brBlobRef x1)) 81 | 82 | newCursor k (Table s t) = Cursor s <$> runInOpenSession s (Model.newCursor k t) 83 | closeCursor _ (Cursor s c) = runInOpenSession s (Model.closeCursor c) 84 | readCursor _ x1 (Cursor s c) = fmap (fmap (BlobRef s)) <$> 85 | runInOpenSession s (Model.readCursor x1 c) 86 | 87 | saveSnapshot x1 x2 (Table s t) = runInOpenSession s (Model.saveSnapshot x1 x2 t) 88 | corruptSnapshot _ x (Table s _t) = runInOpenSession s (Model.corruptSnapshot x) 89 | openTableFromSnapshot s x1 x2 = Table s <$> runInOpenSession s (Model.openTableFromSnapshot x1 x2) 90 | 91 | duplicate (Table s t) = Table s <$> runInOpenSession s (Model.duplicate t) 92 | 93 | union (Table s1 t1) (Table _s2 t2) = 94 | Table s1 <$> runInOpenSession s1 (Model.union Model.getResolve t1 t2) 95 | unions ts = 96 | Table s <$> runInOpenSession s (Model.unions Model.getResolve (fmap thTable ts)) 97 | where 98 | Table s _ = NE.head ts 99 | remainingUnionDebt (Table s t) = runInOpenSession s (Model.remainingUnionDebt t) 100 | supplyUnionCredits (Table s t) credits = runInOpenSession s (Model.supplyUnionCredits t credits) 101 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/Arena.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Test.Database.LSMTree.Internal.Arena ( 3 | tests, 4 | ) where 5 | 6 | import Control.Monad.ST (runST) 7 | import Data.Primitive.ByteArray 8 | import Data.Word (Word8) 9 | import Database.LSMTree.Internal.Arena 10 | import GHC.Exts (toList) 11 | import Test.Tasty (TestTree, testGroup) 12 | import Test.Tasty.HUnit (testCaseSteps, (@?=)) 13 | 14 | tests :: TestTree 15 | tests = testGroup "Test.Database.LSMTree.Internal.Arena" 16 | [ testCaseSteps "safe" $ \_info -> do 17 | let !ba = runST $ withUnmanagedArena $ \arena -> do 18 | (off', mba) <- allocateFromArena arena 32 8 19 | setByteArray mba off' 32 (1 :: Word8) 20 | freezeByteArray mba off' 32 21 | 22 | toList ba @?= replicate 32 (1 :: Word8) 23 | 24 | , testCaseSteps "unsafe" $ \_info -> do 25 | let !(off, ba) = runST $ withUnmanagedArena $ \arena -> do 26 | (off', mba) <- allocateFromArena arena 32 8 27 | setByteArray mba off' 32 (1 :: Word8) 28 | ba' <- unsafeFreezeByteArray mba 29 | pure (off', ba') 30 | 31 | #if NO_IGNORE_ASSERTS 32 | take 32 (drop off (toList ba)) @?= replicate 32 (0x77 :: Word8) 33 | #else 34 | take 32 (drop off (toList ba)) @?= replicate 32 (1 :: Word8) 35 | #endif 36 | ] 37 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/BlobFile/FS.hs: -------------------------------------------------------------------------------- 1 | module Test.Database.LSMTree.Internal.BlobFile.FS (tests) where 2 | 3 | import Control.Concurrent.Class.MonadSTM.Strict 4 | import Control.Monad 5 | import Control.Monad.Class.MonadThrow 6 | import Control.RefCount 7 | import Database.LSMTree.Internal.BlobFile 8 | import System.FS.API 9 | import System.FS.Sim.Error hiding (genErrors) 10 | import qualified System.FS.Sim.MockFS as MockFS 11 | import Test.Tasty 12 | import Test.Tasty.QuickCheck as QC 13 | import Test.Util.FS 14 | 15 | tests :: TestTree 16 | tests = testGroup "Test.Database.LSMTree.Internal.BlobFile.FS" [ 17 | testProperty "prop_fault_openRelease" prop_fault_openRelease 18 | ] 19 | 20 | -- Test that opening and releasing a blob file properly cleans handles and files 21 | -- in the presence of disk faults. 22 | prop_fault_openRelease :: 23 | Bool -- ^ create the file or not 24 | -> OpenMode 25 | -> NoCleanupErrors 26 | -> NoCleanupErrors 27 | -> Property 28 | prop_fault_openRelease doCreateFile om 29 | (NoCleanupErrors openErrors) 30 | (NoCleanupErrors releaseErrors) = 31 | ioProperty $ 32 | withSimErrorHasFS propPost MockFS.empty emptyErrors $ \hfs fsVar errsVar -> do 33 | when doCreateFile $ 34 | withFile hfs path (WriteMode MustBeNew) $ \_ -> pure () 35 | eith <- try @_ @FsError $ 36 | bracket (acquire hfs errsVar) (release errsVar) $ \_blobFile -> do 37 | fs' <- atomically $ readTMVar fsVar 38 | pure $ propNumOpenHandles 1 fs' .&&. propNumDirEntries (mkFsPath []) 1 fs' 39 | pure $ case eith of 40 | Left{} -> 41 | label "FsError" $ property True 42 | Right prop -> 43 | label "Success" $ prop 44 | where 45 | root = mkFsPath [] 46 | path = mkFsPath ["blobfile"] 47 | 48 | acquire hfs errsVar = 49 | withErrors errsVar openErrors $ openBlobFile hfs path om 50 | 51 | release errsVar blobFile = 52 | withErrors errsVar releaseErrors $ releaseRef blobFile 53 | 54 | propPost fs = propNoOpenHandles fs .&&. 55 | if doCreateFile then 56 | case allowExisting om of 57 | AllowExisting -> 58 | -- TODO: fix, see the TODO on openBlobFile 59 | propNoDirEntries root fs .||. propNumDirEntries root 1 fs 60 | MustBeNew -> 61 | propNumDirEntries root 1 fs 62 | MustExist -> 63 | -- TODO: fix, see the TODO on openBlobFile 64 | propNoDirEntries root fs .||. propNumDirEntries root 1 fs 65 | else 66 | propNoDirEntries root fs 67 | 68 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/MergingRun.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Test.Database.LSMTree.Internal.MergingRun (tests) where 4 | 5 | import Database.LSMTree.Internal.MergingRun 6 | import Test.QuickCheck 7 | import Test.Tasty 8 | import Test.Tasty.QuickCheck 9 | 10 | tests :: TestTree 11 | tests = testGroup "Test.Database.LSMTree.Internal.MergingRun" 12 | [ testProperty "prop_CreditsPair" prop_CreditsPair 13 | ] 14 | 15 | -- | The representation of CreditsPair should round trip properly. This is 16 | -- non-trivial because it uses a packed bitfield representation. 17 | -- 18 | prop_CreditsPair :: SpentCredits -> UnspentCredits -> Property 19 | prop_CreditsPair spentCredits unspentCredits = 20 | tabulate "bounds" [spentCreditsBound, unspentCreditsBound] $ 21 | let cp :: Int 22 | !cp = CreditsPair spentCredits unspentCredits 23 | in case cp of 24 | CreditsPair spentCredits' unspentCredits' -> 25 | (spentCredits, unspentCredits) === (spentCredits', unspentCredits') 26 | where 27 | spentCreditsBound 28 | | spentCredits == minBound = "spentCredits == minBound" 29 | | spentCredits == maxBound = "spentCredits == maxBound" 30 | | otherwise = "spentCredits == other" 31 | 32 | unspentCreditsBound 33 | | unspentCredits == minBound = "unspentCredits == minBound" 34 | | unspentCredits == maxBound = "unspentCredits == maxBound" 35 | | otherwise = "unspentCredits == other" 36 | 37 | deriving newtype instance Enum SpentCredits 38 | deriving newtype instance Enum UnspentCredits 39 | 40 | instance Arbitrary SpentCredits where 41 | arbitrary = 42 | frequency [ (1, pure minBound) 43 | , (1, pure maxBound) 44 | , (10, arbitraryBoundedEnum) 45 | ] 46 | 47 | instance Arbitrary UnspentCredits where 48 | arbitrary = 49 | frequency [ (1, pure minBound) 50 | , (1, pure maxBound) 51 | , (10, arbitraryBoundedEnum) 52 | ] 53 | 54 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/PageAcc1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Test.Database.LSMTree.Internal.PageAcc1 (tests) where 3 | 4 | import qualified Data.ByteString as BS 5 | 6 | import Database.LSMTree.Internal.PageAcc1 7 | 8 | import qualified Database.LSMTree.Extras.ReferenceImpl as Ref 9 | 10 | import Test.QuickCheck 11 | import Test.Tasty (TestTree, testGroup) 12 | import Test.Tasty.QuickCheck (testProperty) 13 | import Test.Util.RawPage 14 | 15 | tests :: TestTree 16 | tests = 17 | testGroup "Database.LSMTree.Internal.PageAcc1" $ 18 | [ testProperty "vs reference impl" prop_vsReferenceImpl ] 19 | 20 | ++ [ testProperty 21 | ("example-" ++ show (n :: Int) ++ [a]) 22 | (prop_vsReferenceImpl (Ref.PageContentSingle (Ref.Key "") op)) 23 | | (n,exs) <- zip [1..] examples 24 | , (a, op) <- zip ['a'..] exs 25 | ] 26 | where 27 | examples :: [[Ref.Operation]] 28 | examples = [example1s, example2s, example3s] 29 | example1s = [ Ref.Insert (Ref.Value (BS.replicate sz 120)) Nothing 30 | | sz <- [4064..4066] ] 31 | 32 | example2s = [ Ref.Insert (Ref.Value (BS.replicate sz 120)) 33 | (Just (Ref.BlobRef 3 5)) 34 | | sz <- [4050..4052] ] 35 | 36 | example3s = [ Ref.Mupsert (Ref.Value (BS.replicate sz 120)) 37 | | sz <- [4064..4066] ] 38 | 39 | prop_vsReferenceImpl :: Ref.PageContentSingle -> Property 40 | prop_vsReferenceImpl (Ref.PageContentSingle k op) = 41 | op /= Ref.Delete ==> 42 | label (show (length loverflow) ++ " overflow pages") $ 43 | propEqualRawPages lhs rhs 44 | .&&. counterexample "overflow pages do not match" 45 | (loverflow === roverflow) 46 | where 47 | (lhs, loverflow) = Ref.toRawPage $ Ref.PageContentFits [(k, op)] 48 | (rhs, roverflow) = singletonPage (Ref.toSerialisedKey k) (Ref.toEntry op) 49 | 50 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/RawBytes.hs: -------------------------------------------------------------------------------- 1 | module Test.Database.LSMTree.Internal.RawBytes (tests) where 2 | 3 | import Database.LSMTree.Extras.Generators () 4 | import Database.LSMTree.Internal.RawBytes (RawBytes) 5 | import qualified Database.LSMTree.Internal.RawBytes as RB (size) 6 | import Test.QuickCheck (Property, classify, collect, mapSize, 7 | withDiscardRatio, withMaxSuccess, (.||.), (===), (==>)) 8 | import Test.Tasty (TestTree, testGroup) 9 | import Test.Tasty.QuickCheck (testProperty) 10 | 11 | -- * Tests 12 | 13 | tests :: TestTree 14 | tests = testGroup "Test.Database.LSMTree.Internal.RawBytes" $ 15 | [ 16 | testGroup "Eq laws" $ 17 | [ 18 | testProperty "Reflexivity" prop_eqReflexivity, 19 | testProperty "Symmetry" prop_eqSymmetry, 20 | testProperty "Transitivity" prop_eqTransitivity, 21 | testProperty "Negation" prop_eqNegation 22 | ], 23 | testGroup "Ord laws" $ 24 | [ 25 | testProperty "Comparability" prop_ordComparability, 26 | testProperty "Transitivity" prop_ordTransitivity, 27 | testProperty "Reflexivity" prop_ordReflexivity, 28 | testProperty "Antisymmetry" prop_ordAntisymmetry 29 | ] 30 | ] 31 | 32 | -- * Utilities 33 | 34 | twoBlocksProp :: String -> RawBytes -> RawBytes -> Property -> Property 35 | twoBlocksProp msgAddition block1 block2 36 | = withMaxSuccess 10000 . 37 | classify (block1 == block2) ("equal blocks" ++ msgAddition) 38 | 39 | withFirstBlockSizeInfo :: RawBytes -> Property -> Property 40 | withFirstBlockSizeInfo firstBlock 41 | = collect ("Size of first block is " ++ show (RB.size firstBlock)) 42 | 43 | -- * Properties to test 44 | 45 | -- ** 'Eq' laws 46 | 47 | prop_eqReflexivity :: RawBytes -> Property 48 | prop_eqReflexivity block = block === block 49 | 50 | prop_eqSymmetry :: RawBytes -> RawBytes -> Property 51 | prop_eqSymmetry block1 block2 = twoBlocksProp "" block1 block2 $ 52 | (block1 == block2) === (block2 == block1) 53 | 54 | prop_eqTransitivity :: Property 55 | prop_eqTransitivity = mapSize (const 3) $ 56 | withDiscardRatio 1000 $ 57 | untunedProp 58 | where 59 | 60 | untunedProp :: RawBytes -> RawBytes -> RawBytes -> Property 61 | untunedProp block1 block2 block3 62 | = withFirstBlockSizeInfo block1 $ 63 | block1 == block2 && block2 == block3 ==> block1 === block3 64 | 65 | prop_eqNegation :: RawBytes -> RawBytes -> Property 66 | prop_eqNegation block1 block2 = twoBlocksProp "" block1 block2 $ 67 | (block1 /= block2) === not (block1 == block2) 68 | 69 | -- ** 'Ord' laws 70 | 71 | prop_ordComparability :: RawBytes -> RawBytes -> Property 72 | prop_ordComparability block1 block2 = twoBlocksProp "" block1 block2 $ 73 | block1 <= block2 .||. block2 <= block1 74 | 75 | prop_ordTransitivity :: RawBytes -> RawBytes -> RawBytes -> Property 76 | prop_ordTransitivity block1 block2 block3 77 | = twoBlocksProp " front-side" block1 block2 $ 78 | twoBlocksProp " rear-side" block2 block3 $ 79 | twoBlocksProp " at the edges" block1 block3 $ 80 | block1 <= block2 && block2 <= block3 ==> block1 <= block3 81 | 82 | prop_ordReflexivity :: RawBytes -> Bool 83 | prop_ordReflexivity block = block <= block 84 | 85 | prop_ordAntisymmetry :: Property 86 | prop_ordAntisymmetry = mapSize (const 4) $ 87 | withDiscardRatio 100 $ 88 | untunedProp 89 | where 90 | 91 | untunedProp :: RawBytes -> RawBytes -> Property 92 | untunedProp block1 block2 93 | = withFirstBlockSizeInfo block1 $ 94 | block1 <= block2 && block2 <= block1 ==> block1 === block2 95 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/RawOverflowPage.hs: -------------------------------------------------------------------------------- 1 | module Test.Database.LSMTree.Internal.RawOverflowPage ( 2 | -- * Main test tree 3 | tests, 4 | ) where 5 | 6 | import qualified Data.Primitive.ByteArray as BA 7 | import qualified Data.Vector.Primitive as VP 8 | 9 | import Test.QuickCheck 10 | import Test.QuickCheck.Instances () 11 | import Test.Tasty (TestTree, testGroup) 12 | import Test.Tasty.QuickCheck 13 | 14 | import Database.LSMTree.Extras.Generators (LargeRawBytes (..)) 15 | import Database.LSMTree.Internal.BitMath 16 | import qualified Database.LSMTree.Internal.RawBytes as RB 17 | import Database.LSMTree.Internal.RawOverflowPage 18 | 19 | tests :: TestTree 20 | tests = 21 | testGroup "Database.LSMTree.Internal.RawOverflowPage" 22 | [ testProperty "RawBytes prefix to RawOverflowPage" 23 | prop_rawBytesToRawOverflowPage 24 | , testProperty "RawBytes to [RawOverflowPage]" 25 | prop_rawBytesToRawOverflowPages 26 | ] 27 | 28 | -- | Converting up to the first 4096 bytes of a 'RawBytes' to an 29 | -- 'RawOverflowPage' and back gives us the original, padded with zeros to a 30 | -- multiple of the page size. 31 | prop_rawBytesToRawOverflowPage :: LargeRawBytes -> Property 32 | prop_rawBytesToRawOverflowPage 33 | (LargeRawBytes bytes@(RB.RawBytes (VP.Vector off len ba))) = 34 | label (if RB.size bytes >= 4096 then "large" else "small") $ 35 | label (if BA.isByteArrayPinned ba then "pinned" else "unpinned") $ 36 | label (if off == 0 then "offset 0" else "offset non-0") $ 37 | 38 | rawOverflowPageRawBytes (makeRawOverflowPage ba off (min len 4096)) 39 | === RB.take 4096 bytes <> padding 40 | where 41 | padding = RB.fromVector (VP.replicate paddinglen 0) 42 | paddinglen = 4096 - (min len 4096) 43 | 44 | 45 | -- | Converting the bytes to @[RawOverflowPage]@ and back gives us the original 46 | -- bytes, padded with zeros to a multiple of the page size. 47 | -- 48 | prop_rawBytesToRawOverflowPages :: LargeRawBytes -> Property 49 | prop_rawBytesToRawOverflowPages (LargeRawBytes bytes) = 50 | length pages === roundUpToPageSize (RB.size bytes) `div` 4096 51 | .&&. mconcat (map rawOverflowPageRawBytes pages) === bytes <> padding 52 | where 53 | pages = rawBytesToOverflowPages bytes 54 | padding = RB.fromVector (VP.replicate paddinglen 0) 55 | paddinglen = let trailing = RB.size bytes `mod` 4096 in 56 | if trailing == 0 then 0 else 4096 - trailing 57 | 58 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/RunBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Test.Database.LSMTree.Internal.RunBuilder (tests) where 4 | 5 | import Control.Monad.Class.MonadThrow 6 | import Data.Foldable (traverse_) 7 | import Database.LSMTree.Internal.Entry (NumEntries (..)) 8 | import qualified Database.LSMTree.Internal.Index as Index 9 | import Database.LSMTree.Internal.Paths (RunFsPaths (..)) 10 | import qualified Database.LSMTree.Internal.RunAcc as RunAcc 11 | import qualified Database.LSMTree.Internal.RunBuilder as RunBuilder 12 | import Database.LSMTree.Internal.RunNumber 13 | import qualified System.FS.API as FS 14 | import System.FS.API (HasFS) 15 | import qualified System.FS.BlockIO.API as FS 16 | import qualified System.FS.Sim.MockFS as MockFS 17 | import Test.Tasty 18 | import Test.Tasty.QuickCheck 19 | import Test.Util.FS (propNoOpenHandles, withSimHasBlockIO, 20 | withTempIOHasBlockIO) 21 | 22 | tests :: TestTree 23 | tests = testGroup "Test.Database.LSMTree.Internal.RunBuilder" [ 24 | testGroup "ioHasFS" [ 25 | testProperty "prop_newInExistingDir" $ ioProperty $ 26 | withTempIOHasBlockIO "prop_newInExistingDir" prop_newInExistingDir 27 | , testProperty "prop_newInNonExistingDir" $ ioProperty $ 28 | withTempIOHasBlockIO "prop_newInNonExistingDir" prop_newInNonExistingDir 29 | , testProperty "prop_newTwice" $ ioProperty $ 30 | withTempIOHasBlockIO "prop_newTwice" prop_newTwice 31 | ] 32 | , testGroup "simHasFS" [ 33 | testProperty "prop_newInExistingDir" $ ioProperty $ 34 | withSimHasBlockIO propNoOpenHandles MockFS.empty $ 35 | \hfs hbio _ -> prop_newInExistingDir hfs hbio 36 | , testProperty "prop_newInNonExistingDir" $ ioProperty $ 37 | withSimHasBlockIO propNoOpenHandles MockFS.empty $ 38 | \hfs hbio _ -> prop_newInNonExistingDir hfs hbio 39 | , testProperty "prop_newTwice" $ ioProperty $ 40 | withSimHasBlockIO propNoOpenHandles MockFS.empty $ 41 | \hfs hbio _ -> prop_newTwice hfs hbio 42 | ] 43 | ] 44 | 45 | runParams :: RunBuilder.RunParams 46 | runParams = 47 | RunBuilder.RunParams { 48 | runParamCaching = RunBuilder.CacheRunData, 49 | runParamAlloc = RunAcc.RunAllocFixed 10, 50 | runParamIndex = Index.Ordinary 51 | } 52 | 53 | -- | 'new' in an existing directory should be successful. 54 | prop_newInExistingDir :: HasFS IO h -> FS.HasBlockIO IO h -> IO Property 55 | prop_newInExistingDir hfs hbio = do 56 | let runDir = FS.mkFsPath ["a", "b", "c"] 57 | FS.createDirectoryIfMissing hfs True runDir 58 | bracket 59 | (try (RunBuilder.new hfs hbio runParams (RunFsPaths runDir (RunNumber 17)) (NumEntries 0))) 60 | (traverse_ RunBuilder.close) $ pure . \case 61 | Left e@FS.FsError{} -> 62 | counterexample ("expected a success, but got: " <> show e) $ property False 63 | Right _ -> property True 64 | 65 | -- | 'new' in a non-existing directory should throw an error. 66 | prop_newInNonExistingDir :: HasFS IO h -> FS.HasBlockIO IO h -> IO Property 67 | prop_newInNonExistingDir hfs hbio = do 68 | let runDir = FS.mkFsPath ["a", "b", "c"] 69 | bracket 70 | (try (RunBuilder.new hfs hbio runParams (RunFsPaths runDir (RunNumber 17)) (NumEntries 0))) 71 | (traverse_ RunBuilder.close) $ pure . \case 72 | Left FS.FsError{} -> property True 73 | Right _ -> 74 | counterexample ("expected an FsError, but got a RunBuilder") $ property False 75 | 76 | -- | Calling 'new' twice with the same arguments should throw an error. 77 | -- 78 | -- TODO: maybe in this case a custom error should be thrown? Does the thrown 79 | -- 'FsError' cause file resources to leak? 80 | prop_newTwice :: HasFS IO h -> FS.HasBlockIO IO h -> IO Property 81 | prop_newTwice hfs hbio = do 82 | let runDir = FS.mkFsPath [] 83 | bracket 84 | (RunBuilder.new hfs hbio runParams (RunFsPaths runDir (RunNumber 17)) (NumEntries 0)) 85 | RunBuilder.close $ \_ -> 86 | bracket 87 | (try (RunBuilder.new hfs hbio runParams (RunFsPaths runDir (RunNumber 17)) (NumEntries 0))) 88 | (traverse_ RunBuilder.close) $ pure . \case 89 | Left FS.FsError{} -> property True 90 | Right _ -> 91 | counterexample ("expected an FsError, but got a RunBuilder") $ property False 92 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/Serialise.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | 5 | module Test.Database.LSMTree.Internal.Serialise (tests) where 6 | 7 | import Data.Bits 8 | import qualified Data.ByteString as BS 9 | import qualified Data.ByteString.Builder as BB 10 | import qualified Data.ByteString.Short as SBS 11 | import qualified Data.Vector.Primitive as VP 12 | import Data.Word 13 | import qualified Database.LSMTree.Internal.RawBytes as RB 14 | import Database.LSMTree.Internal.Serialise 15 | import Test.Tasty 16 | import Test.Tasty.HUnit 17 | 18 | tests :: TestTree 19 | tests = testGroup "Test.Database.LSMTree.Internal.Serialise" [ 20 | testCase "example keyTopBits64" $ do 21 | let k = SerialisedKey' (VP.fromList [0, 0, 0, 0, 37, 42, 204, 130]) 22 | expected :: Word64 23 | expected = 37 `shiftL` 24 + 42 `shiftL` 16 + 204 `shiftL` 8 + 130 24 | expected @=? keyTopBits64 k 25 | , testCase "example keyTopBits64 on sliced byte array" $ do 26 | let pvec = VP.fromList [0, 0, 0, 0, 0, 37, 42, 204, 130] 27 | k = SerialisedKey' (VP.slice 1 (VP.length pvec - 1) pvec) 28 | expected :: Word64 29 | expected = 37 `shiftL` 24 + 42 `shiftL` 16 + 204 `shiftL` 8 + 130 30 | expected @=? keyTopBits64 k 31 | , testCase "example unsafeFromByteString and fromShortByteString" $ do 32 | let bb = mconcat [BB.word64LE x | x <- [0..100]] 33 | bs = BS.toStrict . BB.toLazyByteString $ bb 34 | k1 = RB.unsafeFromByteString bs 35 | k2 = RB.fromShortByteString (SBS.toShort bs) 36 | k1 @=? k2 37 | ] 38 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/Unsliced.hs: -------------------------------------------------------------------------------- 1 | module Test.Database.LSMTree.Internal.Unsliced (tests) where 2 | 3 | import Database.LSMTree.Extras.Generators () 4 | import Database.LSMTree.Internal.Serialise 5 | import Database.LSMTree.Internal.Unsliced 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck 8 | 9 | tests :: TestTree 10 | tests = testGroup "Test.Database.LSMTree.Internal.Unsliced" [ 11 | testProperty "prop_makeUnslicedKeyPreservesEq" prop_makeUnslicedKeyPreservesEq 12 | , testProperty "prop_fromUnslicedKeyPreservesEq" prop_fromUnslicedKeyPreservesEq 13 | , testProperty "prop_makeUnslicedKeyPreservesOrd" prop_makeUnslicedKeyPreservesOrd 14 | , testProperty "prop_fromUnslicedKeyPreservesOrd" prop_fromUnslicedKeyPreservesOrd 15 | ] 16 | 17 | -- 'Eq' on serialised keys is preserved when converting to /unsliced/ serialised 18 | -- keys. 19 | prop_makeUnslicedKeyPreservesEq :: SerialisedKey -> SerialisedKey -> Property 20 | prop_makeUnslicedKeyPreservesEq k1 k2 = checkCoverage $ 21 | cover 1 lhs "k1 == k2" $ lhs === rhs 22 | where 23 | lhs = k1 == k2 24 | rhs = makeUnslicedKey k1 == makeUnslicedKey k2 25 | 26 | -- 'Eq' on /unsliced/ serialised keys is preserved when converting to serialised 27 | -- keys. 28 | prop_fromUnslicedKeyPreservesEq :: Unsliced SerialisedKey -> Unsliced SerialisedKey -> Property 29 | prop_fromUnslicedKeyPreservesEq k1 k2 = checkCoverage $ 30 | cover 1 lhs "k1 == k2" $ lhs === rhs 31 | where 32 | lhs = k1 == k2 33 | rhs = fromUnslicedKey k1 == fromUnslicedKey k2 34 | 35 | -- 'Ord' on serialised keys is preserved when converting to /unsliced/ 36 | -- serialised keys. 37 | prop_makeUnslicedKeyPreservesOrd :: SerialisedKey -> SerialisedKey -> Property 38 | prop_makeUnslicedKeyPreservesOrd k1 k2 = checkCoverage $ 39 | cover 50 lhs "k1 <= k2" $ lhs === rhs 40 | where 41 | lhs = k1 <= k2 42 | rhs = makeUnslicedKey k1 <= makeUnslicedKey k2 43 | 44 | -- 'Ord' on /unsliced/ serialised keys is preserved when converting to serialised 45 | -- keys. 46 | prop_fromUnslicedKeyPreservesOrd :: Unsliced SerialisedKey -> Unsliced SerialisedKey -> Property 47 | prop_fromUnslicedKeyPreservesOrd k1 k2 = checkCoverage $ 48 | cover 50 lhs "k1 <= k2" $ lhs === rhs 49 | where 50 | lhs = k1 <= k2 51 | rhs = fromUnslicedKey k1 <= fromUnslicedKey k2 52 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/Vector.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Test.Database.LSMTree.Internal.Vector (tests) where 4 | 5 | import Control.Monad (forM_) 6 | import Control.Monad.ST 7 | import qualified Data.Vector.Unboxed as VU 8 | import qualified Data.Vector.Unboxed.Mutable as VUM 9 | import Data.Word 10 | import Database.LSMTree.Extras 11 | import Database.LSMTree.Internal.Index.CompactAcc 12 | import Database.LSMTree.Internal.Map.Range 13 | import Test.QuickCheck 14 | import Test.QuickCheck.Instances () 15 | import Test.QuickCheck.Monadic (PropertyM, monadicST, run) 16 | import Test.Tasty (TestTree, localOption, testGroup) 17 | import Test.Tasty.QuickCheck (QuickCheckTests (QuickCheckTests), 18 | testProperty) 19 | import Test.Util.Orphans () 20 | import Text.Printf (printf) 21 | 22 | tests :: TestTree 23 | tests = testGroup "Test.Database.LSMTree.Internal.Vector" [ 24 | localOption (QuickCheckTests 400) $ 25 | testProperty "propWriteRange" $ \v lb ub (x :: Word8) -> monadicST $ do 26 | mv <- run $ VU.thaw v 27 | propWriteRange mv lb ub x 28 | , localOption (QuickCheckTests 400) $ 29 | testProperty "propUnsafeWriteRange" $ \v lb ub (x :: Word8) -> monadicST $ do 30 | mv <- run $ VU.thaw v 31 | propUnsafeWriteRange mv lb ub x 32 | ] 33 | 34 | instance Arbitrary (Bound Int) where 35 | arbitrary = oneof [ 36 | pure NoBound 37 | , BoundInclusive <$> arbitrary 38 | , BoundExclusive <$> arbitrary 39 | ] 40 | shrink = \case 41 | NoBound -> [] 42 | BoundInclusive x -> NoBound : (BoundInclusive <$> shrink x) 43 | BoundExclusive x -> NoBound : (BoundInclusive <$> shrink x) 44 | ++ (BoundExclusive <$> shrink x) 45 | 46 | intToInclusiveLowerBound :: Bound Int -> Int 47 | intToInclusiveLowerBound = \case 48 | NoBound -> 0 49 | BoundInclusive i -> i 50 | BoundExclusive i -> i + 1 51 | 52 | intToInclusiveUpperBound :: VUM.Unbox a => VU.Vector a -> Bound Int -> Int 53 | intToInclusiveUpperBound xs = \case 54 | NoBound -> VU.length xs - 1 55 | BoundInclusive i -> i 56 | BoundExclusive i -> i - 1 57 | 58 | -- | Safe version of 'unsafeWriteRange', used to test the unsafe version 59 | -- against. 60 | writeRange :: VU.Unbox a => VU.MVector s a -> Bound Int -> Bound Int -> a -> ST s Bool 61 | writeRange !v !lb !ub !x 62 | | 0 <= lb' && lb' < VUM.length v 63 | , 0 <= ub' && ub' < VUM.length v 64 | , lb' <= ub' 65 | = forM_ [lb' .. ub'] (\j -> VUM.write v j x) >> pure True 66 | | otherwise = pure False 67 | where 68 | !lb' = vectorLowerBound lb 69 | !ub' = mvectorUpperBound v ub 70 | 71 | propWriteRange :: forall s a. (VUM.Unbox a, Eq a, Show a) 72 | => VU.MVector s a 73 | -> Bound Int 74 | -> Bound Int 75 | -> a 76 | -> PropertyM (ST s) Property 77 | propWriteRange mv1 lb ub x = run $ do 78 | v1 <- VU.unsafeFreeze mv1 79 | v2 <- VU.freeze mv1 80 | b <- writeRange mv1 lb ub x 81 | 82 | let xs1 = zip [0 :: Int ..] $ VU.toList v1 83 | xs2 = zip [0..] $ VU.toList v2 84 | lb' = intToInclusiveLowerBound lb 85 | ub' = intToInclusiveUpperBound v1 ub 86 | 87 | pure $ tabulate "range size" [showPowersOf10 (ub' - lb' + 1)] $ 88 | tabulate "vector size" [showPowersOf10 (VU.length v1)] $ 89 | if not b then 90 | label "no suitable range" $ xs1 === xs2 91 | else 92 | counterexample (printf "lb=%d" lb') $ 93 | counterexample (printf "ub=%d" ub') $ 94 | conjoin [ 95 | counterexample "mismatch in prefix" $ 96 | take (lb' - 1) xs1 === take (lb' - 1) xs2 97 | , counterexample "mismatch in suffix" $ 98 | drop (ub' + 1) xs1 === drop (ub' + 1) xs2 99 | , counterexample "mimsatch in infix" $ 100 | fmap snd (drop lb' (take (ub' + 1) xs1)) === 101 | replicate (ub' - lb' + 1) x 102 | ] 103 | 104 | propUnsafeWriteRange :: 105 | forall s a. (VUM.Unbox a, Eq a, Show a) 106 | => VU.MVector s a 107 | -> Bound Int 108 | -> Bound Int 109 | -> a 110 | -> PropertyM (ST s) Property 111 | propUnsafeWriteRange mv1 lb ub x = run $ do 112 | v1 <- VU.unsafeFreeze mv1 113 | v2 <- VU.freeze mv1 114 | mv2 <- VU.unsafeThaw v2 115 | b <- writeRange mv1 lb ub x 116 | if not b then 117 | pure $ label "no suitable range" True 118 | else do 119 | unsafeWriteRange mv2 lb ub x 120 | pure $ v1 === v2 121 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/WriteBufferBlobs/FS.hs: -------------------------------------------------------------------------------- 1 | module Test.Database.LSMTree.Internal.WriteBufferBlobs.FS (tests) where 2 | 3 | import Control.Concurrent.Class.MonadSTM.Strict 4 | import Control.Monad 5 | import Control.Monad.Class.MonadThrow 6 | import Control.RefCount 7 | import Database.LSMTree.Extras.Generators () 8 | import Database.LSMTree.Internal.BlobRef (readRawBlobRef) 9 | import Database.LSMTree.Internal.Serialise (SerialisedBlob) 10 | import Database.LSMTree.Internal.WriteBufferBlobs 11 | import System.FS.API 12 | import System.FS.Sim.Error hiding (genErrors) 13 | import qualified System.FS.Sim.MockFS as MockFS 14 | import Test.Tasty 15 | import Test.Tasty.QuickCheck as QC 16 | import Test.Util.FS 17 | 18 | tests :: TestTree 19 | tests = testGroup "Test.Database.LSMTree.Internal.WriteBufferBlobs.FS" [ 20 | testProperty "prop_fault_WriteBufferBlobs" prop_fault_WriteBufferBlobs 21 | ] 22 | 23 | -- Test that opening and releasing a 'WriteBufferBlobs' properly cleans handles 24 | -- and files in the presence of disk faults. Also test that we can write then 25 | -- read blobs correctly in the presence of disk faults. 26 | -- 27 | -- By testing 'open', we also test 'new'. 28 | prop_fault_WriteBufferBlobs :: 29 | Bool -- ^ create the file or not 30 | -> AllowExisting 31 | -> NoCleanupErrors 32 | -> Errors 33 | -> NoCleanupErrors 34 | -> SerialisedBlob 35 | -> SerialisedBlob 36 | -> Property 37 | prop_fault_WriteBufferBlobs doCreateFile ae 38 | (NoCleanupErrors openErrors) 39 | errs 40 | (NoCleanupErrors releaseErrors) 41 | b1 b2 = 42 | ioProperty $ 43 | withSimErrorHasFS propPost MockFS.empty emptyErrors $ \hfs fsVar errsVar -> do 44 | when doCreateFile $ 45 | withFile hfs path (WriteMode MustBeNew) $ \_ -> pure () 46 | eith <- try @_ @FsError $ 47 | bracket (acquire hfs errsVar) (release errsVar) $ \wbb -> do 48 | fs' <- atomically $ readTMVar fsVar 49 | let prop = propNumOpenHandles 1 fs' .&&. propNumDirEntries root 1 fs' 50 | props <- blobRoundtrips hfs errsVar wbb 51 | pure (prop .&&. props) 52 | pure $ case eith of 53 | Left{} -> do 54 | label "FsError" $ property True 55 | Right prop -> 56 | label "Success" $ prop 57 | where 58 | root = mkFsPath [] 59 | path = mkFsPath ["wbb"] 60 | 61 | acquire hfs errsVar = withErrors errsVar openErrors $ open hfs path ae 62 | 63 | -- Test that we can roundtrip blobs 64 | blobRoundtrips hfs errsVar wbb = withErrors errsVar errs $ do 65 | props <- 66 | forM [b1, b2] $ \b -> do 67 | bspan <- addBlob hfs wbb b 68 | let bref = mkRawBlobRef wbb bspan 69 | b' <- readRawBlobRef hfs bref 70 | pure (b === b') 71 | pure $ conjoin props 72 | 73 | release errsVar wbb = withErrors errsVar releaseErrors $ releaseRef wbb 74 | 75 | propPost fs = propNoOpenHandles fs .&&. 76 | if doCreateFile then 77 | case ae of 78 | AllowExisting -> 79 | -- TODO: fix, see the TODO on openBlobFile 80 | propNoDirEntries root fs .||. propNumDirEntries root 1 fs 81 | MustBeNew -> 82 | propNumDirEntries root 1 fs 83 | MustExist -> 84 | -- TODO: fix, see the TODO on openBlobFile 85 | propNoDirEntries root fs .||. propNumDirEntries root 1 fs 86 | else 87 | propNoDirEntries root fs 88 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Internal/WriteBufferReader/FS.hs: -------------------------------------------------------------------------------- 1 | module Test.Database.LSMTree.Internal.WriteBufferReader.FS (tests) where 2 | 3 | 4 | import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM (..)) 5 | import Control.Concurrent.Class.MonadSTM.Strict.TMVar 6 | import Control.Monad.Class.MonadThrow 7 | import Control.RefCount 8 | import Database.LSMTree.Extras.Generators () 9 | import Database.LSMTree.Extras.RunData (RunData, 10 | withRunDataAsWriteBuffer, withSerialisedWriteBuffer) 11 | import Database.LSMTree.Internal.Paths (ForKOps (ForKOps), 12 | WriteBufferFsPaths (WriteBufferFsPaths), 13 | writeBufferKOpsPath) 14 | import Database.LSMTree.Internal.RunNumber (RunNumber (RunNumber)) 15 | import Database.LSMTree.Internal.Serialise (SerialisedBlob, 16 | SerialisedKey, SerialisedValue (..)) 17 | import qualified Database.LSMTree.Internal.WriteBufferBlobs as WBB 18 | import Database.LSMTree.Internal.WriteBufferReader 19 | import System.FS.API 20 | import System.FS.Sim.Error hiding (genErrors) 21 | import qualified System.FS.Sim.MockFS as MockFS 22 | import qualified System.FS.Sim.Stream as Stream 23 | import Test.Tasty 24 | import Test.Tasty.QuickCheck as QC 25 | import Test.Util.FS as FS 26 | 27 | tests :: TestTree 28 | tests = testGroup "Test.Database.LSMTree.Internal.WriteBufferReader.FS" [ 29 | testProperty "prop_fault_WriteBufferReader" prop_fault_WriteBufferReader 30 | ] 31 | 32 | -- | Test that 'writeWriteBuffer' roundtrips with 'readWriteBuffer', and test 33 | -- that the presence of disk faults for the latter does not leak file handles 34 | -- and files. 35 | prop_fault_WriteBufferReader :: 36 | NoCleanupErrors 37 | -> RunData SerialisedKey SerialisedValue SerialisedBlob 38 | -> Property 39 | prop_fault_WriteBufferReader (NoCleanupErrors readErrors) rdata = 40 | ioProperty $ 41 | withSimErrorHasBlockIO propPost MockFS.empty emptyErrors $ \hfs hbio fsVar errsVar -> 42 | withRunDataAsWriteBuffer hfs resolve inPath rdata $ \wb wbb -> 43 | withSerialisedWriteBuffer hfs hbio outPath wb wbb $ do 44 | fsBefore <- atomically $ readTMVar fsVar 45 | eith <- 46 | try @_ @FsError $ 47 | withErrors errsVar readErrors' $ 48 | withRef wbb $ \wbb' -> do 49 | wb' <- readWriteBuffer resolve hfs hbio outKOpsPath (WBB.blobFile wbb') 50 | pure (wb === wb') 51 | 52 | fsAfter <- atomically $ readTMVar fsVar 53 | pure $ 54 | case eith of 55 | Left{} -> do 56 | label "FsError" $ property True 57 | Right prop -> 58 | label "Success" $ prop .&&. propEqNumDirEntries root fsBefore fsAfter 59 | where 60 | root = mkFsPath [] 61 | -- The run number for the original write buffer. Primarily used to name the 62 | -- 'WriteBufferBlobs' corresponding to the write buffer. 63 | inPath = WriteBufferFsPaths root (RunNumber 0) 64 | -- The run number for the serialised write buffer. Used to name all files 65 | -- that are the result of serialising the write buffer. 66 | outPath = WriteBufferFsPaths root (RunNumber 1) 67 | outKOpsPath = ForKOps (writeBufferKOpsPath outPath) 68 | resolve (SerialisedValue x) (SerialisedValue y) = SerialisedValue (x <> y) 69 | propPost fs = propNoOpenHandles fs .&&. propNoDirEntries root fs 70 | 71 | -- TODO: fix, see the TODO on readDiskPage 72 | readErrors' = readErrors { 73 | hGetBufSomeE = Stream.filter (not . isFsReachedEOFError) (hGetBufSomeE readErrors) 74 | } 75 | 76 | isFsReachedEOFError = maybe False (either isFsReachedEOF (const False)) 77 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Model/Table.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 3 | 4 | module Test.Database.LSMTree.Model.Table (tests) where 5 | 6 | import qualified Data.ByteString as BS 7 | import qualified Data.Vector as V 8 | import Database.LSMTree (ResolveValue (..), ResolveViaSemigroup (..), 9 | SerialiseKey (..), SerialiseValue (..)) 10 | import Database.LSMTree.Model.Table (LookupResult (..), Table, 11 | Update (..), lookups) 12 | import qualified Database.LSMTree.Model.Table as Model 13 | import GHC.Exts (IsList (..)) 14 | import Test.QuickCheck.Instances () 15 | import Test.Tasty 16 | import Test.Tasty.QuickCheck 17 | 18 | tests :: TestTree 19 | tests = testGroup "Database.LSMTree.Model.Table" 20 | [ testProperty "lookup-insert" prop_lookupInsert 21 | , testProperty "lookup-delete" prop_lookupDelete 22 | , testProperty "insert-insert" prop_insertInsert 23 | , testProperty "upsert-insert" prop_upsertInsert 24 | , testProperty "upsert=lookup+insert" prop_upsertDef 25 | , testProperty "insert-commutes" prop_insertCommutes 26 | ] 27 | 28 | type Key = BS.ByteString 29 | 30 | newtype Value = Value BS.ByteString 31 | deriving stock (Eq, Show) 32 | deriving newtype (Arbitrary, Semigroup, SerialiseValue) 33 | deriving ResolveValue via (ResolveViaSemigroup Value) 34 | 35 | type Blob = BS.ByteString 36 | 37 | type Tbl = Table Key Value Blob 38 | 39 | updates :: V.Vector (Key, Update Value Blob) -> Table Key Value Blob -> Table Key Value Blob 40 | updates = Model.updates Model.getResolve 41 | 42 | inserts :: V.Vector (Key, Value, Maybe Blob) -> Table Key Value Blob -> Table Key Value Blob 43 | inserts = Model.inserts Model.getResolve 44 | 45 | deletes :: V.Vector Key -> Table Key Value Blob -> Table Key Value Blob 46 | deletes = Model.deletes Model.getResolve 47 | 48 | mupserts :: V.Vector (Key, Value) -> Table Key Value Blob -> Table Key Value Blob 49 | mupserts = Model.mupserts Model.getResolve 50 | 51 | -- | You can lookup what you inserted. 52 | prop_lookupInsert :: Key -> Value -> Tbl -> Property 53 | prop_lookupInsert k v tbl = 54 | lookups (V.singleton k) (inserts (V.singleton (k, v, Nothing)) tbl) === V.singleton (Found v) 55 | 56 | -- | You cannot lookup what you have deleted 57 | prop_lookupDelete :: Key -> Tbl -> Property 58 | prop_lookupDelete k tbl = 59 | lookups (V.singleton k) (deletes (V.singleton k) tbl) === V.singleton NotFound 60 | 61 | -- | Last insert wins. 62 | prop_insertInsert :: Key -> Value -> Value -> Tbl -> Property 63 | prop_insertInsert k v1 v2 tbl = 64 | inserts (V.fromList [(k, v1, Nothing), (k, v2, Nothing)]) tbl === inserts (V.singleton (k, v2, Nothing)) tbl 65 | 66 | -- | Updating after insert is the same as inserting merged value. 67 | -- 68 | -- Note: the order of merge. 69 | prop_upsertInsert :: Key -> Value -> Value -> Tbl -> Property 70 | prop_upsertInsert k v1 v2 tbl = 71 | updates (V.fromList [(k, Insert v1 Nothing), (k, Upsert v2)]) tbl 72 | === inserts (V.singleton (k, resolve v2 v1, Nothing)) tbl 73 | 74 | -- | Upsert is the same as lookup followed by an insert. 75 | prop_upsertDef :: Key -> Value -> Tbl -> Property 76 | prop_upsertDef k v tbl = 77 | tbl' === mupserts (V.singleton (k, v)) tbl 78 | where 79 | tbl' = case toList (lookups (V.singleton k) tbl) of 80 | [Found v'] -> inserts (V.singleton (k, resolve v v', Nothing)) tbl 81 | [FoundWithBlob v' _] -> inserts (V.singleton (k, resolve v v', Nothing)) tbl 82 | _ -> inserts (V.singleton (k, v, Nothing)) tbl 83 | 84 | -- | Different key inserts commute. 85 | prop_insertCommutes :: Key -> Value -> Key -> Value -> Tbl -> Property 86 | prop_insertCommutes k1 v1 k2 v2 tbl = k1 /= k2 ==> 87 | inserts (V.fromList [(k1, v1, Nothing), (k2, v2, Nothing)]) tbl === inserts (V.fromList [(k2, v2, Nothing), (k1, v1, Nothing)]) tbl 88 | 89 | instance (SerialiseKey k, SerialiseValue v, SerialiseValue b, Arbitrary k, Arbitrary v, Arbitrary b) => Arbitrary (Table k v b) where 90 | arbitrary = fromList <$> arbitrary 91 | shrink t = fromList <$> shrink (toList t) 92 | -------------------------------------------------------------------------------- /test/Test/Database/LSMTree/Resolve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Test.Database.LSMTree.Resolve (tests) where 4 | 5 | import Control.DeepSeq (NFData) 6 | import Data.Monoid (Sum (..)) 7 | import Data.Word 8 | import Database.LSMTree 9 | import Database.LSMTree.Extras.Generators () 10 | import Test.Tasty 11 | import Test.Tasty.QuickCheck 12 | 13 | tests :: TestTree 14 | tests = testGroup "Test.Database.LSMTree.Resolve" 15 | [ testGroup "Sum Word64" (allProperties @(Sum Word64)) 16 | ] 17 | 18 | allProperties :: 19 | forall v. (Show v, Arbitrary v, NFData v, SerialiseValue v, ResolveValue v) 20 | => [TestTree] 21 | allProperties = 22 | [ testProperty "prop_resolveValidOutput" $ withMaxSuccess 1000 $ 23 | prop_resolveValidOutput @v 24 | , testProperty "prop_resolveAssociativity" $ withMaxSuccess 1000 $ 25 | prop_resolveAssociativity @v 26 | ] 27 | 28 | prop_resolveValidOutput :: 29 | forall v. (Show v, NFData v, SerialiseValue v, ResolveValue v) 30 | => v -> v -> Property 31 | prop_resolveValidOutput x y = 32 | counterexample ("inputs: " <> show (x, y)) $ 33 | resolveValidOutput x y 34 | 35 | prop_resolveAssociativity :: 36 | forall v. (Show v, SerialiseValue v, ResolveValue v) 37 | => v -> v -> v -> Property 38 | prop_resolveAssociativity x y z = 39 | counterexample ("inputs: " <> show (x, y)) $ 40 | resolveAssociativity x y z 41 | -------------------------------------------------------------------------------- /test/Test/Util/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | module Test.Util.Arbitrary ( 2 | prop_arbitraryAndShrinkPreserveInvariant 3 | , prop_forAllArbitraryAndShrinkPreserveInvariant 4 | , deepseqInvariant 5 | , noInvariant 6 | , noTags 7 | ) where 8 | 9 | import Control.DeepSeq (NFData, deepseq) 10 | import Database.LSMTree.Extras (showPowersOf10) 11 | import Test.QuickCheck 12 | import Test.Tasty (TestTree) 13 | import Test.Tasty.QuickCheck (testProperty) 14 | 15 | prop_arbitraryAndShrinkPreserveInvariant :: 16 | forall a prop. (Arbitrary a, Show a, Testable prop) 17 | => (a -> Property -> Property) -> (a -> prop) -> [TestTree] 18 | prop_arbitraryAndShrinkPreserveInvariant tag = 19 | prop_forAllArbitraryAndShrinkPreserveInvariant tag arbitrary shrink 20 | 21 | prop_forAllArbitraryAndShrinkPreserveInvariant :: 22 | forall a prop. (Show a, Testable prop) 23 | => (a -> Property -> Property) -> Gen a -> (a -> [a]) -> (a -> prop) -> [TestTree] 24 | prop_forAllArbitraryAndShrinkPreserveInvariant tag gen shr inv = 25 | [ testProperty "Arbitrary satisfies invariant" $ 26 | forAllShrink gen shr $ \x -> 27 | tag x $ property $ inv x 28 | , testProperty "Shrinking satisfies invariant" $ 29 | -- We don't use forallShrink here. If this property fails, it means that 30 | -- the shrinker is broken, so we don't want to rely on it. 31 | forAll gen $ \x -> 32 | case shr x of 33 | [] -> label "no shrinks" $ property True 34 | xs -> tabulate "number of shrinks" [showPowersOf10 (length xs)] $ 35 | forAll (elements xs) inv -- TODO: check more than one? 36 | ] 37 | 38 | -- | Trivial invariant, but checks that the value is finite 39 | deepseqInvariant :: NFData a => a -> Bool 40 | deepseqInvariant x = x `deepseq` True 41 | 42 | noInvariant :: a -> Bool 43 | noInvariant _ = True 44 | 45 | noTags :: a -> Property -> Property 46 | noTags _ = id 47 | -------------------------------------------------------------------------------- /test/Test/Util/Orphans.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralisedNewtypeDeriving #-} 4 | {-# LANGUAGE InstanceSigs #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE StandaloneDeriving #-} 8 | {-# LANGUAGE StandaloneKindSignatures #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | 11 | {-# OPTIONS_GHC -Wno-orphans #-} 12 | 13 | module Test.Util.Orphans () where 14 | 15 | import Control.Concurrent.Class.MonadMVar (MonadMVar (..)) 16 | import Control.Concurrent.Class.MonadSTM (MonadSTM (..)) 17 | import qualified Control.Concurrent.MVar as Real 18 | import qualified Control.Concurrent.STM as Real 19 | import Control.Monad ((<=<)) 20 | import Control.Monad.IOSim (IOSim) 21 | import Data.Kind (Type) 22 | import Database.LSMTree (Cursor, Entry, LookupResult, Table) 23 | import Database.LSMTree.Internal.Serialise (SerialiseKey, 24 | SerialiseValue) 25 | import Database.LSMTree.Internal.Types (BlobRef) 26 | import Test.QuickCheck.Modifiers (Small (..)) 27 | import Test.QuickCheck.StateModel (Realized) 28 | import Test.QuickCheck.StateModel.Lockstep (InterpretOp) 29 | import qualified Test.QuickCheck.StateModel.Lockstep.Op as Op 30 | import qualified Test.QuickCheck.StateModel.Lockstep.Op.SumProd as SumProd 31 | import Test.Util.TypeFamilyWrappers (WrapBlob (..), WrapBlobRef (..), 32 | WrapCursor, WrapTable (..)) 33 | 34 | {------------------------------------------------------------------------------- 35 | IOSim 36 | -------------------------------------------------------------------------------} 37 | 38 | type instance Realized (IOSim s) a = RealizeIOSim s a 39 | 40 | type RealizeIOSim :: Type -> Type -> Type 41 | type family RealizeIOSim s a where 42 | -- io-classes 43 | RealizeIOSim s (Real.TVar a) = TVar (IOSim s) a 44 | RealizeIOSim s (Real.TMVar a) = TMVar (IOSim s) a 45 | RealizeIOSim s (Real.MVar a) = MVar (IOSim s) a 46 | -- lsm-tree 47 | RealizeIOSim s (Table IO k v b) = Table (IOSim s) k v b 48 | RealizeIOSim s (LookupResult v b) = LookupResult v (RealizeIOSim s b) 49 | RealizeIOSim s (Entry k v b) = Entry k v (RealizeIOSim s b) 50 | RealizeIOSim s (Cursor IO k v b) = Table (IOSim s) k v b 51 | RealizeIOSim s (BlobRef IO b) = BlobRef (IOSim s) b 52 | -- Type family wrappers 53 | RealizeIOSim s (WrapTable h IO k v b) = WrapTable h (IOSim s) k v b 54 | RealizeIOSim s (WrapCursor h IO k v b) = WrapCursor h (IOSim s) k v b 55 | RealizeIOSim s (WrapBlobRef h IO b) = WrapBlobRef h (IOSim s) b 56 | RealizeIOSim s (WrapBlob b) = WrapBlob b 57 | -- Congruence 58 | RealizeIOSim s (f a b) = f (RealizeIOSim s a) (RealizeIOSim s b) 59 | RealizeIOSim s (f a) = f (RealizeIOSim s a) 60 | -- Default 61 | RealizeIOSim s a = a 62 | 63 | instance InterpretOp SumProd.Op (Op.WrapRealized (IOSim s)) where 64 | intOp :: 65 | SumProd.Op a b 66 | -> Op.WrapRealized (IOSim s) a 67 | -> Maybe (Op.WrapRealized (IOSim s) b) 68 | intOp = \case 69 | SumProd.OpId -> Just 70 | SumProd.OpFst -> Just . Op.WrapRealized . fst . Op.unwrapRealized 71 | SumProd.OpSnd -> Just . Op.WrapRealized . snd . Op.unwrapRealized 72 | SumProd.OpLeft -> either (Just . Op.WrapRealized) (const Nothing) . Op.unwrapRealized 73 | SumProd.OpRight -> either (const Nothing) (Just . Op.WrapRealized) . Op.unwrapRealized 74 | SumProd.OpComp g f -> Op.intOp g <=< Op.intOp f 75 | 76 | {------------------------------------------------------------------------------- 77 | QuickCheck 78 | -------------------------------------------------------------------------------} 79 | 80 | deriving newtype instance SerialiseKey a => SerialiseKey (Small a) 81 | deriving newtype instance SerialiseValue a => SerialiseValue (Small a) 82 | -------------------------------------------------------------------------------- /test/Test/Util/PrettyProxy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PolyKinds #-} 2 | 3 | module Test.Util.PrettyProxy ( 4 | PrettyProxy (..) 5 | ) where 6 | 7 | import Data.Typeable 8 | 9 | -- | A version of 'Proxy' that also shows its type parameter. 10 | data PrettyProxy a = PrettyProxy 11 | 12 | -- | Shows the type parameter @a@ as an explicit type application. 13 | instance Typeable a => Show (PrettyProxy a) where 14 | showsPrec d p = 15 | showParen (d > app_prec) 16 | $ showString "PrettyProxy @(" 17 | . showString (show (typeRep p)) 18 | . showString ")" 19 | where app_prec = 10 20 | -------------------------------------------------------------------------------- /test/Test/Util/QC.hs: -------------------------------------------------------------------------------- 1 | module Test.Util.QC ( 2 | testClassLaws 3 | , testClassLawsWith 4 | , Proxy (..) 5 | , Choice 6 | , getChoice 7 | ) where 8 | 9 | import Data.Proxy (Proxy (..)) 10 | import Data.Word (Word64) 11 | import Test.QuickCheck.Classes (Laws (..)) 12 | import Test.Tasty (TestTree, testGroup) 13 | import Test.Tasty.QuickCheck (Arbitrary (..), Property, 14 | arbitraryBoundedIntegral, shrinkIntegral, testProperty) 15 | 16 | testClassLaws :: String -> Laws -> TestTree 17 | testClassLaws typename laws = testClassLawsWith typename laws testProperty 18 | 19 | testClassLawsWith :: 20 | String -> Laws 21 | -> (String -> Property -> TestTree) 22 | -> TestTree 23 | testClassLawsWith typename Laws {lawsTypeclass, lawsProperties} k = 24 | testGroup ("class laws" ++ lawsTypeclass ++ " " ++ typename) 25 | [ k name prop 26 | | (name, prop) <- lawsProperties ] 27 | 28 | 29 | -- | A 'Choice' of a uniform random number in a range where shrinking picks smaller numbers. 30 | newtype Choice = Choice Word64 31 | deriving stock (Show, Eq) 32 | 33 | instance Arbitrary Choice where 34 | arbitrary = Choice <$> arbitraryBoundedIntegral 35 | shrink (Choice x) = Choice <$> shrinkIntegral x 36 | 37 | -- | Use a 'Choice' to get a concrete 'Integral' in range @(a, a)@ inclusive. 38 | -- 39 | -- The choice of integral is uniform as long as the range is smaller than or 40 | -- equal to the maximum bound of `Word64`, i.e., 18446744073709551615. 41 | getChoice :: (Integral a) => Choice -> (a, a) -> a 42 | getChoice (Choice n) (l, u) = fromIntegral (((ni * (ui - li)) `div` mi) + li) 43 | where 44 | ni = toInteger n 45 | li = toInteger l 46 | ui = toInteger u 47 | mi = toInteger (maxBound :: Word64) 48 | 49 | -------------------------------------------------------------------------------- /test/Test/Util/QLS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | -- | Utilities for the @quickcheck-lockstep@ package 5 | -- 6 | -- TODO: it might be nice to upstream these utilities to @quickcheck-lockstep@ 7 | -- at some point. 8 | module Test.Util.QLS ( 9 | runActionsBracket 10 | ) where 11 | 12 | import Prelude hiding (init) 13 | 14 | import Control.Exception 15 | import Control.Monad (void) 16 | import Data.Typeable 17 | import qualified Test.QuickCheck as QC 18 | import Test.QuickCheck (Property, Testable) 19 | import Test.QuickCheck.Monadic 20 | import qualified Test.QuickCheck.StateModel as StateModel 21 | import Test.QuickCheck.StateModel hiding (runActions) 22 | import Test.QuickCheck.StateModel.Lockstep 23 | 24 | runActionsBracket :: 25 | ( RunLockstep state m 26 | , e ~ Error (Lockstep state) 27 | , forall a. IsPerformResult e a 28 | , Testable prop 29 | ) 30 | => Proxy state 31 | -> IO st -- ^ Initialisation 32 | -> (st -> IO prop) -- ^ Cleanup 33 | -> (m Property -> st -> IO Property) -- ^ Runner 34 | -> Actions (Lockstep state) 35 | -> Property 36 | runActionsBracket _ init cleanup runner actions = 37 | monadicBracketIO init cleanup runner $ 38 | void $ StateModel.runActions actions 39 | 40 | ioPropertyBracket :: 41 | (Testable a, Testable b) 42 | => IO st 43 | -> (st -> IO b) 44 | -> (m a -> st -> IO a) 45 | -> m a 46 | -> Property 47 | ioPropertyBracket init cleanup runner prop = 48 | QC.ioProperty $ mask $ \restore -> do 49 | st <- init 50 | a <- restore (runner prop st) `onException` cleanup st 51 | b <- cleanup st 52 | pure $ a QC..&&. b 53 | 54 | monadicBracketIO :: forall st a b m. 55 | (Monad m, Testable a, Testable b) 56 | => IO st 57 | -> (st -> IO b) 58 | -> (m Property -> st -> IO Property) 59 | -> PropertyM m a 60 | -> Property 61 | monadicBracketIO init cleanup runner = 62 | monadic (ioPropertyBracket init cleanup runner) 63 | -------------------------------------------------------------------------------- /test/Test/Util/RawPage.hs: -------------------------------------------------------------------------------- 1 | module Test.Util.RawPage ( 2 | assertEqualRawPages, 3 | propEqualRawPages, 4 | ) where 5 | 6 | import Control.Monad (unless) 7 | import Data.Align (align) 8 | import Data.List.Split (chunksOf) 9 | import Data.These (These (..)) 10 | import Data.Word (Word8) 11 | import qualified System.Console.ANSI as ANSI 12 | 13 | import Database.LSMTree.Internal.BitMath (div16, mod16) 14 | import qualified Database.LSMTree.Internal.RawBytes as RB 15 | import Database.LSMTree.Internal.RawPage (RawPage, rawPageRawBytes) 16 | 17 | import Test.Tasty.HUnit (Assertion, assertFailure) 18 | import Test.Tasty.QuickCheck (Property, counterexample) 19 | 20 | assertEqualRawPages :: RawPage -> RawPage -> Assertion 21 | assertEqualRawPages a b = unless (a == b) $ do 22 | assertFailure $ "unequal pages:\n" ++ ANSI.setSGRCode [ANSI.Reset] ++ compareBytes (RB.unpack (rawPageRawBytes a)) (RB.unpack (rawPageRawBytes b)) 23 | 24 | propEqualRawPages :: RawPage -> RawPage -> Property 25 | propEqualRawPages a b = counterexample 26 | (ANSI.setSGRCode [ANSI.Reset] ++ compareBytes (RB.unpack (rawPageRawBytes a)) (RB.unpack (rawPageRawBytes b))) 27 | (a == b) 28 | 29 | -- Print two bytestreams next to each other highlighting the differences. 30 | compareBytes :: [Word8] -> [Word8] -> String 31 | compareBytes xs ys = unlines $ go (grouping chunks) 32 | where 33 | go :: [Either [()] [([Word8], [Word8])]] -> [String] 34 | go [] = [] 35 | go (Left _ : zs) = "..." : go zs 36 | go (Right diff : zs) = map (uncurry showDiff) diff ++ go zs 37 | 38 | showDiff :: [Word8] -> [Word8] -> String 39 | showDiff = aux id id where 40 | aux :: ShowS -> ShowS -> [Word8] -> [Word8] -> String 41 | aux accl accr [] [] = accl . showString " " . accr $ "" 42 | aux accl accr [] rs = accl . showString " " . accr . green (concatMapS showsWord8 rs) $ "" 43 | aux accl accr ls [] = accl . red (concatMapS showsWord8 ls) . showString " " . accr $ "" 44 | aux accl accr (l:ls) (r:rs) 45 | | l == r = aux (accl . showsWord8 l) (accr . showsWord8 r) ls rs 46 | | otherwise = aux (accl . red (showsWord8 l)) (accr . green (showsWord8 r)) ls rs 47 | 48 | -- chunks are either equal, or not 49 | chunks :: [Either () ([Word8], [Word8])] 50 | chunks = 51 | [ case b of 52 | These x y 53 | | x == y -> Left () 54 | | otherwise -> Right (x, y) 55 | This x -> Right (x, []) 56 | That y -> Right ([], y) 57 | | b <- align (chunksOf 16 xs) (chunksOf 16 ys) 58 | ] 59 | 60 | sgr :: [ANSI.SGR] -> ShowS 61 | sgr cs = (ANSI.setSGRCode cs ++) 62 | 63 | red :: ShowS -> ShowS 64 | red s = sgr [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Red] . s . sgr [ANSI.Reset] 65 | 66 | green :: ShowS -> ShowS 67 | green s = sgr [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Green] . s . sgr [ANSI.Reset] 68 | 69 | concatMapS :: (a -> ShowS) -> [a] -> ShowS 70 | concatMapS f xs = \acc -> foldr (\a acc' -> f a acc') acc xs 71 | 72 | showsWord8 :: Word8 -> ShowS 73 | showsWord8 w = \acc -> hexdigit (div16 w) : hexdigit (mod16 w) : acc 74 | 75 | grouping :: [Either a b] -> [Either [a] [b]] 76 | grouping = foldr add [] 77 | where 78 | add (Left x) [] = [Left [x]] 79 | add (Right y) [] = [Right [y]] 80 | add (Left x) (Left xs : rest) = Left (x : xs) : rest 81 | add (Right y) rest@(Left _ : _) = Right [y] : rest 82 | add (Left x) rest@(Right _ : _ ) = Left [x] : rest 83 | add (Right y) (Right ys : rest) = Right (y:ys) : rest 84 | 85 | 86 | hexdigit :: (Num a, Eq a) => a -> Char 87 | hexdigit 0x0 = '0' 88 | hexdigit 0x1 = '1' 89 | hexdigit 0x2 = '2' 90 | hexdigit 0x3 = '3' 91 | hexdigit 0x4 = '4' 92 | hexdigit 0x5 = '5' 93 | hexdigit 0x6 = '6' 94 | hexdigit 0x7 = '7' 95 | hexdigit 0x8 = '8' 96 | hexdigit 0x9 = '9' 97 | hexdigit 0xA = 'a' 98 | hexdigit 0xB = 'b' 99 | hexdigit 0xC = 'c' 100 | hexdigit 0xD = 'd' 101 | hexdigit 0xE = 'e' 102 | hexdigit 0xF = 'f' 103 | hexdigit _ = '?' 104 | -------------------------------------------------------------------------------- /test/Test/Util/TypeFamilyWrappers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE StandaloneKindSignatures #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | -- | Type family wrappers are useful for a variety of reasons: 7 | -- 8 | -- * Type families can not be partially applied, but type wrappers can. 9 | -- 10 | -- * Type family synonyms can not appear in a class head, but type wrappers can. 11 | -- 12 | -- * Wrappers can be used to direct type family reduction. For an example, see 13 | -- the uses of 'WrapTable' and co in the definition of 'RealizeIOSim', 14 | -- which can be found in "Test.Util.Orphans". 15 | module Test.Util.TypeFamilyWrappers ( 16 | WrapSession (..) 17 | , WrapTable (..) 18 | , WrapCursor (..) 19 | , WrapBlobRef (..) 20 | , WrapBlob (..) 21 | ) where 22 | 23 | import Data.Kind (Type) 24 | import qualified Database.LSMTree.Class as SUT.Class 25 | 26 | type WrapSession :: 27 | ((Type -> Type) -> Type -> Type -> Type -> Type) 28 | -> (Type -> Type) -> Type 29 | newtype WrapSession h m = WrapSession { 30 | unwrapSession :: SUT.Class.Session h m 31 | } 32 | 33 | type WrapTable :: 34 | ((Type -> Type) -> Type -> Type -> Type -> Type) 35 | -> (Type -> Type) -> Type -> Type -> Type -> Type 36 | newtype WrapTable h m k v b = WrapTable { 37 | unwrapTable :: h m k v b 38 | } 39 | deriving stock (Show, Eq) 40 | 41 | type WrapCursor :: 42 | ((Type -> Type) -> Type -> Type -> Type -> Type) 43 | -> (Type -> Type) -> Type -> Type -> Type -> Type 44 | newtype WrapCursor h m k v b = WrapCursor { 45 | unwrapCursor :: SUT.Class.Cursor h m k v b 46 | } 47 | 48 | type WrapBlobRef :: 49 | ((Type -> Type) -> Type -> Type -> Type -> Type) 50 | -> (Type -> Type) -> Type -> Type 51 | newtype WrapBlobRef h m b = WrapBlobRef { 52 | unwrapBlobRef :: SUT.Class.BlobRef h m b 53 | } 54 | 55 | deriving stock instance Show (SUT.Class.BlobRef h m b) => Show (WrapBlobRef h m b) 56 | deriving stock instance Eq (SUT.Class.BlobRef h m b) => Eq (WrapBlobRef h m b) 57 | 58 | type WrapBlob :: Type -> Type 59 | newtype WrapBlob b = WrapBlob { 60 | unwrapBlob :: b 61 | } 62 | deriving stock (Show, Eq) 63 | -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/BloomFilterAlloc.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/BloomFilterAlloc.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/BloomFilterAlloc.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/BloomFilterAlloc.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/DiskCachePolicy.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/DiskCachePolicy.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/DiskCachePolicy.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/DiskCachePolicy.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/DiskCachePolicy.C.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/DiskCachePolicy.C.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/FencePointerIndexType.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/FencePointerIndexType.B.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/IndexType.A.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/IndexType.B.snapshot.golden: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/LevelMergeType.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/LevelMergeType.B.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/MergeCredits.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | X -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/MergeDebt.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | X -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/MergePolicy.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/MergePolicyForLevel.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/MergePolicyForLevel.B.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/MergeSchedule.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/MergeSchedule.B.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/NominalCredits.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | * -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/NominalDebt.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | X -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/RunBloomFilterAlloc.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/RunBloomFilterAlloc.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/RunBloomFilterAlloc.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/RunBloomFilterAlloc.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/RunDataCaching.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/RunDataCaching.B.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/RunNumber.A.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/RunParams.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/RunParams.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SizeRatio.A.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapIncomingRun_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapIncomingRun_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapIncomingRun_SnapshotRun.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapIncomingRun_SnapshotRun.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapLevel_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapLevel_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapLevels_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapLevels_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapMergingRun_LevelMergeType_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapMergingRun_LevelMergeType_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapMergingRun_LevelMergeType_SnapshotRun.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapMergingRun_LevelMergeType_SnapshotRun.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapMergingRun_TreeMergeType_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapMergingRun_TreeMergeType_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapMergingRun_TreeMergeType_SnapshotRun.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapMergingRun_TreeMergeType_SnapshotRun.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapMergingTreeState_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapMergingTreeState_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapMergingTreeState_SnapshotRun.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapMergingTreeState_SnapshotRun.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapMergingTreeState_SnapshotRun.C.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapMergingTreeState_SnapshotRun.C.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapMergingTree_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapMergingTree_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapPendingMerge_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapPendingMerge_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapPendingMerge_SnapshotRun.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapPendingMerge_SnapshotRun.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapPreExistingRun_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapPreExistingRun_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapPreExistingRun_SnapshotRun.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapPreExistingRun_SnapshotRun.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapshotLabel.A.snapshot.golden: -------------------------------------------------------------------------------- 1 | qUserProvidedLabel -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapshotLabel.B.snapshot.golden: -------------------------------------------------------------------------------- 1 | ` -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapshotMetaData.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapshotMetaData.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/TableConfig.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/TableConfig.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/TreeMergeType.A.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/TreeMergeType.B.snapshot.golden: -------------------------------------------------------------------------------- 1 |  -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/Vector_SnapshotRun.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/Vector_SnapshotRun.A.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/Vector_SnapshotRun.B.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/Vector_SnapshotRun.B.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/Vector_SnapshotRun.C.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/Vector_SnapshotRun.C.snapshot.golden -------------------------------------------------------------------------------- /test/golden-file-data/snapshot-codec/WriteBufferAlloc.A.snapshot.golden: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntersectMBO/lsm-tree/aa04099d65b9d67b0d54c479d4c83aa78318ddb4/test/golden-file-data/snapshot-codec/WriteBufferAlloc.A.snapshot.golden -------------------------------------------------------------------------------- /test/map-range-test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | module Main (main) where 4 | 5 | import Data.ByteString (ByteString) 6 | import Data.Map (Map) 7 | import qualified Data.Map as Map 8 | import Database.LSMTree.Internal.Map.Range (Bound (..), Clusive (..), 9 | rangeLookup) 10 | import Test.QuickCheck (Arbitrary (..), Property, elements, frequency, 11 | (===)) 12 | import Test.Tasty (defaultMain, testGroup) 13 | import Test.Tasty.HUnit (testCase, (@?=)) 14 | import Test.Tasty.QuickCheck (testProperty) 15 | 16 | main :: IO () 17 | main = defaultMain $ testGroup "map-range-test" 18 | [ testProperty "model" prop 19 | , testCase "example1" $ do 20 | let m = Map.fromList [(0 :: Int, 'x'), (2, 'y')] 21 | 22 | rangeLookup (Bound 0 Inclusive) (Bound 1 Inclusive) m @?= [(0, 'x')] 23 | 24 | , testCase "example2" $ do 25 | let m = Map.fromList [("\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH" :: ByteString,'x')] 26 | 27 | let lb = Bound "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH" Inclusive 28 | ub = Bound "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX" Inclusive 29 | 30 | rangeLookup lb ub m @?= [("\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH",'x')] 31 | 32 | , testCase "unordered-bounds" $ do 33 | let m = Map.fromList [('x', "ex"), ('y', "why" :: String)] 34 | 35 | -- if lower bound is greater than upper bound empty list is returned. 36 | rangeLookup (Bound 'z' Inclusive) (Bound 'a' Inclusive) m @?= [] 37 | naiveRangeLookup (Bound 'z' Inclusive) (Bound 'a' Inclusive) m @?= [] 38 | ] 39 | 40 | prop :: Bound Int -> Bound Int -> Map Int Int -> Property 41 | prop lb ub m = 42 | rangeLookup lb ub m === naiveRangeLookup lb ub m 43 | 44 | naiveRangeLookup :: 45 | Ord k 46 | => Bound k -- ^ lower bound 47 | -> Bound k -- ^ upper bound 48 | -> Map k v 49 | -> [(k, v)] 50 | naiveRangeLookup lb ub m = 51 | [ p 52 | | p@(k, _) <- Map.toList m 53 | , evalLowerBound lb k 54 | , evalUpperBound ub k 55 | ] 56 | 57 | evalLowerBound :: Ord k => Bound k -> k -> Bool 58 | evalLowerBound NoBound _ = True 59 | evalLowerBound (Bound b Exclusive) k = b < k 60 | evalLowerBound (Bound b Inclusive) k = b <= k 61 | 62 | evalUpperBound :: Ord k => Bound k -> k -> Bool 63 | evalUpperBound NoBound _ = True 64 | evalUpperBound (Bound b Exclusive) k = k < b 65 | evalUpperBound (Bound b Inclusive) k = k <= b 66 | 67 | instance Arbitrary k => Arbitrary (Bound k) where 68 | arbitrary = frequency 69 | [ (1, pure NoBound) 70 | , (20, Bound <$> arbitrary <*> arbitrary) 71 | ] 72 | 73 | shrink NoBound = [] 74 | shrink (Bound k b) = NoBound : map (`Bound` b) (shrink k) 75 | 76 | instance Arbitrary Clusive where 77 | arbitrary = elements [Exclusive, Inclusive] 78 | -------------------------------------------------------------------------------- /xxhash/include/HsXXHash.h: -------------------------------------------------------------------------------- 1 | #ifndef HS_XXHASH 2 | #define HS_XXHASH 3 | 4 | #include 5 | 6 | #define XXH_INLINE_ALL 7 | #include "xxhash.h" 8 | 9 | #define hs_XXH3_sizeof_state_s sizeof(struct XXH3_state_s) 10 | 11 | static inline uint64_t hs_XXH3_64bits_withSeed_offset(const uint8_t *ptr, size_t off, size_t len, uint64_t seed) { 12 | return XXH3_64bits_withSeed(ptr + off, len, seed); 13 | } 14 | 15 | static inline uint64_t hs_XXH3_64bits_withSeed_u64(uint64_t val, uint64_t seed) { 16 | return XXH3_64bits_withSeed(&val, sizeof(val), seed); 17 | } 18 | 19 | static inline uint64_t hs_XXH3_64bits_withSeed_u32(uint32_t val, uint64_t seed) { 20 | return XXH3_64bits_withSeed(&val, sizeof(val), seed); 21 | } 22 | 23 | static inline void hs_XXH3_64bits_update_offset(XXH3_state_t *statePtr, const uint8_t *ptr, size_t off, size_t len) { 24 | XXH3_64bits_update(statePtr, ptr + off, len); 25 | } 26 | 27 | static inline void hs_XXH3_64bits_update_u64(XXH3_state_t *statePtr, uint64_t val) { 28 | XXH3_64bits_update(statePtr, &val, sizeof(val)); 29 | } 30 | 31 | static inline void hs_XXH3_64bits_update_u32(XXH3_state_t *statePtr, uint32_t val) { 32 | XXH3_64bits_update(statePtr, &val, sizeof(val)); 33 | } 34 | 35 | #endif /* HS_XXHASH */ 36 | -------------------------------------------------------------------------------- /xxhash/src/FFI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CApiFFI #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnliftedFFITypes #-} 4 | module FFI ( 5 | -- * One shot 6 | unsafe_xxh3_64bit_withSeed_ptr, 7 | unsafe_xxh3_64bit_withSeed_ba, 8 | unsafe_xxh3_64bit_withSeed_u64, 9 | unsafe_xxh3_64bit_withSeed_u32, 10 | -- * Incremental 11 | unsafe_xxh3_sizeof_state, 12 | unsafe_xxh3_initState, 13 | unsafe_xxh3_64bit_reset_withSeed, 14 | unsafe_xxh3_64bit_digest, 15 | unsafe_xxh3_64bit_update_ptr, 16 | unsafe_xxh3_64bit_update_ba, 17 | unsafe_xxh3_64bit_update_u64, 18 | unsafe_xxh3_64bit_update_u32, 19 | ) where 20 | 21 | import Data.Word (Word32, Word64, Word8) 22 | import Foreign.C.Types (CInt (..), CSize (..)) 23 | import Foreign.Ptr (Ptr) 24 | import GHC.Exts (ByteArray#, MutableByteArray#) 25 | 26 | -- Note: we use unsafe FFI calls, as we expect our use case to be hashing only small data (<1kb, at most 4k). 27 | 28 | ------------------------------------------------------------------------------- 29 | -- OneShot 30 | ------------------------------------------------------------------------------- 31 | 32 | foreign import capi unsafe "HsXXHash.h XXH3_64bits_withSeed" 33 | unsafe_xxh3_64bit_withSeed_ptr :: Ptr Word8 -> CSize -> Word64 -> IO Word64 34 | 35 | foreign import capi unsafe "HsXXHash.h hs_XXH3_64bits_withSeed_offset" 36 | unsafe_xxh3_64bit_withSeed_ba :: ByteArray# -> CSize -> CSize -> Word64 -> Word64 37 | 38 | foreign import capi unsafe "HsXXHash.h hs_XXH3_64bits_withSeed_u64" 39 | unsafe_xxh3_64bit_withSeed_u64 :: Word64 -> Word64 -> Word64 40 | 41 | foreign import capi unsafe "HsXXHash.h hs_XXH3_64bits_withSeed_u32" 42 | unsafe_xxh3_64bit_withSeed_u32 :: Word32 -> Word64 -> Word64 43 | 44 | ------------------------------------------------------------------------------- 45 | -- Incremental 46 | ------------------------------------------------------------------------------- 47 | 48 | -- reset and update functions return OK/Error 49 | -- we ignore that: 50 | -- * reset errors only on NULL state 51 | -- * update cannot even error 52 | 53 | foreign import capi unsafe "HsXXHash.h value hs_XXH3_sizeof_state_s" 54 | unsafe_xxh3_sizeof_state :: Int 55 | 56 | foreign import capi unsafe "HsXXHash.h XXH3_INITSTATE" 57 | unsafe_xxh3_initState :: MutableByteArray# s -> IO () 58 | 59 | foreign import capi unsafe "HsXXHash.h XXH3_64bits_reset_withSeed" 60 | unsafe_xxh3_64bit_reset_withSeed :: MutableByteArray# s -> Word64 -> IO () 61 | 62 | foreign import capi unsafe "HsXXHash.h XXH3_64bits_digest" 63 | unsafe_xxh3_64bit_digest :: MutableByteArray# s -> IO Word64 64 | 65 | foreign import capi unsafe "HsXXHash.h XXH3_64bits_update" 66 | unsafe_xxh3_64bit_update_ptr :: MutableByteArray# s -> Ptr Word8 -> CSize -> IO () 67 | 68 | foreign import capi unsafe "HsXXHash.h hs_XXH3_64bits_update_offset" 69 | unsafe_xxh3_64bit_update_ba :: MutableByteArray# s -> ByteArray# -> CSize -> CSize -> IO () 70 | 71 | foreign import capi unsafe "HsXXHash.h hs_XXH3_64bits_update_u64" 72 | unsafe_xxh3_64bit_update_u64 :: MutableByteArray# s -> Word64 -> IO () 73 | 74 | foreign import capi unsafe "HsXXHash.h hs_XXH3_64bits_update_u32" 75 | unsafe_xxh3_64bit_update_u32 :: MutableByteArray# s -> Word32 -> IO () 76 | -------------------------------------------------------------------------------- /xxhash/src/XXH3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MagicHash #-} 3 | 4 | module XXH3 ( 5 | -- * One shot 6 | xxh3_64bit_withSeed_bs, 7 | xxh3_64bit_withSeed_ba, 8 | xxh3_64bit_withSeed_w64, 9 | xxh3_64bit_withSeed_w32, 10 | -- * Incremental 11 | XXH3_State, 12 | xxh3_64bit_createState, 13 | xxh3_64bit_reset_withSeed, 14 | xxh3_64bit_digest, 15 | xxh3_64bit_update_bs, 16 | xxh3_64bit_update_ba, 17 | xxh3_64bit_update_w64, 18 | xxh3_64bit_update_w32, 19 | ) where 20 | 21 | import Control.Monad (unless) 22 | import Control.Monad.ST (ST) 23 | import Control.Monad.ST.Unsafe (unsafeIOToST) 24 | import Data.ByteString.Internal (ByteString (..), 25 | accursedUnutterablePerformIO) 26 | import Data.Coerce (coerce) 27 | import qualified Data.Primitive as P 28 | import Data.Primitive.ByteArray (ByteArray (..)) 29 | import Data.Word (Word32, Word64) 30 | import Foreign.ForeignPtr 31 | import GHC.Exts (MutableByteArray#) 32 | import GHC.ForeignPtr 33 | 34 | import FFI 35 | 36 | {-# INLINE withFP #-} 37 | withFP :: ForeignPtr a -> (P.Ptr a -> IO b) -> IO b 38 | withFP = unsafeWithForeignPtr 39 | 40 | ------------------------------------------------------------------------------- 41 | -- OneShot 42 | ------------------------------------------------------------------------------- 43 | 44 | -- | Hash 'ByteString'. 45 | xxh3_64bit_withSeed_bs :: ByteString -> Word64 -> Word64 46 | xxh3_64bit_withSeed_bs (BS fptr len) !salt = accursedUnutterablePerformIO $ 47 | withFP fptr $ \ptr -> 48 | unsafe_xxh3_64bit_withSeed_ptr ptr (fromIntegral len) salt 49 | 50 | -- | Hash (part of) 'ByteArray'. 51 | xxh3_64bit_withSeed_ba :: ByteArray -> Int -> Int -> Word64 -> Word64 52 | xxh3_64bit_withSeed_ba (ByteArray ba) !off !len !salt = 53 | unsafe_xxh3_64bit_withSeed_ba ba (fromIntegral off) (fromIntegral len) salt 54 | 55 | -- | Hash 'Word64'. 56 | xxh3_64bit_withSeed_w64 :: Word64 -> Word64 -> Word64 57 | xxh3_64bit_withSeed_w64 !x !salt = 58 | unsafe_xxh3_64bit_withSeed_u64 x salt 59 | 60 | -- | Hash 'Word32'. 61 | xxh3_64bit_withSeed_w32 :: Word32 -> Word64 -> Word64 62 | xxh3_64bit_withSeed_w32 !x !salt = 63 | unsafe_xxh3_64bit_withSeed_u32 x salt 64 | 65 | ------------------------------------------------------------------------------- 66 | -- Incremental 67 | ------------------------------------------------------------------------------- 68 | 69 | -- | Mutable XXH3 state. 70 | data XXH3_State s = XXH3 (MutableByteArray# s) 71 | 72 | -- | Create 'XXH3_State'. 73 | xxh3_64bit_createState :: forall s. ST s (XXH3_State s) 74 | xxh3_64bit_createState = do 75 | -- aligned alloc, otherwise we get segfaults. 76 | -- see XXH3_createState implementation 77 | P.MutableByteArray ba <- P.newAlignedPinnedByteArray unsafe_xxh3_sizeof_state 64 78 | unsafeIOToST (unsafe_xxh3_initState ba) 79 | pure (XXH3 ba) 80 | 81 | -- | Reset 'XXH3_State' with a seed. 82 | xxh3_64bit_reset_withSeed :: XXH3_State s -> Word64 -> ST s () 83 | xxh3_64bit_reset_withSeed (XXH3 s) seed = do 84 | unsafeIOToST (unsafe_xxh3_64bit_reset_withSeed s seed) 85 | 86 | -- | Return a hash value from a 'XXH3_State'. 87 | -- 88 | -- Doesn't mutate given state, so you can update, digest and update again. 89 | xxh3_64bit_digest :: XXH3_State s -> ST s Word64 90 | xxh3_64bit_digest (XXH3 s) = 91 | unsafeIOToST (unsafe_xxh3_64bit_digest s) 92 | 93 | -- | Update 'XXH3_State' with 'ByteString'. 94 | xxh3_64bit_update_bs :: XXH3_State s -> ByteString -> ST s () 95 | xxh3_64bit_update_bs (XXH3 s) (BS fptr len) = unsafeIOToST $ 96 | withFP fptr $ \ptr -> 97 | unsafe_xxh3_64bit_update_ptr s ptr (fromIntegral len) 98 | 99 | -- | Update 'XXH3_State' with (part of) 'ByteArray' 100 | xxh3_64bit_update_ba :: XXH3_State s -> ByteArray -> Int -> Int -> ST s () 101 | xxh3_64bit_update_ba (XXH3 s) (ByteArray ba) !off !len = unsafeIOToST $ 102 | unsafe_xxh3_64bit_update_ba s ba (fromIntegral off) (fromIntegral len) 103 | 104 | -- | Update 'XXH3_State' with 'Word64'. 105 | xxh3_64bit_update_w64 :: XXH3_State s -> Word64 -> ST s () 106 | xxh3_64bit_update_w64 (XXH3 s) w64 = unsafeIOToST $ 107 | unsafe_xxh3_64bit_update_u64 s w64 108 | 109 | -- | Update 'XXH3_State' with 'Word32'. 110 | xxh3_64bit_update_w32 :: XXH3_State s -> Word32 -> ST s () 111 | xxh3_64bit_update_w32 (XXH3 s) w32 = unsafeIOToST $ 112 | unsafe_xxh3_64bit_update_u32 s w32 113 | -------------------------------------------------------------------------------- /xxhash/tests/xxhash-tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | module Main (main) where 3 | 4 | import Control.Monad.ST (runST) 5 | import qualified Data.ByteString as BS 6 | import qualified Data.Primitive as P 7 | import Data.Word (Word32, Word64) 8 | import Test.Tasty (defaultMain, testGroup) 9 | import Test.Tasty.HUnit (testCase, (@=?)) 10 | import Test.Tasty.QuickCheck (testProperty, (===)) 11 | 12 | import XXH3 13 | 14 | main :: IO () 15 | main = defaultMain $ testGroup "xxhash" 16 | [ testGroup "oneshot" 17 | [ testProperty "w64-ref" $ \w salt -> 18 | xxh3_64bit_withSeed_w64 w salt === xxh3_64bit_withSeed_w64_ref w salt 19 | , testCase "w64-examples" $ do 20 | xxh3_64bit_withSeed_w64 0 0 @=? 0xc77b_3abb_6f87_acd9 21 | xxh3_64bit_withSeed_w64 0x12 1 @=? 0xbba4_8522_c425_46b2 22 | xxh3_64bit_withSeed_w64 0x2100_0000_0000_0000 0 @=? 0xb7cb_e42a_e127_8055 23 | xxh3_64bit_withSeed_w64 0x1eb6e9 0 @=? 0x8e_adc3_1b56 24 | 25 | , testProperty "w32-ref" $ \w salt -> 26 | xxh3_64bit_withSeed_w32 w salt === xxh3_64bit_withSeed_w32_ref w salt 27 | 28 | , testCase "w32-examples" $ do 29 | xxh3_64bit_withSeed_w32 0 0 @=? 0x48b2_c926_16fc_193d 30 | xxh3_64bit_withSeed_w32 0x12 1 @=? 0x2870_1df3_2a21_6ad3 31 | 32 | ] 33 | 34 | , testGroup "incremental" 35 | [ testProperty "empty" $ \seed -> do 36 | let expected = xxh3_64bit_withSeed_bs BS.empty seed 37 | let actual = runST $ do 38 | s <- xxh3_64bit_createState 39 | xxh3_64bit_reset_withSeed s seed 40 | xxh3_64bit_digest s 41 | 42 | actual === expected 43 | 44 | , testProperty "bs" $ \w8s seed -> do 45 | let bs = BS.pack w8s 46 | let expected = xxh3_64bit_withSeed_bs bs seed 47 | let actual = runST $ do 48 | s <- xxh3_64bit_createState 49 | xxh3_64bit_reset_withSeed s seed 50 | xxh3_64bit_update_bs s bs 51 | xxh3_64bit_digest s 52 | 53 | actual === expected 54 | ] 55 | ] 56 | 57 | xxh3_64bit_withSeed_w64_ref :: Word64 -> Word64 -> Word64 58 | xxh3_64bit_withSeed_w64_ref w salt = case P.primArrayFromList [w] of 59 | P.PrimArray ba -> xxh3_64bit_withSeed_ba (P.ByteArray ba) 0 8 salt 60 | 61 | xxh3_64bit_withSeed_w32_ref :: Word32 -> Word64 -> Word64 62 | xxh3_64bit_withSeed_w32_ref w salt = case P.primArrayFromList [w] of 63 | P.PrimArray ba -> xxh3_64bit_withSeed_ba (P.ByteArray ba) 0 4 salt 64 | -------------------------------------------------------------------------------- /xxhash/xxHash-0.8.2/LICENSE-xxHash: -------------------------------------------------------------------------------- 1 | xxHash Library 2 | Copyright (c) 2012-2021 Yann Collet 3 | All rights reserved. 4 | 5 | BSD 2-Clause License (https://www.opensource.org/licenses/bsd-license.php) 6 | 7 | Redistribution and use in source and binary forms, with or without modification, 8 | are permitted provided that the following conditions are met: 9 | 10 | * Redistributions of source code must retain the above copyright notice, this 11 | list of conditions and the following disclaimer. 12 | 13 | * Redistributions in binary form must reproduce the above copyright notice, this 14 | list of conditions and the following disclaimer in the documentation and/or 15 | other materials provided with the distribution. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 21 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 24 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | --------------------------------------------------------------------------------