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 e@(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
......
......@@ -14,11 +14,13 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
module Types where
import Data.HashMap.Lazy (insert)
import GHC.Generics (Generic)
import Data.Aeson (ToJSON(..), (.=), object)
import Data.Aeson (ToJSON(..), (.=), Value(..), object)
import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Bifunctor (second)
import Data.Kind(Type, Constraint)
......@@ -44,122 +46,68 @@ data TaskState = Finished
instance ToJSON TaskState
-- Newtypes preventing careless
newtype TaskName = TaskName { getTName :: DT.Text } deriving (Eq, Show, Generic)
instance ToJSON TaskName
type TaskName = DT.Text
type TaskDesc = DT.Text
type TaskStateValue = DT.Text
newtype TaskDesc = TaskDesc { getTDesc :: DT.Text } deriving (Eq, Show, Generic)
instance ToJSON TaskDesc
type Partial a = a Maybe
type Complete a = a Identity
data Task = Task { tName :: TaskName
, tDesc :: TaskDesc
, tState :: TaskStateValue
} deriving (Eq, Show, Read, Generic)
instance ToJSON Task
data TaskF f = TaskF { tfName :: f TaskName
, tfDesc :: f TaskDesc
, tfState :: f TaskStateValue
}
deriving instance Eq (Complete TaskF)
deriving instance Show (Complete TaskF)
newtype TaskStateValue = TSV { getTStateLiteral :: DT.Text } deriving (Eq, Show, Generic)
deriving instance Eq (Partial TaskF)
deriving instance Show (Partial TaskF)
-- The beefy task class
data Task (state :: TaskState) f where
FinishedT :: f TaskName -> f TaskDesc -> Task 'Finished f
InProgressT :: f TaskName -> f TaskDesc -> Task 'InProgress f
NotStartedT :: f TaskName -> f TaskDesc -> Task 'NotStarted f
data TaskFInState (state :: TaskState) f where
FinishedT :: f TaskName -> f TaskDesc -> TaskFInState 'Finished f
InProgressT :: f TaskName -> f TaskDesc -> TaskFInState 'InProgress f
NotStartedT :: f TaskName -> f TaskDesc -> TaskFInState 'NotStarted f
-- | The case where we don't know what the state actually is
-- 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 -> f TaskStateValue -> Task state f
SomeStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> Task 'Some 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 (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
_ == _ = False
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 (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
-- Completed tasks
type CompletedTask = Task 'Finished Identity
-- InProgress, partially specified tasks
type InProgressPartialTask = Task 'InProgress Maybe
-- InProgress, fully specified tasks
type InProgressTask = Task 'InProgress Identity
-- Not started, partially specified tasks
type NotStartedPartialTask = Task 'NotStarted Maybe
-- Not started, completely specified tasks
type NotStartedTask = Task 'NotStarted Identity
UnknownStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> TaskFInState state f
type Partial a = a Maybe
type Complete a = a Identity
-- | Similar case, but for when we need to fix the state type variable to *something*
SomeStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> TaskFInState 'Some f
deriving instance forall (state :: TaskState). Show (Complete (TaskFInState state))
deriving instance forall (state :: TaskState). Show (Partial (TaskFInState state))
type TaskWithStateAndID = WithID 'UUIDID (Complete (Task Some))
-- | Bridge Tasks in SomeState to their actual ToJSON instances
instance ToJSON TaskWithStateAndID where
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
-- | GHC says the code below is inaccessible, I choose to believe it
-- toJSON (WUUID uuid (FinishedT n d)) = toJSON $ (WUUID uuid (FinishedT n d))
-- toJSON (WUUID uuid (InProgressT n d)) = toJSON $ (WUUID uuid (InProgressT n d))
-- toJSON (WUUID uuid (NotStartedT n d)) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON _ = error "nope" -- should never get here
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'Finished))) where
toJSON (WUUID uuid (FinishedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WINT64 num (FinishedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WID (Left uuid) (FinishedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WID (Right num) (FinishedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= Finished]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'Finished)))"
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'InProgress))) where
toJSON (WUUID uuid (InProgressT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WINT64 num (InProgressT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WID (Left uuid) (InProgressT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WID (Right num) (InProgressT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'InProgress)))"
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'NotStarted))) where
toJSON (WUUID uuid (NotStartedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WINT64 num (NotStartedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WID (Left uuid) (NotStartedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WID (Right num) (NotStartedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'NotStarted)))"
instance forall (state :: TaskState). Eq (Complete (TaskFInState state)) where
v1 == v2 = toTask v1 == toTask v2
-- Aliases for different task states
type FinishedTask = TaskFInState 'Finished
type InProgressTask = TaskFInState 'InProgress
type NotStartedTask = TaskFInState 'NotStarted
----------------
-- Validation --
----------------
newtype FieldName = FieldName { getFieldName :: DT.Text } deriving (Eq, Show, Read)
type FieldName = DT.Text
data ValidationError = InvalidField FieldName
| MissingField FieldName
| WrongState DT.Text deriving (Eq, Show, Read)
| WrongState DT.Text deriving (Eq, Show, Read, Generic)
instance ToJSON ValidationError
instance Exception ValidationError
instance Exception [ValidationError]
......@@ -171,7 +119,7 @@ type ValidationCheck t = t -> Maybe ValidationError
class Validatable t where
-- | Helper method to quickly determine of a type is valid
isValid :: t -> Bool
isValid = either (const True) (const False) . validate
isValid = isRight . validate
-- | Run all checks on the validated
validate :: t -> Either [ValidationError] (Validated t)
......@@ -183,61 +131,70 @@ class Validatable t where
-- | List of validation checks to run on the type (any of which could produce an error)
validationChecks :: [ValidationCheck t]
type FullySpecifiedTask state = Task state Identity
type PartialTask state = Task state Maybe
-- | Utility function for converting a TaskFInState with some state into a regular Task
toTask :: forall (state :: TaskState). Complete (TaskFInState state) -> Task
toTask (NotStartedT (Identity name) (Identity desc)) = Task name desc "NotStarted"
toTask (InProgressT (Identity name) (Identity desc)) = Task name desc "InProgress"
toTask (FinishedT (Identity name) (Identity desc)) = Task name desc "Finished"
toTask (UnknownStateT (Identity name) (Identity desc) (Identity state)) = Task name desc state
toTask (SomeStateT (Identity name) (Identity desc) (Identity state)) = Task name desc state
taskNameField :: FieldName
taskNameField = FieldName "name"
taskNameField = "name"
taskDescField :: FieldName
taskDescField = FieldName "description"
taskDescField = "description"
showState :: forall (state :: TaskState) (f :: Type -> Type). Task state f -> String
-- | Helper function to access task name for fully specified task
fsTaskName :: forall (state :: TaskState). Complete (TaskFInState state) -> DT.Text
fsTaskName (FinishedT (Identity name) _) = DT.strip name
fsTaskName (InProgressT (Identity name) _) = DT.strip name
fsTaskName (NotStartedT (Identity name) _) = DT.strip name
fsTaskName (UnknownStateT (Identity name) _ _) = DT.strip name
fsTaskName (SomeStateT (Identity name) _ _) = DT.strip name
-- | Helper function to access task desc for fully specified task
fsTaskDesc :: forall (state :: TaskState). Complete (TaskFInState state) -> DT.Text
fsTaskDesc (FinishedT _ (Identity desc)) = DT.strip desc
fsTaskDesc (InProgressT _ (Identity desc)) = DT.strip desc
fsTaskDesc (NotStartedT _ (Identity desc)) = DT.strip desc
fsTaskDesc (UnknownStateT _ (Identity desc) _) = DT.strip desc
fsTaskDesc (SomeStateT _ (Identity desc) _) = DT.strip desc
showState :: forall (state :: TaskState) (f :: Type -> Type). TaskFInState state f -> String
showState (FinishedT _ _) = "Finished"
showState (InProgressT _ _) = "InProgress"
showState (NotStartedT _ _) = "NotStarted"
-- | Helper function to access task name for fully specified task
fsTaskName :: FullySpecifiedTask state -> DT.Text
fsTaskName (FinishedT (Identity name) _) = DT.strip $ getTName name
fsTaskName (InProgressT (Identity name) _) = DT.strip $ getTName name
fsTaskName (NotStartedT (Identity name) _) = DT.strip $ getTName name
fsTaskDesc :: FullySpecifiedTask state -> DT.Text
fsTaskDesc (FinishedT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskDesc (InProgressT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskDesc (NotStartedT _ (Identity desc)) = DT.strip $ getTDesc desc
instance Validatable (FullySpecifiedTask state) where
instance Validatable (Complete (TaskFInState state)) where
validationChecks = [checkName, checkDescription]
where
checkName :: FullySpecifiedTask state -> Maybe ValidationError
checkName :: (Complete (TaskFInState state)) -> Maybe ValidationError
checkName t = if DT.null (fsTaskName t) then Just (InvalidField taskNameField) else Nothing
checkDescription :: FullySpecifiedTask state -> Maybe ValidationError
checkDescription :: (Complete (TaskFInState state)) -> Maybe ValidationError
checkDescription t = if DT.null (fsTaskDesc t) then Just (InvalidField taskDescField) else Nothing
pTaskName :: PartialTask state -> Maybe DT.Text
-- pTaskName = (DT.strip . getTName <$>) . tName
pTaskName (FinishedT name _) = DT.strip . getTName <$> name
pTaskName (InProgressT name _) = DT.strip . getTName <$> name
pTaskName (NotStartedT name _) = DT.strip . getTName <$> name
pTaskName :: Partial (TaskFInState state) -> Maybe DT.Text
pTaskName (FinishedT name _) = DT.strip <$> name
pTaskName (InProgressT name _) = DT.strip <$> name
pTaskName (NotStartedT name _) = DT.strip <$> name
pTaskDesc :: PartialTask state -> Maybe DT.Text
pTaskDesc (FinishedT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc (InProgressT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc (NotStartedT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc :: forall (state :: TaskState). Partial (TaskFInState state) -> Maybe DT.Text
pTaskDesc (FinishedT _ desc) = DT.strip <$> desc
pTaskDesc (InProgressT _ desc) = DT.strip <$> desc
pTaskDesc (NotStartedT _ desc) = DT.strip <$> 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
instance Validatable (Partial (TaskFInState state)) where
validationChecks = [checkName, checkDescription]
where
checkName :: PartialTask state -> Maybe ValidationError
checkName :: Partial (TaskFInState state) -> Maybe ValidationError
checkName = maybe Nothing (nonEmptyIfPresent taskNameField) . pTaskName
checkDescription :: PartialTask state -> Maybe ValidationError
checkDescription :: Partial (TaskFInState state) -> Maybe ValidationError
checkDescription = maybe Nothing (nonEmptyIfPresent taskDescField) . pTaskDesc
----------------
......@@ -251,25 +208,14 @@ class Component c where
class Component c => Constructable c cfg err where
construct :: cfg -> IO (Either err c)
data Identifier = UUIDID
| INT64ID deriving (Eq, Show, Read)
data WithID (ident :: Identifier) a where
WUUID :: UUID -> a -> WithID 'UUIDID a
WINT64 :: Int64 -> a -> WithID 'INT64ID a
WID :: Either UUID Int64 -> a -> WithID ident a
data WithUUID a = WUUID UUID a deriving (Eq, Show, Read)
withoutID :: forall (ident :: Identifier) a. WithID ident a -> a
withoutID (WUUID _ a) = a
withoutID (WINT64 _ a) = a
withoutID (WID _ a) = a
showID :: forall (ident :: Identifier) a. WithID ident a -> String
showID (WUUID v _) = show v
showID (WINT64 v _) = show v
showID (WID (Left v) _) = show v
showID (WID (Right v) _) = show v
instance ToJSON a => ToJSON (WithUUID a) where
toJSON (WUUID uuid obj) = case toJSON obj of
obj@(Object map) -> Object $ insert "uuid" (String uuidTxt) map
v -> object ["uuid" .= uuid, "data" .= v]
where