domaindriven-0.5.0: test/DomainDriven/ServerSpec.hs
{-# LANGUAGE TemplateHaskell #-}
module DomainDriven.ServerSpec where
import Action.ExtraParam
import Action.ServerTest
import Action.Store
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad.Catch (try)
import Control.Monad.Except
import Data.Map qualified as M
import Data.Text (Text)
import DomainDriven
import DomainDriven.Persistance.ForgetfulInMemory
import DomainDriven.Server.Config (ServerConfig (..))
import Network.HTTP.Client
( defaultManagerSettings
, newManager
)
import Network.Wai.Handler.Warp (run)
import Servant
import Servant.Client
import Test.Hspec
import Prelude
-- import Data.Kind (Type)
-- import UnliftIO (MonadUnliftIO)
$(mkServer extraParamConfig ''ExtraParamAction)
-----------------------------------------------------------------------------------------
-- type ExtraParamActionApi (ep_idrrs :: ExtraP) (bool_idrrr :: Bool) =
-- (:<|>) ExtraParamAction_ReverseTextEndpoint ((:<|>) ((:>) "Sub1" (ExtraParamAction_Sub1Api ep_idrrs)) ((:<|>) ((:>) "Sub2" ExtraParamAction_Sub2Api) ((:>) "Sub3" (ExtraParamAction_Sub3Api ep_idrrs bool_idrrr))))
-- type ExtraParamAction_ReverseTextEndpoint =
-- (:>) "ReverseText" ((:>) (ReqBody '[JSON] (NF1 "ExtraParamAction_ReverseText" "text" Text)) (Verb 'POST 200 ( '(:) JSON ('[] :: [Type])) Text))
-- type ExtraParamAction_Sub1Api (ep_idrrs :: ExtraP) =
-- (:<|>) ExtraParamAction_Sub1_TalkToMeEndpoint (ExtraParamAction_Sub1_SayMyNumberEndpoint ep_idrrs)
-- type ExtraParamAction_Sub1_TalkToMeEndpoint =
-- (:>) "TalkToMe" (Verb 'GET 200 ( '(:) JSON ('[] :: [Type])) Text)
-- type ExtraParamAction_Sub1_SayMyNumberEndpoint (ep_idrrs :: ExtraP) =
-- (:>) "SayMyNumber" ((:>) (ReqBody '[JSON] (NF1 "Sub1Action_SayMyNumber" "int" (MyInt ep_idrrs))) (Verb 'POST 200 ( '(:) JSON ('[] :: [Type])) [Char]))
-- extraParamAction_Sub1Server
-- :: forall (m :: Type -> Type) (ep_idrrs :: ExtraP)
-- . MonadUnliftIO m
-- => ActionRunner m (Sub1Action ep_idrrs)
-- -> ServerT (ExtraParamAction_Sub1Api ep_idrrs) m
-- extraParamAction_Sub1Server runner =
-- ( extraParamAction_Sub1_TalkToMeHandler runner
-- :<|> extraParamAction_Sub1_SayMyNumberHandler runner
-- )
-- extraParamAction_Sub1_TalkToMeHandler
-- :: forall (m :: Type -> Type) ep_idrrs
-- . MonadUnliftIO m
-- => ActionRunner m (Sub1Action ep_idrrs)
-- -> m Text
-- extraParamAction_Sub1_TalkToMeHandler runner_adryu =
-- runner_adryu TalkToMe
-- extraParamAction_Sub1_SayMyNumberHandler
-- :: forall (m :: Type -> Type) ep_idrrs
-- . MonadUnliftIO m
-- => ActionRunner m (Sub1Action ep_idrrs)
-- -> NF1 "Sub1Action_SayMyNumber" "int" (MyInt ep_idrrs)
-- -> m [Char]
-- extraParamAction_Sub1_SayMyNumberHandler
-- runner_adryw
-- (NF1 arg_adryv) =
-- runner_adryw (SayMyNumber arg_adryv)
-- type ExtraParamAction_Sub2Api =
-- ExtraParamAction_Sub2_SaySomethingEndpoint
-- type ExtraParamAction_Sub2_SaySomethingEndpoint =
-- (:>)
-- "SaySomething"
-- ( (:>)
-- ( QueryParam'
-- '[ Required
-- , Strict
-- ]
-- "number"
-- Int
-- )
-- (Verb 'GET 200 ( '(:) JSON ('[] :: [Type])) [Char])
-- )
-- extraParamAction_Sub2Server
-- :: forall (m :: Type -> Type)
-- . MonadUnliftIO m
-- => ActionRunner m Sub2Action
-- -> ServerT ExtraParamAction_Sub2Api m
-- extraParamAction_Sub2Server runner =
-- extraParamAction_Sub2_SaySomethingHandler runner
-- extraParamAction_Sub2_SaySomethingHandler
-- :: forall (m :: Type -> Type)
-- . MonadUnliftIO m
-- => ActionRunner m Sub2Action
-- -> Int
-- -> m [Char]
-- extraParamAction_Sub2_SaySomethingHandler runner_adryy arg_adryx =
-- runner_adryy (SaySomething arg_adryx)
-- type ExtraParamAction_Sub3Api a b =
-- ExtraParamAction_Sub3_SayHelloEndpoint
-- type ExtraParamAction_Sub3_SayHelloEndpoint =
-- (:>) "SayHello" (Verb 'GET 200 ( '(:) JSON ('[] :: [Type])) Text)
-- extraParamAction_Sub3Server
-- :: forall
-- (m :: Type -> Type)
-- (ep_idrrs :: ExtraP)
-- (bool_idrrr :: Bool)
-- . MonadUnliftIO m
-- => ActionRunner m (Sub3Action ep_idrrs bool_idrrr)
-- -> ServerT (ExtraParamAction_Sub3Api ep_idrrs bool_idrrr) m
-- extraParamAction_Sub3Server runner =
-- extraParamAction_Sub3_SayHelloHandler runner
-- extraParamAction_Sub3_SayHelloHandler
-- :: forall (m :: Type -> Type) ep_idrrs bool_idrrr
-- . MonadUnliftIO m
-- => ActionRunner m (Sub3Action ep_idrrs bool_idrrr)
-- -> m Text
-- extraParamAction_Sub3_SayHelloHandler runner_adryz =
-- runner_adryz SayHello
-- extraParamActionServer
-- :: forall
-- (m :: Type -> Type)
-- (bool_idrrr :: Bool)
-- (ep_idrrs :: ExtraP)
-- . MonadUnliftIO m
-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)
-- -> ServerT (ExtraParamActionApi ep_idrrs bool_idrrr) m
-- extraParamActionServer runner =
-- ( extraParamAction_ReverseTextHandler runner
-- :<|> ( extraParamAction_Sub1Handler runner
-- :<|> ( extraParamAction_Sub2Handler runner
-- :<|> extraParamAction_Sub3Handler runner
-- )
-- )
-- )
-- extraParamAction_ReverseTextHandler
-- :: forall (m :: Type -> Type) bool_idrrr ep_idrrs
-- . MonadUnliftIO m
-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)
-- -> NF1 "ExtraParamAction_ReverseText" "text" Text
-- -> m Text
-- extraParamAction_ReverseTextHandler runner_adryB (NF1 arg_adryA) =
-- runner_adryB (Action.ExtraParam.ReverseText arg_adryA)
-- extraParamAction_Sub1Handler
-- :: forall
-- (m :: Type -> Type)
-- (bool_idrrr :: Bool)
-- (ep_idrrs :: ExtraP)
-- . MonadUnliftIO m
-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)
-- -> ServerT (ExtraParamAction_Sub1Api ep_idrrs) m
-- extraParamAction_Sub1Handler runner_adryC =
-- extraParamAction_Sub1Server (runner_adryC . Sub1)
-- extraParamAction_Sub2Handler
-- :: forall
-- (m :: Type -> Type)
-- (bool_idrrr :: Bool)
-- (ep_idrrs :: ExtraP)
-- . MonadUnliftIO m
-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)
-- -> ServerT ExtraParamAction_Sub2Api m
-- extraParamAction_Sub2Handler runner_adryD =
-- extraParamAction_Sub2Server (runner_adryD . Sub2)
-- extraParamAction_Sub3Handler
-- :: forall
-- (m :: Type -> Type)
-- (bool_idrrr :: Bool)
-- (ep_idrrs :: ExtraP)
-- . MonadUnliftIO m
-- => ActionRunner m (ExtraParamAction bool_idrrr ep_idrrs)
-- -> ServerT (ExtraParamAction_Sub3Api ep_idrrs bool_idrrr) m
-- extraParamAction_Sub3Handler runner_adryE =
-- extraParamAction_Sub3Server (runner_adryE . Sub3)
-----------------------------------------------------------------------------------------
$(mkServer storeActionConfig ''StoreAction)
--
itemStuff
:: ItemKey
-> (NF1 "ItemAction_Buy" "quantity" Quantity -> ClientM NoContent)
:<|> ClientM Quantity
:<|> ClientM Price
listItems :: ClientM [ItemInfo]
search :: Text -> ClientM [ItemInfo]
adminOrder
:: NF2 "AdminAction_Order" "item" ItemKey "quantity" Quantity -> ClientM NoContent
adminRestock
:: NF2 "AdminAction_Restock" "itemKey" ItemKey "quantity" Quantity
-> ClientM NoContent
adminAddItem
:: NF3 "AdminAction_AddItem" "itemName" ItemName "quantity" Quantity "price" Price
-> ClientM ItemKey
adminRemoveItem :: NF1 "AdminAction_RemoveItem" "item" ItemKey -> ClientM NoContent
listItems :<|> search :<|> itemStuff :<|> (adminOrder :<|> adminRestock :<|> adminAddItem :<|> adminRemoveItem) =
client (Proxy @StoreActionApi)
--
--
type ExpectedReverseText =
"ReverseText" :> ReqBody '[JSON] (NF1 "a" "text" Text) :> Post '[JSON] Text
type ExpectedIntersperse =
"Sub"
:> QueryParam' '[Strict, Required] "text" Text
:> "Intersperse"
:> QueryParam' '[Strict, Required] "intersperse_text" Text
:> Get '[JSON] Text
$(mkServer testActionConfig ''ServerTestAction)
expectedReverseText :: NF1 "a" "text" Text -> ClientM Text
expectedReverseText = client (Proxy @ExpectedReverseText)
-- expectedConcatText :: Text -> Text -> ClientM Text
-- expectedConcatText = client (Proxy @ExpectedConcatText)
expectedIntersperseText :: Text -> Text -> ClientM Text
expectedIntersperseText = client (Proxy @ExpectedIntersperse)
-- writeOpenApi :: IO ()
-- writeOpenApi =
-- BL.writeFile "/tmp/store_schema.json" $ encode $ toOpenApi (Proxy @StoreActionApi)
--
withStoreServer :: IO () -> IO ()
withStoreServer runTests = do
p <- createForgetful applyStoreEvent mempty
server <-
async . run 9898 $
serve (Proxy @StoreActionApi) $
hoistServer
(Proxy @StoreActionApi)
(Handler . ExceptT . try)
(storeActionServer $ runAction p handleStoreAction)
threadDelay 10000 -- Ensure the server is live when the tests run
runTests
cancel server
withTestServer :: IO () -> IO ()
withTestServer runTests = do
p <- createForgetful (\m _ -> m) ()
-- server <- async . run 9898 $ serve (Proxy @StoreActionApi) undefined
server <-
async . run 9898 $
serve (Proxy @ServerTestActionApi) $
hoistServer
(Proxy @ServerTestActionApi)
(Handler . ExceptT . try)
(serverTestActionServer $ runAction p handleAction)
threadDelay 10000 -- Ensure the server is live when the tests run
runTests
cancel server
spec :: Spec
spec = do
clientEnv <- runIO $ do
man <- newManager defaultManagerSettings
pure $ mkClientEnv man (BaseUrl Http "localhost" 9898 "")
aroundAll_ withStoreServer $ do
describe "Server endpoint renaming" $ do
it "Can add item" $ do
r <- runClientM (adminAddItem $ NF3 "Test item" 10 99) clientEnv
r `shouldSatisfy` not . null
it "The new item shows up when listing items" $ do
r <- runClientM listItems clientEnv
case r of
Right [ItemInfo _ n _ _ _] -> n `shouldBe` "Test item"
a -> fail $ "That shouldn't happen! " <> show a
aroundAll_ withTestServer $ do
describe "Endpoints generated as expected" $ do
it "Plaintext endpoint works" $ do
r <- runClientM (expectedReverseText $ NF1 "Hej") clientEnv
r `shouldBe` Right "jeH"
it "Produces the expected parameters for subserver" $ do
r <- runClientM (expectedIntersperseText "hello" "-=") clientEnv
r `shouldBe` Right "h=-=e=-=l=-=l=-=o"
describe "Supports extra parameters on Actions" $ do
it "Can get apiOptions with one extra paramter" $ do
M.lookup "Action.ExtraParam.ExtraParamAction" (allApiOptions extraParamConfig)
`shouldSatisfy` not . null