Commit bbfbc919 authored by MrMan's avatar MrMan

Working update with a test

parent e0450606
......@@ -20,6 +20,7 @@ where
import Control.Monad (ap)
import Data.Proxy (Proxy)
import Data.Maybe (isJust)
import Control.Applicative((<|>))
import Components.EntityStore.Migrations.SQLite (migrations)
import Config (CompleteEntityStoreConfig, EntityStoreConfig(..))
......@@ -64,6 +65,9 @@ instance ToField UUID where
instance ToField TaskState where
toField = SQLText . DT.pack . show
instance ToField TaskStateValue where
toField = SQLText . DT.pack . show
instance ToField TaskName where
toField = SQLText . getTName
......@@ -280,6 +284,25 @@ instance forall e. SQLInsertable e => SQLInsertable (WithID 'INT64ID e) where
where
(SQLCN innerCols) = columnNames :: SQLColumnNames e
instance SQLUpdatable (Partial (Task state)) where
updateColumnGetters NotStartedT{} = [ ("name", \(NotStartedT name _) -> toField <$> name)
, ("description", \(NotStartedT _ desc) -> toField <$> desc)
]
updateColumnGetters InProgressT{} = [ ("name", \(InProgressT name _) -> toField <$> name)
, ("description", \(InProgressT _ desc) -> toField <$> desc)
]
updateColumnGetters FinishedT{} = [ ("name", \(FinishedT name _) -> toField <$> name)
, ("description", \(FinishedT _ desc) -> toField <$> desc)
]
updateColumnGetters UnknownStateT{} = [ ("name", \(UnknownStateT name _ _ ) -> toField <$> name)
, ("description", \(UnknownStateT _ desc _ ) -> toField <$> desc)
, ("state", \(UnknownStateT _ _ state) -> toField <$> state)
]
data QueryWithParams p = QWP Query p
-- | Build the insertion SQL query for a given entity with it's ID
......@@ -327,6 +350,33 @@ getEntityByUUID conn uuid = (query conn selectQuery (Only uuid) :: IO [WithID 'U
(TN tbl) = tableName :: TableName (WithID 'UUIDID entity)
selectQuery = Query $ [text| SELECT * FROM $tbl WHERE uuid = ? |]
updateEntityByUUID :: forall entity.
( SQLInsertable (Complete entity)
, SQLUpdatable (Partial entity)
, FromRow (Complete entity)
, FromRow (WithID 'UUIDID (Complete entity)))
=> Connection
-> UUID
-> Partial entity
-> IO (Either EntityStoreError (WithID 'UUIDID (Complete entity)))
updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChnages
>>= \case
1 -> getEntityByUUID conn uuid
_ -> pure $ Left $ UnexpectedErrorES "Update failed, no rows were changed"
where
(TN tbl) = tableName :: TableName (Complete entity)
(SQLCN cols) = updateColumns partial
setPhrase = DT.intercalate "," $ (<>"=?") <$> cols
values = updateValues partial
valuesWithID = values <> [toField uuid]
updateQuery = Query $ [text| UPDATE $tbl SET $setPhrase WHERE uuid = ? |]
updateAndCheckChnages = execute conn updateQuery valuesWithID
>> changes conn
-- | Generalized typeclass for entity storage.
instance SQLEntityStore SQLiteEntityStore where
create store (Validated entity) = withActiveConn store _work
......@@ -347,6 +397,12 @@ instance SQLEntityStore SQLiteEntityStore where
>>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
updateByID store eid (Validated partial) = undefined
updateByID store eid (Validated partial) = withActiveConn store _work
where
_work conn = case eid of
(Left uuid) -> updateEntityByUUID conn uuid partial
>>= rightOrThrow
>>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
deleteByID eid = undefined
......@@ -15,6 +15,7 @@
module Types where
import Data.Bifunctor (second)
import Data.Kind(Type, Constraint)
import Config (CompleteTaskStoreConfig)
import Control.Exception (throw, Exception)
......@@ -49,15 +50,15 @@ data Task (state :: TaskState) f where
-- Ex. when we pull a value from the DB, we can't be polymorphic over state with the other constructors
-- but the database *has* to know what was stored forthe state.
-- Once we have an UnknownStateT we can write functions that try to translate to what we expect/require and fail otherwise.
UnknownStateT :: f TaskName -> f TaskDesc -> TaskStateValue -> Task state f
UnknownStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> Task state f
instance Eq (Task (state :: TaskState) Identity) where
(FinishedT n1 d1) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(InProgressT n1 d1) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(NotStartedT n1 d1) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "Finished")) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "InProgress")) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "NotStarted")) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (Identity (TSV "Finished"))) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (Identity (TSV "InProgress"))) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (Identity (TSV "NotStarted"))) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 s1) == (UnknownStateT n2 d2 s2) = n1 == n2 &&
d1 == d2 &&
s1 == s2
......@@ -67,21 +68,14 @@ instance Eq (Task (state :: TaskState) Maybe) where
(FinishedT n1 d1) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(InProgressT n1 d1) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(NotStartedT n1 d1) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "Finished")) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "InProgress")) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (TSV "NotStarted")) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (Just (TSV "Finished"))) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (Just (TSV "InProgress"))) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 (Just (TSV "NotStarted"))) == (NotStartedT n2 d2) = n1 == n2 && d1 == d2
(UnknownStateT n1 d1 s1) == (UnknownStateT n2 d2 s2) = n1 == n2 &&
d1 == d2 &&
s1 == s2
_ == _ = False
resolveFinishedT :: forall (state :: TaskState) (f :: Type -> Type). Task state f -> Either ValidationError (Task 'Finished f)
resolveFinishedT (t@FinishedT{}) = Right t
resolveFinishedT (UnknownStateT name desc stateValue) = case stateValue of
(TSV "Finished") -> Right (FinishedT name desc)
_ -> Left $ WrongState "Task state is incompatible (not in finished state)"
resolveFinishedT _ = Left $ WrongState "Task state is incompatible (not in finished state)"
-- Completed tasks
type CompletedTask = Task 'Finished Identity
......@@ -177,20 +171,17 @@ pTaskDesc (FinishedT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc (InProgressT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc (NotStartedT _ desc) = DT.strip . getTDesc <$> desc
nonEmptyIfPresent :: FieldName -> DT.Text -> Maybe ValidationError
nonEmptyIfPresent fieldname v = if DT.null v then Just (InvalidField taskNameField) else Nothing
instance Validatable (PartialTask state) where
validationChecks = [checkName, checkDescription]
where
checkName :: PartialTask state -> Maybe ValidationError
checkName = maybe (Just (MissingField taskNameField)) notEmptyIfPresent . pTaskName
where
notEmptyIfPresent :: DT.Text -> Maybe ValidationError
notEmptyIfPresent v = if DT.null v then Just (InvalidField taskNameField) else Nothing
checkName = maybe Nothing (nonEmptyIfPresent taskNameField) . pTaskName
checkDescription :: PartialTask state -> Maybe ValidationError
checkDescription = maybe (Just (MissingField taskDescField)) notEmptyIfPresent . pTaskDesc
where
notEmptyIfPresent :: DT.Text -> Maybe ValidationError
notEmptyIfPresent v = if DT.null v then Just (InvalidField taskDescField) else Nothing
checkDescription = maybe Nothing (nonEmptyIfPresent taskDescField) . pTaskDesc
----------------
-- Components --
......@@ -294,6 +285,7 @@ instance Exception EntityStoreError
newtype TableName entity = TN { getTableName :: DT.Text } deriving (Eq, Show, Read)
newtype SQLColumnNames entity = SQLCN { getColumnNames :: [DT.Text] } deriving (Eq, Show, Read)
type SQLColumnName = DT.Text
class ToRow entity => SQLInsertable entity where
tableName :: TableName entity
......@@ -303,6 +295,22 @@ class ToRow entity => SQLInsertable entity where
-- ex. data T f = T { name :: f DT.Text }, where f might be a type like `Maybe a` or `Identity a`
type FBounded = (Type -> Type) -> Type
class SQLUpdatable e where
updateColumns :: e -> SQLColumnNames e
updateColumns = SQLCN . map fst . updateColumnsAndValues
updateValues :: e -> [SQLData]
updateValues = map snd . updateColumnsAndValues
updateColumnsAndValues :: e -> [(SQLColumnName, SQLData)]
updateColumnsAndValues e = resolveMaybes $ removeFailedGetters $ applyToE $ updateColumnGetters e
where
resolveMaybes = map (second fromJust)
removeFailedGetters = filter (isJust . snd)
applyToE = map (second (\fn -> fn e))
updateColumnGetters :: e -> [(SQLColumnName, e -> Maybe SQLData)]
-- | Generalized typeclass for entity storage.
class SQLEntityStore store where
-- | Create an entity
......@@ -324,7 +332,9 @@ class SQLEntityStore store where
-- | Update an existing entity by ID
updateByID :: forall (ident :: Identifier) (entity :: FBounded).
FromRow (Complete entity)
( SQLInsertable (Complete entity)
, SQLUpdatable (Partial entity)
, FromRow (Complete entity))
=> store
-> EntityID
-> Validated (Partial entity)
......
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
module Components.EntityStore.SQLiteSpec (spec) where
......@@ -19,7 +21,8 @@ import Types ( Constructable(..)
, TaskName(..)
, TaskDesc(..)
, Complete
, WithID
, Partial
, WithID(..)
, withoutID
, showID
, getValidatedObj
......@@ -42,6 +45,9 @@ generateTask = rightOrThrow $ validate $ NotStartedT name desc
name = Identity $ TaskName "example"
desc = Identity $ TaskDesc "this is a example task"
generateTaskNameUpdate :: IO (Validated (Partial (Task 'NotStarted)))
generateTaskNameUpdate = rightOrThrow $ validate $ NotStartedT (Just (TaskName "updated name")) Nothing
main :: IO ()
main = hspec spec
......@@ -68,3 +74,22 @@ spec = do
>>= \actualWithID -> pure ( showID actualWithID /= "" &&
withoutID actualWithID == getValidatedObj expected )
>>= (`shouldBe` True)
describe "entity store update" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \original -> create store original
>>= rightOrThrow
-- | Generate and perform update
>>= \createdTask -> generateTaskNameUpdate
>>= \update -> case createdTask of
(WUUID uuid _ ) -> updateByID store (Left uuid) update
(WID (Left uuid) _) -> updateByID store (Left uuid) update
_ -> error "Unexpected thing received"
>>= rightOrThrow
-- | The task should have changed
>>= \updated -> pure ( showID updated /= "" &&
withoutID updated /= getValidatedObj original )
>>= (`shouldBe` True)
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