{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module TmpProc.Example1.IntegrationTaste where
import Test.Tasty
import Test.Tasty.HUnit
import Control.Exception (onException)
import qualified Data.ByteString.Char8 as C8
import Data.Either (isLeft)
import Data.Maybe (isJust)
import Data.Proxy (Proxy (..))
import Database.Redis (parseConnectInfo)
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant.Client (BaseUrl (..), ClientEnv,
Scheme (..), mkClientEnv,
runClientM)
import System.TmpProc
import System.TmpProc.Docker.Postgres
import System.TmpProc.Docker.Redis
import qualified TmpProc.Example1.Cache as Cache
import qualified TmpProc.Example1.Client as Client
import qualified TmpProc.Example1.Database as DB
import TmpProc.Example1.Schema (Contact (..), ContactID)
import TmpProc.Example1.Server (waiApp)
dbProc :: TmpPostgres
dbProc :: TmpPostgres
dbProc = [Text] -> TmpPostgres
TmpPostgres [Text
"contacts"]
cacheProc :: TmpRedis
cacheProc :: TmpRedis
cacheProc = [KeyName] -> TmpRedis
TmpRedis []
testProcs :: HList '[TmpPostgres, TmpRedis]
testProcs :: HList '[TmpPostgres, TmpRedis]
testProcs = TmpPostgres
dbProc TmpPostgres -> HList '[TmpRedis] -> HList '[TmpPostgres, TmpRedis]
forall x (xs :: [*]). x -> HList xs -> HList (x : xs)
&: TmpRedis
cacheProc TmpRedis -> HList '[] -> HList '[TmpRedis]
forall x (xs :: [*]). x -> HList xs -> HList (x : xs)
&: HList '[]
HNil
main :: IO ()
main :: IO ()
main = TestTree -> IO ()
defaultMain (TestTree -> IO ()) -> TestTree -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
-> ((ServerHandle '[TmpPostgres, TmpRedis], ClientEnv) -> IO ())
-> (IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
-> TestTree)
-> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
mkFixture (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv) -> IO ()
shutdown' IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv) -> TestTree
tests
tests :: IO Fixture -> TestTree
tests :: IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv) -> TestTree
tests IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture = TestName -> [TestTree] -> TestTree
testGroup TestName
"Tmp.Proc:Demo of testing of DB/Cache server"
[ TestName -> [TestTree] -> TestTree
testGroup TestName
"When the database is empty"
[ TestName -> IO () -> TestTree
testCase TestName
"Using the client to fetch a contact" (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(ServerHandle '[TmpPostgres, TmpRedis]
_handle, ClientEnv
client) <- IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture
Bool
fetched <- (Either ClientError Contact -> Bool)
-> IO (Either ClientError Contact) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either ClientError Contact -> Bool
forall a b. Either a b -> Bool
isLeft (IO (Either ClientError Contact) -> IO Bool)
-> IO (Either ClientError Contact) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ClientM Contact -> ClientEnv -> IO (Either ClientError Contact)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (ContactID -> ClientM Contact
Client.fetch ContactID
1) ClientEnv
client
HasCallStack => TestName -> Bool -> IO ()
TestName -> Bool -> IO ()
assertBool TestName
"should succeed" Bool
fetched
, TestName -> IO () -> TestTree
testCase TestName
"The contact should not be found in the DB" (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(ServerHandle '[TmpPostgres, TmpRedis]
handle, ClientEnv
_client) <- IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture
ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInDb ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestName -> Bool -> Bool -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
TestName -> a -> a -> IO ()
assertEqual TestName
"contact in DB!" Bool
False
, TestName -> IO () -> TestTree
testCase TestName
"The contact should not be found in the cache" (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(ServerHandle '[TmpPostgres, TmpRedis]
handle, ClientEnv
_client) <- IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture
ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestName -> Bool -> Bool -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
TestName -> a -> a -> IO ()
assertEqual TestName
"contact in Cache!" Bool
False
],
DependencyType -> TestName -> TestTree -> TestTree
after DependencyType
AllFinish TestName
"empty" (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestName -> IO () -> TestTree
testCase TestName
"zz: the client should insert a contact" (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(ServerHandle '[TmpPostgres, TmpRedis]
_handle, ClientEnv
client) <- IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture
Bool
inserted <- (Either ClientError ContactID -> Bool)
-> IO (Either ClientError ContactID) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either ClientError ContactID -> Bool
forall a b. Either a b -> Bool
isLeft (IO (Either ClientError ContactID) -> IO Bool)
-> IO (Either ClientError ContactID) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ClientM ContactID -> ClientEnv -> IO (Either ClientError ContactID)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (Contact -> ClientM ContactID
Client.create Contact
testContact) ClientEnv
client
TestName -> Bool -> Bool -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
TestName -> a -> a -> IO ()
assertEqual TestName
"insert failed!" Bool
False Bool
inserted
, DependencyType -> TestName -> TestTree -> TestTree
after DependencyType
AllFinish TestName
"zz" (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestName -> [TestTree] -> TestTree
testGroup TestName
"After the client is inserted"
[ TestName -> IO () -> TestTree
testCase TestName
"the contact should be found in the database" (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(ServerHandle '[TmpPostgres, TmpRedis]
handle, ClientEnv
_client) <- IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture
ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInDb ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestName -> Bool -> Bool -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
TestName -> a -> a -> IO ()
assertEqual TestName
"contact not in DB!" Bool
True
, TestName -> IO () -> TestTree
testCase TestName
"yy: the contact should not be found in the cache" (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(ServerHandle '[TmpPostgres, TmpRedis]
handle, ClientEnv
_client) <- IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture
ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestName -> Bool -> Bool -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
TestName -> a -> a -> IO ()
assertEqual TestName
"contact in Cache!" Bool
False
, DependencyType -> TestName -> TestTree -> TestTree
after DependencyType
AllFinish TestName
"yy" (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestName -> IO () -> TestTree
testCase TestName
"and the client should fetch the contact" (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(ServerHandle '[TmpPostgres, TmpRedis]
_handle, ClientEnv
client) <- IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture
Bool
fetched <- (Either ClientError Contact -> Bool)
-> IO (Either ClientError Contact) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either ClientError Contact -> Bool
forall a b. Either a b -> Bool
isLeft (IO (Either ClientError Contact) -> IO Bool)
-> IO (Either ClientError Contact) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ClientM Contact -> ClientEnv -> IO (Either ClientError Contact)
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (ContactID -> ClientM Contact
Client.fetch ContactID
1) ClientEnv
client
TestName -> Bool -> Bool -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
TestName -> a -> a -> IO ()
assertEqual TestName
"notFetched" Bool
False Bool
fetched
]
, DependencyType -> TestName -> TestTree -> TestTree
after DependencyType
AllFinish TestName
"inserted" (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestName -> [TestTree] -> TestTree
testGroup TestName
"After fetching the contact"
[ TestName -> IO () -> TestTree
testCase TestName
"the contact should be found in the cache" (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
(ServerHandle '[TmpPostgres, TmpRedis]
handle, ClientEnv
_client) <- IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
getFixture
ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestName -> Bool -> Bool -> IO ()
forall a.
(Eq a, Show a, HasCallStack) =>
TestName -> a -> a -> IO ()
assertEqual TestName
"contact in Cache!" Bool
True
]
]
hasInCache :: ServerHandle ('[TmpPostgres, TmpRedis]) -> ContactID -> IO Bool
hasInCache :: ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
sh ContactID
cid = do
Locator
cacheLoc <- ProcHandle TmpRedis -> IO Locator
cacheLocFrom (ProcHandle TmpRedis -> IO Locator)
-> ProcHandle TmpRedis -> IO Locator
forall a b. (a -> b) -> a -> b
$ Proxy TmpRedis
-> HandlesOf '[TmpPostgres, TmpRedis] -> ProcHandle TmpRedis
forall k (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf @TmpRedis Proxy TmpRedis
forall k (t :: k). Proxy t
Proxy (HandlesOf '[TmpPostgres, TmpRedis] -> ProcHandle TmpRedis)
-> HandlesOf '[TmpPostgres, TmpRedis] -> ProcHandle TmpRedis
forall a b. (a -> b) -> a -> b
$ ServerHandle '[TmpPostgres, TmpRedis]
-> HandlesOf '[TmpPostgres, TmpRedis]
forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> HandlesOf procs
handles ServerHandle '[TmpPostgres, TmpRedis]
sh
(Maybe Contact -> Bool) -> IO (Maybe Contact) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Contact -> Bool
forall a. Maybe a -> Bool
isJust (IO (Maybe Contact) -> IO Bool) -> IO (Maybe Contact) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Locator -> ContactID -> IO (Maybe Contact)
Cache.loadContact Locator
cacheLoc ContactID
cid
hasInDb :: ServerHandle ('[TmpPostgres, TmpRedis]) -> ContactID -> IO Bool
hasInDb :: ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInDb ServerHandle '[TmpPostgres, TmpRedis]
sh ContactID
cid = do
let dbUriOf :: ServerHandle '[TmpPostgres, TmpRedis] -> KeyName
dbUriOf = ProcHandle TmpPostgres -> KeyName
forall a. ProcHandle a -> KeyName
hUri (ProcHandle TmpPostgres -> KeyName)
-> (ServerHandle '[TmpPostgres, TmpRedis]
-> ProcHandle TmpPostgres)
-> ServerHandle '[TmpPostgres, TmpRedis]
-> KeyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy "a-postgres-db"
-> HandlesOf '[TmpPostgres, TmpRedis] -> ProcHandle TmpPostgres
forall k (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf @"a-postgres-db" Proxy "a-postgres-db"
forall k (t :: k). Proxy t
Proxy (HandlesOf '[TmpPostgres, TmpRedis] -> ProcHandle TmpPostgres)
-> (ServerHandle '[TmpPostgres, TmpRedis]
-> HandlesOf '[TmpPostgres, TmpRedis])
-> ServerHandle '[TmpPostgres, TmpRedis]
-> ProcHandle TmpPostgres
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerHandle '[TmpPostgres, TmpRedis]
-> HandlesOf '[TmpPostgres, TmpRedis]
forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> HandlesOf procs
handles
(Maybe Contact -> Bool) -> IO (Maybe Contact) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Contact -> Bool
forall a. Maybe a -> Bool
isJust (IO (Maybe Contact) -> IO Bool) -> IO (Maybe Contact) -> IO Bool
forall a b. (a -> b) -> a -> b
$ (KeyName -> ContactID -> IO (Maybe Contact))
-> ContactID -> KeyName -> IO (Maybe Contact)
forall a b c. (a -> b -> c) -> b -> a -> c
flip KeyName -> ContactID -> IO (Maybe Contact)
DB.fetch ContactID
cid (KeyName -> IO (Maybe Contact)) -> KeyName -> IO (Maybe Contact)
forall a b. (a -> b) -> a -> b
$ ServerHandle '[TmpPostgres, TmpRedis] -> KeyName
dbUriOf ServerHandle '[TmpPostgres, TmpRedis]
sh
type Fixture = (ServerHandle ('[TmpPostgres, TmpRedis]), ClientEnv)
mkFixture :: IO (ServerHandle ('[TmpPostgres, TmpRedis]), ClientEnv)
mkFixture :: IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
mkFixture = do
let mkApp :: HList (Proc2Handle procs) -> IO Application
mkApp HList (Proc2Handle procs)
someHandles = do
let redisH :: ProcHandle TmpRedis
redisH = Proxy TmpRedis -> HList (Proc2Handle procs) -> ProcHandle TmpRedis
forall k (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf @TmpRedis Proxy TmpRedis
forall k (t :: k). Proxy t
Proxy HList (Proc2Handle procs)
someHandles
dbLoc :: KeyName
dbLoc = ProcHandle TmpPostgres -> KeyName
forall a. ProcHandle a -> KeyName
hUri (ProcHandle TmpPostgres -> KeyName)
-> ProcHandle TmpPostgres -> KeyName
forall a b. (a -> b) -> a -> b
$ Proxy "a-postgres-db"
-> HList (Proc2Handle procs) -> ProcHandle TmpPostgres
forall k (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf @"a-postgres-db" Proxy "a-postgres-db"
forall k (t :: k). Proxy t
Proxy HList (Proc2Handle procs)
someHandles
KeyName -> IO ()
DB.migrateDB KeyName
dbLoc IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` HList (Proc2Handle procs) -> IO ()
forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HList (Proc2Handle procs)
someHandles
Locator
cacheLoc <- ProcHandle TmpRedis -> IO Locator
cacheLocFrom ProcHandle TmpRedis
redisH IO Locator -> IO () -> IO Locator
forall a b. IO a -> IO b -> IO a
`onException` HList (Proc2Handle procs) -> IO ()
forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HList (Proc2Handle procs)
someHandles
Application -> IO Application
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Application -> IO Application) -> Application -> IO Application
forall a b. (a -> b) -> a -> b
$ KeyName -> Locator -> Application
waiApp KeyName
dbLoc Locator
cacheLoc
ServerHandle '[TmpPostgres, TmpRedis]
sh <- HList '[TmpPostgres, TmpRedis]
-> (HandlesOf '[TmpPostgres, TmpRedis] -> IO Application)
-> IO (ServerHandle '[TmpPostgres, TmpRedis])
forall (procs :: [*]).
AreProcs procs =>
HList procs
-> (HandlesOf procs -> IO Application) -> IO (ServerHandle procs)
runServer HList '[TmpPostgres, TmpRedis]
testProcs HandlesOf '[TmpPostgres, TmpRedis] -> IO Application
forall (procs :: [*]).
(MemberKV
"a-postgres-db"
(ProcHandle TmpPostgres)
(Handle2KV (Proc2Handle procs)),
AreProcs procs,
IsInProof (ProcHandle TmpRedis) (Proc2Handle procs)) =>
HList (Proc2Handle procs) -> IO Application
mkApp
ClientEnv
clientEnv <- ServerHandle '[TmpPostgres, TmpRedis] -> IO ClientEnv
forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> IO ClientEnv
clientEnvOf ServerHandle '[TmpPostgres, TmpRedis]
sh
(ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
-> IO (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
clientEnv)
shutdown' :: (ServerHandle ('[TmpPostgres, TmpRedis]), ClientEnv) -> IO ()
shutdown' :: (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv) -> IO ()
shutdown' (ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
_) = ServerHandle '[TmpPostgres, TmpRedis] -> IO ()
forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> IO ()
shutdown ServerHandle '[TmpPostgres, TmpRedis]
sh
cacheLocFrom :: ProcHandle TmpRedis -> IO Cache.Locator
cacheLocFrom :: ProcHandle TmpRedis -> IO Locator
cacheLocFrom ProcHandle TmpRedis
handle = case TestName -> Either TestName Locator
parseConnectInfo (TestName -> Either TestName Locator)
-> TestName -> Either TestName Locator
forall a b. (a -> b) -> a -> b
$ KeyName -> TestName
C8.unpack (KeyName -> TestName) -> KeyName -> TestName
forall a b. (a -> b) -> a -> b
$ ProcHandle TmpRedis -> KeyName
forall a. ProcHandle a -> KeyName
hUri ProcHandle TmpRedis
handle of
Left TestName
_ -> TestName -> IO Locator
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"Bad redis URI"
Right Locator
x -> Locator -> IO Locator
forall (f :: * -> *) a. Applicative f => a -> f a
pure Locator
x
clientEnvOf :: AreProcs procs => ServerHandle procs -> IO ClientEnv
clientEnvOf :: ServerHandle procs -> IO ClientEnv
clientEnvOf ServerHandle procs
s = do
Manager
mgr <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
ClientEnv -> IO ClientEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientEnv -> IO ClientEnv) -> ClientEnv -> IO ClientEnv
forall a b. (a -> b) -> a -> b
$ Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
mgr (BaseUrl -> ClientEnv) -> BaseUrl -> ClientEnv
forall a b. (a -> b) -> a -> b
$ Scheme -> TestName -> Int -> TestName -> BaseUrl
BaseUrl Scheme
Http TestName
"localhost" (ServerHandle procs -> Int
forall (procs :: [*]). ServerHandle procs -> Int
serverPort ServerHandle procs
s) TestName
""
testContact :: Contact
testContact :: Contact
testContact = Contact :: Text -> Text -> Int -> Text -> Contact
Contact
{ contactName :: Text
contactName = Text
"Bond"
, contactEmail :: Text
contactEmail = Text
"[email protected]"
, contactAge :: Int
contactAge = Int
45
, contactTitle :: Text
contactTitle = Text
"Mr"
}