diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,10 @@ `tmp-proc-example` uses [PVP Versioning][1]. +## 0.5.3.0 -- 2023-08-11 + +* Use the new `both` constructor + ## 0.5.1.2 -- 2022-08-16 * Bump versions of tmp-proc dependencies diff --git a/specs/TmpProc/Example1/IntegrationTaste.hs b/specs/TmpProc/Example1/IntegrationTaste.hs --- a/specs/TmpProc/Example1/IntegrationTaste.hs +++ b/specs/TmpProc/Example1/IntegrationTaste.hs @@ -1,57 +1,57 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-| +{-# LANGUAGE TypeApplications #-} + +{- | Copyright : (c) 2020-2021 Tim Emiola SPDX-License-Identifier: BSD3 Maintainer : Tim Emiola An demo @Tasty@ test that use @tmp-proc@ - -} 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) - +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 . -} +-- | The test uses a Postgres database . dbProc :: TmpPostgres dbProc = TmpPostgres ["contacts"] -- 'reset' will empty the contacts table -{-| The test uses Redis as a cache. -} +-- | The test uses Redis as a cache. cacheProc :: TmpRedis cacheProc = TmpRedis [] -{-| Specifies the procs to be launched as test fixtures. -} +-- | Specifies the procs to be launched as test fixtures. testProcs :: HList '[TmpPostgres, TmpRedis] -testProcs = dbProc &: cacheProc &: HNil +testProcs = dbProc &:& cacheProc main :: IO () @@ -59,89 +59,86 @@ tests :: IO Fixture -> TestTree -tests getFixture = testGroup "Tmp.Proc:Demo of testing of DB/Cache server" - [ testGroup "When the database is empty" - [ testCase "Using the client to fetch a contact" $ do - (_handle, client) <- getFixture - fetched <- fmap isLeft $ runClientM (Client.fetch 1) client - assertBool "should succeed" fetched - - , testCase "The contact should not be found in the DB" $ do - (handle, _client) <- getFixture - hasInDb handle 1 >>= assertEqual "contact in DB!" False - - , testCase "The contact should not be found in the cache" $ do - (handle, _client) <- getFixture - hasInCache handle 1 >>= assertEqual "contact in Cache!" False - ], - - after AllFinish "empty" $ testCase "zz: the client should insert a contact" $ do +tests getFixture = + testGroup + "Tmp.Proc:Demo of testing of DB/Cache server" + [ testGroup + "When the database is empty" + [ testCase "Using the client to fetch a contact" $ do + (_handle, client) <- getFixture + fetched <- isLeft <$> runClientM (Client.fetch 1) client + assertBool "should succeed" fetched + , testCase "The contact should not be found in the DB" $ do + (handle, _client) <- getFixture + hasInDb handle 1 >>= assertEqual "contact in DB!" False + , testCase "The contact should not be found in the cache" $ do + (handle, _client) <- getFixture + hasInCache handle 1 >>= assertEqual "contact in Cache!" False + ] + , after AllFinish "empty" $ testCase "zz: the client should insert a contact" $ do (_handle, client) <- getFixture - inserted <- fmap isLeft $ runClientM (Client.create testContact) client + inserted <- isLeft <$> runClientM (Client.create testContact) client assertEqual "insert failed!" False inserted - - - , after AllFinish "zz" $ testGroup "After the client is inserted" - [ testCase "the contact should be found in the database" $ do - (handle, _client) <- getFixture - hasInDb handle 1 >>= assertEqual "contact not in DB!" True - - , testCase "yy: the contact should not be found in the cache" $ do - (handle, _client) <- getFixture - hasInCache handle 1 >>= assertEqual "contact in Cache!" False - - , after AllFinish "yy" $ testCase "and the client should fetch the contact" $ do - (_handle, client) <- getFixture - fetched <- fmap isLeft $ runClientM (Client.fetch 1) client - assertEqual "notFetched" False fetched + , after AllFinish "zz" $ + testGroup + "After the client is inserted" + [ testCase "the contact should be found in the database" $ do + (handle, _client) <- getFixture + hasInDb handle 1 >>= assertEqual "contact not in DB!" True + , testCase "yy: the contact should not be found in the cache" $ do + (handle, _client) <- getFixture + hasInCache handle 1 >>= assertEqual "contact in Cache!" False + , after AllFinish "yy" $ testCase "and the client should fetch the contact" $ do + (_handle, client) <- getFixture + fetched <- isLeft <$> runClientM (Client.fetch 1) client + assertEqual "notFetched" False fetched + ] + , after AllFinish "inserted" $ + testGroup + "After fetching the contact" + [ testCase "the contact should be found in the cache" $ do + (handle, _client) <- getFixture + hasInCache handle 1 >>= assertEqual "contact in Cache!" True + ] ] - , after AllFinish "inserted" $ testGroup "After fetching the contact" - [ testCase "the contact should be found in the cache" $ do - (handle, _client) <- getFixture - hasInCache handle 1 >>= assertEqual "contact in Cache!" True - ] - ] - -hasInCache :: ServerHandle ('[TmpPostgres, TmpRedis]) -> ContactID -> IO Bool +hasInCache :: ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool hasInCache sh cid = do cacheLoc <- cacheLocFrom $ handleOf @TmpRedis Proxy $ handles sh - fmap isJust $ Cache.loadContact cacheLoc cid + isJust <$> Cache.loadContact cacheLoc cid -hasInDb :: ServerHandle ('[TmpPostgres, TmpRedis]) -> ContactID -> IO Bool +hasInDb :: ServerHandle '[TmpPostgres, TmpRedis] -> ContactID -> IO Bool hasInDb sh cid = do let dbUriOf = hUri . handleOf @"a-postgres-db" Proxy . handles fmap isJust $ flip DB.fetch cid $ dbUriOf sh -{-| The full test fixture. +{- | 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) +type Fixture = (ServerHandle '[TmpPostgres, TmpRedis], ClientEnv) -mkFixture :: IO (ServerHandle ('[TmpPostgres, TmpRedis]), ClientEnv) +mkFixture :: IO Fixture mkFixture = do let mkApp someHandles = do - -- handleOf can obtain a handle using either the Proc type ... let redisH = handleOf @TmpRedis Proxy someHandles -- or the Name of it's Proc type - dbLoc = hUri $ handleOf @"a-postgres-db" Proxy someHandles + dbLoc = hUri $ handleOf @"a-postgres-db" Proxy someHandles -- Create the database schema DB.migrateDB dbLoc `onException` terminateAll someHandles -- Determine the redis location - cacheLoc <- cacheLocFrom redisH `onException` terminateAll someHandles + cacheLoc <- cacheLocFrom redisH `onException` terminateAll someHandles pure $ waiApp dbLoc cacheLoc @@ -150,13 +147,13 @@ pure (sh, clientEnv) -shutdown' :: (ServerHandle ('[TmpPostgres, TmpRedis]), ClientEnv) -> IO () +shutdown' :: Fixture -> IO () shutdown' (sh, _) = shutdown sh cacheLocFrom :: ProcHandle TmpRedis -> IO Cache.Locator cacheLocFrom handle = case parseConnectInfo $ C8.unpack $ hUri handle of - Left _ -> fail "Bad redis URI" + Left _ -> fail "Bad redis URI" Right x -> pure x @@ -167,9 +164,10 @@ testContact :: Contact -testContact = Contact - { contactName = "Bond" - , contactEmail = "james@hmss.gov.uk" - , contactAge = 45 - , contactTitle = "Mr" - } +testContact = + Contact + { contactName = "Bond" + , contactEmail = "james@hmss.gov.uk" + , contactAge = 45 + , contactTitle = "Mr" + } diff --git a/specs/TmpProc/Example2/IntegrationSpec.hs b/specs/TmpProc/Example2/IntegrationSpec.hs --- a/specs/TmpProc/Example2/IntegrationSpec.hs +++ b/specs/TmpProc/Example2/IntegrationSpec.hs @@ -1,89 +1,91 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-| +{-# LANGUAGE TypeApplications #-} + +{- | Copyright : (c) 2020-2021 Tim Emiola SPDX-License-Identifier: BSD3 Maintainer : Tim Emiola An demo @HSpec@ test that use @tmp-proc@ - -} module TmpProc.Example2.IntegrationSpec where -import Test.Hspec -import Test.Hspec.TmpProc (AreProcs, HasHandle, - ServerHandle, handleOf, - handles, runServer, serverPort, - shutdown, tdescribe, - terminateAll, withConnOf, (&:)) - -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 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) +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) -{-| The test uses a Postgres database . -} +-- | The test uses a Postgres database . dbProc :: TmpPostgres dbProc = TmpPostgres ["contacts"] -- 'reset' will empty the contacts table -{-| The test uses Redis as a cache. -} +-- | The test uses Redis as a cache. cacheProc :: TmpRedis cacheProc = TmpRedis [] -{-| Specifies the procs to be launched as test fixtures. -} +-- | Specifies the procs to be launched as test fixtures. testProcs :: HList '[TmpPostgres, TmpRedis] -testProcs = dbProc &: cacheProc &: HNil +testProcs = dbProc &:& cacheProc -{-| Specifies the expected behaviour. -} +-- | Specifies the expected behaviour. spec :: Spec spec = tdescribe "Tmp.Proc:Demo of testing of DB/Cache server" $ do beforeAll mkFixture $ afterAll shutdown' $ do - context "When the database is empty, using the client to fetch a contact" $ do - it "should throw an error" $ \(_, clientEnv) -> - (fmap isLeft $ runClientM (Client.fetch 1) clientEnv) `shouldReturn` True - - context "and the contact "$ do + fmap isLeft (runClientM (Client.fetch 1) clientEnv) `shouldReturn` True + context "and the contact " $ do it "should not be found in the DB" $ \(sh, _) -> hasInDb sh 1 `shouldReturn` False it "should not be found in the cache" $ \(sh, _) -> do hasInCache sh 1 `shouldReturn` False - context "and using the client to insert a contact" $ do - it "should succeed" $ \(_, clientEnv) -> (fmap isLeft $ runClientM (Client.create testContact) clientEnv) `shouldReturn` False - context "When the client is used to insert a contact" $ do - - context "then the contact "$ do - + context "then the contact " $ do it "should be found in the DB" $ \(sh, _) -> hasInDb sh 1 `shouldReturn` True @@ -91,32 +93,27 @@ hasInCache sh 1 `shouldReturn` False context "and using the client to fetch the contact" $ do - it "should succeed" $ \(_, clientEnv) -> (fmap isLeft $ runClientM (Client.fetch 1) clientEnv) `shouldReturn` False context "After fetching the contact with the client" $ do - - context "then the contact "$ do - + context "then the contact " $ do it "should be found in the cache" $ \(sh, _) -> do hasInCache sh 1 `shouldReturn` True -{-| Simplifies the test cases +{- | Simplifies the test cases Note the use of the 'HasHandle' constraint to indicate what TmpProcs the function uses. - -} hasInCache :: HasHandle TmpRedis procs => ServerHandle procs -> ContactID -> IO Bool hasInCache sh cid = withConnOf @TmpRedis Proxy (handles sh) $ \cache -> fmap isJust $ Cache.loadContact cache cid -{-| Simplifies the test cases +{- | Simplifies the test cases Here, ServerHandle specifies the full list of types required by the calling test code. - -} hasInDb :: ServerHandle ('[TmpPostgres, TmpRedis]) -> ContactID -> IO Bool hasInDb sh cid = do @@ -124,13 +121,12 @@ fmap isJust $ flip DB.fetch cid $ dbUriOf sh -{-| The full test fixture. +{- | 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) @@ -138,18 +134,17 @@ mkFixture :: IO Fixture mkFixture = do let mkApp someHandles = do - -- handleOf can obtain a handle using either the Proc type ... let redisH = handleOf @TmpRedis Proxy someHandles -- or the Name of it's Proc type - dbLoc = hUri $ handleOf @"a-postgres-db" Proxy someHandles + dbLoc = hUri $ handleOf @"a-postgres-db" Proxy someHandles -- Create the database schema DB.migrateDB dbLoc `onException` terminateAll someHandles -- Determine the redis location - cache <- openConn redisH `onException` terminateAll someHandles + cache <- openConn redisH `onException` terminateAll someHandles pure $ waiApp $ AppEnv dbLoc cache @@ -169,9 +164,10 @@ testContact :: Contact -testContact = Contact - { contactName = "Bond" - , contactEmail = "james@hmss.gov.uk" - , contactAge = 45 - , contactTitle = "Mr" - } +testContact = + Contact + { contactName = "Bond" + , contactEmail = "james@hmss.gov.uk" + , contactAge = 45 + , contactTitle = "Mr" + } diff --git a/tmp-proc-example.cabal b/tmp-proc-example.cabal --- a/tmp-proc-example.cabal +++ b/tmp-proc-example.cabal @@ -1,29 +1,32 @@ cabal-version: 3.0 name: tmp-proc-example -version: 0.5.1.2 -synopsis: Shows how to test a simple service using tmp-proc +version: 0.5.3.0 +synopsis: Test a simple service with backends running on docker using tmp-proc description: - Provides working examples that use tmp-proc to test a simple postgresql/redis servant-based API service + An example of testing a service that uses Postgresql and Redis where these + backends are launched in docker via simple test setup code that uses tmp-proc license: BSD-3-Clause license-file: LICENSE copyright: 2021 Tim Emiola author: Tim Emiola maintainer: adetokunbo@contacts.noreply.github.com -category: testing +category: testing, docker bug-reports: https://github.com/adetokunbo/tmp-proc/issues build-type: Simple extra-source-files: ChangeLog.md tested-with: GHC == 8.8.4 - GHC == 8.10.5 GHC == 8.10.7 - GHC == 9.2.2 + GHC == 9.0.2 + GHC == 9.2.8 + GHC == 9.4.5 source-repository head type: git location: https://github.com/adetokunbo/tmp-proc.git + subdir: tmp-proc-example library exposed-modules: