diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for delta-store + +## 1.0.0.0 — 2025-03-21 + +* Initial version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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/ diff --git a/delta-store.cabal b/delta-store.cabal new file mode 100644 --- /dev/null +++ b/delta-store.cabal @@ -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 diff --git a/src/Data/DBVar.hs b/src/Data/DBVar.hs new file mode 100644 --- /dev/null +++ b/src/Data/DBVar.hs @@ -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 + } diff --git a/src/Data/Delta/Update.hs b/src/Data/Delta/Update.hs new file mode 100644 --- /dev/null +++ b/src/Data/Delta/Update.hs @@ -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) diff --git a/src/Data/Store.hs b/src/Data/Store.hs new file mode 100644 --- /dev/null +++ b/src/Data/Store.hs @@ -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. . + 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') diff --git a/src/Test/Data/Store.hs b/src/Test/Data/Store.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data/Store.hs @@ -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 diff --git a/test/unit/Data/DBVarSpec.hs b/test/unit/Data/DBVarSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Data/DBVarSpec.hs @@ -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] diff --git a/test/unit/Data/StoreSpec.hs b/test/unit/Data/StoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Data/StoreSpec.hs @@ -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) diff --git a/test/unit/Main.hs b/test/unit/Main.hs new file mode 100644 --- /dev/null +++ b/test/unit/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}