delta-store (empty) → 1.0.0.0
raw patch · 11 files changed
+1820/−0 lines, 11 filesdep +QuickCheckdep +basedep +delta-store
Dependencies added: QuickCheck, base, delta-store, delta-types, hspec, io-classes, io-sim, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +202/−0
- README.md +7/−0
- delta-store.cabal +82/−0
- src/Data/DBVar.hs +177/−0
- src/Data/Delta/Update.hs +165/−0
- src/Data/Store.hs +687/−0
- src/Test/Data/Store.hs +235/−0
- test/unit/Data/DBVarSpec.hs +152/−0
- test/unit/Data/StoreSpec.hs +107/−0
- test/unit/Main.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for delta-store++## 1.0.0.0 — 2025-03-21++* Initial version
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ README.md view
@@ -0,0 +1,7 @@+## Overview++This package provides facilities for storing Haskell values+in persistent storage as opposed to in volatile memory.+Uses [delta-types][].++ [delta-types]: https://github.com/cardano-foundation/delta-types/
+ delta-store.cabal view
@@ -0,0 +1,82 @@+cabal-version: 2.2+name: delta-store+version: 1.0.0.0+synopsis: Facilities for storing a Haskell value, using delta types.+description:+ This package provides facilities for storing Haskell values+ in persistent storage as opposed to in volatile memory.+ .+ * "Data.Store" — store values outside of volatile memory (RAM).+ .+ * "Data.DBVar" — mutable variable that mirrors its value in a 'Store'.++homepage: https://github.com/cardano-foundation/delta-types+license: Apache-2.0+license-file: LICENSE+author: Cardano Foundation (High Assurance Lab)+maintainer: hal@cardanofoundation.org+copyright: 2021-2023 IOHK, 2024-2025 Cardano Foundation+category: Data Structures+build-type: Simple+tested-with: GHC ==8.10.7 || ==9.6.6 || ==9.10.1+extra-doc-files:+ CHANGELOG.md+ README.md++common language+ default-language: Haskell2010+ default-extensions:+ NoImplicitPrelude+ OverloadedStrings++common opts-lib+ ghc-options:+ -Wall -Wcompat -Wredundant-constraints -Wincomplete-uni-patterns+ -Wincomplete-record-updates++ if flag(release)+ ghc-options: -O2 -Werror++common opts-exe+ import: opts-lib+ ghc-options: -threaded -rtsopts++flag release+ description: Enable optimization and `-Werror`+ default: False+ manual: True++library+ import: language, opts-lib+ hs-source-dirs: src+ build-depends:+ , base >=4.14 && <5+ , delta-types >=1.0.0.0 && <1.1+ , io-classes >=1.4.0.0 && <1.8+ , QuickCheck >=2.14 && <2.16+ , transformers >=0.6.1.0 && <0.7++ exposed-modules:+ Data.DBVar+ Data.Delta.Update+ Data.Store+ Test.Data.Store++test-suite unit+ import: language, opts-exe+ type: exitcode-stdio-1.0+ hs-source-dirs: test/unit+ main-is: Main.hs+ build-depends:+ , base+ , delta-store+ , delta-types+ , hspec >=2.11.0 && <2.12+ , io-classes+ , io-sim >=1.4.0.0 && <1.8+ , QuickCheck++ build-tool-depends: hspec-discover:hspec-discover+ other-modules:+ Data.DBVarSpec+ Data.StoreSpec
+ src/Data/DBVar.hs view
@@ -0,0 +1,177 @@+{-# OPTIONS_GHC -Wno-redundant-constraints#-}+-- We intentionally specify more constraints than necessary for some exports.+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-|+Copyright : © 2022-2023 IOHK, 2023-2025 Cardano Foundation+License : Apache-2.0+Description : Mutable variable that mirrors its value in a 'Data.Store.Store'.++'DBVar' represents a mutable variable that stores one Haskell value+in volatile memory (RAM),+but mirrors the value to persistent storage,+for example to a database on disk.++* 'Store' represents the storage facility to which the variable is mirrored.+* Read-access is from volatile memory and highly concurrent.+* Updates are incremental and use delta types, see "Data.Delta".+-}+module Data.DBVar (+ DBVar+ , readDBVar+ , updateDBVar+ , modifyDBVar+ , modifyDBMaybe+ , initDBVar+ , loadDBVar+ ) where++import Prelude++import Control.Concurrent.Class.MonadSTM+ ( MonadSTM+ , atomically+ , newTVarIO+ , readTVar+ , readTVarIO+ , retry+ , writeTVar+ )+import Control.Monad.Class.MonadThrow+ ( MonadEvaluate+ , MonadMask+ , MonadThrow+ , bracket+ , evaluate+ , mask+ , throwIO+ )+import Data.Delta+ ( Delta (..)+ )+import Data.Store+ ( Store (..)+ , UpdateStore+ )++{-------------------------------------------------------------------------------+ DBVar+-------------------------------------------------------------------------------}+-- | A 'DBVar'@ m delta@ is a mutable reference to a Haskell value of type @a@.+-- The type @delta@ is a delta type for this value type @a@,+-- that is we have @a ~ @'Base'@ delta@.+--+-- The Haskell value is cached in memory, in weak head normal form (WHNF).+-- However, whenever the value is updated, a copy of the value will be written+-- to persistent storage like a file or database on disk;+-- the specific storage facility is represented by a 'Store'.+-- For efficient updates, the delta type @delta@ is used in the update.+--+-- Concurrency: 'DBVar' fully supports concurrent reads and updates.+--+-- * Updates are atomic and will block other updates.+-- * Reads will /not/ be blocked during an update+-- (except for a small moment where the new value atomically+-- replaces the old one).+data DBVar m delta = DBVar+ { readDBVar_ :: m (Base delta)+ , modifyDBMaybe_ :: forall b. (Base delta -> (Maybe delta, b)) -> m b+ }++-- | Read the current value of the 'DBVar'.+readDBVar :: (Delta da, a ~ Base da) => DBVar m da -> m a+readDBVar = readDBVar_++-- | Update the value of the 'DBVar' using a delta type.+--+-- The new value will be evaluated to weak head normal form.+updateDBVar :: (Delta da, Monad m) => DBVar m da -> da -> m ()+updateDBVar var delta = modifyDBMaybe var $ \_ -> (Just delta,())++-- | Modify the value in a 'DBVar'.+--+-- The new value will be evaluated to weak head normal form (WHNF).+modifyDBVar+ :: (Delta da, Monad m, a ~ Base da)+ => DBVar m da -> (a -> (da, b)) -> m b+modifyDBVar var f = modifyDBMaybe var $ \a -> let (da,b) = f a in (Just da,b)++-- | Maybe modify the value in a 'DBVar'+--+-- If updated,+-- the new value will be evaluated to weak head normal form (WHNF).+modifyDBMaybe+ :: (Delta da, Monad m, a ~ Base da)+ => DBVar m da -> forall b. (a -> (Maybe da, b)) -> m b+modifyDBMaybe = modifyDBMaybe_++-- | Initialize a new 'DBVar' that mirrors to a given 'Store'.+initDBVar+ :: ( MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m+ , Delta da, a ~ Base da+ )+ => UpdateStore m da -- ^ 'Store' for mirroring.+ -> a -- ^ Initial value.+ -> m (DBVar m da)+initDBVar store v = do+ writeS store v+ newWithCache (updateS store . Just) v++-- | Create a 'DBVar' that mirrors to a given 'Store',+-- and also loads its initial value from there.+-- Throws an exception if the value cannot be loaded.+loadDBVar+ :: ( MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m+ , Delta da+ )+ => UpdateStore m da -- ^ 'Store' for mirroring and for reading the initial value.+ -> m (DBVar m da)+loadDBVar store =+ loadS store >>= \case+ Left e -> throwIO e+ Right a -> newWithCache (updateS store . Just) a++-- | Create 'DBVar' from an initial value and an update function+-- using a 'TVar' as in-memory cache.+--+-- Space: The value in the 'TVar' will be evaluated to weak head normal form.+--+-- Concurrency: The update function needs to be atomic even in the presence+-- of asynchronous exceptions.+newWithCache+ :: ( MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m+ , Delta da, a ~ Base da+ )+ => (a -> da -> m ()) -> a -> m (DBVar m da)+newWithCache update a = do+ cache <- newTVarIO a+ locked <- newTVarIO False -- lock for updating the cache+ pure $ DBVar+ { readDBVar_ = readTVarIO cache+ , modifyDBMaybe_ = \f -> do+ let before = atomically $ do+ readTVar locked >>= \case+ True -> retry+ False -> do+ writeTVar locked True+ readTVar cache+ after _ = atomically $ writeTVar locked False+ action old = do+ let (mdelta, b) = f old+ case mdelta of+ Nothing -> pure ()+ Just delta -> do+ new <- evaluate $ apply delta old+ mask $ \restore -> do+ -- We mask asynchronous exceptions here+ -- to ensure that the TVar will be updated+ -- whenever @update@ succeeds without exception.+ restore $ update old delta+ atomically $ writeTVar cache new+ pure b+ bracket before after action+ }
+ src/Data/Delta/Update.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-|+Copyright : © 2022-2023 IOHK, 2023-2025 Cardano Foundation+License : Apache-2.0+Description : Computations that produce a delta and a result.++'Update' represents a computation which produces a delta and a result.++Similar to the 'Control.Monad.Trans.State.State' monad,+but involves a 'Delta' type.++Useful for composing updates to a 'DBVar', via 'onDBVar'.++Note: This module is preliminary.+-}+module Data.Delta.Update (+ -- * Update+ -- ** Type+ Update+ -- ** View+ , runUpdate+ , applyUpdate+ , onDBVar+ -- ** Combinators+ , nop+ , update+ , updateWithResult+ -- ** Helpers+ , updateWithError+ , updateWithResultAndError+ , updateMany+ , updateField+ ) where++import Prelude++import Data.DBVar+ ( DBVar+ , modifyDBMaybe+ )+import Data.Delta+ ( Delta (..)+ )++{-------------------------------------------------------------------------------+ Update+ Type, View+-------------------------------------------------------------------------------}+-- | A computation which inspects a value @a ~ Base da@+-- and produces a delta @da@ and a result of type @r@.+--+-- Related to the 'Control.Monad.Trans.State.State' monad:+-- The type @'Update' ('Data.Delta.Core.Replace' s) r@ is essentially equivalent to+-- @'Control.Monad.Trans.State.State' s r@.+newtype Update da r = Update { runUpdate_ :: Base da -> (Maybe da, r) }++-- | Run the 'Update' computation.+runUpdate :: (a ~ Base da) => Update da r -> a -> (Maybe da, r)+runUpdate = runUpdate_++-- | Semantics.+applyUpdate+ :: (Delta da, a ~ Base da)+ => Update da r -> a -> (a,r)+applyUpdate (Update g) a =+ case g a of+ (da, r) -> (da `apply` a, r)++-- | Apply an 'Update' to a 'DBVar'.+onDBVar+ :: (Monad m, Delta da)+ => DBVar m da -> Update da r -> m r+onDBVar dbvar = modifyDBMaybe dbvar . runUpdate++{-------------------------------------------------------------------------------+ Combinators+-------------------------------------------------------------------------------}+-- | Map results.+instance Functor (Update da) where+ fmap f (Update g) = Update $ \a ->+ case g a of+ (da, r) -> (da, f r)++-- | No operation.+--+-- Use the 'Functor' instance, specifically '(<$)'+-- to add results other than '()'.+nop :: Update da ()+nop = Update $ const (Nothing, ())++-- | Compute a delta.+update :: (a ~ Base da) => (a -> da) -> Update da ()+update f = Update $ \a -> (Just (f a), ())++-- | Compute a delta with result.+updateWithResult+ :: (a ~ Base da)+ => (a -> (da, r)) -- Delta with result.+ -> Update da r+updateWithResult f = Update $ \a ->+ case f a of+ (da, r) -> (Just da, r)++-- | Compute a delta or fail.+updateWithError+ :: (a ~ Base da)+ => (a -> Either e da)+ -> Update da (Either e ())+updateWithError f = Update $ \a ->+ case f a of+ Left e -> (Nothing, Left e)+ Right da -> (Just da, Right ())++-- | Compute a delta with result or fail.+updateWithResultAndError+ :: (a ~ Base da)+ => (a -> Either e (da, r))+ -> Update da (Either e r)+updateWithResultAndError f = Update $ \a ->+ case f a of+ Left e -> (Nothing, Left e)+ Right (da,r) -> (Just da, Right r)++-- | Lift an update for a single delta to a list of deltas.+updateMany+ :: Update da r+ -> Update [da] r+updateMany (Update g) = Update $ \a ->+ case g a of+ (Nothing, r) -> (Nothing, r)+ (Just da, r) -> (Just [da], r)++{- | Helper function for lifting the 'Update' from a+record field to the record.++Example:++@+data Pair a b = Pair a b+first :: Pair a b -> a++data DeltaPair da db+ = UpdateFirst da+ | UpdateSecond db++updateField first UpdateFirst+ :: (a -> Update da r)+ -> (Pair a b -> Update (DeltaPair da db) r)+@+-}+updateField+ :: (a ~ Base da, b ~ Base db)+ => (b -> a)+ -- ^ View field.+ -> (da -> db)+ -- ^ Lift delta to+ -> Update da r+ -> Update db r+updateField view embed (Update g) =+ Update $ lift . g . view+ where+ lift (mda, r) = (embed <$> mda, r)
+ src/Data/Store.hs view
@@ -0,0 +1,687 @@+-- We intentionally specify more constraints than necessary for some exports.+{-# OPTIONS_GHC -Wno-redundant-constraints#-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-|+Copyright : © 2022-2023 IOHK, 2023-2025 Cardano Foundation+License : Apache-2.0+Description : Store a value of a given type outside of volatile memory.++'Store' represents a facility for storing one value of a given type.+Typically, this type is a collection type,+for example 'Data.Map.Map'@ @'Integer'@ @'String',+so that we actually stores multiple values.++The key benefit of a 'Store' is that it can store the value+__outside of volatile memory (RAM)__ —+for example, the value can be stored in a database file on disk,+that is on persistent storage.++* Read-access is done on parts of the value, through a query GADT+ that is an instance of the 'Query' class.+ In this way, we do not need to load the stored value+ fully into volatile memory.+* Updates are incremental and use delta types, see "Data.Delta".+ In this way, we can modify the persistent storage incrementally.++Conversely, there is no need to use 'Store' if+the value only ever lives in volatile memory+— in this case, it is much simpler to use a plain Haskell value,+introduced with @let@, @where@, or as a function argument.+-}+module Data.Store (+ -- * Store, definition+ -- ** Type+ Store (..)++ -- ** Properties+ -- $Properties++ -- *** Laws: Load and Write+ -- $LoadWriteLaws++ -- *** Laws: Update+ -- $UpdateLaws++ -- *** Laws: Query+ -- $QueryLaws++ -- *** Monad+ -- $StoreMonad++ -- *** updateS, Maybe argument+ -- $updateS++ -- *** loadS, SomeException+ -- $EitherSomeException++ -- * Store, functions+ -- ** Query+ , Query (..)+ , Whole (..)++ -- ** Constructors+ , SimpleStore+ , mkSimpleStore+ , UpdateStore+ , mkUpdateStore+ , mkQueryStore++ -- ** Combinators+ , hoistStore+ , embedStore+ , pairStores+ , newCachedStore++ -- ** Helpers+ , updateLoad+ , loadWhenNothing++ -- ** Testing+ , embedStore'+ , newStore+ , NotInitialized (..)+ , updateSequence+ ) where++import Prelude++import Control.Applicative+ ( liftA2+ )+import Control.Concurrent.Class.MonadSTM+ ( MonadSTM+ , atomically+ , modifyTVar'+ , newTVarIO+ , readTVar+ , readTVarIO+ , retry+ , writeTVar+ )+import Control.Exception+ ( Exception+ , SomeException (..)+ , toException+ )+import Control.Monad+ ( foldM_+ , join+ )+import Control.Monad.Class.MonadThrow+ ( MonadEvaluate+ , MonadMask+ , MonadThrow+ , evaluate+ , finally+ , mask+ , throwIO+ )+import Data.Delta+ ( Delta (..)+ , Embedding+ , Embedding' (..)+ , Replace (..)+ )+import Data.Delta.Embedding+ ( inject+ , project+ )+import Data.Delta.Embedding.Internal+ ( Machine (..)+ )+import Data.Kind+ ( Type+ )+import GHC.Generics+ ( (:+:) (..)+ )++{-------------------------------------------------------------------------------+ Store+-------------------------------------------------------------------------------}+{- |+A 'Store' is a storage facility for Haskell values of type+@a ~ @'Base'@ da ~ @'World'@ qa@.++Typical use cases are a file or a database on the hard disk.++The purpose of the type parameters is:++* The monad @m@ encapsulates access to the storage space.+* The query type @qa@ represents the specialized queries+ that this store supports.+* The delta type @da@ is used for incremental updates.++If you care about one these aspects, but not the others,+we recommend to use a specialized type synonym+such as 'SimpleStore' or 'UpdateStore'.+-}+data Store m (qa :: Type -> Type) da = Store+ {+ -- | Load the value from the store into memory, or fail.+ --+ -- This operation can be expensive.+ loadS :: m (Either SomeException (Base da))+ -- | Write a value from memory into the store.+ , writeS :: Base da -> m ()+ -- | Update the value in the store+ -- incrementally by using a 'Delta' type @da@.+ --+ -- For effiency,+ -- the first argument may supply the current value in-memory.+ , updateS+ :: Maybe (Base da) -- old value, for performance+ -> da -- delta to new value+ -> m () -- write new value+ -- | Run a specialized 'Query' on the value in the store.+ --+ -- This operation can be less expensive than 'loadS',+ -- because the query may not need to load the whole value into memory.+ , queryS :: forall b. qa b -> m b+ }++{- $Properties+Any implementation of 'Store' is expected to satisfy the __properties__+specified in this section.+We make no attempt at enforcing these properties on the type-level.+However, the module "Test.Store" provides QuickCheck code for these+properties for automated testing.+-}++-- Note [LoadWriteLaws]+{- $LoadWriteLaws++The most fundamental operations on a 'Store' are++* 'loadS' — loads the value contained in the 'Store' into memory.+* 'writeS' — writes a value from memory into the 'Store'.++These two operations are characterized by the following design:++1. The store __need not contain__ a properly formatted __value__.++ Loading a value from the store may fail, and this is why 'loadS'+ has an 'Either' result.+ For example, if the 'Store' represents+ a file on disk, then the file may corrupted or in an incompatible+ file format when first opened.+ In such a case of failure, the result 'Left'@ (e :: @'SomeException'@)@+ is returned, where the exception @e@ gives more information+ about the failure.++ However, loading a value after writing it should always succeed,+ we have++ > writeS s a >> loadS s = pure (Right a)++2. The store is __redundant__.++ Two stores with different internal contents may contain+ the same value of type @a@.+ For example, two files with different whitespace+ may describe the same JSON value.+ In general, loading a value and writing it again may change the+ internal store contents, i.e.++ > loadS s >>= either (\_ -> pure ()) (writeS s) ≠ pure ()+-}++-- Note [UpdateLaws]+{- $UpdateLaws++In order to update the store content without loading all of it into memory,+'Store' supports the operation++* 'updateS' — updates the value contained in the 'Store' using a 'Delta' type.++This operation is characterized by the following law:++* Updating a store __commutes with 'apply'__.++ We have++ > updateS s (Just a) da >> loadS s = pure $ Right $ apply a da++ However, since the store is redundant, we often have++ > updateS s (Just a) da ≠ writeS s (apply a da)++The combination of 'loadS', 'writeS', 'updateS' has many similarities+with an 'Embedding' of delta types. However, the main difference+is that manipulating a 'Store' involves side effects.+-}++-- Note [QueryLaws]+{- $QueryLaws++In order to query parts of the store content+without loading all of it into memory,+'Store' supports the operation++* 'queryS' — run a specialized 'Query' on the value contained in the 'Store'.++This operation is characterized by the following law:++* Querying a store __commutes with 'query'__:++ > ∀q. query q <$> (loadS s >>= either throw pure) = queryS s q+-}++-- Note [updateS argument]+{- $updateS++The function 'updateS' applies a delta to the content of the 'Store'.+Depending on the implementation of the 'Store', this operation may+require large parts of the content to be loaded into memory,+which is expensive.+In some use cases such as 'Data.DBVar.DBVar', the value is already available+in memory and can be used for executing the update.+For these cases, the __first argument__ of 'updateS'+__may__ provide the __in-memory value__.+We expect that the following property holds:++> updateS s Nothing da+> =+> loadS s >>= \(Right a) -> updateS s (Just a) da++The helper 'loadWhenNothing' is useful for handling this argument.+-}++{- $StoreMonad++The monad @m@ in 'Store'@ m da@ provides the storage space for the value.+Put differently, we like to think of @m@ as a+'Control.Monad.Trans.State.State' monad whose state contains the value.+However, this monad @m@ could have __additional side effects__+such as exceptions, concurrency, non-determinism, and so on.+We would have to specify how a 'Store' should behave with regards to these+effects, which complicates matters significantly.+(In fact, the equality sign @=@ for the laws above has to be+interpreted "… equal effects as far as the 'Store' is concerned".+A proper approach to a specification would involve Hoare logic.)++For simplicity, we now assume that the monad @m@ only has+the effects __state__ and __exceptions__ —+we make no attempt at specifying how an implementation+should behave for concurrent usage of, say, 'updateS'.+This assumption ensures some composability of the 'Store' abstraction.+However, it also implies that choosing @m ~ @'Control.Monad.STM.STM'+results in specified semantics, whereas choosing @m ~ @'IO' can+result in unspecified behavior.+(TODO: Perhaps create a type class 'MonadSequential' to keep track+of this on the type level?)++More specifically, the interaction between 'Store' functions and+effects are as follows:++* __State__: The laws presented above specify the essentials+of how the store state changes. However, this specification is not complete,+other "expected" rules such as++ > writeS s a >> writeS s b = writeS s b++ etc. should also hold.++* __Exceptions__:++ * 'loadS' should not throw a synchronous exception,+ but return 'Left' instead.+ * 'queryS' should throw a synchronous exception iff 'loadS' returns 'Left'.+ Moving the error case into the monad @m@ simplifes the use of this operation.+ * 'writeS' and 'loadS' should not throw synchronous exceptions.+ However, in case they do throw an exception,+ the contents of the 'Store' should be treated as corrupted,+ and 'loadS' should return 'Left' subsequently.++* __Concurrency__: We do not specify behavior under concurrent operation.+ Concurrent access to a 'Store' is a frequent desideratum+ — but you will have to implement it yourself.++ One design pattern is to use a custom monad @m ~ MyMonad@+ that has a way of executing state changes atomically,++ > atomically :: MyMonad a -> IO a++ Specifically, @atomically@ either applies /all/ state changes,+ or /none/ of the state changes.+ For instance, SQL transactions can be used for this,+ see e.g. <https://www.sqlite.org/lang_transaction.html>.+ Then, you can implement a 'Store'@ MyMonad@ by composing smaller 'Store',+ and use @atomically@ in a scope where you want to use the 'Store'+ rather than implement it.++ Use 'hoistStore'@ atomically@ to map a 'Store'@ MyMonad@+ to a 'Store'@ IO@ where the monad has less atomicity.++* __Non-determinism__ or other effects: Here be dragons.++-}++-- Note [EitherSomeException]+{- $EitherSomeException++In the __error case__ that the store does not contain a value,+'loadS' returns a 'Left' value of type 'SomeException'.+This type is a disjoint sum of all possible+error types (that is, members of the 'Exception' class).++We could parametrize 'Store' by an additional type parameter @e@ representing+the possible error cases. However, we have opted to explore+a region of the design space where the number of type parameters+is kept to a minimum.++In fact, I would argue that making errors visible on the type level is not+very useful: we add much noise to the type level,+but we gain little type-safety in exchange.+Specifically, if we encounter an element of the 'SomeException' type that+we did not expect, we can always 'throw' it.+For example, consider the following code:++@+let ea :: Either SomeException ()+ ea = [..]+in+ case ea of+ Right _ -> "everything is ok"+ Left e -> case fromException e of+ Just (AssertionFailed _) -> "bad things happened"+ Nothing -> throw e+@++In this example, using the more specific type @ea :: Either AssertionFailed ()@+would have eliminated the 'Nothing' case.+However, this case has the sensible default value:+@throw e@, we rethrow the exception that we did not expect.+Ruling out this case on the type-level adds almost no value.+-}++{-------------------------------------------------------------------------------+ Constructors+-------------------------------------------------------------------------------}+{- HLINT ignore newStore "Use readTVarIO" -}+-- | An in-memory 'Store' from a mutable variable ('TVar').+-- Useful for testing.+newStore+ :: (MonadSTM m, MonadThrow m, Delta da, Query qa, Base da ~ World qa)+ => m (Store m qa da)+newStore = do+ ref <- newTVarIO $ Left $ toException NotInitialized+ let load = atomically (readTVar ref)+ pure $ Store+ { loadS = load+ , queryS = \q -> query q <$> (throwLeft =<< load)+ , writeS = atomically . writeTVar ref . Right+ , updateS = \_ -> atomically . modifyTVar' ref . fmap . apply+ }++-- | Failure that occurs when calling 'loadS' on a 'newStore' that is empty.+data NotInitialized = NotInitialized deriving (Eq, Show)+instance Exception NotInitialized++-- | A 'Store' which supports 'loadS' and 'writeS',+-- but no fancy query or update operations.+type SimpleStore m a = Store m (Whole a) (Replace a)++-- | @mkSimpleStore loadS writeS@ constructs a 'SimpleStore'+-- from the given operations.+mkSimpleStore+ :: forall m a+ . (Monad m, MonadThrow m)+ => m (Either SomeException a)+ -> (a -> m ())+ -> SimpleStore m a+mkSimpleStore loadS writeS =+ mkUpdateStore loadS writeS update'+ where+ update' _ (Replace a) = writeS a++-- | A 'Store' whose focus lies on updating the value rather than querying it.+type UpdateStore m da = Store m (Whole (Base da)) da++-- | @mkUpdateStore loadS writeS updateS@ constructs an 'UpdateStore'+-- from the given operations.+mkUpdateStore+ :: forall m a da+ . (Monad m, MonadThrow m, a ~ Base da, Delta da)+ => m (Either SomeException a)+ -> (a -> m ())+ -> (Maybe a -> da -> m ())+ -> UpdateStore m da+mkUpdateStore loadS writeS updateS =+ Store{loadS, queryS=query', writeS, updateS}+ where+ query' :: forall b. Whole a b -> m b+ query' Whole = loadS >>= throwLeft++-- | @mkQueryStore queryS store@ constructs a 'Store'+-- from a query and an 'UpdateStore'.+mkQueryStore :: forall m qa da+ . (MonadThrow m, Delta da, Query qa, Base da ~ World qa)+ => (forall b. qa b -> m b)+ -> UpdateStore m da+ -> Store m qa da+mkQueryStore queryS Store{loadS,writeS,updateS} =+ Store{queryS,loadS,writeS,updateS}++{-------------------------------------------------------------------------------+ Query+-------------------------------------------------------------------------------}+-- | A __query__ @qa b@ for the type @a ~ World qa@+-- corresponds to a function @a -> b@.+-- Put differently, a query allows us to extract some information of type @b@+-- from the larger type @a@.+--+-- Typically, instances of 'Query' are+-- generalized algebraic data types (GADT).+class Query qa where+ type family World qa+ query :: qa b -> World qa -> b++-- | The query that retrieves the whole value.+data Whole a b where+ Whole :: Whole a a++instance Query (Whole a) where+ type World (Whole a) = a+ query Whole a = a++{-------------------------------------------------------------------------------+ Combinators+-------------------------------------------------------------------------------}+-- | Add a caching layer to a 'Store'.+--+-- Access to the underlying 'Store' is enforced to be sequential,+-- but the cache can be accessed in parallel.+--+-- FIXME: There is still a small race condition where the cache+-- could be written twice before it is filled. 🤔+-- TODO: Think about whether it is really necessary to handle concurrency here.+-- I think the answer is "yes", but only because the mutable variables+-- provided by the monad @m@ do not work together with e.g. SQL transactions.+newCachedStore+ :: forall m qa da+ . ( MonadSTM m, MonadThrow m, MonadEvaluate m+ , Delta da, Query qa, Base da ~ World qa+ )+ => Store m qa da -> m (Store m qa da)+newCachedStore Store{loadS,writeS,updateS} = do+ -- Lock that puts loadS, writeS and updateS into sequence+ islocked <- newTVarIO False+ let withLock :: forall b. m b -> m b+ withLock action = do+ atomically $ readTVar islocked >>= \case+ True -> retry+ False -> writeTVar islocked True+ action `finally` atomically (writeTVar islocked False)++ -- Cache that need not be filled in the beginning+ cache <- newTVarIO (Nothing :: Maybe (Base da))+ let writeCache = writeTVar cache++ -- Load the value from the Store only if it is not cached and+ -- nobody else is writing to the store.+ let load :: m (Either SomeException (Base da))+ load = join $ atomically $ do+ ma <- readTVar cache+ case ma of+ Nothing -> readTVar islocked >>= \case+ True -> retry -- somebody is writing+ False -> pure $ withLock $ do+ ea <- loadS+ case ea of+ Left e -> pure $ Left e+ Right a -> do+ atomically $ writeCache $ Just a+ pure $ Right a+ Just a -> pure $ pure $ Right a++ pure $ Store+ { loadS = load+ , queryS = \q -> query q <$> (throwLeft =<< load)+ , writeS = \a -> withLock $ do+ atomically $ writeCache (Just a)+ writeS a+ , updateS = updateLoad load throwIO $ \old delta -> withLock $ do+ new <- evaluate $ apply delta old+ atomically $ writeCache $ Just new+ updateS (Just old) delta+ }++-- | Store one type in the 'Store' of another type by using an 'Embedding'.+embedStore :: (MonadSTM m, MonadMask m, Delta da)+ => Embedding da db -> UpdateStore m db -> m (UpdateStore m da)+embedStore embed bstore = do+ -- For reasons of efficiency, we have to store the 'Machine'+ -- that is created within the 'Embedding'.+ machine <- newTVarIO Nothing+ let readMachine = readTVarIO machine+ writeMachine = atomically . writeTVar machine . Just++ -- Operations of the result 'Store'.+ let load = loadS bstore >>= \case+ Left e -> pure $ Left e+ Right b -> case project embed b of+ Left e -> pure $ Left e+ Right (a,mab) -> do+ writeMachine mab+ pure $ Right a+ write a = do+ let mab = inject embed a+ mask $ \restore -> do+ restore $ writeS bstore (state_ mab)+ writeMachine mab+ update = updateLoad load throwIO $ \a da -> do+ readMachine >>= \case+ Nothing -> do -- we were missing the initial write+ write (apply da a)+ Just mab1 -> do -- advance the machine by one step+ let (db, mab2) = step_ mab1 (a,da)+ mask $ \restore -> do+ restore $ updateS bstore (Just $ state_ mab2) db+ writeMachine mab2+ pure $ mkUpdateStore load write update++-- | Store one type in the 'Store' of another type by using an 'Embedding'.+--+-- Note: This function is exported for testing and documentation only,+-- use the more efficient 'embedStore' instead.+embedStore'+ :: (Monad m, MonadThrow m)+ => Embedding' da db -> UpdateStore m db -> UpdateStore m da+embedStore' Embedding'{load,write,update} Store{loadS,writeS,updateS} =+ let+ loadL = (load =<<) <$> loadS+ updateL ma da = case ma of+ Just a -> loadS >>= \case+ Left _ -> pure ()+ Right b -> updateS (Just b) (update a b da)+ Nothing -> do+ ea <- loadL+ case ea of+ Left e -> throwIO e+ Right a -> updateL (Just a) da+ in mkUpdateStore loadL (writeS . write) updateL++-- | Lift+hoistStore+ :: Monad m+ => (forall a. m a -> n a)+ -> Store m qa da+ -> Store n qa da+hoistStore f Store{loadS,writeS,updateS,queryS} = Store+ { loadS = f loadS+ , writeS = f . writeS+ , updateS = \ma -> f . updateS ma+ , queryS = f . queryS+ }++-- | Combine two 'Stores' into a 'Store' for pairs.+--+-- TODO: Handle the case where 'writeS' or 'updateS' throw an exception+-- and partially break the 'Store'.+pairStores+ :: Monad m+ => Store m qa da+ -> Store m qb db+ -> Store m (qa :+: qb) (da,db)+pairStores sa sb = Store+ { loadS = liftA2 (,) <$> loadS sa <*> loadS sb+ , queryS = \case+ L1 qa -> queryS sa qa+ R1 qb -> queryS sb qb+ , writeS = \(a,b) -> writeS sa a >> writeS sb b+ , updateS = \mi (da,db) ->+ case mi of+ Nothing -> updateS sa Nothing da >> updateS sb Nothing db+ Just (a,b) -> updateS sa (Just a) da >> updateS sb (Just b) db+ }++{-------------------------------------------------------------------------------+ Helpers+-------------------------------------------------------------------------------}+-- | Helper for implementing `updateS`+-- for the case where a value is not yet loaded.+updateLoad :: (Exception e, Monad m)+ => m (Either e t) -- ^ How to load the value.+ -> (e -> m b) -- ^ What to do with the error when loading the value.+ -> (t -> da -> m b) -- ^ What to do with the value.+ -> Maybe t -- ^ Value, maybe loaded, maybe not.+ -> da -- ^ Delta.+ -> m b+updateLoad load handle update' Nothing da = do+ ea <- load+ case ea of+ Left e -> handle e+ Right x -> update' x da+updateLoad _load _ update' (Just x) da = update' x da++-- | Throw 'Left' as an exception in the monad.+throwLeft :: MonadThrow m => Either SomeException b -> m b+throwLeft = \case+ Left (SomeException e) -> throwIO e+ Right a -> pure a++-- | Helper for implementing `updateS`.+-- Call 'loadS' from a 'Store' if the value is not already given in memory.+loadWhenNothing+ :: (Monad m, MonadThrow m, Delta da)+ => Maybe (Base da) -> Store m qa da -> m (Base da)+loadWhenNothing (Just a) _ = pure a+loadWhenNothing Nothing store = loadS store >>= throwLeft++updateSequence+ :: (Monad m, Delta delta)+ => (Base delta -> delta -> m ())+ -> Base delta+ -> [delta]+ -> m ()+updateSequence f s = foldM_ update' s . reverse+ where+ update' s' da = f s' da >> pure (da `apply` s')
+ src/Test/Data/Store.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}++{-|+Copyright : © 2022-2023 IOHK, 2023-2025 Cardano Foundation+License : Apache-2.0+Description : Utilities for testing 'Store' implementations.++This module provides utilities for testing 'Store' implementations.++* 'prop_StoreUpdate' is a general property test that tests+ the laws for 'updateS'.+* 'genChain' generates random sequences of deltas.+* 'StoreUnitTest' provides a monadic DSL+ for writing example test cases for 'Store'.+-}+module Test.Data.Store+ ( -- * Store laws+ GenDelta+ , prop_StoreUpdate++ -- * Generators+ , Chain (..)+ , genChain+ , shrinkChain++ -- * Unit test DSL for developing a Store+ , StoreUnitTest+ , unitTestStore+ , applyS+ , checkLaw+ , reset+ , context+ , observe+ , ignore+ ) where++import Prelude++import Control.Exception+ ( throwIO+ )+import Control.Monad+ ( forM_+ )+import Control.Monad.Trans.Class+ ( lift+ )+import Control.Monad.Trans.RWS+ ( RWST+ , ask+ , censor+ , evalRWST+ , get+ , listen+ , put+ , tell+ )+import Data.Delta+ ( Delta (..)+ )+import Data.Either+ ( isRight+ )+import Data.Store+ ( Store (loadS, updateS, writeS)+ )+import Test.QuickCheck+ ( Gen+ , Property+ , conjoin+ , counterexample+ , forAll+ , forAllShrink+ , getSize+ , (===)+ )+import Test.QuickCheck.Monadic+ ( assert+ , monadicIO+ , monitor+ , run+ )++{-----------------------------------------------------------------------------+ Store laws+------------------------------------------------------------------------------}+-- | Given a value, generate a random delta that applies to this value.+type GenDelta da = Base da -> Gen da++-- | Chain of deltas and the results of their application.+--+-- The delta that is applied *last* appears in the list *first*.+data Chain da = Chain [(Base da, da)] (Base da)++instance Show da => Show (Chain da) where+ show (Chain adas _) = show . map snd $ adas++-- | Randomly generate a chain of deltas.+genChain :: Delta da => Gen (Base da) -> GenDelta da -> Gen (Chain da)+genChain gen0 more = do+ n <- getSize+ a0 <- gen0+ go n a0 [] a0+ where+ go 0 _ das a0 = pure $ Chain das a0+ go n alast das a0 = do+ da <- more alast+ let a = apply da alast+ go (n - 1) a ((a, da) : das) a0++-- | Shrink a chain of deltas.+shrinkChain :: Chain da -> [Chain da]+shrinkChain (Chain [] _) = []+shrinkChain (Chain das a0) =+ [ Chain [] a0, Chain [last das] a0, Chain (tail das) a0 ]++-- | Test whether the law on 'updateS' is satisfied.+--+-- Subsumes test for the law on 'writeS' / 'loadS'.+prop_StoreUpdate+ :: (Monad m, Delta da, Eq (Base da), Show da, Show (Base da))+ => (forall b. m b -> IO b)+ -- ^ Function to embed the monad in 'IO'+ -> m (Store m qa da)+ -- ^ Creation for 'Store' that is to be tested.+ -> Gen (Base da)+ -- ^ Generator for the initial value.+ -> GenDelta da+ -- ^ Generator for deltas.+ -> Property+prop_StoreUpdate toIO mkStore gen0 more =+ forAll gen0 $ \a0' ->+ forAllShrink (genChain (pure a0') more) shrinkChain $ \chain ->+ let Chain adas a0 = chain+ as = map fst adas ++ [a0]+ das = map snd adas+ in counterexample ("\nUpdates applied:\n" <> unlines (map show as))+ $ monadicIO $ do+ ea <- run . toIO $ do+ store <- mkStore+ writeS store a0+ -- first update is applied last!+ let updates = reverse $ zip das (drop 1 as)+ forM_ updates $ \(da, a) -> updateS store (Just a) da+ loadS store+ case ea of+ Left err -> run $ throwIO err+ Right a -> do+ monitor $ counterexample+ $ "\nExpected:\n" <> show (head as)+ monitor $ counterexample+ $ "\nGot:\n" <> show a+ assert $ a == head as++{-----------------------------------------------------------------------------+ DSL for developing+------------------------------------------------------------------------------}+-- | A monadic DSL to unit test a 'Store'.+newtype StoreUnitTest m qa da r = StoreUnitTest+ { runStoreUnitTest :: RWST+ (Store m qa da)+ [Property]+ (Base da, Base da, [da])+ m+ r+ } deriving (Functor, Applicative, Monad)++-- | Apply a delta to the current value.+applyS :: (Monad m, Delta da) => da -> StoreUnitTest m qa da ()+applyS r = StoreUnitTest $ do+ s <- ask+ (q, x, ds) <- get+ put (q, apply r x, r : ds)+ lift $ updateS s (Just x) r++-- | Check the store laws.+checkLaw+ :: (Monad m, Eq (Base da), Show (Base da), Show da)+ => StoreUnitTest m qa da ()+checkLaw = StoreUnitTest $ do+ (_, x, reverse -> ds) <- get+ x' <- ask >>= lift . loadS+ tell+ [ counterexample (show (ds, leftOf x')) (isRight x')+ , counterexample (show ds) $ rightOf x' === x+ ]+ where+ leftOf (Left x) = x+ leftOf _ = undefined+ rightOf (Right x) = x+ rightOf _ = undefined++-- | Reset the store state to the initial value.+reset :: Monad m => StoreUnitTest m qa da ()+reset = StoreUnitTest $ do+ s <- ask+ (q, _, _) <- get+ lift $ writeS s q+ put (q, q, [])++-- | Run a unit test for a 'Store'.+unitTestStore+ :: (Monad m, Eq (Base da), Show (Base da), Show da)+ => Base da+ -> Store m qa da+ -> StoreUnitTest m qa da a+ -> m Property+unitTestStore x s f =+ conjoin . snd+ <$> evalRWST (runStoreUnitTest (f >> checkLaw)) s (x, x, [])++-- | Add a context to test.+context+ :: Monad m+ => (Property -> Property)+ -> StoreUnitTest m qa da x+ -> StoreUnitTest m qa da x+context d f = StoreUnitTest $ do+ (x, w) <- listen $ runStoreUnitTest f+ tell $ fmap d w+ pure x++-- | Observe a property on the current value of the store.+observe :: Monad m => (Base da -> Property) -> StoreUnitTest m qa da ()+observe f = StoreUnitTest $ do+ (_, s, _) <- get+ tell [f s]++-- | Ignore the properties of a sub-test.+ignore :: Monad m => StoreUnitTest m qa da x -> StoreUnitTest m qa da x+ignore = StoreUnitTest . censor (const []) . runStoreUnitTest
+ test/unit/Data/DBVarSpec.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-|+Copyright : © 2022-2023 IOHK, 2023-2025 Cardano Foundation+License : Apache-2.0+-}+module Data.DBVarSpec+ ( spec+ ) where++import Prelude++import Control.Concurrent.Class.MonadSTM+ ( atomically+ , newTVarIO+ , readTVar+ , writeTVar+ )+import Control.Exception+ ( toException+ )+import Control.Monad.Class.MonadAsync+ ( concurrently_+ , race+ )+import Control.Monad.Class.MonadThrow+ ( throwIO+ )+import Control.Monad.Class.MonadTimer+ ( threadDelay+ )+import Control.Monad.IOSim+ ( IOSim+ , runSimOrThrow+ )+import Data.Delta+ ( Delta (..)+ )+import Data.DBVar+ ( initDBVar+ , updateDBVar+ , readDBVar+ )+import Data.Store+ ( NotInitialized (..)+ , UpdateStore+ , mkUpdateStore+ )+import Test.Hspec+ ( Spec+ , describe+ , it+ )+import Test.QuickCheck+ ( Arbitrary (arbitrary)+ , Property+ , Testable (property)+ , elements+ , oneof+ , vectorOf+ , (===)+ )++spec :: Spec+spec = do+ describe "operations" $ do+ it "updateDBVar >> readDBVar" $ property $+ \(da :: DeltaA) a0 ->+ propertyIOSim $ do+ store <- newDelayedStore 0+ var <- initDBVar store a0+ updateDBVar var da+ a1 <- readDBVar var+ pure $ a1 === apply da a0++ describe "concurrency" $ do+ it "readDBVar does not block" $ property $+ \(da :: DeltaA) a0 ->+ propertyIOSim $ do+ store <- newDelayedStore 1000+ var <- initDBVar store a0+ Right a1 <- race+ (updateDBVar var da)+ (threadDelay 500 >> readDBVar var)+ pure $ a1 === a0++ it "updateDBVar blocks" $ property $+ \(da10 :: DeltaA) da21 a0 ->+ propertyIOSim $ do+ store <- newDelayedStore 1000+ var <- initDBVar store a0+ concurrently_+ (updateDBVar var da10)+ (threadDelay 500 >> updateDBVar var da21)+ a2 <- readDBVar var+ pure $ a2 === apply [da21, da10] a0++{-----------------------------------------------------------------------------+ Test setup+------------------------------------------------------------------------------}++propertyIOSim :: Testable p => (forall s. IOSim s p) -> Property+propertyIOSim action = property $ runSimOrThrow action++-- | 'Store' in volatile memory that invalidates the value+-- while performing an expensive update operation.+newDelayedStore+ :: forall da s. Delta da => Int -> IOSim s (UpdateStore (IOSim s) da)+newDelayedStore delay = do+ let broken = Left $ toException NotInitialized+ ref <- newTVarIO broken+ let load = atomically (readTVar ref)+ write = atomically . writeTVar ref . Right+ update :: Maybe (Base da) -> da -> IOSim s ()+ update _ da = do+ ea <- atomically $ do+ ea <- readTVar ref+ writeTVar ref broken -- invalidate the value + pure ea+ threadDelay delay -- wait for a long time+ case ea of+ Left e -> throwIO e+ Right a -> atomically . writeTVar ref . Right $ apply da a+ pure $ mkUpdateStore load write update++{-----------------------------------------------------------------------------+ Delta type for testing+------------------------------------------------------------------------------}++newtype A = A { unA :: [Int] }+ deriving (Show, Eq)++data DeltaA+ = AddOne+ | AddTwo+ | Drop+ deriving (Show, Eq)++instance Delta DeltaA where+ type Base DeltaA = A+ apply AddOne = A . (1:) . unA+ apply AddTwo = A . (2:) . unA+ apply Drop = A . (drop 1) . unA++instance Arbitrary A where+ arbitrary = A <$> oneof (map (\n -> vectorOf n arbitrary) [0,1,2])++instance Arbitrary DeltaA where+ arbitrary = elements [AddOne, AddTwo, Drop]
+ test/unit/Data/StoreSpec.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Copyright: © 2023 IOHK+-- License: Apache-2.0+module Data.StoreSpec+ ( spec+ ) where++import Prelude++import Data.Delta+ ( Delta (..)+ )+import Data.Store+ ( Store (..)+ , UpdateStore+ , newCachedStore+ , newStore+ )+import Test.Data.Store+ ( prop_StoreUpdate+ )+import Test.Hspec+ ( Spec+ , describe+ , it+ )+import Test.QuickCheck+ ( elements+ , generate+ , (===)+ )+import Test.QuickCheck.Gen+ ( Gen+ , listOf+ )+import Test.QuickCheck.Monadic+ ( monadicIO+ , run+ )++spec :: Spec+spec = do+ describe "CachedStore" $ do+ it "respects store laws" $+ let setupStore = do+ testStore <- newTestStore+ resetTestStoreBase testStore+ newCachedStore testStore+ in prop_StoreUpdate+ id+ setupStore+ (pure emptyTestStore)+ $ const genTestStoreDeltas++ it "behaves like the cached one" $ monadicIO $ run $ do++ das <- generate $ listOf genTestStoreDeltas++ testStore <- newTestStore++ cachedStore <- newCachedStore testStore++ resetTestStoreBase testStore+ updateStore cachedStore das+ Right cachedFinal <- loadS cachedStore++ resetTestStoreBase testStore+ updateStore testStore das+ Right originalFinal <- loadS testStore++ pure $ cachedFinal === originalFinal++newTestStore :: IO (UpdateStore IO TestStoreDelta)+newTestStore = newStore++updateStore :: Monad m => Store m qa da -> [da] -> m ()+updateStore store = mapM_ (updateS store Nothing)++genTestStoreDeltas :: Gen TestStoreDelta+genTestStoreDeltas = elements [AddOne, AddTwo, RemoveOne]++resetTestStoreBase :: (Base da ~ TestStoreBase) => Store m qa da -> m ()+resetTestStoreBase store = writeS store emptyTestStore++emptyTestStore :: TestStoreBase+emptyTestStore = TestStoreBase []++newtype TestStoreBase = TestStoreBase [Int]+ deriving (Show, Eq)++data TestStoreDelta+ = AddOne+ | AddTwo+ | RemoveOne+ deriving (Show, Eq)++instance Delta TestStoreDelta where+ type Base TestStoreDelta = TestStoreBase+ apply AddOne = overTestStoreBase (1:)+ apply AddTwo = overTestStoreBase (2:)+ apply RemoveOne = overTestStoreBase (drop 1)++overTestStoreBase :: ([Int] -> [Int]) -> TestStoreBase -> TestStoreBase+overTestStoreBase f (TestStoreBase xs) = TestStoreBase (f xs)
+ test/unit/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}