Commit fb66e403 authored by MrMan's avatar MrMan

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

parent 3ad559d6
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
module Server
(buildApp)
where
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ask)
import Data.Proxy
import Data.Semigroup ((<>))
import Servant.API
import Servant.Server (ServerT, Application, serve, hoistServer)
import qualified Data.Text as DT
import Util (rightOrServantErr, genericServerError)
import Types
type Name = DT.Text
type Greeting = DT.Text
type HelloWorldAPI =
"hello" :> QueryParam "name" DT.Text :> Get '[JSON] Greeting
:<|> "goodbye" :> QueryParam "name" DT.Text :> Get '[JSON] Greeting
type TodoAPI =
"todos" :> Get '[JSON] [TaskWithState]
helloWorldServer :: ServerT HelloWorldAPI AppHandler
helloWorldServer = handleHello
:<|> handleGoodbye
todoServer :: ServerT TodoAPI AppHandler
todoServer = listTodos
handleHello :: Maybe Name -> AppHandler Greeting
handleHello Nothing = return $ "hello world"
handleHello (Just name) = return $ "hello " <> name
listTodos :: AppHandler [TaskWithState]
listTodos = ask
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithID ident (Complete (Task state))]))
>>= rightOrServantErr genericServerError
>>= pure . (TWS <$>)
handleGoodbye :: Maybe Name -> AppHandler Greeting
handleGoodbye Nothing = return $ "goodbye world"
handleGoodbye (Just name) = return $ "goodbye " <> name
helloWorldAPI :: Proxy HelloWorldAPI
helloWorldAPI = Proxy
todoAPI :: Proxy TodoAPI
todoAPI = Proxy
buildApp :: AppState -> Application
buildApp state = serve helloWorldAPI $ hoistServer helloWorldAPI naturalTransform helloWorldServer
buildApp state = serve todoAPI $ hoistServer todoAPI naturalTransform todoServer
where
naturalTransform = appToServantHandler state
......@@ -53,6 +53,7 @@ executables:
- servant
- servant-server
- warp
- transformers
tests:
haskell-restish-todo-test:
......
......@@ -271,7 +271,10 @@ instance SQLInsertable (Complete (Task state)) where
-- | 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
tableName = TN "tasks"
tableName = TN tbl
where
(TN tbl) = tableName :: TableName e
columnNames = SQLCN $ "uuid":innerCols
where
(SQLCN innerCols) = columnNames :: SQLColumnNames e
......@@ -279,12 +282,14 @@ instance forall e. SQLInsertable e => SQLInsertable (WithID 'UUIDID e) where
-- | 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 "tasks"
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
updateColumnGetters NotStartedT{} = [ ("name", \(NotStartedT name _) -> toField <$> name)
, ("description", \(NotStartedT _ desc) -> toField <$> desc)
......@@ -404,6 +409,18 @@ deleteEntityByUUID conn uuid = getEntityByUUID conn uuid
deleteAndCheckChanges = execute conn deleteQuery (Only uuid)
>> 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.
instance SQLEntityStore SQLiteEntityStore where
create store (Validated entity) = withActiveConn store _work
......@@ -439,3 +456,7 @@ instance SQLEntityStore SQLiteEntityStore where
>>= rightOrThrow
>>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
list store = withActiveConn store _work
where
_work conn = listEntities conn
......@@ -12,9 +12,11 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
module Types where
import Data.Aeson (ToJSON(..))
import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Bifunctor (second)
import Data.Kind(Type, Constraint)
......@@ -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.
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
(FinishedT n1 d1) == (FinishedT n2 d2) = n1 == n2 && d1 == d2
(InProgressT n1 d1) == (InProgressT n2 d2) = n1 == n2 && d1 == d2
......@@ -357,6 +364,13 @@ class SQLEntityStore store where
-> EntityID
-> 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
data AppState = forall estore. SQLEntityStore estore =>
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)
-- | Ensure that an Either resolves to it's Right value
......@@ -7,3 +15,11 @@ rightOrThrow :: (Exception a) => Either a b -> IO b
rightOrThrow e = case e of
(Left err) -> throw err
(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
, Validated
, ValidationError
, WithID(..)
, Identifier(..)
, withoutID
, showID
, getValidatedObj
......@@ -120,3 +121,15 @@ spec = do
(WUUID uuid _) -> getFn uuid `shouldThrow` anyException
(WID (Left uuid) _) -> getFn uuid `shouldThrow` anyException
_ -> 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