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
This diff is collapsed.
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