diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/specs/TmpProc/Example1/IntegrationTaste.hs b/specs/TmpProc/Example1/IntegrationTaste.hs new file mode 100644 --- /dev/null +++ b/specs/TmpProc/Example1/IntegrationTaste.hs @@ -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 + +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" + } diff --git a/specs/TmpProc/Example2/IntegrationSpec.hs b/specs/TmpProc/Example2/IntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/specs/TmpProc/Example2/IntegrationSpec.hs @@ -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 + +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" + } diff --git a/src/TmpProc/Example1/Cache.hs b/src/TmpProc/Example1/Cache.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example1/Cache.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE LambdaCase #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +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 diff --git a/src/TmpProc/Example1/Client.hs b/src/TmpProc/Example1/Client.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example1/Client.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +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 diff --git a/src/TmpProc/Example1/Database.hs b/src/TmpProc/Example1/Database.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example1/Database.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +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 diff --git a/src/TmpProc/Example1/Routes.hs b/src/TmpProc/Example1/Routes.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example1/Routes.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +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 diff --git a/src/TmpProc/Example1/Schema.hs b/src/TmpProc/Example1/Schema.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example1/Schema.hs @@ -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 + +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 + } diff --git a/src/TmpProc/Example1/Server.hs b/src/TmpProc/Example1/Server.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example1/Server.hs @@ -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 + +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) diff --git a/src/TmpProc/Example2/Cache.hs b/src/TmpProc/Example2/Cache.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example2/Cache.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE LambdaCase #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +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 diff --git a/src/TmpProc/Example2/Client.hs b/src/TmpProc/Example2/Client.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example2/Client.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +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 diff --git a/src/TmpProc/Example2/Database.hs b/src/TmpProc/Example2/Database.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example2/Database.hs @@ -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 diff --git a/src/TmpProc/Example2/Routes.hs b/src/TmpProc/Example2/Routes.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example2/Routes.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Copyright : (c) 2020-2021 Tim Emiola +SPDX-License-Identifier: BSD3 +Maintainer : Tim Emiola + +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 diff --git a/src/TmpProc/Example2/Schema.hs b/src/TmpProc/Example2/Schema.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example2/Schema.hs @@ -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 + +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 + } diff --git a/src/TmpProc/Example2/Server.hs b/src/TmpProc/Example2/Server.hs new file mode 100644 --- /dev/null +++ b/src/TmpProc/Example2/Server.hs @@ -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 + +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 diff --git a/test/Taste.hs b/test/Taste.hs new file mode 100644 --- /dev/null +++ b/test/Taste.hs @@ -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 diff --git a/tmp-proc-example.cabal b/tmp-proc-example.cabal new file mode 100644 --- /dev/null +++ b/tmp-proc-example.cabal @@ -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