tmp-proc-example 0.5.1.2 → 0.5.3.0
raw patch · 4 files changed
+165/−164 lines, 4 files
Files
- ChangeLog.md +4/−0
- specs/TmpProc/Example1/IntegrationTaste.hs +90/−92
- specs/TmpProc/Example2/IntegrationSpec.hs +62/−66
- tmp-proc-example.cabal +9/−6
ChangeLog.md view
@@ -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
specs/TmpProc/Example1/IntegrationTaste.hs view
@@ -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 <adetokunbo@users.noreply.github.com> 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"+ }
specs/TmpProc/Example2/IntegrationSpec.hs view
@@ -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 <adetokunbo@users.noreply.github.com> 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"+ }
tmp-proc-example.cabal view
@@ -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: