seakale-tests (empty) → 0.1.0.0
raw patch · 7 files changed
+698/−0 lines, 7 filesdep +basedep +bytestringdep +freesetup-changed
Dependencies added: base, bytestring, free, mtl, recursion-schemes, seakale
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- seakale-tests.cabal +43/−0
- src/Database/Seakale/Tests/Mock.hs +144/−0
- src/Database/Seakale/Tests/Request.hs +104/−0
- src/Database/Seakale/Tests/Store.hs +370/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for seakale-tests++## 0.1.0.0 -- 2017-01-31++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Thomas Feron++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Thomas Feron nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ seakale-tests.cabal view
@@ -0,0 +1,43 @@+name: seakale-tests+version: 0.1.0.0+synopsis: Helpers to test code using Seakale+description: This package provides a way to run code written with Seakale with a fake database using mocks.+license: BSD3+license-file: LICENSE+author: Thomas Feron+maintainer: thomas.feron@redspline.com+category: Database+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository head+ type: darcs+ location: http://darcs.redspline.com/seakale+ tag: 0.1.0.0++library+ ghc-options: -Wall+ hs-source-dirs: src+ default-language: Haskell2010++ default-extensions: LambdaCase+ TypeFamilies+ DeriveFunctor+ RankNTypes+ StandaloneDeriving+ FlexibleContexts+ TupleSections+ OverloadedStrings+ ExistentialQuantification++ exposed-modules: Database.Seakale.Tests.Mock+ Database.Seakale.Tests.Request+ Database.Seakale.Tests.Store++ build-depends: base >=4.8 && <4.10+ , seakale+ , mtl+ , bytestring+ , free+ , recursion-schemes
+ src/Database/Seakale/Tests/Mock.hs view
@@ -0,0 +1,144 @@+module Database.Seakale.Tests.Mock where++import Control.Applicative++import Data.Functor.Foldable+import Data.Maybe+import qualified Data.ByteString.Lazy as BSL++data QueryPredicate+ = QPredPlain BSL.ByteString+ | QPredFunction (BSL.ByteString -> Bool)++runQueryPredicate :: QueryPredicate -> BSL.ByteString -> Bool+runQueryPredicate p req = case p of+ QPredPlain req' -> req == req'+ QPredFunction f -> f req++instance Show QueryPredicate where+ show = \case+ QPredPlain bsl -> show bsl+ QPredFunction _ -> "predicate"++instance Eq QueryPredicate where+ (==) qp1 qp2 = case (qp1, qp2) of+ (QPredPlain q1, QPredPlain q2) -> q1 == q2+ (QPredPlain q, QPredFunction f) -> f q+ (QPredFunction f, QPredPlain q) -> f q+ (QPredFunction _, QPredFunction _) -> False++data Mock sub a+ = Action sub+ | Or (Mock sub a) (Mock sub a)+ | And (Mock sub a) (Mock sub a)+ | After (Mock sub a) (Mock sub a)+ | None (Maybe a)+ deriving (Show, Eq)++mockConsumed :: Mock sub a -> Bool+mockConsumed = \case+ None _ -> True+ _ -> False++notMonadError :: a+notMonadError = error "Mock not intended as an actual monad"++instance Monoid (Mock sub a) where+ mempty = None Nothing+ mappend = And++instance Functor (Mock sub) where+ fmap f = \case+ Action sub -> Action sub+ Or m1 m2 -> Or (fmap f m1) (fmap f m2)+ And m1 m2 -> And (fmap f m1) (fmap f m2)+ After m1 m2 -> After (fmap f m1) (fmap f m2)+ None mx -> None (fmap f mx)++instance Applicative (Mock sub) where+ pure = None . Just+ None f <*> fx = fromMaybe notMonadError f <$> fx+ ff <*> None x = ($ fromMaybe notMonadError x) <$> ff+ ff <*> fx = And (castMock ff) (castMock fx)++instance Monad (Mock sub) where+ None mx >>= f = f $ fromMaybe notMonadError mx+ mx >>= f = After (castMock mx) (f notMonadError)++instance Alternative (Mock sub) where+ empty = None Nothing+ mx <|> my = Or mx my++data MockF sub f+ = FAction sub+ | FOr f f+ | FAnd f f+ | FAfter f f+ | FNone+ deriving Functor++type instance Base (Mock sub a) = MockF sub++instance Recursive (Mock sub a) where+ project = \case+ Action sub -> FAction sub+ Or m1 m2 -> FOr m1 m2+ And m1 m2 -> FAnd m1 m2+ After m1 m2 -> FAfter m1 m2+ None _ -> FNone++consumeMock :: (sub -> Maybe b) -> Mock sub a -> Maybe (b, Mock sub a)+consumeMock = para . phi+ where+ phi :: (sub -> Maybe a) -> MockF sub (Mock sub c, Maybe (a, Mock sub c))+ -> Maybe (a, Mock sub c)+ phi f = \case+ FAction sub -> (, None Nothing) <$> f sub+ FOr (_, mRes1) (_, mRes2) -> mRes1 <|> mRes2+ FAnd (m1, mRes1) (m2, mRes2) ->+ case (mRes1, mRes2) of+ (Just (x, m1'), _) -> Just (x, noNone And m1' m2)+ (_, Just (x, m2')) -> Just (x, noNone And m1 m2')+ _ -> Nothing+ FAfter (_, mRes1) (m2, _) ->+ fmap (\(x, m1') -> (x, noNone After m1' m2)) mRes1+ FNone -> Nothing++ noNone :: (Mock sub a -> Mock sub a -> Mock sub a)+ -> Mock sub a -> Mock sub a -> Mock sub a+ noNone _ (None _) m = m+ noNone g m1 m2 = g m1 m2++castMock :: Mock sub a -> Mock sub b+castMock = cata cast+ where+ cast :: MockF sub (Mock sub b) -> Mock sub b+ cast = \case+ FAction sub -> Action sub+ FOr m1 m2 -> Or m1 m2+ FAnd m1 m2 -> And m1 m2+ FAfter m1 m2 -> After m1 m2+ FNone -> None Nothing++mor :: Mock sub a -> Mock sub a -> Mock sub a+mor = Or++mand :: Mock sub a -> Mock sub a -> Mock sub a+mand = And++after, andThen :: Mock sub a -> Mock sub a -> Mock sub a+after = After+andThen = After++anyOf, allOf :: [Mock sub a] -> Mock sub a+anyOf = foldr mor (None Nothing)+allOf = foldr mand (None Nothing)++fixAfter :: Mock sub a -> Mock sub a+fixAfter mock = After mock (fixAfter mock)++times :: Int -> Mock sub a -> Mock sub a+times n mock+ | n <= 0 = None Nothing+ | n == 1 = mock+ | otherwise = After mock $ times (n - 1) mock
+ src/Database/Seakale/Tests/Request.hs view
@@ -0,0 +1,104 @@+module Database.Seakale.Tests.Request+ ( RequestMock+ , mockMatchingQuery+ , mockMatchingExecute+ , mockQuery+ , mockExecute+ , runRequestT+ , runRequest+ , runRequestT'+ , runRequest'+ , module Database.Seakale.Tests.Mock+ ) where++import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Trans.Free+import qualified Control.Monad.Except as E++import Data.Monoid+import qualified Data.ByteString.Lazy as BSL++import Database.Seakale.Request.Internal+ hiding (runRequestT, runRequest)+import Database.Seakale.Types hiding (runQuery, runExecute)++import Database.Seakale.Tests.Mock++data RequestMock backend+ = MockQuery QueryPredicate ([ColumnInfo backend], [Row backend])+ | MockExecute QueryPredicate Integer++mockMatchingQuery :: (BSL.ByteString -> Bool)+ -> ([ColumnInfo backend], [Row backend])+ -> Mock (RequestMock backend) ()+mockMatchingQuery f dat = Action $ MockQuery (QPredFunction f) dat++mockMatchingExecute :: (BSL.ByteString -> Bool) -> Integer+ -> Mock (RequestMock backend) ()+mockMatchingExecute f i = Action $ MockExecute (QPredFunction f) i++mockQuery :: BSL.ByteString -> ([ColumnInfo backend], [Row backend])+ -> Mock (RequestMock backend) ()+mockQuery req dat = Action $ MockQuery (QPredPlain req) dat++mockExecute :: BSL.ByteString -> Integer -> Mock (RequestMock backend) ()+mockExecute req i = Action $ MockExecute (QPredPlain req) i++runQuery :: BSL.ByteString -> Mock (RequestMock backend) a+ -> Maybe ( ([ColumnInfo backend], [Row backend])+ , Mock (RequestMock backend) a )+runQuery req = consumeMock $ \case+ MockQuery p cr | runQueryPredicate p req -> Just cr+ _ -> Nothing++runExecute :: BSL.ByteString -> Mock (RequestMock backend) a+ -> Maybe (Integer, Mock (RequestMock backend) a)+runExecute req = consumeMock $ \case+ MockExecute p i | runQueryPredicate p req -> Just i+ _ -> Nothing++runRequestT :: Monad m => backend -> Mock (RequestMock backend) b+ -> RequestT backend m a -> m (Either SeakaleError a)+runRequestT b m = fmap fst . runRequestT' b m++runRequest :: backend -> Mock (RequestMock backend) b -> Request backend a+ -> Either SeakaleError a+runRequest b m = fst . runRequest' b m++runRequestT' :: Monad m => backend -> Mock (RequestMock backend) b+ -> RequestT backend m a+ -> m (Either SeakaleError a, Mock (RequestMock backend) b)+runRequestT' b m =+ flip runStateT m . E.runExceptT . iterT (interpreter b)+ . hoistFreeT (lift . lift)++ where+ interpreter :: Monad m => backend+ -> RequestF backend+ (E.ExceptT SeakaleError+ (StateT (Mock (RequestMock backend) b) m) a)+ -> E.ExceptT SeakaleError+ (StateT (Mock (RequestMock backend) b) m) a+ interpreter backend = \case+ Query req f -> do+ mock <- get+ case runQuery req mock of+ Nothing -> E.throwError $ BackendError $+ "no mock found for Query on " <> BSL.toStrict req+ Just (res, mock') -> put mock' >> f res++ Execute req f -> do+ mock <- get+ case runExecute req mock of+ Nothing -> E.throwError $ BackendError $+ "no mock found for Execute on " <> BSL.toStrict req+ Just (res, mock') -> put mock' >> f res++ GetBackend f -> f backend+ ThrowError err -> E.throwError err+ CatchError action handler -> E.catchError action handler++runRequest' :: backend -> Mock (RequestMock backend) b -> Request backend a+ -> (Either SeakaleError a, Mock (RequestMock backend) b)+runRequest' backend mock = runIdentity . runRequestT' backend mock
+ src/Database/Seakale/Tests/Store.hs view
@@ -0,0 +1,370 @@+module Database.Seakale.Tests.Store+ ( StoreMock+ , mockSelect+ , mockSelect_+ , mockFailingSelect+ , mockCount+ , mockFailingCount+ , mockGetMany+ , mockGet+ , mockFailingGetMany+ , mockFailingGet+ , mockSelectJoin+ , mockFailingSelectJoin+ , mockCountJoin+ , mockFailingCountJoin+ , mockInsertMany+ , mockInsert+ , mockFailingInsertMany+ , mockFailingInsert+ , mockUpdateMany+ , mockUpdate+ , mockFailingUpdateMany+ , mockFailingUpdate+ , mockDeleteMany+ , mockDelete+ , mockFailingDeleteMany+ , mockFailingDelete+ , runSelect+ , runSelectT+ , runStore+ , runStoreT+ , runSelect'+ , runSelectT'+ , runStore'+ , runStoreT'+ , module Database.Seakale.Tests.Mock+ ) where++import Control.Monad.Identity+import Control.Monad.State+import Control.Monad.Trans.Free+import qualified Control.Monad.Except as E++import Data.Monoid+import Data.Typeable+import qualified Data.ByteString.Lazy.Char8 as BSL++import Database.Seakale.Store hiding (get)+import Database.Seakale.Store.Internal+ hiding (runSelect, runSelectT, runStore, runStoreT)+import Database.Seakale.Store.Join+import Database.Seakale.ToRow+import Database.Seakale.Types++import Database.Seakale.Tests.Mock++data StoreMock backend+ = forall k l a. Storable backend k l a+ => MockSelect (backend -> Relation backend k l a) (Condition backend a)+ (SelectClauses backend a) (Either SeakaleError [Entity a])+ | forall k l a. Storable backend k l a+ => MockCount (backend -> Relation backend k l a) (Condition backend a)+ (Either SeakaleError Integer)+ | forall k l a. (Storable backend k l a, Eq a)+ => MockInsert [a] (Either SeakaleError [EntityID a])+ | forall k l a. Storable backend k l a+ => MockUpdate (UpdateSetter backend a) (Condition backend a)+ (Either SeakaleError Integer)+ | forall k l a. Storable backend k l a+ => MockDelete (Condition backend a) (Either SeakaleError Integer)++mockSelect :: Storable backend k l a => Condition backend a+ -> SelectClauses backend a -> [Entity a]+ -> Mock (StoreMock backend) ()+mockSelect cond clauses ents =+ Action $ MockSelect relation cond clauses (Right ents)++mockSelect_ :: Storable backend k l a => Condition backend a -> [Entity a]+ -> Mock (StoreMock backend) ()+mockSelect_ cond ents = mockSelect cond mempty ents++mockFailingSelect :: Storable backend k l a => Condition backend a+ -> SelectClauses backend a -> SeakaleError+ -> Mock (StoreMock backend) ()+mockFailingSelect cond clauses err =+ Action $ MockSelect relation cond clauses (Left err)++mockCount :: Storable backend k l a => Condition backend a -> Integer+ -> Mock (StoreMock backend) ()+mockCount cond n = Action $ MockCount relation cond (Right n)++mockFailingCount :: Storable backend k l a => Condition backend a+ -> SeakaleError -> Mock (StoreMock backend) ()+mockFailingCount cond err = Action $ MockCount relation cond (Left err)++mockGetMany :: (Storable backend k l a, ToRow backend k (EntityID a))+ => [EntityID a] -> [Entity a] -> Mock (StoreMock backend) ()+mockGetMany ids ents = mockSelect_ (EntityID `inList` ids) ents++mockGet :: (Storable backend k l a, ToRow backend k (EntityID a))+ => EntityID a -> a -> Mock (StoreMock backend) ()+mockGet i v = mockSelect (EntityID ==. i) (limit 1) [Entity i v]++mockFailingGetMany :: (Storable backend k l a, ToRow backend k (EntityID a))+ => [EntityID a] -> SeakaleError+ -> Mock (StoreMock backend) ()+mockFailingGetMany ids = mockFailingSelect (EntityID `inList` ids) mempty++mockFailingGet :: (Storable backend k l a, ToRow backend k (EntityID a))+ => EntityID a -> SeakaleError -> Mock (StoreMock backend) ()+mockFailingGet i = mockFailingSelect (EntityID ==. i) (limit 1)++mockSelectJoin :: Storable backend k l a => JoinRelation backend k l a+ -> Condition backend a -> SelectClauses backend a -> [Entity a]+ -> Mock (StoreMock backend) ()+mockSelectJoin rel cond clauses ents =+ Action $ MockSelect rel cond clauses (Right ents)++mockFailingSelectJoin :: Storable backend k l a => JoinRelation backend k l a+ -> Condition backend a -> SelectClauses backend a+ -> SeakaleError -> Mock (StoreMock backend) ()+mockFailingSelectJoin rel cond clauses err =+ Action $ MockSelect rel cond clauses (Left err)++mockCountJoin :: Storable backend k l a => JoinRelation backend k l a+ -> Condition backend a -> Integer -> Mock (StoreMock backend) ()+mockCountJoin rel cond n = Action $ MockCount rel cond (Right n)++mockFailingCountJoin :: Storable backend k l a => JoinRelation backend k l a+ -> Condition backend a -> SeakaleError+ -> Mock (StoreMock backend) ()+mockFailingCountJoin rel cond err = Action $ MockCount rel cond (Left err)++mockInsertMany :: (Storable backend k l a, Eq a) => [a] -> [EntityID a]+ -> Mock (StoreMock backend) ()+mockInsertMany vals ids = Action $ MockInsert vals (Right ids)++mockInsert :: (Storable backend k l a, Eq a) => a -> EntityID a+ -> Mock (StoreMock backend) ()+mockInsert v i = mockInsertMany [v] [i]++mockFailingInsertMany :: (Storable backend k l a, Eq a) => [a] -> SeakaleError+ -> Mock (StoreMock backend) ()+mockFailingInsertMany vals err = Action $ MockInsert vals (Left err)++mockFailingInsert :: (Storable backend k l a, Eq a) => a -> SeakaleError+ -> Mock (StoreMock backend) ()+mockFailingInsert val = mockFailingInsertMany [val]++mockUpdateMany :: Storable backend k l a => UpdateSetter backend a+ -> Condition backend a -> Integer+ -> Mock (StoreMock backend) ()+mockUpdateMany setter cond n = Action $ MockUpdate setter cond (Right n)++mockUpdate :: (Storable backend k l a, ToRow backend k (EntityID a))+ => EntityID a -> UpdateSetter backend a+ -> Mock (StoreMock backend) ()+mockUpdate i setter = mockUpdateMany setter (EntityID ==. i) 1++mockFailingUpdateMany :: Storable backend k l a => UpdateSetter backend a+ -> Condition backend a -> SeakaleError+ -> Mock (StoreMock backend) ()+mockFailingUpdateMany setter cond err =+ Action $ MockUpdate setter cond (Left err)++mockFailingUpdate :: (Storable backend k l a, ToRow backend k (EntityID a))+ => EntityID a -> UpdateSetter backend a -> SeakaleError+ -> Mock (StoreMock backend) ()+mockFailingUpdate i setter = mockFailingUpdateMany setter (EntityID ==. i)++mockDeleteMany :: Storable backend k l a => Condition backend a -> Integer+ -> Mock (StoreMock backend) ()+mockDeleteMany cond n = Action $ MockDelete cond (Right n)++mockDelete :: (Storable backend k l a, ToRow backend k (EntityID a))+ => EntityID a -> Mock (StoreMock backend) ()+mockDelete i = mockDeleteMany (EntityID ==. i) 1++mockFailingDeleteMany :: Storable backend k l a => Condition backend a+ -> SeakaleError -> Mock (StoreMock backend) ()+mockFailingDeleteMany cond err = Action $ MockDelete cond (Left err)++mockFailingDelete :: (Storable backend k l a, ToRow backend k (EntityID a))+ => EntityID a -> SeakaleError -> Mock (StoreMock backend) ()+mockFailingDelete i = mockFailingDeleteMany (EntityID ==. i)++fakeSelect :: Storable backend k l a => backend -> Relation backend k l a+ -> Condition backend a -> SelectClauses backend a+ -> Mock (StoreMock backend) b+ -> Maybe (Either SeakaleError [Entity a], Mock (StoreMock backend) b)+fakeSelect backend rel cond clauses = consumeMock $ \case+ MockSelect frel cond' clauses' ents -> do+ ents' <- cast ents+ rel' <- cast $ frel backend+ cond'' <- cast cond'+ clauses'' <- cast clauses'+ guard $ eqRelation rel rel' && eqCondition backend cond cond''+ && eqSelectClauses backend clauses clauses''+ return ents'+ _ -> Nothing++fakeCount :: (Storable backend k l a, Typeable backend) => backend+ -> Relation backend k l a -> Condition backend a+ -> Mock (StoreMock backend) b+ -> Maybe (Either SeakaleError Integer, Mock (StoreMock backend) b)+fakeCount backend rel cond = consumeMock $ \case+ MockCount frel cond' n -> do+ rel' <- cast $ frel backend+ cond'' <- cast cond'+ guard $ eqRelation rel rel' && eqCondition backend cond cond''+ return n+ _ -> Nothing++runSelect :: Typeable backend => backend -> Mock (StoreMock backend) b+ -> Select backend a -> Either SeakaleError a+runSelect b m = fst . runSelect' b m++runSelect' :: Typeable backend => backend -> Mock (StoreMock backend) b+ -> Select backend a+ -> (Either SeakaleError a, Mock (StoreMock backend) b)+runSelect' b m = runIdentity . runSelectT' b m++runSelectT :: (Monad m, Typeable backend) => backend+ -> Mock (StoreMock backend) b -> SelectT backend m a+ -> m (Either SeakaleError a)+runSelectT b m = fmap fst . runSelectT' b m++runSelectT' :: (Monad m, Typeable backend) => backend+ -> Mock (StoreMock backend) b -> SelectT backend m a+ -> m (Either SeakaleError a, Mock (StoreMock backend) b)+runSelectT' b m = flip runStateT m . E.runExceptT . runSelectHelper b++runSelectHelper :: (Monad m, Typeable backend) => backend -> SelectT backend m a+ -> E.ExceptT SeakaleError+ (StateT (Mock (StoreMock backend) b) m) a+runSelectHelper b = iterT (interpreter b) . hoistFreeT (lift . lift)+ where+ interpreter :: (Monad m, Typeable backend) => backend+ -> SelectF backend+ (E.ExceptT SeakaleError+ (StateT (Mock (StoreMock backend) b) m) a)+ -> E.ExceptT SeakaleError+ (StateT (Mock (StoreMock backend) b) m) a+ interpreter backend = \case+ Select rel cond clauses f -> do+ mock <- get+ case fakeSelect backend rel cond clauses mock of+ Nothing -> do+ let req = buildSelectRequest backend rel cond clauses+ E.throwError $ BackendError $+ "no mock found for request: " <> BSL.toStrict req+ Just (ents, mock') -> do+ put mock'+ either E.throwError f ents++ Count rel cond f -> do+ mock <- get+ case fakeCount backend rel cond mock of+ Nothing -> do+ let req = buildCountRequest backend rel cond+ E.throwError $ BackendError $+ "no mock found for request: " <> BSL.toStrict req+ Just (n, mock') -> do+ put mock'+ either E.throwError f n++ SelectGetBackend f -> f backend+ SelectThrowError err -> E.throwError err+ SelectCatchError action handler -> E.catchError action handler++fakeInsert :: Storable backend k l a => [a] -> Mock (StoreMock backend) b+ -> Maybe ( Either SeakaleError [EntityID a]+ , Mock (StoreMock backend) b )+fakeInsert vals = consumeMock $ \case+ MockInsert vals' ids -> do+ vals'' <- cast vals+ ids' <- cast ids+ guard $ vals' == vals''+ return ids'+ _ -> Nothing++fakeUpdate :: (Storable backend k l a, Typeable backend) => backend+ -> UpdateSetter backend a+ -> Condition backend a -> Mock (StoreMock backend) b+ -> Maybe (Either SeakaleError Integer, Mock (StoreMock backend) b)+fakeUpdate backend setter cond = consumeMock $ \case+ MockUpdate setter' cond' n -> do+ setter'' <- cast setter'+ cond'' <- cast cond'+ guard $ eqUpdateSetter backend setter setter''+ && eqCondition backend cond cond''+ return n+ _ -> Nothing++fakeDelete :: Storable backend k l a => backend -> Condition backend a+ -> Mock (StoreMock backend) b+ -> Maybe (Either SeakaleError Integer, Mock (StoreMock backend) b)+fakeDelete backend cond = consumeMock $ \case+ MockDelete cond' n -> do+ cond'' <- cast cond'+ guard $ eqCondition backend cond cond''+ return n+ _ -> Nothing++runStore :: Typeable backend => backend -> Mock (StoreMock backend) b+ -> Store backend a -> Either SeakaleError a+runStore b m = fst . runStore' b m++runStore' :: Typeable backend => backend -> Mock (StoreMock backend) b+ -> Store backend a+ -> (Either SeakaleError a, Mock (StoreMock backend) b)+runStore' b m = runIdentity . runStoreT' b m++runStoreT :: (Monad m, Typeable backend) => backend+ -> Mock (StoreMock backend) b -> StoreT backend m a+ -> m (Either SeakaleError a)+runStoreT b m = fmap fst . runStoreT' b m++runStoreT' :: (Monad m, Typeable backend) => backend+ -> Mock (StoreMock backend) b -> StoreT backend m a+ -> m (Either SeakaleError a, Mock (StoreMock backend) b)+runStoreT' b m =+ flip runStateT m . E.runExceptT . iterT (interpreter b)+ . hoistFreeT (runSelectHelper b)++ where+ interpreter :: Monad m => backend+ -> StoreF backend+ (E.ExceptT SeakaleError+ (StateT (Mock (StoreMock backend) b) m) a)+ -> E.ExceptT SeakaleError+ (StateT (Mock (StoreMock backend) b) m) a+ interpreter backend = \case+ Insert dat f -> do+ mock <- get+ case fakeInsert dat mock of+ Nothing -> do+ let req = buildInsertRequest (relationOfXs backend dat)+ (map (toRow backend) dat)+ E.throwError $ BackendError $+ "no mock found for request: " <> BSL.toStrict req+ Just (ids, mock') -> do+ put mock'+ either E.throwError f ids++ Update setter cond f -> do+ mock <- get+ case fakeUpdate backend setter cond mock of+ Nothing -> do+ let req = buildUpdateRequest backend (relation backend) setter cond+ E.throwError $ BackendError $+ "no mock found for request: " <> BSL.toStrict req+ Just (n, mock') -> do+ put mock'+ either E.throwError f n++ Delete cond f -> do+ mock <- get+ case fakeDelete backend cond mock of+ Nothing -> do+ let req = buildDeleteRequest backend (relation backend) cond+ E.throwError $ BackendError $+ "no mock found for request: " <> BSL.toStrict req+ Just (n, mock') -> do+ put mock'+ either E.throwError f n++ relationOfXs :: Storable backend k l a => backend -> [a]+ -> Relation backend k l a+ relationOfXs backend _ = relation backend