{-# 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 forall x y. x -> y -> HList '[x, y]
&:& TmpRedis
cacheProc


main :: IO ()
main :: IO ()
main = TestTree -> IO ()
defaultMain forall a b. (a -> b) -> a -> b
$ 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" forall a b. (a -> b) -> a -> b
$ do
            (ServerHandle '[TmpPostgres, TmpRedis]
_handle, ClientEnv
client) <- IO Fixture
getFixture
            Bool
fetched <- forall a b. Either a b -> Bool
isLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (ContactID -> ClientM Contact
Client.fetch ContactID
1) ClientEnv
client
            HasCallStack => TestName -> Bool -> IO ()
assertBool TestName
"should succeed" Bool
fetched
        , TestName -> IO () -> TestTree
testCase TestName
"The contact should not be found in the DB" 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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" 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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" forall a b. (a -> b) -> a -> b
$ TestName -> IO () -> TestTree
testCase TestName
"zz: the client should insert a contact" forall a b. (a -> b) -> a -> b
$ do
        (ServerHandle '[TmpPostgres, TmpRedis]
_handle, ClientEnv
client) <- IO Fixture
getFixture
        Bool
inserted <- forall a b. Either a b -> Bool
isLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (Contact -> ClientM ContactID
Client.create Contact
testContact) ClientEnv
client
        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" 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" 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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" 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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" forall a b. (a -> b) -> a -> b
$ TestName -> IO () -> TestTree
testCase TestName
"and the client should fetch the contact" forall a b. (a -> b) -> a -> b
$ do
              (ServerHandle '[TmpPostgres, TmpRedis]
_handle, ClientEnv
client) <- IO Fixture
getFixture
              Bool
fetched <- forall a b. Either a b -> Bool
isLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (ContactID -> ClientM Contact
Client.fetch ContactID
1) ClientEnv
client
              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" 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" 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ forall (procs :: [*]).
AreProcs procs =>
ServerHandle procs -> HandlesOf procs
handles ServerHandle '[TmpPostgres, TmpRedis]
sh
  forall a. Maybe a -> Bool
isJust 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 = 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


{- | 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
handleOf @TmpRedis forall {k} (t :: k). Proxy t
Proxy HList (Proc2Handle procs)
someHandles

            -- or the Name of it's Proc type
            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

        -- Create the database schema
        KeyName -> IO ()
DB.migrateDB KeyName
dbLoc forall a b. IO a -> IO b -> IO a
`onException` 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 forall a b. IO a -> IO b -> IO a
`onException` forall (procs :: [*]). AreProcs procs => HandlesOf procs -> IO ()
terminateAll HList (Proc2Handle procs)
someHandles

        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ KeyName -> Locator -> Application
waiApp KeyName
dbLoc Locator
cacheLoc

  ServerHandle '[TmpPostgres, TmpRedis]
sh <- forall (procs :: [*]).
AreProcs procs =>
HList procs
-> (HandlesOf procs -> IO Application) -> IO (ServerHandle procs)
runServer HList '[TmpPostgres, TmpRedis]
testProcs 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 <- 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 -> IO ()
shutdown' (ServerHandle '[TmpPostgres, TmpRedis]
sh, ClientEnv
_) = 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 forall a b. (a -> b) -> a -> b
$ KeyName -> TestName
C8.unpack forall a b. (a -> b) -> a -> b
$ forall a. ProcHandle a -> KeyName
hUri ProcHandle TmpRedis
handle of
  Left TestName
_ -> forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"Bad redis URI"
  Right Locator
x -> 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
  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 -> TestName -> Int -> TestName -> BaseUrl
BaseUrl Scheme
Http TestName
"localhost" (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"
    }