hpqtypes-effectful (empty) → 1.0.0.0
raw patch · 7 files changed
+610/−0 lines, 7 filesdep +basedep +effectful-coredep +exceptions
Dependencies added: base, effectful-core, exceptions, hpqtypes, hpqtypes-effectful, tasty, tasty-hunit, text
Files
- CHANGELOG.md +2/−0
- LICENSE +30/−0
- README.md +12/−0
- examples/OuterJoins.hs +166/−0
- hpqtypes-effectful.cabal +87/−0
- src/Effectful/HPQTypes.hs +212/−0
- test/Main.hs +101/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# hpqtypes-effectful-1.0.0.0 (2022-10-24)+* Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2022, Kyriakos Papachrysanthou++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 Kyriakos Papachrysanthou 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.
+ README.md view
@@ -0,0 +1,12 @@+# hpqtypes-effectful++[](https://github.com/haskell-effectful/hpqtypes-effectful/actions?query=branch%3Amaster)+[](https://hackage.haskell.org/package/hpqtypes-effectful)+[](https://packdeps.haskellers.com/feed?needle=andrzej@rybczak.net)+[](https://www.stackage.org/lts/package/hpqtypes-effectful)+[](https://www.stackage.org/nightly/package/hpqtypes-effectful)++Adaptation of the [hpqtypes](https://hackage.haskell.org/package/hpqtypes)+library for the effectful ecosystem.++Examples can be found in the [examples](https://github.com/haskell-effectful/hpqtypes-effectful/tree/master/examples) directory.
+ examples/OuterJoins.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module OuterJoins (runApp) where++import Control.Monad+import Control.Monad.Catch+import Data.Int+import qualified Data.Text as T+import Effectful+import Effectful.HPQTypes++-- | Generic 'putStrLn'.+printLn :: IOE :> es => String -> Eff es ()+printLn = liftIO . putStrLn++----------------------------------------++tmpID :: Int64+tmpID = 0++data Attribute = Attribute+ { attrID :: !Int64+ , attrKey :: !String+ , attrValues :: ![String]+ }+ deriving (Show)++data Thing = Thing+ { thingID :: !Int64+ , thingName :: !String+ , thingAttributes :: ![Attribute]+ }+ deriving (Show)++type instance CompositeRow Attribute = (Int64, String, Array1 String)++instance PQFormat Attribute where+ pqFormat = "%attribute_"++instance CompositeFromSQL Attribute where+ toComposite (aid, key, Array1 values) =+ Attribute+ { attrID = aid+ , attrKey = key+ , attrValues = values+ }++withDB :: IOE :> es => ConnectionSettings -> Eff es () -> Eff es ()+withDB cs = bracket_ createStructure dropStructure+ where+ ConnectionSource source = simpleSource cs++ createStructure = runDB source defaultTransactionSettings $ do+ printLn "Creating tables..."+ runSQL_ $+ mconcat+ [ "CREATE TABLE things_ ("+ , " id BIGSERIAL NOT NULL"+ , ", name TEXT NOT NULL"+ , ", PRIMARY KEY (id)"+ , ")"+ ]+ runSQL_ $+ mconcat+ [ "CREATE TABLE attributes_ ("+ , " id BIGSERIAL NOT NULL"+ , ", key TEXT NOT NULL"+ , ", thing_id BIGINT NOT NULL"+ , ", PRIMARY KEY (id)"+ , ", FOREIGN KEY (thing_id) REFERENCES things_ (id)"+ , ")"+ ]+ runSQL_ $+ mconcat+ [ "CREATE TABLE values_ ("+ , " attribute_id BIGINT NOT NULL"+ , ", value TEXT NOT NULL"+ , ", FOREIGN KEY (attribute_id) REFERENCES attributes_ (id)"+ , ")"+ ]+ runSQL_ $+ mconcat+ [ "CREATE TYPE attribute_ AS ("+ , " id BIGINT"+ , ", key TEXT"+ , ", value TEXT[]"+ , ")"+ ]++ dropStructure = runDB source defaultTransactionSettings $ do+ printLn "Dropping tables..."+ runSQL_ "DROP TYPE attribute_"+ runSQL_ "DROP TABLE values_"+ runSQL_ "DROP TABLE attributes_"+ runSQL_ "DROP TABLE things_"++insertThings :: DB :> es => [Thing] -> Eff es ()+insertThings = mapM_ $ \Thing {..} -> do+ runQuery_ $+ rawSQL+ "INSERT INTO things_ (name) VALUES ($1) RETURNING id"+ (Identity thingName)+ tid <- fetchOne (runIdentity @Int64)+ forM_ thingAttributes $ \Attribute {..} -> do+ runQuery_ $+ rawSQL+ "INSERT INTO attributes_ (key, thing_id) VALUES ($1, $2) RETURNING id"+ (attrKey, tid)+ aid <- fetchOne (runIdentity @Int64)+ forM_ attrValues $ \value ->+ runQuery_ $+ rawSQL+ "INSERT INTO values_ (attribute_id, value) VALUES ($1, $2)"+ (aid, value)++selectThings :: DB :> es => Eff es [Thing]+selectThings = do+ runSQL_ $ "SELECT t.id, t.name, ARRAY(" <> attributes <> ") FROM things_ t ORDER BY t.id"+ fetchMany $ \(tid, name, CompositeArray1 attrs) ->+ Thing+ { thingID = tid+ , thingName = name+ , thingAttributes = attrs+ }+ where+ attributes = "SELECT (a.id, a.key, ARRAY(" <> values <> "))::attribute_ FROM attributes_ a WHERE a.thing_id = t.id ORDER BY a.id"+ values = "SELECT v.value FROM values_ v WHERE v.attribute_id = a.id ORDER BY v.value"++runApp :: T.Text -> IO ()+runApp connInfo = runEff $ do+ let cs = defaultConnectionSettings {csConnInfo = connInfo}+ withDB cs $ do+ ConnectionSource pool <- liftIO $ do+ poolSource (cs {csComposites = ["attribute_"]}) 10 4+ runDB pool defaultTransactionSettings $ do+ insertThings+ [ Thing+ { thingID = tmpID+ , thingName = "thing1"+ , thingAttributes =+ [ Attribute+ { attrID = tmpID+ , attrKey = "key1"+ , attrValues = ["foo"]+ }+ , Attribute+ { attrID = tmpID+ , attrKey = "key2"+ , attrValues = []+ }+ ]+ }+ , Thing+ { thingID = tmpID+ , thingName = "thing2"+ , thingAttributes =+ [ Attribute+ { attrID = tmpID+ , attrKey = "key2"+ , attrValues = ["bar", "baz"]+ }+ ]+ }+ ]+ selectThings >>= mapM_ (printLn . show)
+ hpqtypes-effectful.cabal view
@@ -0,0 +1,87 @@+cabal-version: 2.4+build-type: Simple+name: hpqtypes-effectful+version: 1.0.0.0+license: BSD-3-Clause+license-file: LICENSE+category: Database+maintainer: andrzej@rybczak.net, jakub.waszczuk@scrive.com+author: Scrive AB+synopsis: Adaptation of the hpqtypes library for the effectful ecosystem.++description: Adaptation of the @<https://hackage.haskell.org/package/hpqtypes hpqtypes>@ library for the @<https://hackage.haskell.org/package/effectful effectful>@ ecosystem.+homepage: https://github.com/haskell-effectful/hpqtypes-effectful++extra-source-files:+ CHANGELOG.md+ README.md++tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 || ==9.4.2++bug-reports: https://github.com/haskell-effectful/hpqtypes-effectful/issues+source-repository head+ type: git+ location: https://github.com/haskell-effectful/hpqtypes-effectful++common language+ ghc-options: -Wall -Wcompat -Wredundant-constraints+ -Wno-unticked-promoted-constructors+++ default-language: Haskell2010++ default-extensions: BangPatterns+ ConstraintKinds+ DataKinds+ DeriveFunctor+ DeriveGeneric+ DerivingStrategies+ FlexibleContexts+ FlexibleInstances+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ MultiParamTypeClasses+ NoStarIsType+ RankNTypes+ RoleAnnotations+ ScopedTypeVariables+ StandaloneDeriving+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators++library+ import: language++ build-depends: base >= 4.13 && < 5+ , effectful-core >= 1.2.0.0 && < 3.0.0.0+ , exceptions+ , hpqtypes >= 1.9.4.0 && < 1.11.0.0++ hs-source-dirs: src++ exposed-modules: Effectful.HPQTypes++test-suite test+ import: language++ ghc-options: -threaded++ build-depends: base+ , effectful-core+ , hpqtypes-effectful+ , exceptions+ , hpqtypes+ , tasty+ , tasty-hunit+ , text++ hs-source-dirs: examples test++ -- Include examples to make sure they compile.+ other-modules: OuterJoins++ type: exitcode-stdio-1.0+ main-is: Main.hs
+ src/Effectful/HPQTypes.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Access to a PostgreSQL database via 'MonadDB'.+module Effectful.HPQTypes+ ( -- * Effect+ DB (..)++ -- ** Handlers+ , runDB++ -- * Re-exports+ , module Database.PostgreSQL.PQTypes+ )+where++import Control.Concurrent.MVar (readMVar)+import Control.Monad.Catch+import Database.PostgreSQL.PQTypes+import qualified Database.PostgreSQL.PQTypes.Internal.Connection as PQ+import qualified Database.PostgreSQL.PQTypes.Internal.Notification as PQ+import qualified Database.PostgreSQL.PQTypes.Internal.Query as PQ+import qualified Database.PostgreSQL.PQTypes.Internal.State as PQ+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.State.Static.Local (State, evalState)+import qualified Effectful.State.Static.Local as State++-- | Provide the ability to access a PostgreSQL database via 'MonadDB'.+data DB :: Effect where+ RunQuery :: IsSQL sql => sql -> DB m Int+ GetQueryResult :: FromRow row => DB m (Maybe (QueryResult row))+ ClearQueryResult :: DB m ()+ GetConnectionStats :: DB m PQ.ConnectionStats+ RunPreparedQuery :: IsSQL sql => PQ.QueryName -> sql -> DB m Int+ GetLastQuery :: DB m SomeSQL+ GetTransactionSettings :: DB m TransactionSettings+ SetTransactionSettings :: TransactionSettings -> DB m ()+ WithFrozenLastQuery :: m a -> DB m a+ WithNewConnection :: m a -> DB m a+ GetNotification :: Int -> DB m (Maybe PQ.Notification)++type instance DispatchOf DB = Dynamic++-- | Orphan, canonical instance.+instance DB :> es => MonadDB (Eff es) where+ runQuery = send . RunQuery+ getQueryResult = send GetQueryResult+ clearQueryResult = send ClearQueryResult+ getConnectionStats = send GetConnectionStats+ runPreparedQuery qn = send . RunPreparedQuery qn+ getLastQuery = send GetLastQuery+ getTransactionSettings = send GetTransactionSettings+ setTransactionSettings = send . SetTransactionSettings+ withFrozenLastQuery = send . WithFrozenLastQuery+ withNewConnection = send . WithNewConnection+ getNotification = send . GetNotification++-- | Run the 'DB' effect with the given connection source and transaction+-- settings.+--+-- /Note:/ this is the @effectful@ version of 'runDBT'.+runDB+ :: forall es a+ . (IOE :> es)+ => PQ.ConnectionSourceM (Eff es)+ -- ^ Connection source.+ -> TransactionSettings+ -- ^ Transaction settings.+ -> Eff (DB : es) a+ -> Eff es a+runDB connectionSource transactionSettings =+ reinterpret runWithState $ \env -> \case+ RunQuery sql -> unDBEff $ runQuery sql+ GetQueryResult -> unDBEff getQueryResult+ ClearQueryResult -> unDBEff clearQueryResult+ GetConnectionStats -> unDBEff getConnectionStats+ RunPreparedQuery queryName sql -> unDBEff $ runPreparedQuery queryName sql+ GetLastQuery -> unDBEff getLastQuery+ GetTransactionSettings -> unDBEff getTransactionSettings+ SetTransactionSettings settings -> unDBEff $ setTransactionSettings settings+ WithFrozenLastQuery (action :: Eff localEs b) -> do+ localSeqUnlift env $ \unlift -> do+ unDBEff . withFrozenLastQuery . DBEff $ unlift action+ WithNewConnection (action :: Eff localEs b) -> do+ localSeqUnlift env $ \unlift -> do+ unDBEff . withNewConnection . DBEff $ unlift action+ GetNotification time -> unDBEff $ getNotification time+ where+ runWithState :: Eff (State (DBState es) : es) a -> Eff es a+ runWithState eff =+ PQ.withConnection connectionSource $ \conn -> do+ let dbState0 = mkDBState connectionSource conn transactionSettings+ evalState dbState0 $ do+ handleAutoTransaction transactionSettings doWithTransaction eff++ doWithTransaction+ :: TransactionSettings+ -> Eff (State (DBState es) : es) a+ -> Eff (State (DBState es) : es) a+ doWithTransaction ts eff = unDBEff . withTransaction' ts $ DBEff eff++mkDBState+ :: PQ.ConnectionSourceM m+ -> PQ.Connection+ -> TransactionSettings+ -> PQ.DBState m+mkDBState connectionSource conn ts =+ PQ.DBState+ { PQ.dbConnection = conn+ , PQ.dbConnectionSource = connectionSource+ , PQ.dbTransactionSettings = ts+ , PQ.dbLastQuery = SomeSQL (mempty :: SQL)+ , PQ.dbRecordLastQuery = True+ , PQ.dbQueryResult = Nothing+ }++handleAutoTransaction+ :: TransactionSettings+ -> (TransactionSettings -> m a -> m a)+ -> m a+ -> m a+handleAutoTransaction transactionSettings doWithTransaction action =+ -- We don't set tsAutoTransaction to False in the context of the action+ -- because if the action calls commit inside, then with tsAutoTransaction+ -- another transaction should be started automatically and if it's not set, it+ -- won't happen (see source of the commit' function). On the other hand,+ -- withTransaction itself uses commit' and there we don't want to start+ -- another transaction.+ if tsAutoTransaction transactionSettings+ then doWithTransaction (transactionSettings {tsAutoTransaction = False}) action+ else action++---------------------------------------------------+-- Internal effect stack+---------------------------------------------------++-- | Newtype wrapper over the internal DB effect stack+newtype DBEff es a = DBEff+ { unDBEff :: Eff (State (DBState es) : es) a+ }+ deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask)++-- | Internal state used to reinterpret the `DB` effect+type DBState es = PQ.DBState (Eff es)++-- Convenience `MonadIO` instance+instance (IOE :> es) => MonadIO (DBEff es) where+ liftIO b = DBEff $ liftIO b++get :: DBEff es (DBState es)+get = DBEff State.get++put :: DBState es -> DBEff es ()+put = DBEff . State.put++modify :: (DBState es -> DBState es) -> DBEff es ()+modify = DBEff . State.modify++instance (IOE :> es) => MonadDB (DBEff es) where+ runQuery sql = do+ dbState <- get+ (result, dbState') <- liftIO $ PQ.runQueryIO sql dbState+ put dbState'+ pure result++ getQueryResult =+ get >>= \dbState -> pure $ PQ.dbQueryResult dbState++ clearQueryResult =+ modify $ \st -> st {PQ.dbQueryResult = Nothing}++ getConnectionStats = do+ dbState <- get+ mconn <- liftIO . readMVar . PQ.unConnection $ PQ.dbConnection dbState+ case mconn of+ Nothing -> throwDB $ HPQTypesError "getConnectionStats: no connection"+ Just cd -> pure $ PQ.cdStats cd++ runPreparedQuery queryName sql = do+ dbState <- get+ (result, dbState') <- liftIO $ PQ.runPreparedQueryIO queryName sql dbState+ put dbState'+ pure result++ getLastQuery = PQ.dbLastQuery <$> get++ getTransactionSettings = PQ.dbTransactionSettings <$> get++ setTransactionSettings settings = modify $ \st' ->+ st' {PQ.dbTransactionSettings = settings}++ withFrozenLastQuery action = do+ let restoreRecordLastQuery st =+ modify $ \st' ->+ st' {PQ.dbRecordLastQuery = PQ.dbRecordLastQuery st}+ bracket get restoreRecordLastQuery $ \st -> do+ put st {PQ.dbRecordLastQuery = False}+ action++ withNewConnection action = DBEff $ do+ dbState0 <- State.get+ raiseWith SeqUnlift $ \lower -> do+ PQ.withConnection (PQ.dbConnectionSource dbState0) $ \newConn -> lower $ do+ let transactionSettings = PQ.dbTransactionSettings dbState0+ dbState = mkDBState (PQ.dbConnectionSource dbState0) newConn transactionSettings+ unDBEff . bracket_ (put dbState) (put dbState0) $ do+ handleAutoTransaction transactionSettings withTransaction' action++ getNotification time = do+ dbState <- get+ liftIO $ PQ.getNotificationIO dbState time
+ test/Main.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Monad (void)+import Data.Int (Int32)+import qualified Data.Text as T+import Effectful+import Effectful.Error.Static+import Effectful.HPQTypes+import System.Environment (lookupEnv)+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+ testGroup+ "tests"+ [ testCase "test getLastQuery" testGetLastQuery+ , testCase "test withFrozenLastQuery" testWithFrozenLastQuery+ , testCase "test connection stats retrieval with new connection" testConnectionStatsWithNewConnection+ ]++testGetLastQuery :: Assertion+testGetLastQuery = do+ dbUrl <- getConnString+ let connectionSource = simpleSource $ ConnectionSettings dbUrl Nothing []+ void . runEff . runErrorNoCallStack @HPQTypesError . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do+ do+ -- Run the first query and perform some basic sanity checks+ let sql = mkSQL "SELECT 1"+ rowNo <- runQuery sql+ liftIO $ assertEqual "One row should be retrieved" 1 rowNo+ result <- fetchMany (runIdentity @Int32)+ liftIO $ assertEqual "Result should be [1]" [1] result+ SomeSQL lastQuery <- getLastQuery+ liftIO $ assertEqual "SQL don't match" (show sql) (show lastQuery)+ do+ -- Run the second query and check that `getLastQuery` gives updated result+ let newSQL = mkSQL "SELECT 2"+ runQuery_ newSQL+ SomeSQL newLastQuery <- getLastQuery+ liftIO $ assertEqual "SQL don't match" (show newSQL) (show newLastQuery)++testWithFrozenLastQuery :: Assertion+testWithFrozenLastQuery = do+ dbUrl <- getConnString+ let connectionSource = simpleSource $ ConnectionSettings dbUrl Nothing []+ void . runEff . runErrorNoCallStack @HPQTypesError . runDB (unConnectionSource connectionSource) defaultTransactionSettings $ do+ let sql = mkSQL "SELECT 1"+ runQuery_ sql+ withFrozenLastQuery $ do+ runQuery_ $ mkSQL "SELECT 2"+ getLastQuery >>= \(SomeSQL lastQuery) ->+ liftIO $ assertEqual "The last query before freeze should be reported" (show sql) (show lastQuery)+ getLastQuery >>= \(SomeSQL lastQuery) ->+ liftIO $ assertEqual "The last query before freeze should be reported" (show sql) (show lastQuery)++testConnectionStatsWithNewConnection :: Assertion+testConnectionStatsWithNewConnection = do+ dbUrl <- getConnString+ let connectionSource = simpleSource $ ConnectionSettings dbUrl Nothing []+ transactionSettings =+ defaultTransactionSettings+ { tsIsolationLevel = ReadCommitted+ , tsAutoTransaction = False+ }+ void . runEff . runErrorNoCallStack @HPQTypesError . runDB (unConnectionSource connectionSource) transactionSettings $ do+ do+ runQuery_ $ mkSQL "SELECT 1"+ runQuery_ $ mkSQL "SELECT 2"+ connectionStats <- getConnectionStats+ liftIO $ assertEqual "Incorrect connection stats" (ConnectionStats 2 2 2 0) connectionStats+ do+ runQuery_ $ mkSQL "CREATE TABLE some_table (field INT)"+ runQuery_ $ mkSQL "BEGIN"+ runQuery_ $ mkSQL "INSERT INTO some_table VALUES (1)"+ withNewConnection $ do+ connectionStats <- getConnectionStats+ liftIO $ assertEqual "Connection stats should be reset" (ConnectionStats 0 0 0 0) connectionStats+ noOfResults <- runQuery $ mkSQL "SELECT * FROM some_table"+ liftIO $ assertEqual "Results should not be visible yet" 0 noOfResults+ runQuery_ $ mkSQL "COMMIT"+ noOfResults <- runQuery $ mkSQL "SELECT * FROM some_table"+ liftIO $ assertEqual "Results should be visible" 1 noOfResults+ runQuery_ $ mkSQL "DROP TABLE some_table"++----------------------------------------+-- Helpers++getConnString :: IO T.Text+getConnString =+ lookupEnv "GITHUB_ACTIONS" >>= \case+ Just "true" -> pure . T.pack $ "host=postgres user=postgres password=postgres"+ _ -> do+ lookupEnv "DATABASE_URL" >>= \case+ Just url -> pure $ T.pack url+ Nothing -> error "DATABASE_URL environment variable is not set"