Commit 77ad3ff8 authored by MrMan's avatar MrMan

Simplify, simplify, simplify!

- tests pass
- listing endpoint works
parent 3d6792b9
......@@ -90,7 +90,7 @@ server cfg = buildEntityStore entityStoreCfg -- | Build & start the entity store
-- | Start the app
>>= startApp
where
makeTestTask = pure $ validate $ NotStartedT (Identity (TaskName "test")) (Identity (TaskDesc "test description"))
makeTestTask = pure $ validate $ NotStartedT (Identity "test") (Identity "test description")
entityStoreCfg = runIdentity $ entityStoreConfig cfg
appPort = runIdentity $ port cfg
......
......@@ -27,14 +27,14 @@ type Name = DT.Text
type Greeting = DT.Text
type TodoAPI =
"todos" :> Get '[JSON] [TaskWithStateAndID]
"todos" :> Get '[JSON] [WithUUID Task]
todoServer :: ServerT TodoAPI AppHandler
todoServer = listTodos
listTodos :: AppHandler [TaskWithStateAndID]
listTodos :: AppHandler [WithUUID Task]
listTodos = ask
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithID 'UUIDID (Complete (Task Some))]))
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithUUID Task]))
>>= rightOrServantErr genericServerError
todoAPI :: Proxy TodoAPI
......
......@@ -36,6 +36,7 @@ library:
- sqlite-simple
- neat-interpolation
- transformers
- unordered-containers
executables:
haskell-restish-todo-exe:
......@@ -89,3 +90,4 @@ tests:
dependencies:
- haskell-restish-todo
- hspec
- uuid
......@@ -68,39 +68,20 @@ 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
instance FromField TaskName where
fromField = (TaskName <$>) . (fromField :: FieldParser DT.Text)
instance FromField TaskDesc where
fromField = (TaskDesc <$>) . (fromField :: FieldParser DT.Text)
instance FromField TaskStateValue where
fromField = (TSV <$>) . (fromField :: FieldParser DT.Text)
instance ToField TaskDesc where
toField = SQLText . getTDesc
instance ToField a => ToField (Identity a) where
toField = toField . runIdentity
-- | ToRow (WithID a) can be generically performed if we just always put the ID first
-- this introduces the requirement that ids should always come first.
instance forall (ident :: Identifier) a. ToRow a => ToRow (WithID ident a) where
instance forall a. ToRow a => ToRow (WithUUID a) where
toRow (WUUID id_ obj) = [toField id_] <> toRow obj
toRow (WINT64 id_ obj) = [toField id_] <> toRow obj
instance forall (state :: TaskState) a. ToRow (FullySpecifiedTask state) where
instance forall (state :: TaskState) a. ToRow (Complete (TaskFInState state)) where
toRow t@(FinishedT name desc) = toRow (name, desc, showState t)
toRow t@(InProgressT (Identity name) (Identity desc)) = toRow (name, desc, showState t)
toRow t@(NotStartedT (Identity name) (Identity desc)) = toRow (name, desc, showState t)
instance forall (ident :: Identifier) a. FromRow a => FromRow (WithID ident a) where
instance forall a. FromRow a => FromRow (WithUUID a) where
-- While normally FromRow instances are written like: `ValueConstructor <$> field <*> field ...`
-- I can't figure out how to cleanly construct and build the partial result using applicatives
-- since I need to pull out the ID, set it aside, then work on the rest, *then* use the right GADT constructor for WithId a
......@@ -110,10 +91,9 @@ instance forall (ident :: Identifier) a. FromRow a => FromRow (WithID ident a) w
where
chooseCtor sqldata = case sqldata of
(SQLText txt) -> \obj -> case fromText txt of
Just uuid -> pure $ WUUID uuid obj
Nothing -> throw $ ConversionFailed (show sqldata) "Text" "UUID failed fromText conversion"
Just uuid -> pure $ WID (Left uuid) obj
(SQLInteger int) -> pure . WID (Right (fromIntegral int))
_ -> throw $ ConversionFailed (show sqldata) "???" "Unrecognized contents in ID field (no valid WithID GADT constructor)"
_ -> throw $ ConversionFailed (show sqldata) "???" "Unrecognized contents in UUID field (no valid WithID GADT constructor)"
instance FromRow a => FromRow (Identity a) where
fromRow = Identity <$> (fromRow :: RowParser a)
......@@ -126,7 +106,7 @@ instance FromField TaskState where
SQLText txt -> pure $ read $ DT.unpack txt
fd -> returnError ConversionFailed f "Unexpected TaskState field type"
instance forall (state :: TaskState). FromRow (FullySpecifiedTask state) where
instance forall (state :: TaskState). FromRow (Complete (TaskFInState state)) where
fromRow = UnknownStateT <$> field <*> field <*> field
disconnectionError :: IO (Either EntityStoreError a)
......@@ -135,10 +115,10 @@ disconnectionError = pure $ Left $ DisconnectedES "Store is disconnected"
makeGenericInsertError :: SomeException -> IO (Either EntityStoreError a)
makeGenericInsertError = pure . Left . UnexpectedErrorES . ("INSERT command failed: " <>) . DT.pack . show
saveAndReturnTask :: forall (state :: TaskState) (ident :: Identifier).
saveAndReturnTask :: forall (state :: TaskState).
Connection
-> WithID ident (FullySpecifiedTask state)
-> IO (Either EntityStoreError (WithID ident (FullySpecifiedTask state)))
-> WithUUID (Complete (TaskFInState state))
-> IO (Either EntityStoreError (WithUUID (Complete (TaskFInState state))))
saveAndReturnTask c t = catch doInsert makeGenericInsertError
where
doInsert = execute c "INSERT INTO tasks (uuid, name, description, state) VALUES (?,?,?,?)" t
......@@ -246,34 +226,37 @@ withActiveConn :: SQLiteEntityStore -> (Connection -> IO (Either EntityStoreErro
withActiveConn store action = maybe disconnectionError action $ stsConn store
-- | Ensure that a UUID is present on a given entity
ensureUUID :: entity -> IO (Either EntityStoreError (WithID 'UUIDID entity))
ensureUUID :: entity -> IO (Either EntityStoreError (WithUUID entity))
ensureUUID e = Right . flip WUUID e <$> nextRandom
-- | Insert and return an entity
insertAndReturnEntity :: forall (ident :: Identifier) entity.
( SQLInsertable (WithID ident (Complete entity))
insertAndReturnEntity :: forall entity.
( SQLInsertable (WithUUID (Complete entity))
, SQLInsertable (Complete entity)
, FromRow (Complete entity))
, FromRow (WithUUID (Complete entity))
)
=> Connection
-> WithID ident (Complete entity)
-> IO (Either EntityStoreError (WithID ident (Complete entity)))
insertAndReturnEntity conn (WINT64 _ _) = pure $ Left $ UnexpectedErrorES "insertion with integer based UUIDs is not allowed"
-> WithUUID (Complete entity)
-> IO (Either EntityStoreError (WithUUID (Complete entity)))
insertAndReturnEntity conn entity@(WUUID uuid _) = insertEntity conn entity
>> getEntityByUUID conn uuid
instance SQLInsertable Task where
tableName = TN "tasks"
columnNames = SQLCN ["name", "description", "state"]
-- | Convert an type-specified identifier to a generic one identifier to a generic one
-- This is necessary when interfaces need the generic version but haskell is smart enough to know which is there and can't unify them
uuidToGenericIdent :: forall (ident :: Identifier) e. WithID 'UUIDID e -> WithID ident e
uuidToGenericIdent (WUUID uuid v) = WID (Left uuid) v
uuidToGenericIdent (WID (Left uuid) v) = WID (Left uuid) v
instance SQLInsertable (Complete (Task state)) where
instance forall (state :: TaskState). SQLInsertable (Complete (TaskFInState state)) where
tableName = TN "tasks"
columnNames = SQLCN ["name", "description", "state"]
instance ToRow Task where
toRow (Task n d s) = toRow (n, d, s)
instance FromRow Task where
fromRow = Task <$> field <*> field <*> field
-- | If some value e is SQLInsertable, then the same value with a UUID is insertable
-- All we do is ensure the columns include a "uuid" column at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithID 'UUIDID e) where
instance forall e. SQLInsertable e => SQLInsertable (WithUUID e) where
tableName = TN tbl
where
(TN tbl) = tableName :: TableName e
......@@ -282,18 +265,7 @@ instance forall e. SQLInsertable e => SQLInsertable (WithID 'UUIDID e) where
where
(SQLCN innerCols) = columnNames :: SQLColumnNames e
-- | If some value e is insertable in the SQL paradigm, then the same value with an ID is insertable
-- All we do is ensure teh columns include an "id" at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithID 'INT64ID e) where
tableName = TN tbl
where
(TN tbl) = tableName :: TableName e
columnNames = SQLCN $ "id":innerCols
where
(SQLCN innerCols) = columnNames :: SQLColumnNames e
instance SQLUpdatable (Partial (Task state)) where
instance SQLUpdatable (Partial (TaskFInState state)) where
updateColumnGetters NotStartedT{} = [ ("name", \(NotStartedT name _) -> toField <$> name)
, ("description", \(NotStartedT _ desc) -> toField <$> desc)
]
......@@ -313,33 +285,33 @@ instance SQLUpdatable (Partial (Task state)) where
data QueryWithParams p = QWP Query p
instance SQLDeletable (Task state) where
instance forall (state :: TaskState). SQLDeletable (TaskFInState state) where
deletionMode = Hard
instance SQLDeletable a => SQLDeletable (Complete a) where
deletionMode = case (deletionMode :: DeletionMode a) of
Hard -> Hard
Soft -> Soft
instance SQLDeletable a => SQLDeletable (WithUUID a) where
deletionMode = case (deletionMode :: DeletionMode a) of
Hard -> Hard
Soft -> Soft
-- | 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
(SQLInsertable (Complete entity),
SQLInsertable (WithID ident (Complete entity))) -- | entity must be insertable under SQL & complete w/ an ID
=> WithID ident (Complete entity)
-> QueryWithParams (WithID ident (Complete entity))
buildInsertQuery :: forall entity. SQLInsertable entity => entity -> QueryWithParams entity
buildInsertQuery = QWP insertQuery
where
(TN tbl) = tableName :: TableName (WithID ident (Complete entity))
(SQLCN cols) = columnNames :: SQLColumnNames (WithID ident (Complete entity))
(TN tbl) = tableName :: TableName entity
(SQLCN cols) = columnNames :: SQLColumnNames entity
columnPhrase = DT.intercalate "," cols
valueQs = DT.intercalate "," $ replicate (length cols) "?"
insertQuery = Query $ [text| INSERT INTO $tbl ( $columnPhrase ) VALUES ( $valueQs ) |]
-- | Do the actual insertion for an entity
insertEntity :: forall (ident :: Identifier) entity.
( SQLInsertable (WithID ident (Complete entity))
, SQLInsertable (Complete entity))
=> Connection
-> WithID ident (Complete entity)
-> IO (Either EntityStoreError ())
insertEntity conn (WINT64 _ _) = pure $ Left $ UnexpectedErrorES "entities must be UUID-identified"
insertEntity conn e@(WUUID uuid _) = Right <$> execute conn query params
insertEntity :: forall entity. SQLInsertable entity => Connection -> entity -> IO (Either EntityStoreError ())
insertEntity conn e = Right <$> execute conn query params
where
(QWP query params) = buildInsertQuery e
......@@ -347,29 +319,30 @@ insertEntity conn [email protected](WUUID uuid _) = Right <$> execute conn query params
getEntityByUUID :: forall entity.
( SQLInsertable entity
, FromRow entity
, FromRow (WithID 'UUIDID entity)
, ToRow (WithID 'UUIDID entity))
, ToRow entity
)
=> Connection
-> UUID
-> IO (Either EntityStoreError (WithID 'UUIDID entity))
getEntityByUUID conn uuid = (query conn selectQuery (Only uuid) :: IO [WithID 'UUIDID entity])
-> IO (Either EntityStoreError entity)
getEntityByUUID conn uuid = query conn selectQuery (Only uuid)
-- ^ TODO: Dangerous IO (add try/catch)
>>= \case
(v@WUUID{}:_) -> pure $ Right v
(v@(WID (Left uuid) inner):_) -> pure $ Right $ WID (Left uuid) inner
_ -> pure $ Left $ NoSuchEntityES (Left uuid) "Failed to find task with given UUID"
(v:_) -> pure $ Right v
_ -> pure $ Left $ NoSuchEntityES uuid $ "Failed to find task with UUID [" <> toText uuid <> "]"
where
(TN tbl) = tableName :: TableName (WithID 'UUIDID entity)
(TN tbl) = tableName :: TableName 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)))
, FromRow (WithUUID (Complete entity)))
=> Connection
-> UUID
-> Partial entity
-> IO (Either EntityStoreError (WithID 'UUIDID (Complete entity)))
-> IO (Either EntityStoreError (WithUUID (Complete entity)))
updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChanges
>>= \case
1 -> getEntityByUUID conn uuid
......@@ -389,13 +362,13 @@ updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChange
>> changes conn
deleteEntityByUUID :: forall entity.
( SQLInsertable (Complete entity)
( SQLInsertable entity
, SQLDeletable entity
, FromRow (Complete entity)
, FromRow (WithID 'UUIDID (Complete entity)))
, FromRow entity
)
=> Connection
-> UUID
-> IO (Either EntityStoreError (WithID 'UUIDID (Complete entity)))
-> IO (Either EntityStoreError entity)
deleteEntityByUUID conn uuid = getEntityByUUID conn uuid
>>= rightOrThrow
>>= \beforeDelete -> withTransaction conn deleteAndCheckChanges
......@@ -403,7 +376,7 @@ deleteEntityByUUID conn uuid = getEntityByUUID conn uuid
1 -> pure $ Right $ beforeDelete
_ -> pure $ Left $ UnexpectedErrorES "Delete failed, no rows were changed"
where
(TN tbl) = tableName :: TableName (Complete entity)
(TN tbl) = tableName :: TableName entity
deleteQuery = case deletionMode :: DeletionMode entity of
Hard -> Query $ [text| DELETE FROM $tbl WHERE uuid = ? |]
......@@ -421,7 +394,7 @@ listEntities :: forall entity.
-> IO (Either EntityStoreError [entity])
listEntities conn = Right <$> query_ conn selectAllQuery
where
(TN tbl) = tableName :: TableName (WithID 'UUIDID entity)
(TN tbl) = tableName :: TableName entity
selectAllQuery = Query $ [text| SELECT * FROM $tbl |]
-- | Generalized typeclass for entity storage.
......@@ -432,33 +405,18 @@ instance SQLEntityStore SQLiteEntityStore where
>>= rightOrThrow
-- | Generate an insert query for the `WithID entity`
>>= insertAndReturnEntity conn
>>= rightOrThrow
-- | We need to obscure the type to match for "any" ident
>>= pure . Right . uuidToGenericIdent
getByID store eid = withActiveConn store _work
getByUUID store uuid = withActiveConn store _work
where
_work conn = case eid of
(Left uuid) -> getEntityByUUID conn uuid
>>= rightOrThrow
>>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
_work conn = getEntityByUUID conn uuid
updateByID store eid (Validated partial) = withActiveConn store _work
updateByUUID store uuid (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"
_work conn = updateEntityByUUID conn uuid partial
deleteByID store eid = withActiveConn store _work
deleteByUUID store uuid = 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"
_work conn = deleteEntityByUUID conn uuid
list store = withActiveConn store _work
where
......
This diff is collapsed.
......@@ -7,34 +7,14 @@ module Components.EntityStore.SQLiteSpec (spec) where
import Components.EntityStore.SQLite (SQLiteEntityStore)
import Control.Monad (when)
import Types ( Complete
, Constructable(..)
, EntityStoreError
, FullySpecifiedTask
, HasMigratableDB(..)
, NotStartedTask
, Partial
, SQLEntityStore(..)
, SQLInsertable
, SQLMigrationVersion(..)
, Task(..)
, TaskDesc(..)
, TaskName(..)
, TaskState(..)
, Validatable(..)
, Validated
, ValidationError
, WithID(..)
, Identifier(..)
, withoutID
, showID
, getValidatedObj
)
import Types
import Data.Either (isLeft)
import Data.Functor.Identity
import Config (defaultCompleteEntityStoreConfig)
import Data.Either (isRight)
import Control.Monad.IO.Class (liftIO)
import Util (rightOrThrow)
import Data.UUID (toText)
import Test.Hspec
......@@ -42,14 +22,14 @@ makeDefaultStore :: IO (Either EntityStoreError SQLiteEntityStore)
makeDefaultStore = construct defaultCompleteEntityStoreConfig
-- generateTask :: IO (Validated NotStartedTask)
generateTask :: IO (Validated NotStartedTask)
generateTask :: IO (Validated (Complete NotStartedTask))
generateTask = rightOrThrow $ validate $ NotStartedT name desc
where
name = Identity $ TaskName "example"
desc = Identity $ TaskDesc "this is a example task"
name = Identity "example"
desc = Identity "this is a example task"
generateTaskNameUpdate :: IO (Validated (Partial (Task 'NotStarted)))
generateTaskNameUpdate = rightOrThrow $ validate $ NotStartedT (Just (TaskName "updated name")) Nothing
generateTaskNameUpdate :: IO (Validated (Partial NotStartedTask))
generateTaskNameUpdate = rightOrThrow $ validate $ NotStartedT (Just "updated name") Nothing
main :: IO ()
main = hspec spec
......@@ -71,11 +51,10 @@ spec = do
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \expected -> create store (expected :: Validated NotStartedTask)
>>= \expected -> (create store expected :: IO (Either EntityStoreError (WithUUID (Complete NotStartedTask))))
>>= rightOrThrow
-- | Ensure that the ID is non-empty when printed, and the object we got back is right
>>= \actualWithID -> pure ( showID actualWithID /= "" &&
withoutID actualWithID == getValidatedObj expected )
>>= \(WUUID uuid task) -> pure (toText uuid /= "" && task == getValidatedObj expected)
>>= (`shouldBe` True)
describe "entity store update" $
......@@ -83,18 +62,14 @@ spec = do
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \original -> create store original
>>= \original -> (create store original :: IO (Either EntityStoreError (WithUUID (Complete NotStartedTask))))
>>= 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"
>>= \expected@(WUUID uuid _) -> generateTaskNameUpdate
>>= updateByUUID store uuid
>>= rightOrThrow
-- | The task should have changed
>>= \updated -> pure ( showID updated /= "" &&
withoutID updated /= getValidatedObj original )
>>= \returned@(WUUID uuid task) -> pure (toText uuid /= "" && returned /= expected)
>>= (`shouldBe` True)
describe "entity store delete" $
......@@ -106,30 +81,22 @@ spec = do
>>= \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"
>>= \(WUUID uuid _) -> (deleteByUUID store uuid :: IO (Either EntityStoreError (WithUUID (Complete NotStartedTask))))
>>= 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"
>>= \(WUUID _ obj) -> when (obj /= getValidatedObj original) (error "returned deleted object mismatch")
-- | Ensure that a get with the deleted item's ID fails (produces a Left value)
>> (getByUUID store uuid :: IO (Either EntityStoreError (WithUUID (Complete NotStartedTask))))
>>= (`shouldSatisfy` isLeft)
describe "entity store lsit" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \expected -> create store (expected :: Validated NotStartedTask)
>>= \expected -> create store expected
>>= rightOrThrow
-- | Ensure that the ID is non-empty when printed, and the object we got back is right
>> (list store :: IO (Either EntityStoreError [(WithID 'UUIDID (Complete (Task state)))]))
>> (list store :: IO (Either EntityStoreError [WithUUID Task]))
>>= rightOrThrow
>>= (`shouldBe` 1) . length
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