packages feed

tmp-proc-example (empty) → 0.5.0.0

raw patch · 20 files changed

+1226/−0 lines, 20 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, exceptions, hedis, hspec, hspec-tmp-proc, http-client, http-client-tls, monad-logger, mtl, persistent, persistent-postgresql, persistent-template, postgresql-simple, servant, servant-client, servant-server, tasty, tasty-hunit, text, time, tmp-proc, tmp-proc-example, tmp-proc-postgres, tmp-proc-redis, transformers, wai, warp

Files

+ ChangeLog.md view
@@ -0,0 +1,9 @@+# Revision history for tmp-proc-example++`tmp-proc-example` uses [PVP Versioning][1].++## 0.5.0.0 -- 2021-09-28++* First version.++[1]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021, Tim Emiola++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tim Emiola nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ specs/TmpProc/Example1/IntegrationTaste.hs view
@@ -0,0 +1,175 @@+{-# 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           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)++++{-| The test uses a Postgres database . -}+dbProc :: TmpPostgres+dbProc = TmpPostgres ["contacts"] -- 'reset' will empty the contacts table+++{-| The test uses Redis as a cache. -}+cacheProc :: TmpRedis+cacheProc = TmpRedis []+++{-| Specifies the procs to be launched as test fixtures.  -}+testProcs :: HList '[TmpPostgres, TmpRedis]+testProcs = dbProc &: cacheProc &: HNil+++main :: IO ()+main = defaultMain $ withResource mkFixture shutdown' tests+++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+        (_handle, client) <- getFixture+        inserted <- fmap 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 "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 sh cid = do+  cacheLoc <- cacheLocFrom $ handleOf @TmpRedis Proxy $ handles sh+  fmap isJust $ Cache.loadContact cacheLoc cid+++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.++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 (ServerHandle ('[TmpPostgres, TmpRedis]), ClientEnv)+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++        -- Create the database schema+        DB.migrateDB dbLoc `onException` terminateAll someHandles++        -- Determine the redis location+        cacheLoc <- cacheLocFrom redisH  `onException` terminateAll someHandles++        pure $ waiApp dbLoc cacheLoc++  sh <- runServer testProcs mkApp+  clientEnv <- clientEnvOf sh+  pure (sh, clientEnv)+++shutdown' :: (ServerHandle ('[TmpPostgres, TmpRedis]), ClientEnv) -> 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"+  Right x -> pure x+++clientEnvOf :: AreProcs procs => ServerHandle procs -> IO ClientEnv+clientEnvOf s = do+  mgr <- newManager tlsManagerSettings+  pure $ mkClientEnv mgr $ BaseUrl Http "localhost" (serverPort s) ""+++testContact :: Contact+testContact = Contact+  { contactName = "Bond"+  , contactEmail = "james@hmss.gov.uk"+  , contactAge = 45+  , contactTitle = "Mr"+  }
+ specs/TmpProc/Example2/IntegrationSpec.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE MonoLocalBinds    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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)+++{-| The test uses a Postgres database . -}+dbProc :: TmpPostgres+dbProc = TmpPostgres ["contacts"] -- 'reset' will empty the contacts table+++{-| The test uses Redis as a cache. -}+cacheProc :: TmpRedis+cacheProc = TmpRedis []+++{-| Specifies the procs to be launched as test fixtures.  -}+testProcs :: HList '[TmpPostgres, TmpRedis]+testProcs = dbProc &: cacheProc &: HNil+++{-| 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++        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++        it "should be found in the DB" $ \(sh, _) ->+          hasInDb sh 1 `shouldReturn` True++        it "should not be found in the cache" $ \(sh, _) -> do+          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++        it "should be found in the cache" $ \(sh, _) -> do+          hasInCache sh 1 `shouldReturn` True+++{-| 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++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+  let dbUriOf = hUri . handleOf @"a-postgres-db" Proxy . handles+  fmap isJust $ flip DB.fetch cid $ dbUriOf 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 = 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++        -- Create the database schema+        DB.migrateDB dbLoc `onException` terminateAll someHandles++        -- Determine the redis location+        cache <- openConn redisH  `onException` terminateAll someHandles++        pure $ waiApp $ AppEnv dbLoc cache++  sh <- runServer testProcs mkApp+  clientEnv <- clientEnvOf sh+  pure (sh, clientEnv)+++shutdown' :: Fixture -> IO ()+shutdown' (sh, _) = shutdown sh+++clientEnvOf :: AreProcs procs => ServerHandle procs -> IO ClientEnv+clientEnvOf s = do+  mgr <- newManager tlsManagerSettings+  pure $ mkClientEnv mgr $ BaseUrl Http "localhost" (serverPort s) ""+++testContact :: Contact+testContact = Contact+  { contactName = "Bond"+  , contactEmail = "james@hmss.gov.uk"+  , contactAge = 45+  , contactTitle = "Mr"+  }
+ src/TmpProc/Example1/Cache.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE LambdaCase #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Implements a cache for the demo service++-}+module TmpProc.Example1.Cache+  ( -- * Cache services+    deleteContact+  , loadContact+  , saveContact+  , runRedisAction++    -- * Redis location+  , Locator+  , defaultLoc+  )+where++import           Control.Monad (void)+import           Data.ByteString.Char8 (pack, unpack, ByteString)+import           Database.Redis++import           TmpProc.Example1.Schema++{-| Specifies the @Redis@ instance to use as a cache .-}+type Locator = ConnectInfo++{-| A default for local development .-}+defaultLoc :: Locator+defaultLoc = defaultConnectInfo++runRedisAction :: Locator -> Redis a -> IO a+runRedisAction loc action = do+  connection <- connect loc+  runRedis connection action++saveContact :: Locator -> ContactID -> Contact -> IO ()+saveContact loc cid contact = runRedisAction loc $ void $ setex (toKey cid) 3600 (pack . show $ contact)++loadContact :: Locator -> ContactID -> IO (Maybe Contact)+loadContact loc cid = runRedisAction loc $ do+  (get $ toKey cid) >>= \case+    Right (Just contactString) -> return $ Just (read . unpack $ contactString)+    _ -> return Nothing++deleteContact :: Locator -> ContactID -> IO ()+deleteContact loc cid = do+  connection <- connect loc+  runRedis connection $ do+    _ <- del [pack . show $ cid]+    return ()+++toKey :: ContactID -> ByteString+toKey = pack . show
+ src/TmpProc/Example1/Client.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Defines client combinators that access the demo service++-}+module TmpProc.Example1.Client+  ( -- * Client combinators+    fetch+  , create+  ) where++import           Servant.API             ((:<|>) (..))+import           Servant.Client          (ClientM, client)++import           TmpProc.Example1.Routes (contactsAPI)+import           TmpProc.Example1.Schema (Contact, ContactID)++{-| Fetch a contact via the API. -}+fetch :: ContactID -> ClientM Contact++{-| Create a contact via the API. -}+create :: Contact -> ClientM ContactID+(fetch :<|> create) = client contactsAPI
+ src/TmpProc/Example1/Database.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Defines data access combinators used by the demo service++-}+module TmpProc.Example1.Database+  ( -- * Contact Database access+    create+  , fetch+  , remove+  , migrateDB++    -- * Database location+  , Locator+  , defaultLoc+  )+where++import           Control.Monad.Logger        (LogLevel (..), LoggingT,+                                              filterLogger, runStdoutLoggingT, LogSource)+import           Control.Monad.Reader        (runReaderT)+import           Database.Persist+import           Database.Persist.Postgresql (ConnectionString, SqlPersistT,+                                              fromSqlKey, runMigration,+                                              toSqlKey, withPostgresqlConn)++import           TmpProc.Example1.Schema++{-| Specifies the database to connect to .-}+type Locator = ConnectionString+++{-| A default for local development .-}+defaultLoc :: Locator+defaultLoc = "host=127.0.0.1 port=5432 contact=postgres dbname=postgres password=postgres"+++migrateDB :: Locator -> IO ()+migrateDB loc = doDb loc $ runMigration migrateAll+++fetch :: Locator -> ContactID -> IO (Maybe Contact)+fetch loc cid = doDb loc $ get $ toSqlKey cid+++create :: Locator -> Contact -> IO ContactID+create loc contact = fromSqlKey <$> doDb loc (insert contact)+++remove :: Locator -> ContactID -> IO ()+remove loc cid = doDb loc $ delete contactKey+  where+    contactKey :: Key Contact+    contactKey = toSqlKey cid+++doDb :: Locator -> SqlPersistT (LoggingT IO) a -> IO a+doDb = doDb' defaultFilter+++doDb' :: (LogSource -> LogLevel -> Bool) -> Locator -> SqlPersistT (LoggingT IO) a ->  IO a+doDb' logFilter loc action  =+  runStdoutLoggingT $ filterLogger logFilter $ withPostgresqlConn loc $ \backend ->+    runReaderT action backend+++defaultFilter :: a -> LogLevel -> Bool+defaultFilter _ level = level > LevelDebug
+ src/TmpProc/Example1/Routes.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Specifies the API provided by the demo service.++-}+module TmpProc.Example1.Routes+  ( -- * API route definition+    ContactsAPI+  , contactsAPI+  )+where++import           Data.Proxy (Proxy(..))+import           Servant.API++import           TmpProc.Example1.Schema+++{-| API allowing 'Contact' creation and retrieval. -}+type ContactsAPI =+       "contacts" :> Capture "contactid" ContactID :> Get '[JSON] Contact+  :<|> "contacts" :> ReqBody '[JSON] Contact :> Post '[JSON] ContactID+++{-| For convenience in "Servant" combinators where a proxy is required. -}+contactsAPI :: Proxy ContactsAPI+contactsAPI = Proxy :: Proxy ContactsAPI
+ src/TmpProc/Example1/Schema.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Specifies the schema of the data accessed by the demo service.++-}+module TmpProc.Example1.Schema++where++import           Data.Int (Int64)+import           Data.Aeson+import           Data.Aeson.Types+import           Data.Text           (Text)+import qualified Database.Persist.TH as P++type ContactID = Int64++P.share [P.mkPersist P.sqlSettings, P.mkMigrate "migrateAll"] [P.persistLowerCase|+  Contact sql=contacts+    email Text+    name Text+    age Int+    title Text+    UniqueEmail email+    deriving Show Read+|]++instance ToJSON Contact where+  toJSON Contact {contactEmail, contactName, contactAge, contactTitle } = object+    [ "email" .= contactEmail+    , "name" .= contactName+    , "age" .= contactAge+    , "title" .= contactTitle+    ]++instance FromJSON Contact where+  parseJSON = withObject "Contact" parseContact++parseContact :: Object -> Parser Contact+parseContact o = do+  contactName <- o .: "name"+  contactEmail <- o .: "email"+  contactAge <- o .: "age"+  contactTitle <- o .: "title"+  return Contact+    { contactName+    , contactEmail+    , contactAge+    , contactTitle+    }
+ src/TmpProc/Example1/Server.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Implements the demo service.++-}+module TmpProc.Example1.Server+  ( -- * Server implementation+    runServer'+  , runServer+  , waiApp+  ) where++import           Control.Monad.IO.Class     (liftIO)+import           Control.Monad.Trans.Except (throwE)+import           Network.Wai                (Application)+import           Network.Wai.Handler.Warp   (Port, run)+import           Servant.API                ((:<|>) (..))+import           Servant.Server             (Handler (..), Server, err401,+                                             errBody, serve)++import           TmpProc.Example1.Routes    (ContactsAPI, contactsAPI)+import           TmpProc.Example1.Schema    (Contact, ContactID)++import qualified TmpProc.Example1.Cache     as Cache+import qualified TmpProc.Example1.Database  as DB+++{-| Runs 'waiApp' on the given port. -}+runServer' :: Port -> DB.Locator -> Cache.Locator -> IO ()+runServer' port dbLoc cacheLoc = run port $ waiApp dbLoc cacheLoc+++{-| An 'Application' that runs the server using the given DB and Cache. -}+waiApp :: DB.Locator -> Cache.Locator -> Application+waiApp dbLoc cacheLoc = serve contactsAPI $ server dbLoc cacheLoc+++{-| Runs 'waiApp' using defaults for local development. -}+runServer :: IO ()+runServer = runServer' 8000 DB.defaultLoc Cache.defaultLoc+++fetchContact :: DB.Locator -> Cache.Locator -> ContactID -> Handler Contact+fetchContact dbLoc cacheLoc cid = do+  (liftIO $ Cache.loadContact cacheLoc cid) >>= \case+    Just contact -> pure contact+    Nothing -> (liftIO $ DB.fetch dbLoc cid) >>= \case+      Just contact -> liftIO (Cache.saveContact cacheLoc cid contact) >> pure contact+      Nothing -> Handler $ (throwE $ err401 { errBody = "No Contact with this ID" })+++createContact :: DB.Locator -> Contact -> Handler ContactID+createContact dbLoc contact = liftIO $ DB.create dbLoc contact+++server :: DB.Locator -> Cache.Locator -> Server ContactsAPI+server dbLoc cacheLoc =+  (fetchContact dbLoc cacheLoc) :<|>+  (createContact dbLoc)
+ src/TmpProc/Example2/Cache.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE LambdaCase #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Implements a cache for the demo service++-}+module TmpProc.Example2.Cache+  ( -- * Cache services+    deleteContact+  , loadContact+  , saveContact+  , runRedisAction++    -- * Redis Connection+  , Connection+  , defaultConn+  )+where++import           Control.Monad (void)+import           Data.ByteString.Char8 (pack, unpack, ByteString)+import           Database.Redis++import           TmpProc.Example2.Schema++{-| A default for local development .-}+defaultConn :: IO Connection+defaultConn = connect defaultConnectInfo++runRedisAction :: Connection -> Redis a -> IO a+runRedisAction loc action = runRedis loc action++saveContact :: Connection -> ContactID -> Contact -> IO ()+saveContact loc cid contact = runRedisAction loc $ void $ setex (toKey cid) 3600 (pack . show $ contact)++loadContact :: Connection -> ContactID -> IO (Maybe Contact)+loadContact loc cid = runRedisAction loc $ do+  (get $ toKey cid) >>= \case+    Right (Just contactString) -> return $ Just (read . unpack $ contactString)+    _ -> return Nothing++deleteContact :: Connection -> ContactID -> IO ()+deleteContact loc cid = do+  runRedis loc $ do+    _ <- del [pack . show $ cid]+    return ()+++toKey :: ContactID -> ByteString+toKey = pack . show
+ src/TmpProc/Example2/Client.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Defines client combinators that access the demo service++-}+module TmpProc.Example2.Client+  ( -- * Client combinators+    fetch+  , create+  ) where++import           Servant.API             ((:<|>) (..))+import           Servant.Client          (ClientM, client)++import           TmpProc.Example2.Routes (contactsAPI)+import           TmpProc.Example2.Schema (Contact, ContactID)++{-| Fetch a contact via the API. -}+fetch :: ContactID -> ClientM Contact++{-| Create a contact via the API. -}+create :: Contact -> ClientM ContactID+(fetch :<|> create) = client contactsAPI
+ src/TmpProc/Example2/Database.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module TmpProc.Example2.Database+  ( -- * Contact Database access+    create+  , fetch+  , remove+  , migrateDB++    -- * Database location+  , Locator+  , defaultLoc+  )+where++import           Control.Monad.Logger        (LogLevel (..), LoggingT,+                                              filterLogger, runStdoutLoggingT, LogSource)+import           Control.Monad.Reader        (runReaderT)+import           Database.Persist+import           Database.Persist.Postgresql (ConnectionString, SqlPersistT,+                                              fromSqlKey, runMigration,+                                              toSqlKey, withPostgresqlConn)++import           TmpProc.Example2.Schema++{-| Specifies the database to connect to .-}+type Locator = ConnectionString+++{-| A default for local development .-}+defaultLoc :: Locator+defaultLoc = "host=127.0.0.1 port=5432 contact=postgres dbname=postgres password=postgres"+++migrateDB :: Locator -> IO ()+migrateDB loc = doDb loc $ runMigration migrateAll+++fetch :: Locator -> ContactID -> IO (Maybe Contact)+fetch loc cid = doDb loc $ get $ toSqlKey cid+++create :: Locator -> Contact -> IO ContactID+create loc contact = fromSqlKey <$> doDb loc (insert contact)+++remove :: Locator -> ContactID -> IO ()+remove loc cid = doDb loc $ delete contactKey+  where+    contactKey :: Key Contact+    contactKey = toSqlKey cid+++doDb :: Locator -> SqlPersistT (LoggingT IO) a -> IO a+doDb = doDb' defaultFilter+++doDb' :: (LogSource -> LogLevel -> Bool) -> Locator -> SqlPersistT (LoggingT IO) a ->  IO a+doDb' logFilter loc action  =+  runStdoutLoggingT $ filterLogger logFilter $ withPostgresqlConn loc $ \backend ->+    runReaderT action backend+++defaultFilter :: a -> LogLevel -> Bool+defaultFilter _ level = level > LevelDebug
+ src/TmpProc/Example2/Routes.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Specifies the API provided by the demo service.++-}+module TmpProc.Example2.Routes+  ( -- * API route definition+    ContactsAPI+  , contactsAPI+  )+where++import           Data.Proxy (Proxy(..))+import           Servant.API++import           TmpProc.Example2.Schema+++{-| API allowing 'Contact' creation and retrieval. -}+type ContactsAPI =+       "contacts" :> Capture "contactid" ContactID :> Get '[JSON] Contact+  :<|> "contacts" :> ReqBody '[JSON] Contact :> Post '[JSON] ContactID+++{-| For convenience in "Servant" combinators where a proxy is required. -}+contactsAPI :: Proxy ContactsAPI+contactsAPI = Proxy :: Proxy ContactsAPI
+ src/TmpProc/Example2/Schema.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Specifies the schema of the data accessed by the demo service.++-}+module TmpProc.Example2.Schema++where++import           Data.Int (Int64)+import           Data.Aeson+import           Data.Aeson.Types+import           Data.Text           (Text)+import qualified Database.Persist.TH as P++type ContactID = Int64++P.share [P.mkPersist P.sqlSettings, P.mkMigrate "migrateAll"] [P.persistLowerCase|+  Contact sql=contacts+    email Text+    name Text+    age Int+    title Text+    UniqueEmail email+    deriving Show Read+|]++instance ToJSON Contact where+  toJSON Contact {contactEmail, contactName, contactAge, contactTitle } = object+    [ "email" .= contactEmail+    , "name" .= contactName+    , "age" .= contactAge+    , "title" .= contactTitle+    ]++instance FromJSON Contact where+  parseJSON = withObject "Contact" parseContact++parseContact :: Object -> Parser Contact+parseContact o = do+  contactName <- o .: "name"+  contactEmail <- o .: "email"+  contactAge <- o .: "age"+  contactTitle <- o .: "title"+  return Contact+    { contactName+    , contactEmail+    , contactAge+    , contactTitle+    }
+ src/TmpProc/Example2/Server.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeOperators              #-}+{-|+Copyright   : (c) 2020-2021 Tim Emiola+SPDX-License-Identifier: BSD3+Maintainer  : Tim Emiola <adetokunbo@users.noreply.github.com>++Implements a demo service.++-}+module TmpProc.Example2.Server+  ( -- * Server implementation+    AppEnv(..)+  , runServer'+  , runServer+  , waiApp+  ) where++import           Control.Exception          (try, throw)+import           Control.Monad.Catch        (MonadCatch, MonadMask, MonadThrow)+import           Control.Monad.IO.Class     (MonadIO, liftIO)+import           Control.Monad.Reader       (MonadReader, ReaderT, asks,+                                             runReaderT)+import           Control.Monad.Trans.Except (ExceptT (..))+import           Network.Wai                (Application)+import           Network.Wai.Handler.Warp   (Port, run)+import           Servant.API                ((:<|>) (..))+import           Servant.Server             (Handler (..), ServerT,+                                             err401, errBody, serve, hoistServer)++import           TmpProc.Example2.Routes    (ContactsAPI, contactsAPI)+import           TmpProc.Example2.Schema    (Contact, ContactID)++import qualified TmpProc.Example2.Cache     as Cache+import qualified TmpProc.Example2.Database  as DB+++{-| Runs 'waiApp' on the given port. -}+runServer' :: IO AppEnv -> Port -> IO ()+runServer' mkEnv port = mkEnv >>= run port . waiApp+++{-| An 'Application' that runs the server using the given DB and Cache. -}+waiApp :: AppEnv -> Application+waiApp env =+  let+    hoist' = Handler . ExceptT . try . runApp' env+  in+    serve contactsAPI $ hoistServer contactsAPI hoist' server+++{-| Runs 'waiApp' using defaults for local development. -}+runServer :: IO ()+runServer = runServer' defaultEnv 8000+++fetchContact+  :: (MonadIO m, MonadReader r m, Has DB.Locator r, Has Cache.Connection r)+  => ContactID -> m Contact+fetchContact cid = do+  cache <- grab @Cache.Connection+  (liftIO $ Cache.loadContact cache cid) >>= \case+    Just contact -> pure contact+    Nothing -> do+      db <- grab @DB.Locator+      (liftIO $ DB.fetch db cid) >>= \case+        Just contact -> liftIO (Cache.saveContact cache cid contact) >> pure contact+        Nothing -> throw $ err401 { errBody = "No Contact with this ID" }+++createContact+  :: (MonadIO m, MonadReader r m, Has DB.Locator r)+  => Contact -> m ContactID+createContact contact = do+  db <- grab @DB.Locator+  liftIO $ DB.create db contact+++server+  :: ( Has Cache.Connection r+     , Has DB.Locator r+     , MonadReader r m+     , MonadIO m+     )+  => ServerT ContactsAPI m+server = fetchContact :<|> createContact+++-- | The application-level Monad, provides access to AppEnv via @Reader AppEnv@.+newtype App a = App+  { runApp :: ReaderT AppEnv IO a+  } deriving ( Applicative+             , Functor+             , Monad+             , MonadCatch+             , MonadMask+             , MonadThrow+             , MonadReader AppEnv+             , MonadIO+             )+++instance Has DB.Locator     AppEnv  where obtain = aeDbLocator+instance Has Cache.Connection  AppEnv  where obtain = aeCacheLocator+++defaultEnv :: IO AppEnv+defaultEnv = AppEnv <$> (pure DB.defaultLoc) <*> Cache.defaultConn+++-- | Run a 'App' computation with the given environment.+runApp' :: AppEnv -> App a -> IO a+runApp' env = flip runReaderT env . runApp+++{-| An application-level environment suitable for storing in a Reader. -}+data AppEnv = AppEnv+  { aeDbLocator    :: !(DB.Locator)+  , aeCacheLocator :: !(Cache.Connection)+  }+++{- | General type class representing which @field@ is in @env@. -}+class Has field env where+  obtain :: env -> field+++-- | A combinator that simplifies accessing 'Has' fields.+grab :: forall field env m . (MonadReader env m, Has field env) => m field+grab = asks $ obtain @field
+ test/Spec.hs view
@@ -0,0 +1,13 @@+module Main (main) where++import           Test.Hspec++import           System.IO+import qualified TmpProc.Example2.IntegrationSpec as Ex2++main :: IO ()+main = do+  hSetBuffering stdin NoBuffering+  hSetBuffering stdout NoBuffering+  hspec $ do+    Ex2.spec
+ test/Taste.hs view
@@ -0,0 +1,10 @@+module Main (main) where++import           System.IO+import qualified TmpProc.Example1.IntegrationTaste as Ex1++main :: IO ()+main = do+  hSetBuffering stdin NoBuffering+  hSetBuffering stdout NoBuffering+  Ex1.main
+ tmp-proc-example.cabal view
@@ -0,0 +1,99 @@+cabal-version:      3.0+name:               tmp-proc-example+version:            0.5.0.0+synopsis:           Shows how to test a simple service using tmp-proc+description:+  Provides working examples that use tmp-proc to test a simple postgresql/redis servant-based API service++license:            BSD-3-Clause+license-file:       LICENSE+copyright:          2021 Tim Emiola+author:             Tim Emiola+maintainer:         adetokunbo@contacts.noreply.github.com+category:           testing+bug-reports:        https://github.com/adetokunbo/tmp-proc/issues+build-type:         Simple+extra-source-files:+  ChangeLog.md+tested-with:+  GHC == 8.10.5++source-repository head+  type:     git+  location: https://github.com/adetokunbo/tmp-proc.git++library+  exposed-modules:+    TmpProc.Example1.Cache+    TmpProc.Example1.Client+    TmpProc.Example1.Database+    TmpProc.Example1.IntegrationTaste+    TmpProc.Example1.Routes+    TmpProc.Example1.Schema+    TmpProc.Example1.Server+    TmpProc.Example2.Cache+    TmpProc.Example2.Client+    TmpProc.Example2.Database+    TmpProc.Example2.IntegrationSpec+    TmpProc.Example2.Routes+    TmpProc.Example2.Schema+    TmpProc.Example2.Server++  hs-source-dirs:   src specs+  build-depends:+    , aeson+    , base                   >=4.11 && <4.16+    , bytestring+    , exceptions+    , hedis+    , hspec+    , hspec-tmp-proc+    , http-client+    , http-client-tls+    , monad-logger+    , mtl+    , persistent+    , persistent-postgresql+    , persistent-template+    , postgresql-simple+    , servant+    , servant-client+    , servant-server+    , tasty+    , tasty-hunit+    , text+    , time+    , tmp-proc+    , tmp-proc-postgres+    , tmp-proc-redis+    , transformers+    , wai+    , warp++  default-language: Haskell2010+  ghc-options:      -fno-ignore-asserts -Wall++test-suite hspec-integration-test+  type:             exitcode-stdio-1.0+  main-is:          Spec.hs+  hs-source-dirs:   test+  build-depends:+    , base+    , hspec+    , tmp-proc-example++  default-language: Haskell2010+  ghc-options:+    -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wall++test-suite tasty-integration-test+  type:             exitcode-stdio-1.0+  main-is:          Taste.hs+  hs-source-dirs:   test+  build-depends:+    , base+    , tmp-proc-example++  default-language: Haskell2010+  ghc-options:+    -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wall