{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

{- |
Copyright   : (c) 2020-2021 Tim Emiola
SPDX-License-Identifier: BSD3
Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>

An demo @Tasty@ test that use @tmp-proc@
-}
module TmpProc.Example1.IntegrationTaste where

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 Test.Tasty
import Test.Tasty.HUnit
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)


-- | The test uses a Postgres database .
dbProc :: TmpPostgres
dbProc :: TmpPostgres
dbProc = [Text] -> TmpPostgres
TmpPostgres [Text
"contacts"] -- 'reset' will empty the contacts table


-- | The test uses Redis as a cache.
cacheProc :: TmpRedis
cacheProc :: TmpRedis
cacheProc = [KeyName] -> TmpRedis
TmpRedis []


-- | Specifies the procs to be launched as test fixtures.
testProcs :: HList '[TmpPostgres, TmpRedis]
testProcs :: HList '[TmpPostgres, TmpRedis]
testProcs = TmpPostgres
dbProc TmpPostgres -> TmpRedis -> HList '[TmpPostgres, TmpRedis]
forall x y. x -> y -> HList '[x, y]
&:& TmpRedis
cacheProc


main :: IO ()
main :: IO ()
main = TestTree -> IO ()
defaultMain (TestTree -> IO ()) -> TestTree -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Fixture
-> (Fixture -> IO ()) -> (IO Fixture -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO Fixture
mkFixture Fixture -> IO ()
shutdown' IO Fixture -> TestTree
tests


tests :: IO Fixture -> TestTree
tests :: IO Fixture -> TestTree
tests IO Fixture
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 Fixture
getFixture
            Bool
fetched <- Either ClientError Contact -> Bool
forall a b. Either a b -> Bool
isLeft (Either ClientError Contact -> Bool)
-> IO (Either ClientError Contact) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 Fixture
getFixture
            ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInDb ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 Fixture
getFixture
            ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 Fixture
getFixture
        Bool
inserted <- Either ClientError ContactID -> Bool
forall a b. Either a b -> Bool
isLeft (Either ClientError ContactID -> Bool)
-> IO (Either ClientError ContactID) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 Fixture
getFixture
              ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInDb ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 Fixture
getFixture
              ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 Fixture
getFixture
              Bool
fetched <- Either ClientError Contact -> Bool
forall a b. Either a b -> Bool
isLeft (Either ClientError Contact -> Bool)
-> IO (Either ClientError Contact) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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 Fixture
getFixture
              ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool
hasInCache ServerHandle '[TmpPostgres, TmpRedis]
handle ContactID
1 IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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
$ forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
forall a (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
forall a. Maybe a -> Bool
isJust (Maybe Contact -> Bool) -> IO (Maybe Contact) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
. forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
forall (a :: Symbol) (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 a b. (a -> b) -> IO a -> IO b
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


{- | The full test fixture.

It allows tests to

- use the servant client to invoke the backend
- check the state of service backends via the @ProcHandles@ in the 'ServerHandle'.
-}
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
        -- handleOf can obtain a handle using either the Proc type ...
        let redisH :: ProcHandle TmpRedis
redisH = forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
forall a (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

            -- or the Name of it's Proc type
            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
$ forall {k} (a :: k) (procs :: [*]) b.
HandleOf a procs b =>
Proxy a -> HandlesOf procs -> ProcHandle b
forall (a :: Symbol) (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

        -- Create the database schema
        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

        -- Determine the redis location
        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 a. a -> IO a
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
  Fixture -> IO Fixture
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
clientEnv)


shutdown' :: Fixture -> IO ()
shutdown' :: Fixture -> 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 a. TestName -> IO a
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"Bad redis URI"
  Right Locator
x -> Locator -> IO Locator
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Locator
x


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
  ClientEnv -> IO ClientEnv
forall a. a -> IO a
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
    { contactName :: Text
contactName = Text
"Bond"
    , contactEmail :: Text
contactEmail = Text
"james@hmss.gov.uk"
    , contactAge :: Int
contactAge = Int
45
    , contactTitle :: Text
contactTitle = Text
"Mr"
    }