packages feed

polysemy-hasql (empty) → 0.0.1.0

raw patch · 51 files changed

+3768/−0 lines, 51 filesdep +aesondep +asyncdep +basesetup-changed

Dependencies added: aeson, async, base, containers, exon, generics-sop, hasql, hedgehog, polysemy, polysemy-db, polysemy-hasql, polysemy-plugin, polysemy-test, postgresql-libpq, prelate, sqel, stm-chans, tasty, torsor, transformers, uuid, vector, zeugma

Files

+ LICENSE view
@@ -0,0 +1,34 @@+Copyright (c) 2023 Torsten Schmits++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the+following conditions are met:++  1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following+  disclaimer.+  2. 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.++Subject to the terms and conditions of this license, each copyright holder and contributor hereby grants to those+receiving rights under this license a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except+for failure to satisfy the conditions of this license) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer this software, where such license applies only to those patent claims, already acquired+or hereafter acquired, licensable by such copyright holder or contributor that are necessarily infringed by:++  (a) their Contribution(s) (the licensed copyrights of copyright holders and non-copyrightable additions of+  contributors, in source or binary form) alone; or+  (b) combination of their Contribution(s) with the work of authorship to which such Contribution(s) was added by such+  copyright holder or contributor, if, at the time the Contribution is added, such addition causes such combination to+  be necessarily infringed. The patent license shall not apply to any other combinations which include the Contribution.++Except as expressly stated above, no rights or licenses from any copyright holder or contributor is granted under this+license, whether expressly, by implication, estoppel or otherwise.++DISCLAIMER++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 HOLDERS 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
+ integration/Main.hs view
@@ -0,0 +1,44 @@+module Main where++import Polysemy.Hasql.Test.ArrayTest (test_arrayField)+import Polysemy.Hasql.Test.AtomicStateTest (test_atomicStateDb)+import Polysemy.Hasql.Test.DefaultTest (test_default)+import Polysemy.Hasql.Test.JsonTest (test_json)+import Polysemy.Hasql.Test.MigrationTest (test_migration)+import Polysemy.Hasql.Test.QueryTest (test_query, test_queryId)+import Polysemy.Hasql.Test.QueueTest (test_queue)+import Polysemy.Hasql.Test.RetryTest (test_retry)+import Polysemy.Hasql.Test.SimpleQueryTest (test_simpleQuery)+import Polysemy.Hasql.Test.SumQueryTest (test_sumQuery)+import Polysemy.Hasql.Test.SumTest (test_sum)+import Polysemy.Hasql.Test.TransactionTest (test_transaction)+import Polysemy.Hasql.Test.TransformMigrationTest (test_transformMigration)+import Polysemy.Hasql.Test.UnaryConTest (test_unaryCon)+import Polysemy.Hasql.Test.WithInitTest (test_withInit)+import Polysemy.Test (unitTest)+import Test.Tasty (TestTree, defaultMain, testGroup)++tests :: TestTree+tests =+  testGroup "integration" [+    unitTest "array db column" test_arrayField,+    unitTest "queue with notifications" test_queue,+    unitTest "retry on error" test_retry,+    unitTest "atomic state as table" test_atomicStateDb,+    unitTest "json field" test_json,+    unitTest "simple query" test_simpleQuery,+    unitTest "query" test_query,+    unitTest "query" test_queryId,+    unitTest "sum" test_sum,+    unitTest "sum query" test_sumQuery,+    unitTest "sum with unary constructor" test_unaryCon,+    unitTest "migration" test_migration,+    unitTest "column default" test_default,+    unitTest "transaction" test_transaction,+    unitTest "init hook" test_withInit,+    unitTest "migration with transformation" test_transformMigration+  ]++main :: IO ()+main =+  defaultMain tests
+ integration/Polysemy/Hasql/Test/ArrayTest.hs view
@@ -0,0 +1,67 @@+module Polysemy.Hasql.Test.ArrayTest where++import Data.UUID (UUID)+import Data.Vector (Vector)+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (UuidStore)+import Polysemy.Test (UnitTest)+import Polysemy.Test.Hedgehog (assertJust)+import Sqel.Column (nullable)+import Sqel.Data.Dd ((:>) ((:>)))+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import qualified Sqel.Data.Uid as Uid+import Sqel.Data.Uid (Uid (Uid), Uuid)+import Sqel.PgType (tableSchema)+import Sqel.Prim (array, enum, prim, primAs, readShow)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Uid (uid)++import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data Flag = On | Off | Superposition+  deriving stock (Eq, Show, Generic, Ord, Read)++data ArrayField =+  ArrayField {+    f1 :: Maybe [Flag],+    f2 :: Set Flag,+    f3 :: Vector Int,+    f4 :: NonEmpty Double+  }+  deriving stock (Eq, Show, Generic)++table :: TableSchema (Uuid ArrayField)+query :: QuerySchema UUID (Uuid ArrayField)+(table, query) =+  (tableSchema dd, checkQuery (primAs @"id") dd)+  where+    dd = uid prim (prod (nullable (array enum) :> array readShow :> array prim :> array prim))++id' :: UUID+id' =+  Uid.intUUID 555++payload :: ArrayField+payload =+  ArrayField (Just [On, Off, Superposition]) [On, Off, Superposition] [1, 2, 3] [4, 5]++prog ::+  Member (UuidStore ArrayField) r =>+  Sem r (Maybe ArrayField)+prog = do+  _ <- Store.upsert (Uid id' payload)+  Store.fetchPayload id'++-- TODO add query with enum field+-- TODO add Maybe Array field+test_arrayField :: UnitTest+test_arrayField =+  integrationTest do+    interpretTable table $ interpretStoreDb table query do+      result <- restop @DbError prog+      assertJust payload result
+ integration/Polysemy/Hasql/Test/AtomicStateTest.hs view
@@ -0,0 +1,32 @@+module Polysemy.Hasql.Test.AtomicStateTest where++import Exon (exon)+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Test (UnitTest, (===))+import Sqel.Data.TableSchema (TableSchema)+import Sqel.PgType (MkTableSchema (tableSchema))+import Sqel.Prim (prims)+import Sqel.Product (prod)++import Polysemy.Hasql.Interpreter.AtomicState (interpretAtomicStateDb)+import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data Cat =+  Cat {+    number :: Int,+    name :: Text+  }+  deriving stock (Eq, Show, Generic)++test_atomicStateDb :: UnitTest+test_atomicStateDb =+  integrationTest $ interpretTable ts do+    r <- interpretAtomicStateDb ts (pure (Cat 5 "fuzzyboots")) do+      restop @DbError do+        atomicModify' \ (Cat _ nam) -> Cat 200 [exon|mr. #{nam}|]+        atomicGet+    Cat 200 "mr. fuzzyboots" === r+  where+    ts :: TableSchema Cat+    ts = tableSchema (prod prims)
+ integration/Polysemy/Hasql/Test/DbConfig.hs view
@@ -0,0 +1,19 @@+module Polysemy.Hasql.Test.DbConfig where++import Exon (exon)+import Polysemy.Db.Data.DbConfig (DbConfig (DbConfig))+import System.Environment (lookupEnv)++dbConfig ::+  MonadIO m =>+  m (Maybe DbConfig)+dbConfig = do+  traverse cons =<< (liftIO (lookupEnv "polysemy_db_test_host"))+  where+    cons host = do+      port <- parsePort =<< (fromMaybe "4321" <$> liftIO (lookupEnv "polysemy_db_test_port"))+      pure (DbConfig (fromString host) port "polysemy-db" "polysemy-db" "polysemy-db")+    parsePort p =+      case readMaybe p of+        Just a -> pure a+        Nothing -> error [exon|invalid port in env var $polysemy_db_test_port: #{p}|]
+ integration/Polysemy/Hasql/Test/DefaultTest.hs view
@@ -0,0 +1,53 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Polysemy.Hasql.Test.DefaultTest where++import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (UnitTest, assertEq)+import Prelude hiding (sum)+import Sqel.Column (pgDefault)+import Sqel.Data.Dd (Dd, (:>) ((:>)))+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.PgType (tableSchema)+import Sqel.Prim (prim, primAs, primNullable)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Uid (uid)++import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data Dat =+  Dat {+    name :: Text,+    number :: Int,+    count :: Maybe Int+  }+  deriving stock (Eq, Show, Generic)++dd :: Dd _+dd = uid prim (prod (prim :> prim :> pgDefault "13" primNullable))++ts :: TableSchema (Uid Int Dat)+ts = tableSchema dd++idSchema :: QuerySchema Int (Uid Int Dat)+idSchema =+  checkQuery (primAs @"id") dd++-- TODO problem: default value is not used when explicit null is specified. would need to omit the column from the+-- insert statement, but that would require dynamic statement+test_default :: UnitTest+test_default =+  integrationTest do+    interpretTable ts $ interpretStoreDb ts idSchema do+      restop @DbError @(Store _ _) do+        Store.insert d+        assertEq [d] =<< Store.fetchAll+  where+    d = Uid 1 (Dat "name" 1 Nothing)
+ integration/Polysemy/Hasql/Test/JsonTest.hs view
@@ -0,0 +1,68 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Polysemy.Hasql.Test.JsonTest where++import qualified Data.Aeson as Aeson+import Exon (exon)+import qualified Hasql.Decoders as Decoders+import Hasql.Decoders (column, jsonBytes)+import qualified Hasql.Encoders as Encoders+import Hasql.Encoders (int8, param)+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Test (UnitTest, assertJust, assertRight, evalMaybe)+import Sqel.Data.Dd (Dd, DdK (DdK), (:>) ((:>)))+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.PgType (tableSchema)+import qualified Sqel.Prim as Sqel+import Sqel.Prim (prim, primAs)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Uid (uid)++import qualified Polysemy.Hasql.Database as Database+import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data Field3 =+  Field3 {+    int :: Int,+    txt :: Text+  }+  deriving stock (Eq, Show, Generic)++json ''Field3++data Dat =+  Dat {+    field1 :: Text,+    field2 :: Int,+    field3 :: Field3+  }+  deriving stock (Eq, Show, Generic)++table :: Dd ('DdK _ _ (Uid Int64 Dat) _)+table =+  uid prim (prod (prim :> prim :> Sqel.json))++ts :: TableSchema (Uid Int64 Dat)+ts =+  tableSchema table++test_json :: UnitTest+test_json = do+  integrationTest do+    interpretTable ts $ interpretStoreDb ts (checkQuery (primAs @"id") table) do+      restop @DbError do+        Store.insert dat+        raise . assertJust dat =<< Store.fetch 5+    result <- evalMaybe =<< Database.retryingQuerySqlDef @DbError query dec enc 5+    assertRight f3 (Aeson.eitherDecodeStrict' result)+  where+    query = [exon|select field3 from dat where id = $1|]+    dec = column (Decoders.nonNullable (jsonBytes pure))+    enc = param (Encoders.nonNullable int8)+    dat = Uid 5 (Dat "field1" 8 f3)+    f3 = Field3 2 "field3"
+ integration/Polysemy/Hasql/Test/MigrationTest.hs view
@@ -0,0 +1,156 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Polysemy.Hasql.Test.MigrationTest where++import Lens.Micro.Extras (view)+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Query as Query+import Polysemy.Db.Effect.Query (Query)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (UnitTest, assertEq)+import Prelude hiding (sum)+import Sqel.Data.Dd (Dd, DdK (DdK), type (:>) ((:>)))+import Sqel.Data.Migration (AutoMigrations, migrate)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.Migration.Table (migrateAuto)+import Sqel.PgType (tableSchema)+import Sqel.Prim (array, migrateDef, migrateDelete, migrateRename, migrateRenameType, prim, primAs, primNullable)+import Sqel.Product (Product (prod))+import Sqel.Query (checkQuery)+import Sqel.Uid (uidAs)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Interpreter.DbTable (interpretTableMigrations, interpretTables)+import Polysemy.Hasql.Interpreter.Query (interpretQueryDd)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Migration (MigrateSem)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data PordOld =+  PordOld {+    p1 :: Int64+  }+  deriving stock (Eq, Show, Generic)++data Pord =+  Pord {+    p1 :: Int64,+    p2 :: Maybe Text+  }+  deriving stock (Eq, Show, Generic)++data Dat0 =+  Dat0 {+    old :: Text,+    names :: [Text]+  }+  deriving stock (Eq, Show, Generic)++data Dat1 =+  Dat1 {+    size :: Int64,+    names :: [Text],+    pordOld :: PordOld+  }+  deriving stock (Eq, Show, Generic)++data Dat2 =+  Dat2 {+    number :: Int64,+    names :: [Text],+    pord :: Pord+  }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    name :: Text,+    names :: [Text],+    num :: Int64,+    pord :: Pord+  }+  deriving stock (Eq, Show, Generic)++data Q =+  Q {+    name :: Text+  }+  deriving stock (Eq, Show, Generic)++t0 :: Dd ('DdK _ _ (Uid Int64 Dat0) _)+t0 =+  uidAs @"dat" prim (prod (migrateDelete prim :> array prim))++t1 :: Dd ('DdK _ _ (Uid Int64 Dat1) _)+t1 =+  uidAs @"dat" prim (prod (+    migrateDelete (migrateDef 0 prim) :>+    array prim :>+    prod (+      migrateDef 53 prim+    )+  ))++t2 :: Dd ('DdK _ _ (Uid Int64 Dat2) _)+t2 =+  uidAs @"dat" prim (prod (+    migrateDef 15 prim :>+    array prim :>+    migrateRename @"pordOld" (migrateRenameType @"sqel_type__PordOld" (prod (+      prim :>+      primNullable+    )))+  ))++tcur :: Dd ('DdK _ _ (Uid Int64 Dat) _)+tcur =+  uidAs @"dat" prim (prod (+    migrateDef ("vunqach" :: Text) prim :>+    array prim :>+    migrateRename @"number" prim :>+    prod (+      prim :>+      primNullable+    )+  ))++q :: Dd ('DdK _ _ Q _)+q =+  prod (primAs @"name")++schemaOld :: TableSchema (Uid Int64 Dat1)+schemaOld =+  tableSchema t1++schemaCur :: TableSchema (Uid Int64 Dat)+schemaCur =+  tableSchema tcur++migrations ::+  AutoMigrations (MigrateSem r) [Uid Int64 Dat2, Uid Int64 Dat1, Uid Int64 Dat0] (Uid Int64 Dat)+migrations =+  migrate (+    migrateAuto t2 tcur :>+    migrateAuto t1 t2 :>+    migrateAuto t0 t1+  )++test_migration :: UnitTest+test_migration =+  integrationTest do+    interpretTables schemaOld $ interpretStoreDb schemaOld (checkQuery (primAs @"id") t1) $ restop @DbError do+      Store.insert (Uid 3 (Dat1 11 ["0"] (PordOld 93)))+      Store.insert (Uid 4 (Dat1 55 ["0", "1"] (PordOld 78)))+    restop @DbError Database.release+    restop @DbError Database.resetInit+    interpretTableMigrations schemaCur migrations $+      interpretStoreDb schemaCur (checkQuery (primAs @"id") tcur) $+      interpretQueryDd @[_] tcur tcur q $+      restop @DbError @(Query _ _) $+      restop @DbError @(Store _ _) do+        Store.insert (Uid 1 (Dat "1" ["11"] 5 (Pord 10 (Just "new 1"))))+        Store.insert (Uid 2 (Dat "2" ["22", "33"] 5 (Pord 10 (Just "new 2"))))+        assertEq [3, 4] =<< fmap (view #id) <$> Query.query (Q "vunqach")+        assertEq [2] =<< fmap (view #id) <$> Query.query (Q "2")
+ integration/Polysemy/Hasql/Test/QueryTest.hs view
@@ -0,0 +1,130 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Polysemy.Hasql.Test.QueryTest where++import Hasql.Statement (Statement)+import Lens.Micro.Extras (view)+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Query as Query+import Polysemy.Db.Effect.Query (Query (Query))+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (UnitTest, (===))+import Prelude hiding (sum)+import Sqel.Column (nullable)+import Sqel.Data.Dd (Dd, DdK (DdK), (:>) ((:>)))+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.Names (named)+import Sqel.PgType (fullProjection, tableSchema)+import Sqel.Prim (ignore, prim, primAs, primNewtype)+import Sqel.Product (prod, prodAs)+import Sqel.Query (checkQuery)+import qualified Sqel.Query.Combinators as Q+import Sqel.Statement (selectWhere)+import Sqel.Uid (uid)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database)+import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Interpreter.Query (interpretQueryDd)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++newtype TextNt =+  TextNt { unTextNt :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++data PordQ =+  PordQ {+    p2 :: Text+  }+  deriving stock (Eq, Show, Generic)++data Par =+  Par {+    limit :: Maybe Int64,+    offset :: Maybe Int64+  }+  deriving stock (Eq, Show, Generic)++data Q =+  Q {+    pr :: PordQ,+    params :: Par,+    n :: TextNt,+    ig :: Maybe Int+  }+  deriving stock (Eq, Show, Generic)++data Pord =+  Pord {+    p1 :: Int64,+    p2 :: Maybe TextNt+  }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    name :: Text,+    po :: Pord+  }+  deriving stock (Eq, Show, Generic)++ddUidDat :: Dd ('DdK _ _ (Uid Int64 Dat) _)+ddUidDat =+  uid prim (prod (+    prim :>+    prod (prim :> nullable primNewtype)+  ))++ts :: TableSchema (Uid Int64 Dat)+ts = tableSchema ddUidDat++queryIdDat :: QuerySchema Int64 (Uid Int64 Dat)+queryIdDat =+  checkQuery (primAs @"id") ddUidDat++interpretQuery ::+  Member (Database !! DbError) r =>+  InterpreterFor (Query Q [Uid Int64 Dat] !! DbError) r+interpretQuery =+  interpretResumable \ (Query params) -> restop (Database.statement params stm)+  where+    stm :: Statement Q [Uid Int64 Dat]+    stm =+      selectWhere (checkQuery qd ddUidDat) (fullProjection ddUidDat)+    qd =+      prod (+        prodAs @"po" prim :>+        prod (nullable Q.limit :> nullable Q.offset) :>+        named @"name" primNewtype :>+        ignore+      )++inserts ::+  Member (Store Int64 Dat) r =>+  Sem r ()+inserts =+  for_ @[] [1..10] \ i ->+    Store.insert (Uid i (Dat "name" (Pord i (Just (TextNt "hnnnggg")))))++test_query :: UnitTest+test_query =+  integrationTest do+    interpretTable ts $ interpretStoreDb ts queryIdDat $ interpretQuery do+      restop @DbError @(Query _ _) $ restop @DbError @(Store _ _) do+        inserts+        r <- fmap (view #id) <$> Query.query (Q (PordQ "hnnnggg") (Par (Just 2) (Just 2)) "name" Nothing)+        [3, 4] === r++test_queryId :: UnitTest+test_queryId =+  integrationTest do+    interpretTable ts $ interpretStoreDb ts queryIdDat $ interpretQueryDd @[Int64] ddUidDat (primAs @"id" @Int64) (primAs @"id" @Int64) do+      restop @DbError @(Query _ _) $ restop @DbError @(Store _ _) do+        inserts+        r <- Query.query (5 :: Int64)+        [5] === r
+ integration/Polysemy/Hasql/Test/QueueTest.hs view
@@ -0,0 +1,59 @@+module Polysemy.Hasql.Test.QueueTest where++import Polysemy.Db.Data.DbConnectionError (DbConnectionError)+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Test (UnitTest, assertJust)+import Polysemy.Test.Data.Hedgehog (Hedgehog)+import qualified Time as Time+import Time (MilliSeconds (MilliSeconds), Seconds (Seconds))+import Sqel.Data.Uid (Uuid, intUuid)++import Polysemy.Hasql.Data.QueueOutputError (QueueOutputError)+import qualified Polysemy.Hasql.Effect.DbConnectionPool as DbConnectionPool+import Polysemy.Hasql.Effect.DbConnectionPool (DbConnectionPool)+import Polysemy.Hasql.Queue.Input (interpretInputQueueDb)+import Polysemy.Hasql.Queue.Output (interpretOutputQueueDb)+import Polysemy.Hasql.Queue.Store (interpretQueueStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data Dat =+  Dat {+    num :: Text+  }+  deriving stock (Eq, Show, Generic)++json ''Dat++prog ::+  ∀ oe t dt r .+  Members [Input (Maybe (Uuid Dat)), Output (Uuid Dat) !! oe, Stop oe, Stop DbError, Time t dt, Hedgehog IO] r =>+  Members [DbConnectionPool !! DbConnectionError, Stop DbConnectionError] r =>+  Sem r ()+prog = do+  Time.sleep (MilliSeconds 500)+  restop (output d1 >> output d2)+  dequeue1 <- input+  restop @DbConnectionError (DbConnectionPool.kill "dequeue-test-queue")+  dequeue2 <- input+  assertJust d1 dequeue1+  assertJust d2 dequeue2+  restop (output d3)+  assertJust d3 =<< input+  -- tag @"test-queue-output" (restop @DbConnectionError (raiseUnder @HasqlConnection DbConnection.kill))+  -- TODO this used to kill the output queue connection, but it's not unique anymore+  -- restop @DbConnectionError (DbConnectionPool.release "dequeue-test-queue")+  restop (output d1)+  assertJust d1 =<< input+  where+    d1 = intUuid 1 (Dat "5'\\'\'\n")+    d2 = intUuid 2 (Dat "bonjour")+    d3 = intUuid 3 (Dat "data")++test_queue :: UnitTest+test_queue =+  integrationTest $+  mapStop @QueueOutputError @Text show $+  interpretQueueStoreDb $+  interpretOutputQueueDb @"test-queue" @(Uuid Dat) $+  interpretInputQueueDb @"test-queue" (Seconds 0) def (const (pure True)) $+  prog
+ integration/Polysemy/Hasql/Test/RetryTest.hs view
@@ -0,0 +1,34 @@+module Polysemy.Hasql.Test.RetryTest where++import qualified Hasql.Connection as Hasql+import Hasql.Decoders (column, int8, nonNullable)+import Polysemy.Db.Data.DbConnectionError (DbConnectionError)+import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Test (Hedgehog, UnitTest, assertEq)+import Time (Seconds (Seconds))+import Sqel.Statement (unprepared)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Databases, withDatabaseUnique)+import qualified Polysemy.Hasql.Effect.DbConnectionPool as DbConnectionPool+import Polysemy.Hasql.Effect.DbConnectionPool (DbConnectionPool)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++prog ::+  Members [Hedgehog IO, Databases, DbConnectionPool !! DbConnectionError, Stop DbError, Embed IO] r =>+  Sem r ()+prog = do+  withDatabaseUnique (Just "retry") do+    assertEq 1 =<< restop run+    conn <- stopNote "no connection" =<< resumeHoist DbError.Connection (DbConnectionPool.unsafeGet "retry")+    embed (Hasql.release conn)+    assertEq 1 =<< restop (Database.retry (Seconds 1) (Just 1) run)+  where+    run = Database.statement () stmt+    stmt = runIdentity <$> unprepared "select 1" (column (nonNullable int8)) mempty++test_retry :: UnitTest+test_retry =+  integrationTest do+    prog
+ integration/Polysemy/Hasql/Test/RunIntegration.hs view
@@ -0,0 +1,83 @@+module Polysemy.Hasql.Test.RunIntegration where++import Data.UUID (UUID)+import Hasql.Session (QueryError)+import Hedgehog (TestT)+import Log (Severity (Error))+import Polysemy.Db.Data.DbConfig (DbConfig)+import Polysemy.Db.Data.DbConnectionError (DbConnectionError)+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Db.Data.InitDbError (InitDbError)+import Polysemy.Db.Effect.Random (Random)+import Polysemy.Db.Interpreter.Random (interpretRandom)+import Time (GhcTime, interpretTimeGhc)+import Zeugma.Run (TestStack, runTestLevel)++import Polysemy.Hasql.Test.Database (TestConnectionEffects, withTestConnection)+import Polysemy.Hasql.Test.DbConfig (dbConfig)++type DbErrors =+  [+    Stop DbConnectionError,+    Stop DbError,+    Stop QueryError,+    Stop Text,+    Error InitDbError,+    Error DbError+  ]++type TestEffects =+  DbErrors ++ [+    GhcTime,+    Random UUID+  ] ++ TestStack++runIntegrationTestWith ::+  Members [Error Text, Embed IO] r =>+  HasCallStack =>+  (DbConfig -> Sem (DbErrors ++ r) ()) ->+  Sem r ()+runIntegrationTestWith run =+  withFrozenCallStack do+    dbConfig >>= \case+      Just conf ->+        mapError @DbError @Text show $+        mapError @InitDbError @Text show $+        stopToError @Text $+        mapStop @QueryError @Text show $+        mapStop @DbError @Text show $+        mapStop @DbConnectionError @Text show $+        run conf+      Nothing ->+        unit++integrationTestLevelWith ::+  HasCallStack =>+  Severity ->+  (DbConfig -> Sem TestEffects ()) ->+  TestT IO ()+integrationTestLevelWith level run =+  withFrozenCallStack $ runTestLevel level $ interpretRandom $ interpretTimeGhc $ runIntegrationTestWith run++integrationTestWith ::+  HasCallStack =>+  (DbConfig -> Sem TestEffects ()) ->+  TestT IO ()+integrationTestWith =+  integrationTestLevelWith Error++integrationTestLevel ::+  HasCallStack =>+  Severity ->+  Sem (TestConnectionEffects ++ TestEffects) () ->+  TestT IO ()+integrationTestLevel level thunk =+  withFrozenCallStack do+    integrationTestLevelWith level \ conf -> withTestConnection conf thunk++integrationTest ::+  HasCallStack =>+  Sem (TestConnectionEffects ++ TestEffects) () ->+  TestT IO ()+integrationTest =+  integrationTestLevel Error
+ integration/Polysemy/Hasql/Test/SimpleQueryTest.hs view
@@ -0,0 +1,73 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Polysemy.Hasql.Test.SimpleQueryTest where++import Lens.Micro.Extras (view)+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Query as Query+import Polysemy.Db.Effect.Query (Query (Query))+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (UnitTest, (===))+import Prelude hiding (sum)+import Sqel.Data.Dd (Dd, (:>) ((:>)))+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.PgType (tableSchema, toFullProjection)+import Sqel.Prim (prim, primAs, prims)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Statement (selectWhere)+import Sqel.Uid (uid)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database)+import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data Q =+  Q {+    name :: Text,+    number :: Int+  }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    name :: Text,+    number :: Int,+    count :: Int+  }+  deriving stock (Eq, Show, Generic)++td :: Dd _+td = uid prim (prod prims)++ts :: TableSchema (Uid Int Dat)+ts = tableSchema td++idSchema :: QuerySchema Int (Uid Int Dat)+idSchema =+  checkQuery (primAs @"id") td++interpretQuery ::+  Member (Database !! DbError) r =>+  InterpreterFor (Query Q [Uid Int Dat] !! DbError) r+interpretQuery =+  interpretResumable \case+    Query params ->+      restop (Database.statement params stm)+      where+        stm = selectWhere (checkQuery (prod (prim :> prim)) td) (toFullProjection ts)++test_simpleQuery :: UnitTest+test_simpleQuery =+  integrationTest do+    interpretTable ts $ interpretStoreDb ts idSchema $ interpretQuery do+      restop @DbError @(Query _ _) $ restop @DbError @(Store _ _) do+        for_ @[] [1..10] \ i ->+          Store.insert (Uid i (Dat "name" i 12))+        r <- fmap (view #id) <$> Query.query (Q "name" 5)+        [5] === r
+ integration/Polysemy/Hasql/Test/SumQueryTest.hs view
@@ -0,0 +1,77 @@+{-# options_ghc -Wno-partial-type-signatures -fconstraint-solver-iterations=10 #-}++module Polysemy.Hasql.Test.SumQueryTest where++import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Query as Query+import Polysemy.Db.Effect.Query (Query)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (UnitTest, (===))+import Prelude hiding (sum)+import Sqel.Data.Dd (Dd, DdK (DdK), Sqel, type (:>) ((:>)))+import Sqel.Data.Projection (Projection)+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.PgType (projection, tableSchema)+import Sqel.Prim (prim, primAs, prims)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Sum (con1, con1As, sum)+import Sqel.Uid (uid)++import Polysemy.Hasql.Interpreter.DbTable (interpretTable, interpretTableViewDd)+import Polysemy.Hasql.Interpreter.Query (interpretQuery)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data Dat =+  Dat {+    name :: Text,+    number :: Int64+  }+  deriving stock (Eq, Show, Generic)++data NaNu =+  Na { name :: Text }+  |+  Nu Int64+  deriving stock (Eq, Show, Generic)++td :: Sqel (Uid Int64 Dat) _+td = uid prim (prod prims)++ts :: TableSchema (Uid Int64 Dat)+ts = tableSchema td++vd :: Dd ('DdK _ _ Dat _)+vd = prod prims++vs :: Projection Dat (Uid Int64 Dat)+vs =+  projection vd td++idSchema :: QuerySchema Int64 (Uid Int64 Dat)+idSchema =+  checkQuery (primAs @"id") td++qd :: Dd ('DdK _ _ NaNu _)+qd = sum (con1 prim :> con1As @"number" prim)++test_sumQuery :: UnitTest+test_sumQuery =+  integrationTest do+    interpretTable ts $ interpretTableViewDd td vd $ interpretStoreDb ts idSchema $ interpretQuery @[_] vs (checkQuery qd td) do+      restop @DbError @(Query _ _) $ restop @DbError @(Store _ _) do+        Store.insert (Uid 1 d1)+        Store.insert (Uid 2 d2)+        Store.insert (Uid 3 d3)+        r1 <- Query.query (Na "x")+        [d1, d2] === r1+        r2 <- Query.query (Nu 10)+        [d2, d3] === r2+  where+    d1 = Dat "x" 5+    d2 = Dat "x" 10+    d3 = Dat "y" 10
+ integration/Polysemy/Hasql/Test/SumTest.hs view
@@ -0,0 +1,118 @@+{-# options_ghc -Wno-partial-type-signatures -fconstraint-solver-iterations=10 #-}++module Polysemy.Hasql.Test.SumTest where++import Hasql.Statement (Statement)+import Lens.Micro.Extras (view)+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Query as Query+import Polysemy.Db.Effect.Query (Query (Query))+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (UnitTest, (===))+import Prelude hiding (sum)+import Sqel.Data.Dd (Sqel, type (:>) ((:>)))+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.Names (typeAs)+import Sqel.PgType (fullProjection, tableSchema)+import Sqel.Prim (prim, primAs, prims)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Statement (selectWhere)+import Sqel.Sum (con, conAs, sum)+import Sqel.Uid (uid)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database)+import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data Pord =+  Pord {+    p1 :: Int,+    p2 :: Text+  }+  deriving stock (Eq, Show, Generic)++data Sumbo =+  Glorpf { g1 :: Int, g2 :: Text }+  |+  Vnarp { v1 :: Int, v2 :: Text }+  |+  Shwank { s1 :: Text, s2 :: Pord }+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    name :: Text,+    sumb :: Sumbo+  }+  deriving stock (Eq, Show, Generic)++data SumboQ =+  GlorpfQ { g1 :: Int }+  |+  ShwankQ { s1 :: Text }+  deriving stock (Eq, Show, Generic)++data Q =+  Q {+    n :: Text,+    sumb :: SumboQ+  }+  deriving stock (Eq, Show, Generic)++td :: Sqel (Uid Int64 Dat) _+td =+  uid prim (prod (+    prim :>+    typeAs @"sombo" (sum (+      con prims :>+      con prims :>+      con (prim :> prod prims)+    ))+  ))++ts :: TableSchema (Uid Int64 Dat)+ts = tableSchema td++idSchema :: QuerySchema Int64 (Uid Int64 Dat)+idSchema =+  checkQuery (primAs @"id") td++stm :: Statement Q [Uid Int64 Dat]+stm =+  selectWhere (checkQuery qd td) (fullProjection td)+  where+    qd =+      prod (+        primAs @"name" :>+        sum (+          conAs @"Glorpf" prim :>+          conAs @"Shwank" prim+        )+      )++interpretQuery ::+  Member (Database !! DbError) r =>+  InterpreterFor (Query Q [Uid Int64 Dat] !! DbError) r+interpretQuery =+  interpretResumable \case+    Query params ->+      restop (Database.statement params stm)++test_sum :: UnitTest+test_sum =+  integrationTest do+    interpretTable ts $ interpretStoreDb ts idSchema $ interpretQuery do+      restop @DbError @(Query _ _) $ restop @DbError @(Store _ _) do+        Store.insert (Uid 1 (Dat "ellow" (Glorpf 5 "crinp")))+        Store.insert (Uid 2 (Dat "ellow" (Glorpf 6 "crinp")))+        Store.insert (Uid 3 (Dat "cheerio" (Shwank "gzerq" (Pord 93 "pord"))))+        r1 <- fmap (view #id) <$> Query.query (Q "ellow" (GlorpfQ 5))+        [1] === r1+        r2 <- fmap (view #id) <$> Query.query (Q "cheerio" (ShwankQ "gzerq"))+        [3] === r2
+ integration/Polysemy/Hasql/Test/TransactionTest.hs view
@@ -0,0 +1,89 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Polysemy.Hasql.Test.TransactionTest where++import Exon (exon)+import Lens.Micro.Extras (view)+import qualified Log+import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (Hedgehog, UnitTest, assertEq, assertLeft)+import Sqel.Data.Dd (Dd, DdK (DdK))+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.PgType (tableSchema)+import Sqel.Prim (prim, primAs)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Uid (uid)++import Polysemy.Hasql.Effect.Transaction (Transactions, abort)+import Polysemy.Hasql.Interpreter.DbTable (interpretTables)+import Polysemy.Hasql.Interpreter.Store (interpretQStores)+import Polysemy.Hasql.Interpreter.Transaction (interpretTransactions)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)+import Polysemy.Hasql.Transaction (XaStore, transactStores)++data Dat =+  Dat {+    color :: Text+  }+  deriving stock (Eq, Show, Generic)++data Rat =+  Rat {+    color :: Text+  }+  deriving stock (Eq, Show, Generic)++ddDat :: Dd ('DdK _ _ (Uid Int64 Dat) _)+ddDat =+  uid prim (prod prim)++tableDat :: TableSchema (Uid Int64 Dat)+tableDat = tableSchema ddDat++queryDat :: QuerySchema Int64 (Uid Int64 Dat)+queryDat =+  checkQuery (primAs @"id") ddDat++tableRat :: TableSchema (Uid Int64 Rat)+queryRat :: QuerySchema Int64 (Uid Int64 Rat)+(tableRat, queryRat) =+  (tableSchema ddRat, checkQuery (primAs @"id") ddRat)+  where+    ddRat = uid prim (prod prim)++prog ::+  Members [XaStore conn DbError Int64 Dat, XaStore conn DbError Int64 Rat] r =>+  Members [Transactions conn !! DbError, Log, Stop DbError, Hedgehog IO] r =>+  Sem r ()+prog = do+  let xaError e = Log.error [exon|transaction failed: #{show e}|]+  resuming @_ @(Transactions _) xaError $ transactStores @['(_, Dat), '(_, Rat)] do+    Store.insert (Uid 2 (Dat "cyan"))+  e <- resumeEither @_ @(Transactions _) $ transactStores @['(_, Dat), '(_, Rat)] do+    Store.insert (Uid 2 (Rat "purple"))+    Store.insert (Uid 3 (Dat "pink"))+    abort+    unit+  resuming @_ @(Transactions _) xaError $ transactStores @['(_, Dat), '(_, Rat)] do+    Store.insert (Uid 3 (Rat "magenta"))+  assertLeft (DbError.Query "aborted by user") e++test_transaction :: UnitTest+test_transaction =+  integrationTest $+  interpretTables tableDat $+  interpretTables tableRat $+  interpretQStores tableDat queryDat $+  interpretQStores tableRat queryRat $+  interpretTransactions do+    restop @DbError @(Store _ Dat) (Store.insert (Uid 1 (Dat "gold")))+    restop @DbError @(Store _ Rat) (Store.insert (Uid 1 (Rat "green")))+    prog+    assertEq ["gold", "cyan"] . fmap (view (#payload . #color)) =<< restop @DbError @(Store _ Dat) Store.fetchAll+    assertEq ["green", "magenta"] . fmap (view (#payload . #color)) =<< restop @DbError @(Store _ Rat) Store.fetchAll
+ integration/Polysemy/Hasql/Test/TransformMigrationTest.hs view
@@ -0,0 +1,107 @@+{-# options_ghc -Wno-partial-type-signatures #-}++module Polysemy.Hasql.Test.TransformMigrationTest where++import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (UnitTest, assertEq)+import Sqel.Column (pk)+import Sqel.Data.Dd (Sqel, (:>) ((:>)))+import Sqel.Data.Migration (Mig (Mig), Migrations, migrate)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.Migration.Transform (MigrateTransform, migrateTransform)+import Sqel.Names (typeAs)+import Sqel.PgType (tableSchema)+import Sqel.Prim (enum, prim, primAs, prims)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Uid (uid)+import Zeugma (resumeTest)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Interpreter.DbTable (interpretTableMigrations, interpretTables)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Migration (MigrateSem)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data DatOld =+  DatOld {+    number :: Int,+    user :: Text,+    admin :: Bool+  }+  deriving stock (Eq, Show, Generic)++data Admin =+  Admin+  |+  NotAdmin+  deriving stock (Eq, Show, Generic)++adminBool :: Bool -> Admin+adminBool = \case+  True -> Admin+  False -> NotAdmin++data Meta =+  Meta {+    admin :: Admin,+    loggedIn :: Bool+  }+  deriving stock (Eq, Show, Generic)++data User =+  User {+    name :: Text,+    meta :: Meta+  }+  deriving stock (Eq, Show, Generic)++ddDatOld :: Sqel (Uid Int64 DatOld) _+ddDatOld =+  uid (pk prim) (typeAs @"User" (prod prims))++schemaOld :: TableSchema (Uid Int64 DatOld)+schemaOld =+  tableSchema ddDatOld++ddUser :: Sqel (Uid Int64 User) _+ddUser =+  uid (pk prim) (prod (prim :> prod (enum :> prim)))++schemaCur :: TableSchema (Uid Int64 User)+schemaCur =+  tableSchema ddUser++toUser :: DatOld -> User+toUser DatOld {..} =+  User {+    name = user,+    meta = Meta {admin = adminBool admin, loggedIn = False}+  }++migrations ::+  Migrations (MigrateSem r) ('[ 'Mig (Uid Int64 DatOld) (Uid Int64 User) (MigrateSem r) (MigrateTransform (MigrateSem r) (Uid Int64 DatOld) (Uid Int64 User))])+migrations =+  migrate (+    migrateTransform ddDatOld ddUser (pure . fmap (fmap toUser))+  )++target :: [Uid Int64 User]+target =+  [Uid 1 (User "user1" (Meta NotAdmin False)), Uid 2 (User "user2" (Meta Admin False))]++test_transformMigration :: UnitTest+test_transformMigration =+  integrationTest do+    interpretTables schemaOld $ interpretStoreDb schemaOld (checkQuery (primAs @"id") ddDatOld) $ resumeTest @DbError do+      Store.insert (Uid 1 (DatOld 1 "user1" False))+      Store.insert (Uid 2 (DatOld 2 "user2" True))+    resumeTest @DbError Database.release+    resumeTest @DbError Database.resetInit+    interpretTableMigrations schemaCur migrations $+      interpretStoreDb schemaCur (checkQuery (primAs @"id") ddUser) $+      restop @DbError @(Store _ _) do+        assertEq target =<< Store.fetchAll
+ integration/Polysemy/Hasql/Test/UnaryConTest.hs view
@@ -0,0 +1,110 @@+{-# options_ghc -Wno-partial-type-signatures -fconstraint-solver-iterations=10 #-}++module Polysemy.Hasql.Test.UnaryConTest where++import Generics.SOP (NP (Nil, (:*)))+import Hasql.Statement (Statement)+import Lens.Micro.Extras (view)+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Query as Query+import Polysemy.Db.Effect.Query (Query (Query))+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Test (UnitTest, (===))+import Prelude hiding (sum)+import Sqel.Data.Dd+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid (Uid))+import Sqel.PgType (tableSchema, toFullProjection)+import Sqel.Prim (prim, primAs)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Statement (selectWhere)+import Sqel.Sum (con1, sum)+import Sqel.Uid (uid)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database)+import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++data F2 =+  F2 {+    a2 :: Text,+    b2 :: Int+  }+  deriving stock (Eq, Show, Generic)++data S =+  S1 { f1 :: Text }+  |+  S2 F2+  deriving stock (Eq, Show, Generic)++data Dat =+  Dat {+    name :: Text,+    s :: S+  }+  deriving stock (Eq, Show, Generic)++data Q =+  Q {+    name :: Text,+    s :: S+  }+  deriving stock (Eq, Show, Generic)++t1C :: Dd ('DdK _ _ (Uid Int64 Dat) _)+t1C =+  uid prim (prod (+    prim :*+    sum (+      con1 prim :*+      con1 (prod (primAs @"desc" :* prim :* Nil)) :* Nil+    ) :*+    Nil+  ))++q :: Dd ('DdK _ _ Q _)+q =+  prod (+    primAs @"name" :*+    sum (+      con1 prim :*+      con1 (prod (primAs @"desc" :* prim :* Nil)) :* Nil+    ) :*+    Nil+  )++t1d :: TableSchema (Uid Int64 Dat)+t1d =+  tableSchema t1C++checkedQ :: QuerySchema Q (Uid Int64 Dat)+checkedQ =+  checkQuery q t1C++checkedQStm :: Statement Q [Uid Int64 Dat]+checkedQStm =+  selectWhere checkedQ (toFullProjection t1d)++interpretQuery ::+  Member (Database !! DbError) r =>+  InterpreterFor (Query Q [Uid Int64 Dat] !! DbError) r+interpretQuery =+  interpretResumable \case+    Query params ->+      restop (Database.statement params checkedQStm)++test_unaryCon :: UnitTest+test_unaryCon =+  integrationTest do+    interpretTable t1d $ interpretStoreDb t1d (checkQuery (primAs @"id") t1C) $ interpretQuery do+      restop @DbError @(Query _ _) $ restop @DbError @(Store _ _) do+        Store.insert (Uid 1 (Dat "ellow" (S1 "crinp")))+        Store.insert (Uid 2 (Dat "cheerio" (S2 (F2 "pord" 93))))+        r <- fmap (view #id) <$> Query.query (Q "ellow" (S1 "crinp"))+        [1] === r
+ integration/Polysemy/Hasql/Test/WithInitTest.hs view
@@ -0,0 +1,32 @@+module Polysemy.Hasql.Test.WithInitTest where++import Conc (interpretAtomic)+import Hasql.Decoders (column, int8, nonNullable)+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Test (Hedgehog, UnitTest, assertEq)+import Sqel.Statement (unprepared)++import Polysemy.Hasql.Data.InitDb (InitDb (InitDb))+import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database)+import Polysemy.Hasql.Test.RunIntegration (integrationTest)++prog ::+  Members [Hedgehog IO, Database, AtomicState Int] r =>+  Sem r Int+prog = do+  assertEq 1 =<< run+  Database.release+  assertEq 1 =<< run+  assertEq 1 =<< run+  pure ()+  atomicGet+  where+    run = Database.withInit initDb (Database.statement () stmt)+    stmt = runIdentity <$> unprepared "select 1" (column (nonNullable int8)) mempty+    initDb = (InitDb "test" False \ _ -> atomicModify' (1 +))++test_withInit :: UnitTest+test_withInit = do+  integrationTest do+    assertEq 2 =<< restop @DbError @Database (interpretAtomic 0 prog)
+ lib/Polysemy/Hasql.hs view
@@ -0,0 +1,80 @@+module Polysemy.Hasql (+  -- * Introduction+  -- $intro++  -- * Hasql interpreters for [Polysemy.Db]("Polysemy.Db")+  interpretQStoreDb,+  interpretQStoreXa,+  interpretQStores,+  interpretStoreDb,+  interpretStoreXa,+  interpretStores,++  interpretQuery,+  interpretQueryDd,++  -- * Database effects+  DbConnectionPool,+  Database,+  Databases,+  DbTable,+  StoreTable,+  Transaction,+  Transactions,+  abort,++  -- * Database interpeters+  interpretDbConnectionPool,+  interpretDbConnectionPoolSingle,++  interpretDatabase,+  interpretDatabases,+  interpretHasql,++  interpretTablesMigrations,+  interpretTableMigrations,+  interpretTableMigrationsScoped,+  interpretTables,+  interpretTable,+  interpretTableView,+  interpretTableViewDd,++  -- * Misc combinators+  queryVia,+  mapQuery,++  -- * Misc+  interpretAtomicStateDb,+  interpretAtomicStatesDb,+  interpretReaderDb,+) where++import Polysemy.Hasql.Effect.Database (Database, Databases)+import Polysemy.Hasql.Effect.DbConnectionPool (DbConnectionPool)+import Polysemy.Hasql.Effect.DbTable (DbTable, StoreTable)+import Polysemy.Hasql.Effect.Transaction (Transaction, Transactions, abort)+import Polysemy.Hasql.Interpreter.AtomicState (interpretAtomicStateDb, interpretAtomicStatesDb)+import Polysemy.Hasql.Interpreter.Database (interpretDatabase, interpretDatabases, interpretHasql)+import Polysemy.Hasql.Interpreter.DbConnectionPool (interpretDbConnectionPool, interpretDbConnectionPoolSingle)+import Polysemy.Hasql.Interpreter.DbTable (+  interpretTable,+  interpretTableMigrations,+  interpretTableMigrationsScoped,+  interpretTableView,+  interpretTableViewDd,+  interpretTables,+  interpretTablesMigrations,+  )+import Polysemy.Hasql.Interpreter.Query (interpretQuery, interpretQueryDd, mapQuery, queryVia)+import Polysemy.Hasql.Interpreter.Reader (interpretReaderDb)+import Polysemy.Hasql.Interpreter.Store (+  interpretQStoreDb,+  interpretQStoreXa,+  interpretQStores,+  interpretStoreDb,+  interpretStoreXa,+  interpretStores,+  )++-- $intro+-- This library provides Hasql-specific interpreters for the effects in [Polysemy.Db]("Polysemy.Db")
+ lib/Polysemy/Hasql/Data/ConnectionState.hs view
@@ -0,0 +1,25 @@+module Polysemy.Hasql.Data.ConnectionState where++import Control.Concurrent (ThreadId)+import Hasql.Connection (Connection)++import Polysemy.Hasql.Data.InitDb (ClientTag)++data ConnectionState =+  ConnectionState {+    count :: Int,+    connection :: Maybe Connection,+    activeCommands :: Map ThreadId Int+  }+  deriving stock (Generic)++instance Default ConnectionState where+  def =+    ConnectionState 0 Nothing mempty++data ConnectionsState =+  ConnectionsState {+    counter :: Integer,+    clientInits :: Map ClientTag Int+  }+  deriving stock (Eq, Show, Generic)
+ lib/Polysemy/Hasql/Data/ConnectionTag.hs view
@@ -0,0 +1,23 @@+module Polysemy.Hasql.Data.ConnectionTag where++import Exon (ToSegment (toSegment))++data ConnectionTag =+  GlobalTag+  |+  NamedTag Text+  |+  SerialTag Integer+  deriving stock (Eq, Show, Ord, Generic)++instance IsString ConnectionTag where+  fromString =+    NamedTag . fromString++instance (+    IsString a+  ) => ToSegment ConnectionTag a where+    toSegment = \case+      GlobalTag -> "global"+      NamedTag n -> fromText n+      SerialTag n -> show n
+ lib/Polysemy/Hasql/Data/InitDb.hs view
@@ -0,0 +1,28 @@+module Polysemy.Hasql.Data.InitDb where++import Hasql.Connection (Connection)++newtype ClientTag =+  ClientTag { unInitTag :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)++data InitDb m =+  InitDb {+    tag :: ClientTag,+    once :: Bool,+    thunk :: Connection -> m ()+  }+  deriving stock (Generic)++instance Applicative m => Default (InitDb m) where+  def =+    InitDb "global" True (const unit)++hoistInitDb :: (m () -> n ()) -> InitDb m -> InitDb n+hoistInitDb f (InitDb t o th) =+  InitDb t o (f . th)++raiseInitDb :: InitDb (Sem r) -> InitDb (Sem (e : r))+raiseInitDb =+  hoistInitDb raise
+ lib/Polysemy/Hasql/Data/QueueOutputError.hs view
@@ -0,0 +1,9 @@+module Polysemy.Hasql.Data.QueueOutputError where++import Polysemy.Db.Data.DbError (DbError)++data QueueOutputError =+  Insert DbError+  |+  Notify DbError+  deriving stock (Eq, Show)
+ lib/Polysemy/Hasql/Database.hs view
@@ -0,0 +1,83 @@+module Polysemy.Hasql.Database where++import Hasql.Decoders (Row)+import Hasql.Encoders (Params)+import Time (Seconds (Seconds))+import Sqel.Data.Codec (Encoder, FullCodec)+import Sqel.Data.Dd (Dd, DdType)+import Sqel.Data.QuerySchema (QuerySchema (QuerySchema))+import Sqel.Data.Sql (Sql)+import Sqel.Data.TableSchema (TableSchema (TableSchema))+import Sqel.PgType (tableSchema)+import Sqel.Query (CheckedQuery, checkQuery)+import Sqel.ReifyCodec (ReifyCodec)+import Sqel.ReifyDd (ReifyDd)+import Sqel.ResultShape (ResultShape)+import Sqel.Statement (plain, prepared, unprepared)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database (..))++retryingSql ::+  TimeUnit t =>+  Member Database r =>+  t ->+  Sql ->+  Sem r ()+retryingSql interval =+  Database.retry interval Nothing . Database.statement () . plain++retryingSqlDef ::+  Member Database r =>+  Sql ->+  Sem r ()+retryingSqlDef =+  retryingSql (Seconds 3)++retryingQuerySql ::+  TimeUnit t =>+  ResultShape d result =>+  Members [Database !! e, Stop e] r =>+  t ->+  Sql ->+  Row d ->+  Params param ->+  param ->+  Sem r result+retryingQuerySql interval s row params q =+  restop (Database.retry interval Nothing (Database.statement q (prepared s row params)))++retryingQuerySqlDef ::+  ∀ e d param result r .+  ResultShape d result =>+  Members [Database !! e, Stop e] r =>+  Sql ->+  Row d ->+  Params param ->+  param ->+  Sem r result+retryingQuerySqlDef =+  retryingQuerySql (Seconds 3)++-- TODO check projection+query ::+  ∀ res query proj table r .+  Member Database r =>+  CheckedQuery query table =>+  ReifyCodec Encoder query (DdType query) =>+  ReifyDd proj =>+  ReifyCodec FullCodec proj (DdType proj) =>+  ResultShape (DdType proj) res =>+  Dd query ->+  Dd proj ->+  Dd table ->+  DdType query ->+  Sql ->+  Sem r res+query queryDd projDd tableDd q s =+  Database.statement q (unprepared s decoder (encoder ^. #encodeValue))+  where+    QuerySchema _ encoder =+      checkQuery queryDd tableDd+    TableSchema _ decoder _ =+      tableSchema projDd
+ lib/Polysemy/Hasql/Effect/Database.hs view
@@ -0,0 +1,79 @@+module Polysemy.Hasql.Effect.Database where++import Hasql.Connection (Connection)+import qualified Hasql.Session as Session+import Hasql.Session (Session)+import Hasql.Statement (Statement)+import Polysemy.Db.Data.DbError (DbError)+import Prelude hiding (tag)++import Polysemy.Hasql.Data.ConnectionTag (ConnectionTag)+import Polysemy.Hasql.Data.InitDb (InitDb)++data ConnectionSource =+  Global+  |+  Unique (Maybe ConnectionTag)+  |+  Supplied ConnectionTag Connection++-- |This effect provides the capability to execute 'Statement's.+-- Additionally, it exposes managed access to the raw 'Connection' resource and automatic table initialization as+-- higher-order actions.+--+-- With the minimal stack, an SQL query can be executed in two fashions.+-- One is to use automatically derived codecs:+--+-- @+-- prog :: Member Database r => Sem r ()+-- prog = do+--   user :: Maybe User <- Database.sql () "select * from users where id = 1"+--   user :: [User] <- Database.sql ("guest", True) "select * from users where name = $1 and locked = $2"+-- @+--+-- The other works by providing an explicit 'Statement':+--+-- @+-- statement :: Statement Text User+-- statement = ...+--+-- prog :: Member Database r => Sem r ()+-- prog = do+--   user <- Database.runStatement "guest" statement+-- @+--+-- For documentation on the individual constructors, see the module page.+data Database :: Effect where+  Tag :: Database m ConnectionTag+  Release :: Database m ()+  Retry :: TimeUnit t => t -> Maybe Int -> m a -> Database m a+  WithInit :: InitDb m -> m a -> Database m a+  Use :: (Connection -> m a) -> Database m a+  Session :: Session a -> Database m a+  ResetInit :: Database m ()++makeSem ''Database++type Databases =+  Scoped ConnectionSource (Database !! DbError)++withDatabaseUnique ::+  Member Databases r =>+  Maybe ConnectionTag ->+  InterpreterFor (Database !! DbError) r+withDatabaseUnique t =+  scoped (Unique t)++withDatabaseGlobal ::+  Member Databases r =>+  InterpreterFor (Database !! DbError) r+withDatabaseGlobal =+  scoped Global++statement ::+  Member Database r =>+  p ->+  Statement p o ->+  Sem r o+statement p s =+  session (Session.statement p s)
+ lib/Polysemy/Hasql/Effect/DbConnectionPool.hs view
@@ -0,0 +1,17 @@+module Polysemy.Hasql.Effect.DbConnectionPool where++import Hasql.Connection (Connection)+import Polysemy.Db.Data.DbConfig (DbConfig)++import Polysemy.Hasql.Data.ConnectionTag (ConnectionTag)++data DbConnectionPool :: Effect where+  Acquire :: ConnectionTag -> DbConnectionPool m Connection+  Free :: ConnectionTag -> DbConnectionPool m ()+  Release :: ConnectionTag -> DbConnectionPool m ()+  Use :: ConnectionTag -> m a -> DbConnectionPool m a+  Kill :: ConnectionTag -> DbConnectionPool m ()+  UnsafeGet :: ConnectionTag -> DbConnectionPool m (Maybe Connection)+  Config :: DbConnectionPool m DbConfig++makeSem ''DbConnectionPool
+ lib/Polysemy/Hasql/Effect/DbTable.hs view
@@ -0,0 +1,13 @@+module Polysemy.Hasql.Effect.DbTable where++import Hasql.Statement (Statement)+import Sqel.Data.Uid (Uid)++type DbTable :: Type -> Effect+data DbTable a :: Effect where+  Statement :: p -> Statement p o -> DbTable a m o++makeSem ''DbTable++type StoreTable i a =+  DbTable (Uid i a)
+ lib/Polysemy/Hasql/Effect/Transaction.hs view
@@ -0,0 +1,11 @@+module Polysemy.Hasql.Effect.Transaction where++type Transaction :: Type -> Effect+data Transaction res :: Effect where+  Resource :: Transaction res m res+  Abort :: Transaction res m a++makeSem ''Transaction++type Transactions res =+  Scoped_ (Transaction res)
+ lib/Polysemy/Hasql/Interpreter/AtomicState.hs view
@@ -0,0 +1,39 @@+module Polysemy.Hasql.Interpreter.AtomicState where++import Conc (interpretLockReentrant)+import Hasql.Connection (Connection)+import Polysemy.Db.Data.InitDbError (InitDbError)+import Polysemy.Db.Interpreter.AtomicState (interpretAtomicStateStore, interpretAtomicStatesStore)+import Sqel.Data.QuerySchema (emptyQuerySchema)+import Sqel.Data.TableSchema (TableSchema)++import Polysemy.Hasql.Effect.Database (ConnectionSource)+import Polysemy.Hasql.Effect.DbTable (DbTable)+import Polysemy.Hasql.Interpreter.Store (interpretQStoreDb, interpretQStores)++-- |Interpret 'AtomicState' as a singleton table.+--+-- Given an action that produces an initial value, every state action reads the value from the database and writes it+-- back.+interpretAtomicStateDb ::+  Members [DbTable d !! e, Error InitDbError, Mask, Resource, Race, Embed IO] r =>+  TableSchema d ->+  Sem r d ->+  InterpreterFor (AtomicState d !! e) r+interpretAtomicStateDb table initial =+  interpretLockReentrant . untag .+  interpretQStoreDb @Maybe table emptyQuerySchema .+  interpretAtomicStateStore (insertAt @0 initial) .+  insertAt @1++interpretAtomicStatesDb ::+  Members [Error InitDbError, Mask, Resource, Race, Embed IO] r =>+  Members [Scoped ConnectionSource (DbTable d !! err), DbTable d !! err, Log, Embed IO] r =>+  TableSchema d ->+  Sem r d ->+  InterpretersFor [AtomicState d !! err, Scoped Connection (AtomicState d !! err) !! err] r+interpretAtomicStatesDb table initial =+  interpretLockReentrant . untag .+  interpretQStores @Maybe table emptyQuerySchema .+  interpretAtomicStatesStore (insertAt @0 initial) .+  insertAt @2
+ lib/Polysemy/Hasql/Interpreter/Database.hs view
@@ -0,0 +1,295 @@+module Polysemy.Hasql.Interpreter.Database where++import Conc (Lock, interpretAtomic, interpretLockReentrant, lock)+import qualified Database.PostgreSQL.LibPQ as LibPQ+import Exon (exon)+import Hasql.Connection (Connection, withLibPQConnection)+import qualified Log+import Polysemy.Db.Data.DbConfig (DbConfig)+import Polysemy.Db.Data.DbConnectionError (DbConnectionError)+import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)+import qualified Time+import Time (NanoSeconds (NanoSeconds))++import qualified Polysemy.Hasql.Data.ConnectionState as ConnectionState+import Polysemy.Hasql.Data.ConnectionState (ConnectionState (ConnectionState), ConnectionsState (ConnectionsState))+import Polysemy.Hasql.Data.ConnectionTag (ConnectionTag (GlobalTag, SerialTag))+import Polysemy.Hasql.Data.InitDb (InitDb (InitDb), hoistInitDb)+import Polysemy.Hasql.Effect.Database (+  ConnectionSource (Global, Supplied, Unique),+  Database (Release, ResetInit, Retry, Session, Tag, Use, WithInit),+  withDatabaseGlobal,+  )+import qualified Polysemy.Hasql.Effect.DbConnectionPool as DbConnectionPool+import Polysemy.Hasql.Effect.DbConnectionPool (DbConnectionPool)+import Polysemy.Hasql.Interpreter.DbConnectionPool (interpretDbConnectionPool)+import Polysemy.Hasql.Session (runSession)++genTag ::+  Member (AtomicState ConnectionsState) r =>+  Sem r ConnectionTag+genTag =+  SerialTag <$> atomicState' \ ConnectionsState {..} ->+    let new = counter + 1+    in (ConnectionsState {counter = new, ..}, new)++tagForSource ::+  Member (AtomicState ConnectionsState) r =>+  ConnectionSource ->+  Sem r (Either Connection ConnectionTag)+tagForSource = \case+  Global -> pure (Right GlobalTag)+  Unique t -> Right <$> fromMaybeA genTag t+  Supplied _ c -> pure (Left c)++needsInit ::+  Member (AtomicState ConnectionsState) r =>+  InitDb m ->+  Int ->+  Sem r Bool+needsInit (InitDb clientId once _) count =+  atomicView (#clientInits . at clientId) <&> \case+    Just lastConnection ->+      not once && lastConnection < count+    Nothing ->+      True++runInit ::+  Members [AtomicState ConnectionsState, Log, Embed IO] r =>+  InitDb (Sem r) ->+  Int ->+  Connection ->+  Sem r ()+runInit (InitDb clientId _ initDb) count connection = do+  Log.trace [exon|Running init for '##{clientId}'|]+  initDb connection+  atomicModify' (#clientInits . at clientId ?~ count)++acquireConnection ::+  Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionState, Stop DbError, Lock] r =>+  ConnectionTag ->+  Sem r (Int, Connection)+acquireConnection ctag =+  lock do+    atomicGet >>= \case+      ConnectionState count Nothing tids -> do+        conn <- resumeHoist DbError.Connection (DbConnectionPool.acquire ctag)+        atomicPut (ConnectionState (count + 1) (Just conn) tids)+        pure (count + 1, conn)+      ConnectionState count (Just conn) _ ->+        pure (count, conn)++releaseConnection ::+  Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionState, Log] r =>+  ConnectionTag ->+  Sem r ()+releaseConnection ctag = do+  atomicModify' (#connection .~ Nothing)+  DbConnectionPool.release ctag !! \ e ->+    Log.error [exon|Releasing connection failed: #{show e}|]++-- | After a computation failed, the Postgres connection needs to be health-checked.+-- If the status is 'LibPQ.ConnectionBad', remove the connection from the state and release it, causing the next call to+-- 'acquireConnection' to request a new one.+--+-- It is conceivable for the connection to be stuck in a startup phase like 'LibPQ.ConnectionSSLStartup', but since+-- hasql only uses a connection that is fully established, it shouldn't happen.+--+-- TODO Can't hurt to investigate this anyway.+releaseBadConnection ::+  Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionState, Stop DbError, Log, Lock, Embed IO] r =>+  ConnectionTag ->+  Connection ->+  Sem r ()+releaseBadConnection ctag conn =+  tryIOError (withLibPQConnection conn LibPQ.status) >>= \case+    Right LibPQ.ConnectionBad -> do+      Log.debug [exon|Releasing bad connection ##{ctag}|]+      releaseConnection ctag+    Left err ->+      Log.error [exon|Releasing bad connection failed: #{err}|]+    _ ->+      unit++bracketConnection ::+  Member Resource r =>+  Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionState, Stop DbError, Log, Lock, Embed IO] r =>+  ConnectionTag ->+  (Int -> Connection -> Sem r a) ->+  Sem r a+bracketConnection ctag use =+  resumeHoist DbError.Connection $ DbConnectionPool.use ctag $+  bracketOnError (acquireConnection ctag) onError (raise . uncurry use)+  where+    onError (_, conn) = releaseBadConnection ctag conn++withInit ::+  Members [AtomicState ConnectionsState, Stop DbError, Log, Embed IO] r =>+  Int ->+  Connection ->+  InitDb (Sem r) ->+  Sem r a ->+  Sem r a+withInit count connection initDb main = do+  whenM (needsInit initDb count) do+    runInit initDb count connection+  main++withInitManaged ::+  Members [AtomicState ConnectionState, AtomicState ConnectionsState, DbConnectionPool !! DbConnectionError] r =>+  Members [Stop DbError, Lock, Resource, Log, Embed IO] r =>+  ConnectionTag ->+  InitDb (Sem r) ->+  (Connection -> Sem r a) ->+  Sem r a+withInitManaged ctag initDb use = do+  bracketConnection ctag \ count connection -> do+    Log.trace [exon|Client '##{clientTag}' uses database connection '##{ctag}'|]+    withInit count connection initDb (use connection)+  where+    clientTag = initDb ^. #tag++retrying ::+  Members [DbConnectionPool !! DbConnectionError, Time t d, Stop DbError, Resource, Embed IO] r =>+  (Int, NanoSeconds) ->+  Sem (Stop DbError : r) a ->+  Sem r a+retrying (total, interval) action =+  spin total+  where+    spin 0 = subsume action+    spin count =+      runStop action >>= leftA \case+        DbError.Connection _ -> do+          Time.sleep interval+          spin (count - 1)+        e ->+          stop e++managedConnection ::+  ∀ r m t d a .+  Members [AtomicState ConnectionsState, AtomicState ConnectionState, DbConnectionPool !! DbConnectionError] r =>+  Members [Time t d, Resource, Lock, Log, Embed IO] r =>+  ConnectionTag ->+  InitDb (Sem r) ->+  Maybe (Int, NanoSeconds) ->+  Database m a ->+  Tactical (Database !! DbError) m (Stop DbError : r) a+managedConnection ctag initDb retryMay = \case+  WithInit (InitDb t o new) ma -> do+    s <- getInitialStateT+    newT <- bindT new+    let new' c = void (interpretResumableH (managedConnection ctag def Nothing) (newT (c <$ s)))+    raise . interpretResumableH (managedConnection ctag (InitDb t o new') retryMay) =<< runT ma+  Session ma -> do+    result <- retrying retry $ withInitManaged ctag (hoistInitDb (insertAt @0) initDb) \ connection ->+      runSession connection ma+    pureT result+  Use use ->+    withInitManaged ctag (hoistInitDb (insertAt @0) initDb) \ connection ->+      runTSimple (use connection)+  Release ->+    pureT =<< releaseConnection ctag+  Retry interval count ma -> do+    let r = Just (fromMaybe 0 count, Time.convert interval)+    raise . interpretResumableH (managedConnection ctag (hoistInitDb raise initDb) r) =<< runT ma+  Tag ->+    pureT ctag+  ResetInit ->+    pureT =<< atomicModify' @ConnectionsState (#clientInits .~ mempty)+  where+    retry = fromMaybe (0, NanoSeconds 0) retryMay++unmanagedConnection ::+  ∀ r m a .+  Members [AtomicState ConnectionsState, AtomicState ConnectionState, DbConnectionPool !! DbConnectionError] r =>+  Members [Resource, Lock, Log, Embed IO, Final IO] r =>+  Connection ->+  InitDb (Sem r) ->+  Database m a ->+  Tactical (Database !! DbError) m (Stop DbError : r) a+unmanagedConnection connection initDb = \case+  WithInit (InitDb t o new) ma -> do+    s <- getInitialStateT+    newT <- bindT new+    let new' c = void (interpretResumableH (unmanagedConnection connection def) (newT (c <$ s)))+    raise . interpretResumableH (unmanagedConnection connection (InitDb t o new')) =<< runT ma+  Session ma ->+    withInit 0 connection (hoistInitDb (insertAt @0) initDb) do+      pureT =<< runSession connection ma+  Use use ->+    withInit 0 connection (hoistInitDb (insertAt @0) initDb) do+      runTSimple (use connection)+  Release ->+    unitT+  -- TODO+  Retry _ _ ma ->+    runTSimple ma+  Tag ->+    pureT "unmanaged"+  -- TODO+  ResetInit ->+    unitT++handleDatabase ::+  ∀ r m a t d .+  Members [AtomicState ConnectionsState, AtomicState ConnectionState, DbConnectionPool !! DbConnectionError] r =>+  Members [Time t d, Resource, Lock, Log, Embed IO, Final IO] r =>+  Either Connection ConnectionTag ->+  Database m a ->+  Tactical (Database !! DbError) m (Stop DbError : r) a+handleDatabase = \case+  Right t -> managedConnection t def Nothing+  Left c -> unmanagedConnection c def++type DatabaseScope =+  [+    AtomicState ConnectionState,+    Lock+  ]++databaseScope ::+  Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionsState, Resource, Mask, Race, Embed IO] r =>+  (Either Connection ConnectionTag -> Sem (DatabaseScope ++ r) a) ->+  ConnectionSource ->+  Sem r a+databaseScope use source =+  interpretLockReentrant $ interpretAtomic def do+    ctag <- tagForSource source+    finally (use ctag) (traverse_ (resume_ . DbConnectionPool.free) ctag)++interpretDatabases ::+  ∀ t d r .+  Members [DbConnectionPool !! DbConnectionError, AtomicState ConnectionsState] r =>+  Members [Time t d, Log, Resource, Mask, Race, Embed IO, Final IO] r =>+  InterpreterFor (Scoped ConnectionSource (Database !! DbError)) r+interpretDatabases =+  interpretResumableScopedWithH @DatabaseScope (flip databaseScope) handleDatabase++interpretDatabase ::+  ∀ t d r .+  Members [DbConnectionPool !! DbConnectionError, Time t d, Resource, Log, Mask, Race, Embed IO, Final IO] r =>+  InterpretersFor [Database !! DbError, Scoped ConnectionSource (Database !! DbError)] r+interpretDatabase =+  interpretAtomic (ConnectionsState 0 mempty) .+  interpretDatabases .+  raiseUnder .+  withDatabaseGlobal++type HasqlStack =+  [+    Database !! DbError,+    Scoped ConnectionSource (Database !! DbError),+    DbConnectionPool !! DbConnectionError+  ]++interpretHasql ::+  Members [Time t d, Log, Mask, Resource, Race, Embed IO, Final IO] r =>+  DbConfig ->+  Maybe Int ->+  Maybe Int ->+  InterpretersFor HasqlStack r+interpretHasql dbConfig maxActive maxAvailable =+  interpretDbConnectionPool dbConfig maxActive maxAvailable .+  interpretDatabase
+ lib/Polysemy/Hasql/Interpreter/DbConnectionPool.hs view
@@ -0,0 +1,274 @@+module Polysemy.Hasql.Interpreter.DbConnectionPool where++import Conc (interpretAtomic)+import Control.Concurrent (ThreadId, myThreadId, throwTo)+import qualified Data.Map.Strict as Map+import Data.Map.Strict ((!?))+import qualified Data.Sequence as Seq+import Data.Sequence (Seq ((:<|)), (<|))+import Exon (exon)+import qualified Hasql.Connection as Connection+import Hasql.Connection (Connection)+import Lens.Micro.Extras (view)+import qualified Log+import Polysemy.Db.Data.DbConfig (DbConfig (DbConfig))+import qualified Polysemy.Db.Data.DbConnectionError as DbConnectionError+import Polysemy.Db.Data.DbConnectionError (DbConnectionError)+import Polysemy.Db.Data.DbHost (DbHost (DbHost))+import Polysemy.Db.Data.DbName (DbName (DbName))+import Polysemy.Db.Data.DbPassword (DbPassword (DbPassword))+import Polysemy.Db.Data.DbUser (DbUser (DbUser))+import qualified Text.Show as Show++import Polysemy.Hasql.Data.ConnectionTag (ConnectionTag)+import Polysemy.Hasql.Effect.DbConnectionPool (DbConnectionPool (Acquire, Config, Free, Kill, Release, UnsafeGet, Use))++data KillCommand =+  KillCommand+  deriving stock (Show)+  deriving anyclass (Exception)++newtype PoolConn =+  PoolConn { unPoolConn :: Connection }+  deriving stock (Generic)++instance Show PoolConn where+  show _ = "PoolConn"++data ConnectionClients =+  ConnectionClients {+    connection :: PoolConn,+    clients :: Map ThreadId Int+  }+  deriving stock (Show, Generic)++data Pools =+  Pools {+    maxActive :: Maybe Int,+    maxAvailable :: Maybe Int,+    active :: Map ConnectionTag ConnectionClients,+    available :: Seq PoolConn+  }+  deriving stock (Show, Generic)++connectionSettings ::+  DbConfig ->+  Connection.Settings+connectionSettings (DbConfig (DbHost host) port (DbName dbName) (DbUser user) (DbPassword password)) =+  Connection.settings (encodeUtf8 host) (fromIntegral port) (encodeUtf8 user) (encodeUtf8 password) (encodeUtf8 dbName)++dbError :: Maybe ByteString -> DbConnectionError+dbError err =+  DbConnectionError.Acquire (maybe "unspecified error" decodeUtf8 err)++withActive ::+  Member (AtomicState Pools) r =>+  (Int -> Map ConnectionTag ConnectionClients -> Sem r a) ->+  Sem r (Maybe a)+withActive f =+  atomicGet >>= \case+    Pools {maxActive = Just ma, ..} ->+      Just <$> f ma active+    _ ->+      pure Nothing++acquireNative ::+  Members [Stop DbConnectionError, Embed IO] r =>+  DbConfig ->+  Sem r Connection+acquireNative dbConfig = do+  conn <- stopTryIOError DbConnectionError.Acquire (Connection.acquire (connectionSettings dbConfig))+  stopEither (first dbError conn)++acquire ::+  Members [AtomicState Pools, Stop DbConnectionError, Embed IO] r =>+  DbConfig ->+  ConnectionTag ->+  Sem r Connection+acquire dbConfig ctag = do+  void $ withActive \ m act ->+    when (Map.size act >= m) (stop (DbConnectionError.Limit [exon|Too many active connections: #{show m}|]))+  conn <- acquireNative dbConfig+  conn <$ atomicModify' (#active . at ctag ?~ ConnectionClients (PoolConn conn) mempty)++reuseOrAcquire ::+  Members [AtomicState Pools, Stop DbConnectionError, Log, Embed IO] r =>+  DbConfig ->+  ConnectionTag ->+  Sem r Connection+reuseOrAcquire dbConfig ctag = do+  reuse <- atomicState' \ pools@Pools {..} ->+    case active !? ctag of+      Just (ConnectionClients (PoolConn conn) _) ->+        (pools, Just conn)+      Nothing ->+        case available of+          PoolConn conn :<| rest ->+            (pools {available = rest}, Just conn)+          _ ->+            (pools, Nothing)+  when (isJust reuse) do+    Log.trace [exon|Reusing connection for '##{ctag}'|]+  fromMaybeA (acquire dbConfig ctag) reuse++releaseNative ::+  Members [Stop DbConnectionError, Embed IO] r =>+  Connection ->+  Sem r ()+releaseNative connection =+  stopTryIOError DbConnectionError.Release (Connection.release connection)++release ::+  Members [AtomicState Pools, Stop DbConnectionError, Embed IO] r =>+  ConnectionTag ->+  Sem r ()+release ctag = do+  conn <- atomicState' \ Pools {..} -> (Pools {active = Map.delete ctag active, ..}, active !? ctag)+  traverse_ (releaseNative . coerce . connection) conn++-- | Remove the connection used by @ctag@ from the active pool if it exists.+-- Store it for reuse if @maxAvailable@ is @Nothing@ or larger than the currently stored number, otherwise return the+-- connection for release.+removeActive :: ConnectionTag -> Pools -> (Pools, Maybe Connection)+removeActive ctag Pools {..} =+  (Pools {active = newActive, available = newAvailable, ..}, coerce toRelease)+  where+    -- Chooses the functor @(Maybe Connection, -)@ for @alterF@, thereby returning the potentially existing element.+    -- The @Nothing@ causes the element to be deleted if it exists.+    (conn, newActive) = Map.alterF (,Nothing) ctag active++    (toRelease, newAvailable) = case conn of+      Just (ConnectionClients c _)+        | keep -> (Nothing, c <| available)+        | otherwise -> (Just c, available)+      Nothing -> (Nothing, available)++    keep = case maxAvailable of+      Nothing -> True+      Just m -> Seq.length available < m++catchingKill ::+  Members [Stop DbConnectionError, Final IO] r =>+  Sem r a ->+  Sem r a+catchingKill =+  stopOnError . mapError exception . fromExceptionSem . raiseUnder . raise+  where+    exception KillCommand =+      DbConnectionError.Query "command was interrupted by DbConnectionPool.Kill"++-- Incrementing the tid must not be masked or it might not be cleaned up.+withRegisteredClient ::+  Members [AtomicState Pools, Stop DbConnectionError, Resource, Embed IO, Final IO] r =>+  ConnectionTag ->+  Sem r a ->+  Sem r a+withRegisteredClient ctag main = do+  tid <- embed myThreadId+  finally+    do+      catchingKill do+        change tid increment+        main+    do+      change tid decrement+  where+    change tid f =+      atomicModify' (#active . at ctag %~ fmap (#clients %~ Map.alter f tid))+    increment = \case+      Just n -> Just (n + 1)+      Nothing -> Just 1+    decrement = \case+      Just 1 -> Nothing+      Just n -> Just (n - 1)+      Nothing -> Nothing++releaseAll ::+  Members [AtomicState Pools, Log, Resource, Embed IO, Final IO] r =>+  Sem r ()+releaseAll =+  atomicGet >>= \ Pools {active, available} -> do+    for_ (Map.elems active) \ (ConnectionClients conn _) ->+      releaseOrLog conn+    traverse_ releaseOrLog available+  where+    releaseOrLog (PoolConn conn) =+      runStop (releaseNative conn) >>= leftA \ e ->+        Log.error [exon|Releasing connection failed: #{show e}|]++handleDbConnectionPool ::+  Members [AtomicState Pools, Stop DbConnectionError, Log, Resource, Embed IO, Final IO] r =>+  DbConfig ->+  DbConnectionPool m a ->+  Tactical e m r a+handleDbConnectionPool dbConfig = \case+  Acquire ctag -> do+    Log.trace [exon|Acquiring connection '##{ctag}'|]+    pureT =<< reuseOrAcquire dbConfig ctag+  Free ctag -> do+    traverse_ releaseNative =<< atomicState' (removeActive ctag)+    unitT+  Release ctag -> do+    Log.trace [exon|Releasing connection '##{ctag}'|]+    pureT =<< release ctag+  Use ctag ma ->+    withRegisteredClient ctag (runTSimple ma)+  Kill ctag -> do+    cur <- embed myThreadId+    atomicGets (view (#active . at ctag)) >>= traverse_ \ (ConnectionClients _ clients) -> do+      for_ (Map.keys clients) \ c ->+        unless (cur == c) (embed (throwTo c KillCommand))+    pureT =<< release ctag+  UnsafeGet ctag ->+    pureT . fmap (coerce . connection) =<< atomicGets (view (#active . at ctag))+  Config ->+    pureT dbConfig++interpretDbConnectionPool ::+  Members [Log, Resource, Embed IO, Final IO] r =>+  DbConfig ->+  Maybe Int ->+  Maybe Int ->+  InterpreterFor (DbConnectionPool !! DbConnectionError) r+interpretDbConnectionPool dbConfig maxActive maxAvailable =+  interpretAtomic (Pools maxActive maxAvailable mempty mempty) .+  flip finally releaseAll .+  interpretResumableH (handleDbConnectionPool dbConfig) .+  raiseUnder++handleDbConnectionPoolSingle ::+  Members [AtomicState (Maybe Connection), Stop DbConnectionError, Embed IO] r =>+  DbConfig ->+  DbConnectionPool m a ->+  Tactical e m r a+handleDbConnectionPoolSingle dbConfig = \case+  Acquire _ -> do+    let+      acquireSingle = do+        c <- acquireNative dbConfig+        c <$ atomicPut (Just c)+    pureT =<< fromMaybeA acquireSingle =<< atomicGet+  Free _ ->+    unitT+  -- TODO this should be called from outside of the DbConnection scope interpreter only+  Release _ -> do+    traverse_ releaseNative =<< atomicGet+    unitT+  -- TODO maybe not very useful but possible+  Use _ ma ->+    runTSimple ma+  Kill _ ->+    unitT+  UnsafeGet _ ->+    pureT Nothing+  Config ->+    pureT dbConfig++interpretDbConnectionPoolSingle ::+  Member (Embed IO) r =>+  DbConfig ->+  InterpreterFor (DbConnectionPool !! DbConnectionError) r+interpretDbConnectionPoolSingle dbConfig =+  interpretAtomic Nothing .+  interpretResumableH (handleDbConnectionPoolSingle dbConfig) .+  raiseUnder
+ lib/Polysemy/Hasql/Interpreter/DbTable.hs view
@@ -0,0 +1,119 @@+module Polysemy.Hasql.Interpreter.DbTable where++import Polysemy.Db.Data.DbError (DbError)+import Sqel.Data.Dd (Dd, DdType)+import Sqel.Data.Migration (noMigrations)+import qualified Sqel.Data.PgType as PgType+import Sqel.Data.PgType (PgTable (PgTable))+import Sqel.Data.PgTypeName (pattern PgTypeName)+import Sqel.Data.ProjectionWitness (ProjectionWitness)+import Sqel.Data.TableSchema (TableSchema (TableSchema))+import Sqel.Migration.Run (runMigrations)+import Sqel.PgType (CheckedProjection, projectionWitness)++import Polysemy.Hasql.Data.InitDb (ClientTag (ClientTag), InitDb (InitDb))+import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database)+import qualified Polysemy.Hasql.Effect.DbTable as DbTable+import Polysemy.Hasql.Effect.DbTable (DbTable)+import Polysemy.Hasql.Migration (CustomSemMigrations, MigrateSem (unMigrateSem), SemMigrations)++handleDbTable ::+  ∀ d migs m r' r a .+  CustomSemMigrations r' migs =>+  Members [Log, Embed IO] r =>+  Member Log r' =>+  (∀ x . Sem (Database : Stop DbError : r') x -> Sem (Database : Stop DbError : r) x) ->+  TableSchema d ->+  SemMigrations r' migs ->+  DbTable d m a ->+  Sem (Stop DbError : Database !! DbError : r) a+handleDbTable raiser (TableSchema table@PgTable {name = PgTypeName name} _ _) migrations = \case+  DbTable.Statement q stmt ->+    restop (Database.withInit initDb (Database.statement q stmt))+  where+    initDb :: InitDb (Sem (Database : Stop DbError : Database !! DbError : r))+    initDb = InitDb (ClientTag name) True \ _ -> raise2Under (raiser (unMigrateSem (runMigrations table migrations)))++interpretTable ::+  ∀ d r .+  Members [Database !! DbError, Log, Embed IO] r =>+  TableSchema d ->+  InterpreterFor (DbTable d !! DbError) r+interpretTable schema =+  interpretResumable (subsume . subsume . raise2Under . handleDbTable id schema noMigrations)++tablesScope ::+  Member (Scoped p (Database !! DbError)) r =>+  p ->+  (() -> Sem (Database !! DbError : r) a) ->+  Sem r a+tablesScope conn use =+  scoped conn (use ())++interpretTableMigrations ::+  ∀ d migs r .+  CustomSemMigrations r migs =>+  Members [Database !! DbError, Log, Embed IO] r =>+  TableSchema d ->+  SemMigrations r migs ->+  InterpreterFor (DbTable d !! DbError) r+interpretTableMigrations schema migrations =+  interpretResumable \ ma ->+    subsume_ (handleDbTable id schema migrations ma)++interpretTableMigrationsScoped ::+  CustomSemMigrations r migs =>+  Members [Scoped p (Database !! DbError), Log, Embed IO] r =>+  TableSchema d ->+  SemMigrations r migs ->+  InterpreterFor (Scoped p (DbTable d !! DbError)) r+interpretTableMigrationsScoped schema migrations =+  interpretResumableScopedWith @'[Database !! DbError] tablesScope \ () -> handleDbTable id schema migrations++interpretTableMigrationsScoped' ::+  CustomSemMigrations r' migs =>+  Member Log r' =>+  Members [Scoped p (Database !! DbError), Log, Embed IO] r =>+  (∀ x . Sem (Database : Stop DbError : r') x -> Sem (Database : Stop DbError : r) x) ->+  TableSchema d ->+  SemMigrations r' migs ->+  InterpreterFor (Scoped p (DbTable d !! DbError)) r+interpretTableMigrationsScoped' raiser schema migrations =+  interpretResumableScopedWith @'[Database !! DbError] tablesScope \ () -> handleDbTable raiser schema migrations++interpretTablesMigrations ::+  ∀ d migs p r .+  CustomSemMigrations r migs =>+  Members [Scoped p (Database !! DbError), Database !! DbError, Log, Embed IO] r =>+  TableSchema d ->+  SemMigrations r migs ->+  InterpretersFor [Scoped p (DbTable d !! DbError), DbTable d !! DbError] r+interpretTablesMigrations schema migrations =+  interpretTableMigrations schema migrations .+  interpretTableMigrationsScoped' raise2Under schema migrations++interpretTables ::+  Members [Scoped p (Database !! DbError), Database !! DbError, Log, Embed IO] r =>+  TableSchema d ->+  InterpretersFor [Scoped p (DbTable d !! DbError), DbTable d !! DbError] r+interpretTables schema =+  interpretTablesMigrations schema noMigrations++interpretTableView ::+  Member (DbTable table !! DbError) r =>+  ProjectionWitness view table ->+  InterpreterFor (DbTable view !! DbError) r+interpretTableView _ =+  interpretResumable \case+    DbTable.Statement q stmt ->+      restop (DbTable.statement q stmt)++interpretTableViewDd ::+  CheckedProjection view table =>+  Member (DbTable (DdType table) !! DbError) r =>+  Dd table ->+  Dd view ->+  InterpreterFor (DbTable (DdType view) !! DbError) r+interpretTableViewDd table view =+  interpretTableView (projectionWitness view table)
+ lib/Polysemy/Hasql/Interpreter/Query.hs view
@@ -0,0 +1,66 @@+module Polysemy.Hasql.Interpreter.Query where++import Hasql.Statement (Statement)+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Db.Effect.Query (Query (Query), query)+import Sqel.Data.Dd (Dd, DdType)+import Sqel.Data.Projection (Projection)+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.PgType (CheckedProjection, MkTableSchema, projection)+import Sqel.Query (CheckQuery, checkQuery)+import Sqel.ResultShape (ResultShape)+import Sqel.Statement (selectWhere)++import qualified Polysemy.Hasql.Effect.DbTable as DbTable+import Polysemy.Hasql.Effect.DbTable (DbTable)++interpretQuery ::+  ∀ result query proj table r .+  ResultShape proj result =>+  Member (DbTable table !! DbError) r =>+  Projection proj table ->+  QuerySchema query table ->+  InterpreterFor (Query query result !! DbError) r+interpretQuery proj que =+  interpretResumable \ (Query param) -> restop (DbTable.statement param stmt)+  where+    stmt :: Statement query result+    stmt = selectWhere que proj++interpretQueryDd ::+  ∀ result query proj table r .+  MkTableSchema proj =>+  MkTableSchema table =>+  CheckedProjection proj table =>+  CheckQuery query table =>+  ResultShape (DdType proj) result =>+  Member (DbTable (DdType table) !! DbError) r =>+  Dd table ->+  Dd proj ->+  Dd query ->+  InterpreterFor (Query (DdType query) result !! DbError) r+interpretQueryDd table proj que =+  interpretQuery ps qs+  where+    qs = checkQuery que table+    ps = projection proj table++queryVia ::+  (q1 -> Sem (Stop DbError : r) q2) ->+  (r2 -> Sem (Stop DbError : r) r1) ->+  Sem (Query q1 r1 !! DbError : r) a ->+  Sem (Query q2 r2 !! DbError : r) a+queryVia transQ transR =+  interpretResumable \case+    Query param -> do+      q2 <- raiseUnder (transQ param)+      r2 <- restop (query q2)+      raiseUnder (transR r2)+  . raiseUnder++mapQuery ::+  (q1 -> Sem (Stop DbError : r) q2) ->+  Sem (Query q1 result !! DbError : r) a ->+  Sem (Query q2 result !! DbError : r) a+mapQuery f =+  queryVia f pure
+ lib/Polysemy/Hasql/Interpreter/Reader.hs view
@@ -0,0 +1,22 @@+module Polysemy.Hasql.Interpreter.Reader where++import Polysemy.Db.Interpreter.Reader (interpretReaderStore)+import Sqel.Data.QuerySchema (emptyQuerySchema)+import Sqel.Data.TableSchema (TableSchema)++import Polysemy.Hasql.Effect.DbTable (DbTable)+import Polysemy.Hasql.Interpreter.Store (interpretQStoreDb)++-- |Interpret 'Reader' as a singleton table.+--+-- Given an initial value, every state action reads the value from the database, potentially writing it on first access.+interpretReaderDb ::+  ∀ d e r .+  Member (DbTable d !! e) r =>+  TableSchema d ->+  Sem r d ->+  InterpreterFor (Reader d !! e) r+interpretReaderDb table initial =+  interpretQStoreDb @Maybe table emptyQuerySchema .+  interpretReaderStore (raise initial) .+  raiseUnder
+ lib/Polysemy/Hasql/Interpreter/Store.hs view
@@ -0,0 +1,109 @@+module Polysemy.Hasql.Interpreter.Store where++import Hasql.Connection (Connection)+import Hasql.Statement (Statement)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (QStore, Store)+import Sqel.Data.QuerySchema (QuerySchema, emptyQuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uid)+import Sqel.PgType (toFullProjection)+import Sqel.ResultShape (ResultShape)+import Sqel.Statement (delete, insert, selectWhere, upsert)++import Polysemy.Hasql.Effect.Database (ConnectionSource)+import qualified Polysemy.Hasql.Effect.DbTable as DbTable+import Polysemy.Hasql.Effect.DbTable (DbTable, StoreTable)+import Polysemy.Hasql.Transaction (interpretForXa)++handleQStoreDb ::+  ∀ f q d e r m a .+  ResultShape d (f d) =>+  Members [DbTable d !! e, Stop e] r =>+  TableSchema d ->+  QuerySchema q d ->+  QStore f q d m a ->+  Sem r a+handleQStoreDb table query = \case+  Store.Insert d ->+    restop (DbTable.statement d is)+  Store.Upsert d ->+    restop (DbTable.statement d us)+  Store.Delete i ->+    restop (DbTable.statement i ds)+  Store.DeleteAll ->+    restop (DbTable.statement () das)+  Store.Fetch i ->+    restop (DbTable.statement i qs)+  Store.FetchAll ->+    restop (DbTable.statement () qas)+  where+    is = insert table+    us = upsert table+    ds :: Statement q (f d)+    ds = delete query table+    qs :: Statement q (f d)+    qs = selectWhere query full+    qas :: Statement () [d]+    qas = selectWhere emptyQuerySchema full+    das :: Statement () [d]+    das = delete emptyQuerySchema table+    full = toFullProjection table++interpretQStoreDb ::+  ∀ f q d e r .+  ResultShape d (f d) =>+  Member (DbTable d !! e) r =>+  TableSchema d ->+  QuerySchema q d ->+  InterpreterFor (QStore f q d !! e) r+interpretQStoreDb table query =+  interpretResumable (handleQStoreDb table query)++interpretStoreDb ::+  ∀ i d e r .+  Member (StoreTable i d !! e) r =>+  TableSchema (Uid i d) ->+  QuerySchema i (Uid i d) ->+  InterpreterFor (Store i d !! e) r+interpretStoreDb table query =+  interpretQStoreDb table query++interpretQStoreXa ::+  ∀ f err i d r .+  ResultShape d (f d) =>+  Members [Scoped ConnectionSource (DbTable d !! err), Log, Embed IO] r =>+  TableSchema d ->+  QuerySchema i d ->+  InterpreterFor (Scoped Connection (QStore f i d !! err) !! err) r+interpretQStoreXa table query =+  interpretForXa (handleQStoreDb table query)++interpretStoreXa ::+  ∀ err i d r .+  Members [Scoped ConnectionSource (DbTable (Uid i d) !! err), Log, Embed IO] r =>+  TableSchema (Uid i d) ->+  QuerySchema i (Uid i d) ->+  InterpreterFor (Scoped Connection (Store i d !! err) !! err) r+interpretStoreXa =+  interpretQStoreXa @Maybe++interpretQStores ::+  ∀ f err q d r .+  ResultShape d (f d) =>+  Members [Scoped ConnectionSource (DbTable d !! err), DbTable d !! err, Log, Embed IO] r =>+  TableSchema d ->+  QuerySchema q d ->+  InterpretersFor [QStore f q d !! err, Scoped Connection (QStore f q d !! err) !! err] r+interpretQStores table query =+  interpretQStoreXa table query .+  interpretQStoreDb table query++interpretStores ::+  ∀ err i d r .+  Members [Scoped ConnectionSource (DbTable (Uid i d) !! err), StoreTable i d !! err, Log, Embed IO] r =>+  TableSchema (Uid i d) ->+  QuerySchema i (Uid i d) ->+  InterpretersFor [Store i d !! err, Scoped Connection (Store i d !! err) !! err] r+interpretStores =+  interpretQStores @Maybe
+ lib/Polysemy/Hasql/Interpreter/Transaction.hs view
@@ -0,0 +1,40 @@+module Polysemy.Hasql.Interpreter.Transaction where++import Hasql.Connection (Connection)+import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (ConnectionSource, Database, withDatabaseUnique)+import Polysemy.Hasql.Effect.Transaction (Transaction (Abort, Resource), Transactions)+import Polysemy.Hasql.Statement.Transaction (beginTransaction, commitTransaction, rollbackTransaction)++transactionScopeWithConnection ::+  Members [Database, Resource, Stop DbError] r =>+  (Connection -> Sem (Stop DbError : r) a) ->+  Sem r a+transactionScopeWithConnection use =+  bracketOnError (runS (beginTransaction def False)) abortTr \ () -> do+    Database.use \ connection ->+      subsume (use connection) <* runS (commitTransaction False)+  where+    abortTr _ = runS (rollbackTransaction False)+    runS = Database.statement ()++transactionScope ::+  Members [Scoped ConnectionSource (Database !! DbError), Resource] (Stop DbError : r) =>+  (Connection -> Sem (Stop DbError : r) a) ->+  Sem (Stop DbError : r) a+transactionScope use =+  withDatabaseUnique Nothing $ restop @DbError @Database do+    transactionScopeWithConnection (insertAt @1 . use)++interpretTransactions ::+  Members [Scoped ConnectionSource (Database !! DbError), Resource] r =>+  InterpreterFor (Transactions Connection !! DbError) r+interpretTransactions =+  interpretScopedResumableWithH @'[] (const transactionScope) \ conn -> \case+    Resource ->+      pureT conn+    Abort ->+      stop (DbError.Query "aborted by user")
+ lib/Polysemy/Hasql/Migration.hs view
@@ -0,0 +1,59 @@+module Polysemy.Hasql.Migration where++import Generics.SOP (All)+import qualified Log+import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)+import Sqel.Class.MigrationEffect (MigrationEffect (error, log, runMigrationStatements, runStatement, runStatement_))+import Sqel.Data.Migration (+  CustomMigration,+  HoistMigration (hoistMigration),+  HoistMigrations (hoistMigrations), Migrations,+  )+import Sqel.Migration.Statement (migrationSession)+import qualified Sqel.Migration.Transform as Transform+import Sqel.Migration.Transform (MigrateTransform (MigrateTransform))++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database)++newtype MigrateSem r a =+  MigrateSem { unMigrateSem :: Sem (Database : Stop DbError : r) a }+  deriving stock (Generic, Functor)+  deriving newtype (Applicative, Monad)++type SemMigrations r migs = Migrations (MigrateSem r) migs++type HoistSemMigrations extra r migs migs' =+  HoistMigrations (MigrateSem r) (MigrateSem (extra ++ r)) migs migs'++type CustomSemMigrations r migs =+  All (CustomMigration (MigrateSem r)) migs++instance HoistMigration (MigrateSem r) (MigrateSem r') (MigrateTransform (MigrateSem r) old new) (MigrateTransform (MigrateSem r') old new) where+  hoistMigration f MigrateTransform {..} = MigrateTransform {trans = f . trans, ..}++hoistSemMigrations ::+  ∀ extra r migs migs' .+  HoistSemMigrations extra r migs migs' =>+  (∀ x . Sem (Database : Stop DbError : r) x -> Sem (Database : Stop DbError : extra ++ r) x) ->+  SemMigrations r migs ->+  SemMigrations (extra ++ r) migs'+hoistSemMigrations f m =+  hoistMigrations (MigrateSem . f . unMigrateSem) m++instance (+    Member Log r+  ) => MigrationEffect (MigrateSem r) where+    runMigrationStatements actions =+      MigrateSem (Database.session (migrationSession actions))++    runStatement_ q s = MigrateSem (Database.statement q s)++    runStatement q s = MigrateSem (Database.statement q s)++    log = MigrateSem . Log.debug++    error msg = MigrateSem do+      Log.error msg+      stop (DbError.Table msg)
+ lib/Polysemy/Hasql/Queue.hs view
@@ -0,0 +1,17 @@+module Polysemy.Hasql.Queue (+  Queue,+  Queued,+  QueueOutputError,+  module Polysemy.Hasql.Queue.Input,+  module Polysemy.Hasql.Queue.Output,+  module Polysemy.Hasql.Queue.Store,+) where++import Prelude hiding (Queue)++import Polysemy.Hasql.Data.QueueOutputError (QueueOutputError)+import Polysemy.Hasql.Queue.Data.Queue (Queue)+import Polysemy.Hasql.Queue.Data.Queued (Queued)+import Polysemy.Hasql.Queue.Input (interpretInputQueueDb)+import Polysemy.Hasql.Queue.Output (interpretOutputQueueDb)+import Polysemy.Hasql.Queue.Store (interpretQueueStoreDb)
+ lib/Polysemy/Hasql/Queue/Data/Queue.hs view
@@ -0,0 +1,33 @@+module Polysemy.Hasql.Queue.Data.Queue where++import Prelude hiding (Queue)++type family InputConn (queue :: Symbol) :: Symbol where+  InputConn queue =+    AppendSymbol queue "-input"++type family OutputConn (queue :: Symbol) :: Symbol where+  OutputConn queue =+    AppendSymbol queue "-output"++type family Queue (queue :: Symbol) t :: Constraint where+  Queue queue t =+    (+      Ord t,+      KnownSymbol queue,+      KnownSymbol (InputConn queue),+      KnownSymbol (OutputConn queue)+    )++type family QueueInput (queue :: Symbol) t :: Constraint where+  QueueInput queue t =+    (Ord t, KnownSymbol (InputConn queue))++type family QueueOutput (queue :: Symbol) t :: Constraint where+  QueueOutput queue t =+    (Ord t, KnownSymbol (OutputConn queue))++newtype QueueName =+  QueueName { unQueueName :: Text }+  deriving stock (Eq, Show, Generic)+  deriving newtype (IsString, Ord)
+ lib/Polysemy/Hasql/Queue/Data/Queued.hs view
@@ -0,0 +1,19 @@+module Polysemy.Hasql.Queue.Data.Queued where++import Sqel.Comp (CompName (compName))+import Sqel.Data.Sel (MkTSel (mkTSel), SelPrefix (NoPrefix), TSel (TSel))++data Queued t a =+  Queued {+    queue_created :: t,+    queue_payload :: a+  }+  deriving stock (Eq, Show, Generic)++instance (+    CompName d ('TSel prefix inner),+    name ~ AppendSymbol "Queued" inner,+    sel ~ 'TSel 'NoPrefix name,+    MkTSel sel+  ) => CompName (Queued t d) sel where+  compName = mkTSel
+ lib/Polysemy/Hasql/Queue/Input.hs view
@@ -0,0 +1,260 @@+module Polysemy.Hasql.Queue.Input where++import Conc (+  ClockSkewConfig,+  Monitor,+  Restart,+  RestartingMonitor,+  interpretAtomic,+  interpretMonitorRestart,+  monitor,+  monitorClockSkew,+  restart,+  )+import Control.Concurrent (threadWaitRead)+import qualified Control.Concurrent.Async as Concurrent+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TBMQueue (TBMQueue, closeTBMQueue, newTBMQueueIO, readTBMQueue, writeTBMQueue)+import Control.Exception (IOException)+import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.UUID as UUID+import Data.UUID (UUID)+import qualified Database.PostgreSQL.LibPQ as LibPQ+import Exon (exon)+import Hasql.Connection (Connection, withLibPQConnection)+import qualified Polysemy.Db.Data.DbConnectionError as DbConnectionError+import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import Polysemy.Final (withWeavingToFinal)+import Polysemy.Input (Input (Input))+import qualified Log+import qualified Time as Time+import Prelude hiding (Queue, listen)+import Sqel.Data.Sql (sql)+import qualified Sqel.Data.Uid as Uid+import Sqel.Data.Uid (Uuid)+import Sqel.SOP.Constraint (symbolText)+import Torsor (Torsor)++import Polysemy.Hasql.Data.ConnectionTag (ConnectionTag (NamedTag))+import Polysemy.Hasql.Data.InitDb (InitDb (InitDb))+import qualified Polysemy.Hasql.Database as Database (retryingSqlDef)+import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (Database, Databases, withDatabaseUnique)+import Polysemy.Hasql.Queue.Data.Queue (Queue, QueueName (QueueName))+import Polysemy.Hasql.Queue.Data.Queued (Queued)+import qualified Polysemy.Hasql.Queue.Data.Queued as Queued (Queued (..))++-- | Try to fetch a notification, and if there is none, wait on the connection's file descriptor until some data is+-- received.+-- This connection will be fully blocked when waiting, so it must not be shared with other parts of the application.+--+-- TODO Could it be possible to share a connection among all queues, only for waiting?+tryDequeue ::+  Members [Monitor Restart, Reader QueueName, Log, Embed IO] r =>+  LibPQ.Connection ->+  Sem r (Either Text (Maybe UUID))+tryDequeue connection = do+  QueueName name <- ask+  let status msg = Log.trace [exon|#{msg} on connection for '#{name}'|]+  status "Trying dequeue"+  embed (LibPQ.notifies connection) >>= \case+    Just (LibPQ.Notify _ _ payload) -> do+      status "Received notify"+      case UUID.fromASCIIBytes payload of+        Just d ->+          pure (Right (Just d))+        Nothing ->+          pure (Left [exon|invalid UUID payload: #{decodeUtf8 payload}|])+    Nothing -> do+      status "No notify"+      embed (LibPQ.socket connection) >>= \case+        Just fd -> do+          status "Waiting for activity"+          monitor (embed (threadWaitRead fd))+          status "Activity received"+          Right Nothing <$ embed (LibPQ.consumeInput connection)+        Nothing ->+          pure (Left "couldn't connect with LibPQ.socket")++listen ::+  Members [Database, Reader QueueName, Log, Embed IO] r =>+  Sem r ()+listen = do+  QueueName name <- ask+  Log.debug [exon|executing `listen` for queue ##{name}|]+  Database.retryingSqlDef [sql|listen "##{name}"|]++unlisten ::+  ∀ e r .+  Members [Database !! e, Reader QueueName, Log] r =>+  Sem r ()+unlisten = do+  QueueName name <- ask+  Log.debug [exon|executing `unlisten` for queue `##{name}`|]+  resume_ (Database.retryingSqlDef [sql|unlisten "##{name}"|])++processMessages ::+  Ord t =>+  NonEmpty (Uuid (Queued t d)) ->+  NonEmpty d+processMessages =+  fmap (Queued.queue_payload . Uid.payload) . NonEmpty.sortWith (Queued.queue_created . Uid.payload)++initQueue ::+  ∀ e d t r .+  Ord t =>+  Members [Store UUID (Queued t d) !! e, Reader QueueName, Database, Log, Embed IO] r =>+  (d -> Sem r ()) ->+  Sem r ()+initQueue write = do+  QueueName name <- ask+  Log.trace [exon|Initializing queue '#{name}'|]+  waiting <- resumeAs Nothing (nonEmpty <$> Store.deleteAll)+  traverse_ (traverse_ write . processMessages) waiting+  listen++withPqConn ::+  Member (Final IO) r =>+  Connection ->+  (LibPQ.Connection -> Sem r a) ->+  Sem r (Either Text a)+withPqConn connection use =+  errorToIOFinal $ fromExceptionSemVia @IOException show $ withWeavingToFinal \ s lower _ -> do+    withLibPQConnection connection \ c -> lower (raise (use c) <$ s)++-- TODO check that DbConnectionError is right here+dequeueAndProcess ::+  ∀ d t dt r .+  Ord t =>+  Members [Monitor Restart, Reader QueueName, Final IO] r =>+  Members [Store UUID (Queued t d) !! DbError, Database !! DbError, Time t dt, Stop DbError, Log, Embed IO] r =>+  TBMQueue d ->+  Connection ->+  Sem r ()+dequeueAndProcess queue connection = do+  result <- join <$> withPqConn connection tryDequeue+  void $ runMaybeT do+    id' <- MaybeT (stopEitherWith (DbError.Connection . DbConnectionError.Acquire) result)+    messages <- MaybeT (restop (Store.delete id'))+    liftIO (traverse_ (atomically . writeTBMQueue queue) (processMessages (pure messages)))++dequeue ::+  ∀ d t dt r .+  Ord t =>+  Members [Monitor Restart, Reader QueueName, Final IO] r =>+  Members [Store UUID (Queued t d) !! DbError, Database !! DbError, Stop DbError, Time t dt, Log, Embed IO] r =>+  TBMQueue d ->+  Sem r ()+dequeue queue = do+  QueueName name <- ask+  let+    initDb = InitDb [exon|dequeue-##{name}|] False \ _ -> initQueue (embed . atomically . writeTBMQueue queue)+  restop @_ @Database do+    Database.withInit initDb (Database.use (dequeueAndProcess queue))++dequeueLoop ::+  ∀ d t dt u r .+  Ord t =>+  TimeUnit u =>+  Members [Monitor Restart, Reader QueueName] r =>+  Members [Store UUID (Queued t d) !! DbError, Database !! DbError, Time t dt, Log, Resource, Embed IO, Final IO] r =>+  u ->+  (DbError -> Sem r Bool) ->+  TBMQueue d ->+  Sem r ()+dequeueLoop errorDelay errorHandler queue = do+  QueueName name <- ask+  let+    spin =+      runStop (dequeue queue) >>= \case+        Right () -> spin+        Left err -> result =<< errorHandler err+    result = \case+      True ->+        disconnect *> Time.sleep errorDelay *> spin+      False -> do+        Log.warn [exon|Exiting dequeue loop for '##{name}' after error|]+        embed (atomically (closeTBMQueue queue))+    disconnect =+      unlisten *> resume_ Database.release+  spin++startDequeueLoop ::+  ∀ d t dt u r .+  Ord t =>+  TimeUnit u =>+  Members [RestartingMonitor, Reader QueueName] r =>+  Members [Store UUID (Queued t d) !! DbError, Databases, Time t dt, Log, Resource, Embed IO, Final IO] r =>+  u ->+  (DbError -> Sem r Bool) ->+  TBMQueue d ->+  Sem r ()+startDequeueLoop errorDelay errorHandler queue = do+  QueueName name <- ask+  withDatabaseUnique (Just (NamedTag [exon|dequeue-#{name}|])) do+    finally (restart (dequeueLoop errorDelay (insertAt @0 . errorHandler) queue)) unlisten++interpretInputQueue ::+  ∀ d r .+  Member (Embed IO) r =>+  TBMQueue d ->+  InterpreterFor (Input (Maybe d)) r+interpretInputQueue queue =+  interpret \case+    Input ->+      embed (atomically (readTBMQueue queue))++dequeueThread ::+  ∀ d t dt u r .+  Ord t =>+  TimeUnit u =>+  Members [RestartingMonitor, Reader QueueName, Resource] r =>+  Members [Store UUID (Queued t d) !! DbError, Databases, Time t dt, Log, Async, Embed IO, Final IO] r =>+  u ->+  (DbError -> Sem r Bool) ->+  Sem r (Concurrent.Async (Maybe ()), TBMQueue d)+dequeueThread errorDelay errorHandler = do+  queue <- embed (newTBMQueueIO 64)+  handle <- async (startDequeueLoop errorDelay errorHandler queue)+  pure (handle, queue)++interpretInputDbQueueListen ::+  ∀ (name :: Symbol) d t dt u r .+  Ord t =>+  TimeUnit u =>+  KnownSymbol name =>+  Members [RestartingMonitor, Final IO] r =>+  Members [Store UUID (Queued t d) !! DbError, Databases, Time t dt, Log, Resource, Async, Embed IO] r =>+  u ->+  (DbError -> Sem r Bool) ->+  InterpreterFor (Input (Maybe d)) r+interpretInputDbQueueListen errorDelay errorHandler sem =+  runReader (QueueName (symbolText @name)) $+  bracket acquire release \ (_, queue) -> do+    interpretInputQueue queue (raiseUnder sem)+  where+    acquire = dequeueThread errorDelay (raise . errorHandler)+    release (handle, _) = cancel handle++interpretInputQueueDb ::+  ∀ qname u t dt d diff r .+  TimeUnit u =>+  TimeUnit diff =>+  Torsor t diff =>+  Queue qname t =>+  Members [Store UUID (Queued t d) !! DbError, Databases] r =>+  Members [Time t dt, Log, Resource, Async, Race, Embed IO, Final IO] r =>+  u ->+  ClockSkewConfig ->+  (DbError -> Sem r Bool) ->+  InterpreterFor (Input (Maybe d)) r+interpretInputQueueDb errorDelay csConfig errorHandler =+  interpretAtomic Nothing .+  interpretMonitorRestart (monitorClockSkew csConfig) .+  raiseUnder .+  interpretInputDbQueueListen @qname errorDelay (insertAt @0 . errorHandler) .+  raiseUnder
+ lib/Polysemy/Hasql/Queue/Output.hs view
@@ -0,0 +1,42 @@+module Polysemy.Hasql.Queue.Output where++import Data.UUID (UUID)+import Exon (exon)+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Db.Effect.Random (Random, random)+import qualified Polysemy.Db.Effect.Store as Store+import Polysemy.Db.Effect.Store (Store)+import qualified Log+import Polysemy.Output (Output (Output))+import qualified Time as Time+import Time (Seconds (Seconds))+import Prelude hiding (Queue, group)+import Sqel.Data.Sql (Sql (Sql))+import Sqel.Data.Uid (Uid (Uid))+import Sqel.SOP.Constraint (symbolText)++import qualified Polysemy.Hasql.Data.QueueOutputError as QueueOutputError+import Polysemy.Hasql.Data.QueueOutputError (QueueOutputError)+import qualified Polysemy.Hasql.Database as Database (retryingSql)+import Polysemy.Hasql.Effect.Database (Database)+import Polysemy.Hasql.Queue.Data.Queued (Queued (Queued))++-- TODO I think notify doesn't even need a unique connection, only listen does+interpretOutputQueueDb ::+  ∀ (queue :: Symbol) d t dt r .+  KnownSymbol queue =>+  Members [Store UUID (Queued t d) !! DbError, Database !! DbError, Time t dt, Log, Random UUID, Embed IO] r =>+  InterpreterFor (Output d !! QueueOutputError) r+interpretOutputQueueDb =+  interpretResumable \case+    Output d -> do+      id' <- random+      created <- Time.now+      resumeHoist QueueOutputError.Insert do+        Store.insert (Uid id' (Queued created d))+      Log.debug [exon|executing `notify` for queue '#{symbolText @queue}'|]+      resumeHoist QueueOutputError.Notify do+        Database.retryingSql (Seconds 3) (sql id')+      where+        sql id' =+          [exon|notify "#{Sql (symbolText @queue)}", '#{show id'}'|]
+ lib/Polysemy/Hasql/Queue/Store.hs view
@@ -0,0 +1,54 @@+module Polysemy.Hasql.Queue.Store where++import Data.UUID (UUID)+import Generics.SOP (NP (Nil, (:*)))+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Db.Effect.Store (Store)+import Prelude hiding (Queue, listen)+import Sqel.Codec (PrimColumn)+import Sqel.Comp (CompName)+import Sqel.Data.QuerySchema (QuerySchema)+import Sqel.Data.TableSchema (TableSchema)+import Sqel.Data.Uid (Uuid)+import Sqel.PgType (tableSchema)+import qualified Sqel.Prim as Sqel+import Sqel.Prim (prim, primAs)+import Sqel.Product (prod)+import Sqel.Query (checkQuery)+import Sqel.Uid (uid)++import Polysemy.Hasql.Effect.Database (Database)+import Polysemy.Hasql.Interpreter.DbTable (interpretTable)+import Polysemy.Hasql.Interpreter.Store (interpretStoreDb)+import Polysemy.Hasql.Queue.Data.Queued (Queued)+import Sqel.Data.Sel (TSel(TSel))++class StoreTable t d where+  storeTable :: (TableSchema (Uuid (Queued t d)), QuerySchema UUID (Uuid (Queued t d)))++instance (+    ToJSON d,+    FromJSON d,+    PrimColumn t,+    CompName d ('TSel prefix name),+    KnownSymbol (AppendSymbol "Queued" name)+  ) => StoreTable t d where+  storeTable =+    (ts, qs)+    where+      ts = tableSchema table+      qs = checkQuery query table+      query = primAs @"id"+      table = uid prim (prod (prim :* Sqel.json :* Nil))++interpretQueueStoreDb ::+  ∀ d t dt r .+  StoreTable t d =>+  Members [Database !! DbError, Time t dt, Log, Resource, Async, Race, Embed IO, Final IO] r =>+  InterpreterFor (Store UUID (Queued t d) !! DbError) r+interpretQueueStoreDb =+  interpretTable ts .+  interpretStoreDb ts qs .+  raiseUnder+  where+    (ts, qs) = storeTable @t
+ lib/Polysemy/Hasql/Session.hs view
@@ -0,0 +1,37 @@+module Polysemy.Hasql.Session where++import qualified Data.Text as Text+import Exon (exon)+import Hasql.Connection (Connection)+import qualified Hasql.Session as Session+import Hasql.Session (CommandError (ClientError, ResultError), QueryError (QueryError), Session)+import Hasql.Statement (Statement)+import qualified Polysemy.Db.Data.DbConnectionError as DbConnectionError+import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)++convertQueryError :: QueryError -> DbError+convertQueryError (QueryError template (Text.intercalate "," -> args) cmdError) =+  case cmdError of+    ClientError err ->+      DbError.Connection (DbConnectionError.Query (maybe "no error" decodeUtf8 err))+    ResultError err ->+      DbError.Query [exon|#{decodeUtf8 template} #{args} #{show err}|]++runSession ::+  Members [Stop DbError, Embed IO] r =>+  Connection ->+  Session a ->+  Sem r a+runSession connection session = do+  result <- tryIOError (Session.run session connection)+  stopEither (first convertQueryError =<< first DbError.Unexpected result)++runStatement ::+  Members [Stop DbError, Embed IO] r =>+  Connection ->+  p ->+  Statement p a ->+  Sem r a+runStatement connection p stmt =+  runSession connection (Session.statement p stmt)
+ lib/Polysemy/Hasql/Statement.hs view
@@ -0,0 +1,34 @@+module Polysemy.Hasql.Statement where++import Hasql.Statement (Statement)+import Polysemy.Db.Data.DbName (DbName, unDbName)+import Sqel.Data.Sql (Sql, sql, sqlQuote)+import Sqel.Statement (plain)++quoteName :: DbName -> Sql+quoteName =+  sqlQuote . unDbName++createDbSql ::+  DbName ->+  Sql+createDbSql (quoteName -> name) =+  [sql|create database #{name}|]++createDb ::+  DbName ->+  Statement () ()+createDb =+  plain . createDbSql++dropDbSql ::+  DbName ->+  Sql+dropDbSql (quoteName -> name) =+  [sql|drop database #{name}|]++dropDb ::+  DbName ->+  Statement () ()+dropDb =+  plain . dropDbSql
+ lib/Polysemy/Hasql/Statement/Transaction.hs view
@@ -0,0 +1,62 @@+module Polysemy.Hasql.Statement.Transaction where++import Exon (exon)+import Hasql.Decoders (noResult)+import Hasql.Encoders (noParams)+import Hasql.Statement (Statement (Statement))++data AccessMode =+  Read+  |+  Write+  deriving stock (Show, Eq, Ord, Enum, Bounded)++data IsolationLevel =+  ReadCommitted+  |+  RepeatableRead+  |+  Serializable+  deriving stock (Show, Eq, Ord, Enum, Bounded)++data TransactionConfig =+  TransactionConfig {+    isolationLevel :: IsolationLevel,+    accessMode :: AccessMode,+    deferrable :: Bool+  }+  deriving stock (Eq, Show, Generic)++instance Default TransactionConfig where+  def =+    TransactionConfig {+      isolationLevel = ReadCommitted,+      accessMode = Write,+      deferrable = False+    }++beginTransactionSql :: TransactionConfig -> ByteString+beginTransactionSql TransactionConfig {..} =+  [exon|start transaction #{isolation isolationLevel} #{mode accessMode} #{defer}|]+  where+    isolation = \case+      ReadCommitted -> "isolation level read committed"+      RepeatableRead -> "isolation level repeatable read"+      Serializable -> "isolation level serializable"+    mode = \case+      Write -> "read write"+      Read -> "read only"+    defer | deferrable = "deferrable"+          | otherwise = ""++beginTransaction :: TransactionConfig -> Bool -> Statement () ()+beginTransaction conf preparable =+  Statement (beginTransactionSql conf) noParams noResult preparable++commitTransaction :: Bool -> Statement () ()+commitTransaction preparable =+  Statement "commit" noParams noResult preparable++rollbackTransaction :: Bool -> Statement () ()+rollbackTransaction preparable =+  Statement "rollback" noParams noResult preparable
+ lib/Polysemy/Hasql/Test/Database.hs view
@@ -0,0 +1,90 @@+module Polysemy.Hasql.Test.Database where++import qualified Data.UUID as UUID+import Data.UUID (UUID)+import Exon (exon)+import Hasql.Connection (Connection)+import Hasql.Session (QueryError)+import Polysemy.Db.Data.DbConfig (DbConfig (DbConfig))+import Polysemy.Db.Data.DbConnectionError (DbConnectionError)+import qualified Polysemy.Db.Data.DbError as DbError+import Polysemy.Db.Data.DbError (DbError)+import Polysemy.Db.Data.DbName (DbName (DbName))+import Polysemy.Db.Effect.Random (Random, random)+import Polysemy.Db.Interpreter.Random (interpretRandom)+import Time (GhcTime)+import Sqel.Data.PgTypeName (pattern PgTypeName, pgTableName)+import Sqel.Data.TableSchema (TableSchema)++import Polysemy.Hasql.Effect.Database (ConnectionSource, Database)+import qualified Polysemy.Hasql.Effect.DbConnectionPool as DbConnectionPool+import Polysemy.Hasql.Effect.DbConnectionPool (DbConnectionPool)+import Polysemy.Hasql.Interpreter.Database (interpretDatabase)+import Polysemy.Hasql.Interpreter.DbConnectionPool (interpretDbConnectionPool, interpretDbConnectionPoolSingle)+import Polysemy.Hasql.Session (convertQueryError, runStatement)+import qualified Polysemy.Hasql.Statement as Statement++suffixedTableSchema ::+  Text ->+  TableSchema d ->+  TableSchema d+suffixedTableSchema suffix =+  #pg . #name %~ \ (PgTypeName name) -> pgTableName [exon|#{name}-#{suffix}|]++createTestDb ::+  Members [Random UUID, Stop DbError, Embed IO] r =>+  DbConfig ->+  Connection ->+  Sem r DbConfig+createTestDb dbConfig@(DbConfig _ _ (DbName name) _ _) connection = do+  suffix <- UUID.toText <$> random+  let+    suffixedName = DbName [exon|#{name}-#{suffix}|]+    suffixed = dbConfig & #name .~ suffixedName+  suffixed <$ runStatement connection () (Statement.createDb suffixedName)++withTestDb ::+  Members [Stop DbError, Resource, Mask, Race, Embed IO, Final IO] r =>+  DbConfig ->+  (DbConfig -> Sem r a) ->+  Sem r a+withTestDb baseConfig f =+  interpretDbConnectionPoolSingle baseConfig do+    resumeHoist DbError.Connection $ DbConnectionPool.acquire "test" >>= \ connection ->+      bracket (acquire baseConfig connection) (release connection) (raise . raise . f)+  where+    acquire config connection =+      interpretRandom $ createTestDb config connection+    release connection (DbConfig _ _ name _ _) =+      mapStop convertQueryError (runStatement connection () (Statement.dropDb name))++type TestConnectionEffects =+  [+    Database !! DbError,+    Scoped ConnectionSource (Database !! DbError),+    DbConnectionPool !! DbConnectionError+  ]++withTestConnection ::+  Members [Stop DbError, Time t dt, Log, Resource, Mask, Race, Embed IO, Final IO] r =>+  DbConfig ->+  InterpretersFor TestConnectionEffects r+withTestConnection baseConfig ma =+  withTestDb baseConfig \ dbConfig ->+    interpretDbConnectionPool dbConfig Nothing Nothing $+    interpretDatabase $+    ma++type TestStoreDeps =+  [+    Resource,+    Embed IO,+    Scoped ConnectionSource (Database !! DbError),+    Database !! DbError,+    Error DbError,+    Random UUID,+    Log,+    Stop QueryError,+    Stop DbError,+    GhcTime+  ]
+ lib/Polysemy/Hasql/Transaction.hs view
@@ -0,0 +1,93 @@+module Polysemy.Hasql.Transaction where++import Hasql.Connection (Connection)+import Polysemy.Db.Effect.Store (QStore, Store)+import Sqel.Data.Uid (Uid)++import qualified Polysemy.Hasql.Effect.Database as Database+import Polysemy.Hasql.Effect.Database (ConnectionSource)+import qualified Polysemy.Hasql.Effect.Transaction as Transaction+import Polysemy.Hasql.Effect.Transaction (Transaction, Transactions)+import Polysemy.Internal.CustomErrors (FirstOrder)++type XaQStore res err f q d =+  Scoped res (QStore f q d !! err) !! err++type XaStore res err i d =+  XaQStore res err Maybe i (Uid i d)++type TransactionEffects :: EffectRow -> EffectRow -> Type -> Type -> EffectRow -> Constraint+class TransactionEffects all effs err res r where+  transactionEffects :: res -> InterpretersFor effs r++instance TransactionEffects all '[] err res r where+  transactionEffects _ = id++instance (+    TransactionEffects all effs err res r,+    Member (Scoped res (eff !! err) !! err) (effs ++ r),+    Member (Stop err) (effs ++ r)+  ) => TransactionEffects all (eff : effs) err res r where+  transactionEffects res =+    transactionEffects @all @effs @err res .+    restop @err @(Scoped res (eff !! err)) .+    scoped res .+    restop @err @eff .+    raiseUnder2++-- TODO add scope parameter of type TransactionConfig+transact ::+  ∀ effs res err r .+  effs ++ '[Transaction res] ++ r ~ (effs ++ '[Transaction res]) ++ r =>+  Member (Transactions res) r =>+  TransactionEffects effs effs err res (Transaction res : r) =>+  InterpretersFor (effs ++ '[Transaction res]) r+transact ma =+  scoped_ do+    conn <- Transaction.resource+    transactionEffects @effs @effs @err conn do+      ma++type family XaStores (ds :: [(Type, Type)]) :: [Effect] where+  XaStores '[] = '[]+  XaStores ('(i, d) : ds) = Store i d : XaStores ds++transactStores ::+  ∀ ds res err r xas .+  xas ~ XaStores ds =>+  XaStores ds ++ (Transaction res : r) ~ (xas ++ '[Transaction res]) ++ r =>+  Member (Transactions res) r =>+  TransactionEffects xas xas err res (Transaction res : r) =>+  InterpretersFor (xas ++ '[Transaction res]) r+transactStores ma =+  scoped_ do+    conn <- Transaction.resource+    transactionEffects @xas @xas @err conn do+      ma++connectionScope ::+  ∀ eff err r a .+  Member (Scoped ConnectionSource (eff !! err)) r =>+  Connection ->+  (() -> Sem (eff !! err : r) a) ->+  Sem r a+connectionScope conn use =+  scoped (Database.Supplied "transaction" conn) (use ())++interpretForXa ::+  ∀ dep eff err r .+  Member (Scoped ConnectionSource (dep !! err)) r =>+  (∀ x r0 . eff (Sem r0) x -> Sem (Stop err : dep !! err : r) x) ->+  InterpreterFor (Scoped Connection (eff !! err) !! err) r+interpretForXa handler =+  interpretScopedRWith @'[dep !! err] connectionScope \ () -> insertAt @2 . handler++interpretWithXa ::+  ∀ dep eff err r .+  FirstOrder eff "interpretResumable" =>+  Members [Scoped ConnectionSource (dep !! err), dep !! err] r =>+  (∀ x r0 . eff (Sem r0) x -> Sem (Stop err : dep !! err : r) x) ->+  InterpretersFor [Scoped Connection (eff !! err) !! err, eff !! err] r+interpretWithXa handler =+  interpretResumable (subsume_ . raise2Under . handler) .+  interpretForXa (raise2Under . handler)
+ polysemy-hasql.cabal view
@@ -0,0 +1,249 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.35.0.+--+-- see: https://github.com/sol/hpack++name:           polysemy-hasql+version:        0.0.1.0+synopsis:       Polysemy effects for databases+description:    See https://hackage.haskell.org/package/polysemy-hasql/docs/Polysemy-Hasql.html+category:       Database+author:         Torsten Schmits+maintainer:     hackage@tryp.io+copyright:      2023 Torsten Schmits+license:        BSD-2-Clause-Patent+license-file:   LICENSE+build-type:     Simple++library+  exposed-modules:+      Polysemy.Hasql+      Polysemy.Hasql.Data.ConnectionState+      Polysemy.Hasql.Data.ConnectionTag+      Polysemy.Hasql.Data.InitDb+      Polysemy.Hasql.Data.QueueOutputError+      Polysemy.Hasql.Database+      Polysemy.Hasql.Effect.Database+      Polysemy.Hasql.Effect.DbConnectionPool+      Polysemy.Hasql.Effect.DbTable+      Polysemy.Hasql.Effect.Transaction+      Polysemy.Hasql.Interpreter.AtomicState+      Polysemy.Hasql.Interpreter.Database+      Polysemy.Hasql.Interpreter.DbConnectionPool+      Polysemy.Hasql.Interpreter.DbTable+      Polysemy.Hasql.Interpreter.Query+      Polysemy.Hasql.Interpreter.Reader+      Polysemy.Hasql.Interpreter.Store+      Polysemy.Hasql.Interpreter.Transaction+      Polysemy.Hasql.Migration+      Polysemy.Hasql.Queue+      Polysemy.Hasql.Queue.Data.Queue+      Polysemy.Hasql.Queue.Data.Queued+      Polysemy.Hasql.Queue.Input+      Polysemy.Hasql.Queue.Output+      Polysemy.Hasql.Queue.Store+      Polysemy.Hasql.Session+      Polysemy.Hasql.Statement+      Polysemy.Hasql.Statement.Transaction+      Polysemy.Hasql.Test.Database+      Polysemy.Hasql.Transaction+  hs-source-dirs:+      lib+  default-extensions:+      StandaloneKindSignatures+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedLabels+      OverloadedLists+      OverloadedStrings+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -fplugin=Polysemy.Plugin+  build-depends:+      async ==2.2.*+    , base >=4.12 && <5+    , containers+    , exon ==1.4.*+    , generics-sop ==0.5.*+    , hasql ==1.6.*+    , polysemy+    , polysemy-db >=0.0.1.0 && <0.1+    , polysemy-plugin+    , postgresql-libpq ==0.9.*+    , prelate >=0.5.1 && <0.6+    , sqel >=0.0.1 && <0.1+    , stm-chans ==3.0.*+    , torsor ==0.1.*+    , transformers+    , uuid ==1.3.*+  mixins:+      base hiding (Prelude)+    , prelate (Prelate as Prelude)+    , prelate hiding (Prelate)+  default-language: Haskell2010++test-suite polysemy-hasql-integration+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Polysemy.Hasql.Test.ArrayTest+      Polysemy.Hasql.Test.AtomicStateTest+      Polysemy.Hasql.Test.DbConfig+      Polysemy.Hasql.Test.DefaultTest+      Polysemy.Hasql.Test.JsonTest+      Polysemy.Hasql.Test.MigrationTest+      Polysemy.Hasql.Test.QueryTest+      Polysemy.Hasql.Test.QueueTest+      Polysemy.Hasql.Test.RetryTest+      Polysemy.Hasql.Test.RunIntegration+      Polysemy.Hasql.Test.SimpleQueryTest+      Polysemy.Hasql.Test.SumQueryTest+      Polysemy.Hasql.Test.SumTest+      Polysemy.Hasql.Test.TransactionTest+      Polysemy.Hasql.Test.TransformMigrationTest+      Polysemy.Hasql.Test.UnaryConTest+      Polysemy.Hasql.Test.WithInitTest+  hs-source-dirs:+      integration+  default-extensions:+      StandaloneKindSignatures+      AllowAmbiguousTypes+      ApplicativeDo+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveAnyClass+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      DisambiguateRecordFields+      DoAndIfThenElse+      DuplicateRecordFields+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      InstanceSigs+      KindSignatures+      LambdaCase+      LiberalTypeSynonyms+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedLabels+      OverloadedLists+      OverloadedStrings+      PackageImports+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      QuasiQuotes+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UnicodeSyntax+      ViewPatterns+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson ==2.0.*+    , base >=4.12 && <5+    , exon ==1.4.*+    , generics-sop ==0.5.*+    , hasql ==1.6.*+    , hedgehog ==1.1.*+    , polysemy+    , polysemy-db >=0.0.1.0 && <0.1+    , polysemy-hasql >=0.0.1.0 && <0.1+    , polysemy-plugin+    , polysemy-test ==0.7.*+    , prelate >=0.5.1 && <0.6+    , sqel >=0.0.1 && <0.1+    , tasty ==1.4.*+    , uuid ==1.3.*+    , vector ==0.12.*+    , zeugma ==0.7.*+  mixins:+      base hiding (Prelude)+    , prelate (Prelate as Prelude)+    , prelate hiding (Prelate)+  default-language: Haskell2010