{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module TmpProc.Example2.IntegrationSpec where
import Control.Exception (onException)
import Data.Either (isLeft)
import Data.Maybe (isJust)
import Data.Proxy (Proxy (..))
import Network.HTTP.Client (newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant.Client
( BaseUrl (..)
, ClientEnv
, Scheme (..)
, mkClientEnv
, runClientM
)
import System.TmpProc.Docker.Postgres
import System.TmpProc.Docker.Redis
import Test.Hspec
import Test.Hspec.TmpProc
( AreProcs
, HasHandle
, ServerHandle
, handleOf
, handles
, runServer
, serverPort
, shutdown
, tdescribe
, terminateAll
, withConnOf
, (&:&)
)
import qualified TmpProc.Example2.Cache as Cache
import qualified TmpProc.Example2.Client as Client
import qualified TmpProc.Example2.Database as DB
import TmpProc.Example2.Schema (Contact (..), ContactID)
import TmpProc.Example2.Server (AppEnv (..), 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 forall x y. x -> y -> HList '[x, y]
&:& TmpRedis
cacheProc
spec :: Spec
spec :: Spec
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
tdescribe String
"Tmp.Proc:Demo of testing of DB/Cache server" forall a b. (a -> b) -> a -> b
$ do
forall a. HasCallStack => IO a -> SpecWith a -> Spec
beforeAll IO Fixture
mkFixture forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => ActionWith a -> SpecWith a -> SpecWith a
afterAll Fixture -> Expectation
shutdown' forall a b. (a -> b) -> a -> b
$ do
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
context String
"When the database is empty, using the client to fetch a contact" forall a b. (a -> b) -> a -> b
$ do
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should throw an error" forall a b. (a -> b) -> a -> b
$ \(ServerHandle '[TmpPostgres, TmpRedis]
_, ClientEnv
clientEnv) ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. Either a b -> Bool
isLeft (forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (ContactID -> ClientM Contact
Client.fetch ContactID
1) ClientEnv
clientEnv) forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Bool
True
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
context String
"and the contact " forall a b. (a -> b) -> a -> b
$ do
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should not be found in the DB" forall a b. (a -> b) -> a -> b
$ \(ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
_) ->
ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInDb ServerHandle '[TmpPostgres, TmpRedis]
sh ContactID
1 forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Bool
False
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should not be found in the cache" forall a b. (a -> b) -> a -> b
$ \(ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
_) -> do
forall (procs :: [*]).
HasHandle TmpRedis procs =>
ServerHandle procs -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
sh ContactID
1 forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Bool
False
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
context String
"and using the client to insert a contact" forall a b. (a -> b) -> a -> b
$ do
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should succeed" forall a b. (a -> b) -> a -> b
$ \(ServerHandle '[TmpPostgres, TmpRedis]
_, ClientEnv
clientEnv) ->
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. Either a b -> Bool
isLeft forall a b. (a -> b) -> a -> b
$ forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (Contact -> ClientM ContactID
Client.create Contact
testContact) ClientEnv
clientEnv) forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Bool
False
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
context String
"When the client is used to insert a contact" forall a b. (a -> b) -> a -> b
$ do
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
context String
"then the contact " forall a b. (a -> b) -> a -> b
$ do
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should be found in the DB" forall a b. (a -> b) -> a -> b
$ \(ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
_) ->
ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInDb ServerHandle '[TmpPostgres, TmpRedis]
sh ContactID
1 forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Bool
True
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should not be found in the cache" forall a b. (a -> b) -> a -> b
$ \(ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
_) -> do
forall (procs :: [*]).
HasHandle TmpRedis procs =>
ServerHandle procs -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
sh ContactID
1 forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Bool
False
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
context String
"and using the client to fetch the contact" forall a b. (a -> b) -> a -> b
$ do
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should succeed" forall a b. (a -> b) -> a -> b
$ \(ServerHandle '[TmpPostgres, TmpRedis]
_, ClientEnv
clientEnv) ->
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. Either a b -> Bool
isLeft forall a b. (a -> b) -> a -> b
$ forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (ContactID -> ClientM Contact
Client.fetch ContactID
1) ClientEnv
clientEnv) forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Bool
False
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
context String
"After fetching the contact with the client" forall a b. (a -> b) -> a -> b
$ do
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
context String
"then the contact " forall a b. (a -> b) -> a -> b
$ do
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"should be found in the cache" forall a b. (a -> b) -> a -> b
$ \(ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
_) -> do
forall (procs :: [*]).
HasHandle TmpRedis procs =>
ServerHandle procs -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
sh ContactID
1 forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Bool
True
hasInCache :: HasHandle TmpRedis procs => ServerHandle procs -> ContactID -> IO Bool
hasInCache :: forall (procs :: [*]).
HasHandle TmpRedis procs =>
ServerHandle procs -> ContactID -> IO Bool
hasInCache ServerHandle procs
sh ContactID
cid = forall {k} (idx :: k) (procs :: [*]) namedConn b.
(HandleOf idx procs namedConn, Connectable namedConn) =>
Proxy idx -> HandlesOf procs -> (Conn namedConn -> IO b) -> IO b
withConnOf @TmpRedis forall {k} (t :: k). Proxy t
Proxy (forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> HandlesOf procs
handles ServerHandle procs
sh) forall a b. (a -> b) -> a -> b
$ \Conn TmpRedis
cache ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Connection -> ContactID -> IO (Maybe Contact)
Cache.loadContact Conn TmpRedis
cache 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 = forall a. ProcHandle a -> KeyName
hUri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf @"a-postgres-db" forall {k} (t :: k). Proxy t
Proxy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> HandlesOf procs
handles
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip KeyName -> ContactID -> IO (Maybe Contact)
DB.fetch ContactID
cid forall a b. (a -> b) -> a -> b
$ ServerHandle '[TmpPostgres, TmpRedis] -> KeyName
dbUriOf ServerHandle '[TmpPostgres, TmpRedis]
sh
type Fixture = (ServerHandle ('[TmpPostgres, TmpRedis]), ClientEnv)
mkFixture :: IO Fixture
mkFixture :: IO Fixture
mkFixture = do
let mkApp :: HList (Proc2Handle procs) -> IO Application
mkApp HList (Proc2Handle procs)
someHandles = do
let redisH :: ProcHandle TmpRedis
redisH = forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf @TmpRedis forall {k} (t :: k). Proxy t
Proxy HList (Proc2Handle procs)
someHandles
dbLoc :: KeyName
dbLoc = forall a. ProcHandle a -> KeyName
hUri forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
handleOf @"a-postgres-db" forall {k} (t :: k). Proxy t
Proxy HList (Proc2Handle procs)
someHandles
KeyName -> Expectation
DB.migrateDB KeyName
dbLoc forall a b. IO a -> IO b -> IO a
`onException` forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> Expectation
terminateAll HList (Proc2Handle procs)
someHandles
Connection
cache <- forall a. Connectable a => ProcHandle a -> IO (Conn a)
openConn ProcHandle TmpRedis
redisH forall a b. IO a -> IO b -> IO a
`onException` forall (procs :: [*]).
AreProcs procs =>
HandlesOf procs -> Expectation
terminateAll HList (Proc2Handle procs)
someHandles
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AppEnv -> Application
waiApp forall a b. (a -> b) -> a -> b
$ KeyName -> Connection -> AppEnv
AppEnv KeyName
dbLoc Connection
cache
ServerHandle '[TmpPostgres, TmpRedis]
sh <- forall (procs :: [*]).
AreProcs procs =>
HList procs
-> (HandlesOf procs -> IO Application) -> IO (ServerHandle procs)
runServer HList '[TmpPostgres, TmpRedis]
testProcs forall {procs :: [*]}.
(AreProcs procs,
MemberKV
"a-postgres-db"
(ProcHandle TmpPostgres)
(Handle2KV (Proc2Handle procs)),
IsInProof (ProcHandle TmpRedis) (Proc2Handle procs)) =>
HList (Proc2Handle procs) -> IO Application
mkApp
ClientEnv
clientEnv <- forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> IO ClientEnv
clientEnvOf ServerHandle '[TmpPostgres, TmpRedis]
sh
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
clientEnv)
shutdown' :: Fixture -> IO ()
shutdown' :: Fixture -> Expectation
shutdown' (ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
_) = forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> Expectation
shutdown ServerHandle '[TmpPostgres, TmpRedis]
sh
clientEnvOf :: AreProcs procs => ServerHandle procs -> IO ClientEnv
clientEnvOf :: forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> IO ClientEnv
clientEnvOf ServerHandle procs
s = do
Manager
mgr <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
mgr forall a b. (a -> b) -> a -> b
$ Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Http String
"localhost" (forall (procs :: [*]). ServerHandle procs -> Int
serverPort ServerHandle procs
s) String
""
testContact :: Contact
testContact :: Contact
testContact =
Contact
{ contactName :: Text
contactName = Text
"Bond"
, contactEmail :: Text
contactEmail = Text
"james@hmss.gov.uk"
, contactAge :: Int
contactAge = Int
45
, contactTitle :: Text
contactTitle = Text
"Mr"
}