Commit fb66e403 authored by MrMan's avatar MrMan

Progress up to forall vs no-forall error on listing endpoint

parent 3ad559d6
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
module Server module Server
(buildApp) (buildApp)
where where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ask)
import Data.Proxy import Data.Proxy
import Data.Semigroup ((<>)) import Data.Semigroup ((<>))
import Servant.API import Servant.API
import Servant.Server (ServerT, Application, serve, hoistServer) import Servant.Server (ServerT, Application, serve, hoistServer)
import qualified Data.Text as DT import qualified Data.Text as DT
import Util (rightOrServantErr, genericServerError)
import Types import Types
type Name = DT.Text type Name = DT.Text
type Greeting = DT.Text type Greeting = DT.Text
type HelloWorldAPI = type TodoAPI =
"hello" :> QueryParam "name" DT.Text :> Get '[JSON] Greeting "todos" :> Get '[JSON] [TaskWithState]
:<|> "goodbye" :> QueryParam "name" DT.Text :> Get '[JSON] Greeting
helloWorldServer :: ServerT HelloWorldAPI AppHandler todoServer :: ServerT TodoAPI AppHandler
helloWorldServer = handleHello todoServer = listTodos
:<|> handleGoodbye
handleHello :: Maybe Name -> AppHandler Greeting listTodos :: AppHandler [TaskWithState]
handleHello Nothing = return $ "hello world" listTodos = ask
handleHello (Just name) = return $ "hello " <> name >>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithID ident (Complete (Task state))]))
>>= rightOrServantErr genericServerError
>>= pure . (TWS <$>)
handleGoodbye :: Maybe Name -> AppHandler Greeting todoAPI :: Proxy TodoAPI
handleGoodbye Nothing = return $ "goodbye world" todoAPI = Proxy
handleGoodbye (Just name) = return $ "goodbye " <> name
helloWorldAPI :: Proxy HelloWorldAPI
helloWorldAPI = Proxy
buildApp :: AppState -> Application buildApp :: AppState -> Application
buildApp state = serve helloWorldAPI $ hoistServer helloWorldAPI naturalTransform helloWorldServer buildApp state = serve todoAPI $ hoistServer todoAPI naturalTransform todoServer
where where
naturalTransform = appToServantHandler state naturalTransform = appToServantHandler state
...@@ -53,6 +53,7 @@ executables: ...@@ -53,6 +53,7 @@ executables:
- servant - servant
- servant-server - servant-server
- warp - warp
- transformers
tests: tests:
haskell-restish-todo-test: haskell-restish-todo-test:
......
...@@ -271,19 +271,24 @@ instance SQLInsertable (Complete (Task state)) where ...@@ -271,19 +271,24 @@ instance SQLInsertable (Complete (Task state)) where
-- | If some value e is SQLInsertable, then the same value with a UUID is insertable -- | 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 -- 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 (WithID 'UUIDID e) where
tableName = TN "tasks" tableName = TN tbl
columnNames = SQLCN $ "uuid":innerCols where
(TN tbl) = tableName :: TableName e
columnNames = SQLCN $ "uuid":innerCols
where where
(SQLCN innerCols) = columnNames :: SQLColumnNames e (SQLCN innerCols) = columnNames :: SQLColumnNames e
-- | If some value e is insertable in the SQL paradigm, then the same value with an ID is insertable -- | 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 -- All we do is ensure teh columns include an "id" at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithID 'INT64ID e) where instance forall e. SQLInsertable e => SQLInsertable (WithID 'INT64ID e) where
tableName = TN "tasks" tableName = TN tbl
columnNames = SQLCN $ "id":innerCols
where where
(SQLCN innerCols) = columnNames :: SQLColumnNames e (TN tbl) = tableName :: TableName e
columnNames = SQLCN $ "id":innerCols
where
(SQLCN innerCols) = columnNames :: SQLColumnNames e
instance SQLUpdatable (Partial (Task state)) where instance SQLUpdatable (Partial (Task state)) where
updateColumnGetters NotStartedT{} = [ ("name", \(NotStartedT name _) -> toField <$> name) updateColumnGetters NotStartedT{} = [ ("name", \(NotStartedT name _) -> toField <$> name)
...@@ -404,6 +409,18 @@ deleteEntityByUUID conn uuid = getEntityByUUID conn uuid ...@@ -404,6 +409,18 @@ deleteEntityByUUID conn uuid = getEntityByUUID conn uuid
deleteAndCheckChanges = execute conn deleteQuery (Only uuid) deleteAndCheckChanges = execute conn deleteQuery (Only uuid)
>> changes conn >> changes conn
-- | List entities
listEntities :: forall entity.
( SQLInsertable entity
, SQLInsertable entity
, FromRow entity)
=> Connection
-> IO (Either EntityStoreError [entity])
listEntities conn = Right <$> query_ conn selectAllQuery
where
(TN tbl) = tableName :: TableName (WithID 'UUIDID entity)
selectAllQuery = Query $ [text| SELECT * FROM $tbl |]
-- | Generalized typeclass for entity storage. -- | Generalized typeclass for entity storage.
instance SQLEntityStore SQLiteEntityStore where instance SQLEntityStore SQLiteEntityStore where
create store (Validated entity) = withActiveConn store _work create store (Validated entity) = withActiveConn store _work
...@@ -439,3 +456,7 @@ instance SQLEntityStore SQLiteEntityStore where ...@@ -439,3 +456,7 @@ instance SQLEntityStore SQLiteEntityStore where
>>= rightOrThrow >>= rightOrThrow
>>= pure . Right . uuidToGenericIdent >>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported" _ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
list store = withActiveConn store _work
where
_work conn = listEntities conn
...@@ -12,9 +12,11 @@ ...@@ -12,9 +12,11 @@
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
module Types where module Types where
import Data.Aeson (ToJSON(..))
import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Bifunctor (second) import Data.Bifunctor (second)
import Data.Kind(Type, Constraint) import Data.Kind(Type, Constraint)
...@@ -54,6 +56,11 @@ data Task (state :: TaskState) f where ...@@ -54,6 +56,11 @@ data Task (state :: TaskState) f where
-- Once we have an UnknownStateT we can write functions that try to translate to what we expect/require and fail otherwise. -- 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 UnknownStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> Task state f
newtype TaskWithState = TWS { getTask :: forall (ident :: Identifier) (s :: TaskState). WithID ident (Complete (Task s)) }
instance ToJSON (TaskWithState) where
toJSON = undefined
instance Eq (Task (state :: TaskState) Identity) where instance Eq (Task (state :: TaskState) Identity) where
(FinishedT n1 d1) == (FinishedT n2 d2) = n1 == n2 && d1 == d2 (FinishedT n1 d1) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(InProgressT n1 d1) == (InProgressT n2 d2) = n1 == n2 && d1 == d2 (InProgressT n1 d1) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
...@@ -357,6 +364,13 @@ class SQLEntityStore store where ...@@ -357,6 +364,13 @@ class SQLEntityStore store where
-> EntityID -> EntityID
-> IO (Either EntityStoreError (WithID ident (Complete entity))) -> IO (Either EntityStoreError (WithID ident (Complete entity)))
-- | Get a listing of all entities
list :: forall (ident :: Identifier) (entity :: FBounded).
( SQLInsertable (WithID ident (Complete entity))
, FromRow (WithID ident (Complete entity)))
=> store
-> IO (Either EntityStoreError [WithID ident (Complete entity)])
-- | Our application state -- | Our application state
data AppState = forall estore. SQLEntityStore estore => data AppState = forall estore. SQLEntityStore estore =>
AppState { appConfig :: Complete AppConfig AppState { appConfig :: Complete AppConfig
......
module Util where {-# LANGUAGE OverloadedStrings #-}
module Util
( rightOrServantErr
, rightOrThrow
, genericServerError
)
where
import Servant.Server (ServantErr(..), err500)
import Control.Exception (Exception, throw) import Control.Exception (Exception, throw)
-- | Ensure that an Either resolves to it's Right value -- | Ensure that an Either resolves to it's Right value
...@@ -7,3 +15,11 @@ rightOrThrow :: (Exception a) => Either a b -> IO b ...@@ -7,3 +15,11 @@ rightOrThrow :: (Exception a) => Either a b -> IO b
rightOrThrow e = case e of rightOrThrow e = case e of
(Left err) -> throw err (Left err) -> throw err
(Right v) -> return v (Right v) -> return v
-- | Ensure that an Either resolves to it's Right value
rightOrServantErr :: (Exception a, Monad m) => ServantErr -> Either a b -> m b
rightOrServantErr err (Left _) = throw err
rightOrServantErr _ (Right v) = return v
genericServerError :: ServantErr
genericServerError = err500 { errBody = "Unexpected server error" }
...@@ -25,6 +25,7 @@ import Types ( Complete ...@@ -25,6 +25,7 @@ import Types ( Complete
, Validated , Validated
, ValidationError , ValidationError
, WithID(..) , WithID(..)
, Identifier(..)
, withoutID , withoutID
, showID , showID
, getValidatedObj , getValidatedObj
...@@ -120,3 +121,15 @@ spec = do ...@@ -120,3 +121,15 @@ spec = do
(WUUID uuid _) -> getFn uuid `shouldThrow` anyException (WUUID uuid _) -> getFn uuid `shouldThrow` anyException
(WID (Left uuid) _) -> getFn uuid `shouldThrow` anyException (WID (Left uuid) _) -> getFn uuid `shouldThrow` anyException
_ -> expectationFailure "uuid missing when ensuring get failed" _ -> expectationFailure "uuid missing when ensuring get failed"
describe "entity store lsit" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \expected -> create store (expected :: Validated NotStartedTask)
>>= 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)))]))
>>= 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