Commit bf66ff3a authored by MrMan's avatar MrMan

Delete working with a single test

parent bbfbc919
...@@ -305,6 +305,9 @@ instance SQLUpdatable (Partial (Task state)) where ...@@ -305,6 +305,9 @@ instance SQLUpdatable (Partial (Task state)) where
data QueryWithParams p = QWP Query p data QueryWithParams p = QWP Query p
instance SQLDeletable (Task state) where
deletionMode = Hard
-- | Build the insertion SQL query for a given entity with it's ID -- | Build the insertion SQL query for a given entity with it's ID
buildInsertQuery :: forall (ident :: Identifier) (entity :: FBounded). -- | polymorphic over entities and identifiers (uuid/int64) and params buildInsertQuery :: forall (ident :: Identifier) (entity :: FBounded). -- | polymorphic over entities and identifiers (uuid/int64) and params
(SQLInsertable (Complete entity), (SQLInsertable (Complete entity),
...@@ -359,7 +362,7 @@ updateEntityByUUID :: forall entity. ...@@ -359,7 +362,7 @@ updateEntityByUUID :: forall entity.
-> UUID -> UUID
-> Partial entity -> Partial entity
-> IO (Either EntityStoreError (WithID 'UUIDID (Complete entity))) -> IO (Either EntityStoreError (WithID 'UUIDID (Complete entity)))
updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChnages updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChanges
>>= \case >>= \case
1 -> getEntityByUUID conn uuid 1 -> getEntityByUUID conn uuid
_ -> pure $ Left $ UnexpectedErrorES "Update failed, no rows were changed" _ -> pure $ Left $ UnexpectedErrorES "Update failed, no rows were changed"
...@@ -374,7 +377,31 @@ updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChnage ...@@ -374,7 +377,31 @@ updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChnage
updateQuery = Query $ [text| UPDATE $tbl SET $setPhrase WHERE uuid = ? |] updateQuery = Query $ [text| UPDATE $tbl SET $setPhrase WHERE uuid = ? |]
updateAndCheckChnages = execute conn updateQuery valuesWithID updateAndCheckChanges = execute conn updateQuery valuesWithID
>> changes conn
deleteEntityByUUID :: forall entity.
( SQLInsertable (Complete entity)
, SQLDeletable entity
, FromRow (Complete entity)
, FromRow (WithID 'UUIDID (Complete entity)))
=> Connection
-> UUID
-> IO (Either EntityStoreError (WithID 'UUIDID (Complete entity)))
deleteEntityByUUID conn uuid = getEntityByUUID conn uuid
>>= rightOrThrow
>>= \beforeDelete -> withTransaction conn deleteAndCheckChanges
>>= \case
1 -> pure $ Right $ beforeDelete
_ -> pure $ Left $ UnexpectedErrorES "Delete failed, no rows were changed"
where
(TN tbl) = tableName :: TableName (Complete entity)
deleteQuery = case deletionMode :: DeletionMode entity of
Hard -> Query $ [text| DELETE FROM $tbl WHERE uuid = ? |]
Soft -> Query $ [text| UPDATE $tbl SET deleted=1 WHERE uuid = ? |]
deleteAndCheckChanges = execute conn deleteQuery (Only uuid)
>> changes conn >> changes conn
-- | Generalized typeclass for entity storage. -- | Generalized typeclass for entity storage.
...@@ -405,4 +432,10 @@ instance SQLEntityStore SQLiteEntityStore where ...@@ -405,4 +432,10 @@ instance SQLEntityStore SQLiteEntityStore where
>>= pure . Right . uuidToGenericIdent >>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported" _ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
deleteByID eid = undefined deleteByID store eid = withActiveConn store _work
where
_work conn = case eid of
(Left uuid) -> deleteEntityByUUID conn uuid
>>= rightOrThrow
>>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
...@@ -311,6 +311,12 @@ class SQLUpdatable e where ...@@ -311,6 +311,12 @@ class SQLUpdatable e where
updateColumnGetters :: e -> [(SQLColumnName, e -> Maybe SQLData)] updateColumnGetters :: e -> [(SQLColumnName, e -> Maybe SQLData)]
data DeletionMode e = Soft
| Hard deriving (Eq, Show, Read)
class SQLDeletable entity where
deletionMode :: DeletionMode entity
-- | Generalized typeclass for entity storage. -- | Generalized typeclass for entity storage.
class SQLEntityStore store where class SQLEntityStore store where
-- | Create an entity -- | Create an entity
...@@ -342,7 +348,9 @@ class SQLEntityStore store where ...@@ -342,7 +348,9 @@ class SQLEntityStore store where
-- | Delete an entity by ID -- | Delete an entity by ID
deleteByID :: forall (ident :: Identifier) (entity :: FBounded). deleteByID :: forall (ident :: Identifier) (entity :: FBounded).
FromRow (Complete entity) ( SQLInsertable (Complete entity)
, SQLDeletable entity
, FromRow (Complete entity))
=> store => store
-> EntityID -> EntityID
-> IO (Either EntityStoreError (WithID ident (Complete entity))) -> IO (Either EntityStoreError (WithID ident (Complete entity)))
...@@ -6,22 +6,24 @@ ...@@ -6,22 +6,24 @@
module Components.EntityStore.SQLiteSpec (spec) where module Components.EntityStore.SQLiteSpec (spec) where
import Components.EntityStore.SQLite (SQLiteEntityStore) import Components.EntityStore.SQLite (SQLiteEntityStore)
import Types ( Constructable(..) import Control.Monad (when)
, HasMigratableDB(..) import Types ( Complete
, ValidationError , Constructable(..)
, SQLEntityStore(..)
, EntityStoreError , EntityStoreError
, SQLMigrationVersion(..)
, Validated
, Validatable(..)
, FullySpecifiedTask , FullySpecifiedTask
, HasMigratableDB(..)
, NotStartedTask , NotStartedTask
, TaskState(..) , Partial
, SQLEntityStore(..)
, SQLInsertable
, SQLMigrationVersion(..)
, Task(..) , Task(..)
, TaskName(..)
, TaskDesc(..) , TaskDesc(..)
, Complete , TaskName(..)
, Partial , TaskState(..)
, Validatable(..)
, Validated
, ValidationError
, WithID(..) , WithID(..)
, withoutID , withoutID
, showID , showID
...@@ -85,7 +87,7 @@ spec = do ...@@ -85,7 +87,7 @@ spec = do
-- | Generate and perform update -- | Generate and perform update
>>= \createdTask -> generateTaskNameUpdate >>= \createdTask -> generateTaskNameUpdate
>>= \update -> case createdTask of >>= \update -> case createdTask of
(WUUID uuid _ ) -> updateByID store (Left uuid) update (WUUID uuid _) -> updateByID store (Left uuid) update
(WID (Left uuid) _) -> updateByID store (Left uuid) update (WID (Left uuid) _) -> updateByID store (Left uuid) update
_ -> error "Unexpected thing received" _ -> error "Unexpected thing received"
>>= rightOrThrow >>= rightOrThrow
...@@ -93,3 +95,28 @@ spec = do ...@@ -93,3 +95,28 @@ spec = do
>>= \updated -> pure ( showID updated /= "" && >>= \updated -> pure ( showID updated /= "" &&
withoutID updated /= getValidatedObj original ) withoutID updated /= getValidatedObj original )
>>= (`shouldBe` True) >>= (`shouldBe` True)
describe "entity store delete" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
-- | Create a task
>>= \original -> create store original
>>= rightOrThrow
-- | Delete the created task right after creating it
>>= \created -> case created of
(WUUID uuid _) -> deleteByID store (Left uuid)
(WID (Left uuid) _) -> deleteByID store (Left uuid)
_ -> error "Unexpected thing received"
>>= rightOrThrow
-- | Ensure task returned by the deletion matches created one
>>= \deleted -> when (withoutID deleted /= getValidatedObj original) (error "returned deleted object mismatch")
-- | Ensure that a get with the deleted item's ID fails
>> let
-- | Unfortunately we have to give GHC some hints so it can work out what's supposed to come out of get
getFn uuid = getByID store (Left uuid) :: IO (Either EntityStoreError (WithID ident (Complete (Task state)))) in
case created of
(WUUID uuid _) -> getFn uuid `shouldThrow` anyException
(WID (Left uuid) _) -> getFn uuid `shouldThrow` anyException
_ -> expectationFailure "uuid missing when ensuring get failed"
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment