Persistent query in progress issue

persistent-mongoDB/persistent-mongoDB.cabal

@@ -22,12 +22,12 @@ library
     build-depends:   base               >= 4.8 && < 5
                    , persistent         >= 2.8   && < 3
                    , aeson              >= 1.0
-                   , bson               >= 0.3.2   && < 0.4
+                   , bson               >= 0.3.2   && < 0.5
                    , bytestring
                    , cereal             >= 0.5
                    , conduit            >= 1.2
                    , http-api-data      >= 0.3.7     && < 0.5
-                   , mongoDB            >= 2.3       && < 2.7
+                   , mongoDB            >= 2.3       && < 2.8
                    , network            >= 2.6
                    , path-pieces        >= 0.2
                    , resource-pool      >= 0.2       && < 0.3

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -40,8 +40,8 @@ import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS
 import Database.PostgreSQL.Simple.Ok (Ok (..))
 
 import Control.Arrow
-import Control.Exception (Exception, throw, throwIO)
-import Control.Monad (forM, guard)
+import Control.Exception (Exception, throw, throwIO, getMaskingState, finally, catch)
+import Control.Monad
 import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO)
 import Control.Monad.Logger (MonadLogger, runNoLoggingT)
 import Control.Monad.Trans.Reader (runReaderT)

persistent-postgresql/persistent-postgresql.cabal

@@ -24,6 +24,7 @@ library
                    , conduit               >= 1.2.12
                    , containers            >= 0.5
                    , monad-logger          >= 0.3.25
+                   , mtl
                    , postgresql-simple     >= 0.6.1    && < 0.7
                    , postgresql-libpq      >= 0.9.4.2  && < 0.10
                    , resourcet             >= 1.1.9
@@ -52,14 +53,17 @@ test-suite test
                      JSONTest
                      CustomConstraintTest
                      PgIntervalTest
+                     QueryInProgressTest
     ghc-options:     -Wall
 
     build-depends:   base                 >= 4.9 && < 5
                    , persistent
+                   , async
                    , persistent-postgresql
                    , persistent-qq
                    , persistent-template
                    , persistent-test
+                   , unliftio-pool
                    , aeson
                    , bytestring
                    , containers
@@ -71,6 +75,7 @@ test-suite test
                    , QuickCheck
                    , quickcheck-instances
                    , resourcet
+                   , resource-pool
                    , text
                    , time
                    , transformers

persistent-postgresql/test/QueryInProgressTest.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs, DataKinds, FlexibleInstances                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeApplications               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+
+module QueryInProgressTest where
+
+import qualified Control.Concurrent            as Concurrent
+import qualified Control.Concurrent.Async      as Concurrent
+import qualified Control.Exception             as Exception
+import qualified Control.Monad                 as Monad
+import           Control.Monad.IO.Class
+import qualified Control.Monad.Logger          as Logger
+import qualified Data.ByteString               as BS
+import           Data.Either
+import qualified Data.Pool                     as Pool
+import           Data.Time
+import qualified Database.Persist              as Persist
+import qualified Database.Persist.Postgresql   as Persist
+import qualified Database.Persist.Sql          as Persist
+import           PgInit
+-- import Database.PostgreSQL.LibPQ (transactionStatus)
+import Data.Maybe
+
+createTableFoo :: Pool.Pool Persist.SqlBackend -> IO ()
+createTableFoo pool = flip Persist.runSqlPersistMPool pool
+    $ Persist.rawExecute "CREATE table if not exists foobar(id int);" []
+
+testInterruptedConnection :: IO (Either SomeException [Maybe (Single String)])
+testInterruptedConnection = do
+    pool <- Logger.runNoLoggingT $ Persist.createPostgresqlPool
+        "postgresql://postgres:secret@localhost/postgres"
+        1
+
+    Monad.void $ createTableFoo pool
+
+    simulateFailedLongRunningPostgresCall pool
+
+    result :: Either SomeException [Maybe (Single String)] <-
+        Exception.try . flip Persist.runSqlPool pool $ do
+
+            Persist.rawSql @(Maybe (Persist.Single String))
+                "select pg_sleep(10)"
+                []
+
+    pure result
+
+
+specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec
+specsWith _ =
+    describe "QueryInProgress" $ fit "queries are cleaned up correctly" $ do
+
+  result <- testInterruptedConnection
+  result `shouldNotSatisfy` isLeft
+
+  -- results :: [Either SomeException [Maybe (Single String)]] <- Concurrent.replicateConcurrently 5 testInterruptedConnection
+  -- results `shouldSatisfy` all (== [Nothing]) . rights
+
+
+
+
+simulateFailedLongRunningPostgresCall :: Pool.Pool Persist.SqlBackend -> IO ()
+simulateFailedLongRunningPostgresCall pool = do
+    threadId <- Concurrent.forkIO
+        (do
+
+            putStrLn
+                "verify pool can't be borrowed and we've set things up correctly"
+
+            let numThings :: Int = 100000000
+            putStrLn $ "start inserting " <> show numThings <> " things"
+
+            Monad.forM_ [1 .. numThings] $ \i -> do
+                Logger.runStdoutLoggingT
+                    $ flip Persist.runSqlPool pool
+                    $
+                      Persist.rawExecute "insert into foobar values(?);"
+                                         [toPersistValue i]
+        )
+
+    putStrLn "waiting 5 seconds"
+    Concurrent.threadDelay 5000000
+    Monad.void $ Concurrent.killThread threadId
+    putStrLn "killed thread"

persistent-postgresql/test/main.hs

@@ -54,6 +54,7 @@ import qualified UpsertTest
 import qualified CustomConstraintTest
 import qualified LongIdentifierTest
 import qualified PgIntervalTest
+import qualified QueryInProgressTest
 
 type Tuple = (,)
 
@@ -102,96 +103,98 @@ setup migration = do
 
 main :: IO ()
 main = do
-  runConn $ do
-    mapM_ setup
-      [ PersistentTest.testMigrate
-      , PersistentTest.noPrefixMigrate
-      , PersistentTest.customPrefixMigrate
-      , PersistentTest.treeMigrate
-      , EmbedTest.embedMigrate
-      , EmbedOrderTest.embedOrderMigrate
-      , LargeNumberTest.numberMigrate
-      , UniqueTest.uniqueMigrate
-      , MaxLenTest.maxlenMigrate
-      , Recursive.recursiveMigrate
-      , CompositeTest.compositeMigrate
-      , TreeTest.treeMigrate
-      , PersistUniqueTest.migration
-      , RenameTest.migration
-      , CustomPersistFieldTest.customFieldMigrate
-      , PrimaryTest.migration
-      , CustomPrimaryKeyReferenceTest.migration
-      , MigrationColumnLengthTest.migration
-      , TransactionLevelTest.migration
-      , LongIdentifierTest.migration
-      , ForeignKey.compositeMigrate
-      , MigrationTest.migrationMigrate
-      , PgIntervalTest.pgIntervalMigrate
-      ]
-    PersistentTest.cleanDB
+  -- runConn $ do
+  --   mapM_ setup
+  --     [ PersistentTest.testMigrate
+  --     , PersistentTest.noPrefixMigrate
+  --     , PersistentTest.customPrefixMigrate
+  --     , PersistentTest.treeMigrate
+  --     , EmbedTest.embedMigrate
+  --     , EmbedOrderTest.embedOrderMigrate
+  --     , LargeNumberTest.numberMigrate
+  --     , UniqueTest.uniqueMigrate
+  --     , MaxLenTest.maxlenMigrate
+  --     , Recursive.recursiveMigrate
+  --     , CompositeTest.compositeMigrate
+  --     , TreeTest.treeMigrate
+  --     , PersistUniqueTest.migration
+  --     , RenameTest.migration
+  --     , CustomPersistFieldTest.customFieldMigrate
+  --     , PrimaryTest.migration
+  --     , CustomPrimaryKeyReferenceTest.migration
+  --     , MigrationColumnLengthTest.migration
+  --     , TransactionLevelTest.migration
+  --     , LongIdentifierTest.migration
+  --     , ForeignKey.compositeMigrate
+  --     , MigrationTest.migrationMigrate
+  --     , PgIntervalTest.pgIntervalMigrate
+  --     ]
+  --   PersistentTest.cleanDB
 
   hspec $ do
-    RenameTest.specsWith runConnAssert
-    DataTypeTest.specsWith runConnAssert
-        (Just (runMigrationSilent dataTypeMigrate))
-        [ TestFn "text" dataTypeTableText
-        , TestFn "textMaxLen" dataTypeTableTextMaxLen
-        , TestFn "bytes" dataTypeTableBytes
-        , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple
-        , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen
-        , TestFn "int" dataTypeTableInt
-        , TestFn "intList" dataTypeTableIntList
-        , TestFn "intMap" dataTypeTableIntMap
-        , TestFn "bool" dataTypeTableBool
-        , TestFn "day" dataTypeTableDay
-        , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime)
-        , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc)
-        , TestFn "jsonb" dataTypeTableJsonb
-        ]
-        [ ("pico", dataTypeTablePico) ]
-        dataTypeTableDouble
-    HtmlTest.specsWith
-        runConnAssert
-        (Just (runMigrationSilent HtmlTest.htmlMigrate))
+  --   RenameTest.specsWith runConnAssert
+  --   DataTypeTest.specsWith runConnAssert
+  --       (Just (runMigrationSilent dataTypeMigrate))
+  --       [ TestFn "text" dataTypeTableText
+  --       , TestFn "textMaxLen" dataTypeTableTextMaxLen
+  --       , TestFn "bytes" dataTypeTableBytes
+  --       , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple
+  --       , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen
+  --       , TestFn "int" dataTypeTableInt
+  --       , TestFn "intList" dataTypeTableIntList
+  --       , TestFn "intMap" dataTypeTableIntMap
+  --       , TestFn "bool" dataTypeTableBool
+  --       , TestFn "day" dataTypeTableDay
+  --       , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime)
+  --       , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc)
+  --       , TestFn "jsonb" dataTypeTableJsonb
+  --       ]
+  --       [ ("pico", dataTypeTablePico) ]
+  --       dataTypeTableDouble
+  --   HtmlTest.specsWith
+  --       runConnAssert
+  --       (Just (runMigrationSilent HtmlTest.htmlMigrate))
 
-    EmbedTest.specsWith runConnAssert
-    EmbedOrderTest.specsWith runConnAssert
-    LargeNumberTest.specsWith runConnAssert
-    ForeignKey.specsWith runConnAssert
-    UniqueTest.specsWith runConnAssert
-    MaxLenTest.specsWith runConnAssert
-    Recursive.specsWith runConnAssert
-    SumTypeTest.specsWith runConnAssert (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))
-    MigrationTest.specsWith runConnAssert
-    MigrationOnlyTest.specsWith runConnAssert
+  --   EmbedTest.specsWith runConnAssert
+  --   EmbedOrderTest.specsWith runConnAssert
+  --   LargeNumberTest.specsWith runConnAssert
+  --   ForeignKey.specsWith runConnAssert
+  --   UniqueTest.specsWith runConnAssert
+  --   MaxLenTest.specsWith runConnAssert
+  --   Recursive.specsWith runConnAssert
+  --   SumTypeTest.specsWith runConnAssert (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))
+  --   MigrationTest.specsWith runConnAssert
+  --   MigrationOnlyTest.specsWith runConnAssert
 
-        (Just
-            $ runMigrationSilent MigrationOnlyTest.migrateAll1
-            >> runMigrationSilent MigrationOnlyTest.migrateAll2
-        )
-    PersistentTest.specsWith runConnAssert
-    ReadWriteTest.specsWith runConnAssert
-    PersistentTest.filterOrSpecs runConnAssert
-    RawSqlTest.specsWith runConnAssert
-    UpsertTest.specsWith
-        runConnAssert
-        UpsertTest.Don'tUpdateNull
-        UpsertTest.UpsertPreserveOldKey
+  --       (Just
+  --           $ runMigrationSilent MigrationOnlyTest.migrateAll1
+  --           >> runMigrationSilent MigrationOnlyTest.migrateAll2
+  --       )
+  --   PersistentTest.specsWith runConnAssert
+  --   ReadWriteTest.specsWith runConnAssert
+  --   PersistentTest.filterOrSpecs runConnAssert
+  --   RawSqlTest.specsWith runConnAssert
+  --   UpsertTest.specsWith
+  --       runConnAssert
+  --       UpsertTest.Don'tUpdateNull
+  --       UpsertTest.UpsertPreserveOldKey
+
+  --   MpsNoPrefixTest.specsWith runConnAssert
+  --   MpsCustomPrefixTest.specsWith runConnAssert
+  --   EmptyEntityTest.specsWith runConnAssert (Just (runMigrationSilent EmptyEntityTest.migration))
+  --   CompositeTest.specsWith runConnAssert
+  --   TreeTest.specsWith runConnAssert
+  --   PersistUniqueTest.specsWith runConnAssert
+  --   PrimaryTest.specsWith runConnAssert
+  --   CustomPersistFieldTest.specsWith runConnAssert
+  --   CustomPrimaryKeyReferenceTest.specsWith runConnAssert
+  --   MigrationColumnLengthTest.specsWith runConnAssert
+  --   EquivalentTypeTestPostgres.specs
+  --   TransactionLevelTest.specsWith runConnAssert
+  --   LongIdentifierTest.specsWith runConnAssert
+  --   JSONTest.specs
+  --   CustomConstraintTest.specs
+  --   PgIntervalTest.specs
+  --   ArrayAggTest.specs
+    QueryInProgressTest.specsWith runConnAssert
 
-    MpsNoPrefixTest.specsWith runConnAssert
-    MpsCustomPrefixTest.specsWith runConnAssert
-    EmptyEntityTest.specsWith runConnAssert (Just (runMigrationSilent EmptyEntityTest.migration))
-    CompositeTest.specsWith runConnAssert
-    TreeTest.specsWith runConnAssert
-    PersistUniqueTest.specsWith runConnAssert
-    PrimaryTest.specsWith runConnAssert
-    CustomPersistFieldTest.specsWith runConnAssert
-    CustomPrimaryKeyReferenceTest.specsWith runConnAssert
-    MigrationColumnLengthTest.specsWith runConnAssert
-    EquivalentTypeTestPostgres.specs
-    TransactionLevelTest.specsWith runConnAssert
-    LongIdentifierTest.specsWith runConnAssert
-    JSONTest.specs
-    CustomConstraintTest.specs
-    PgIntervalTest.specs
-    ArrayAggTest.specs

persistent/Database/Persist/Sql/Raw.hs

@@ -60,6 +60,7 @@ rawExecuteCount sql vals = do
     conn <- projectBackend `liftM` ask
     runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals)
         (connLogFunc conn)
+    -- liftIO $ putStrLn "rawExecute"
     stmt <- getStmt sql
     res <- liftIO $ stmtExecute stmt vals
     liftIO $ stmtReset stmt
@@ -212,8 +213,12 @@ rawSql stmt = run
       process = rawSqlProcessRow
 
       withStmt' colSubsts params sink = do
+            liftIO $ putStrLn " calling withStmt'"
             srcRes <- rawQueryRes sql params
-            liftIO $ with srcRes (\src -> runConduit $ src .| sink)
+            liftIO $ putStrLn "about to call with"
+            res <- liftIO $ with srcRes (\src -> runConduit $ src .| sink)
+            liftIO $ putStrLn "called with"
+            pure res
           where
             sql = T.concat $ makeSubsts colSubsts $ T.splitOn placeholder stmt
             placeholder = "??"
@@ -232,6 +237,7 @@ rawSql stmt = run
       run params = do
         conn <- projectBackend `liftM` ask
         let (colCount, colSubsts) = rawSqlCols (connEscapeName conn) x
+        liftIO $ putStrLn "foo foo"
         withStmt' colSubsts params $ firstRow colCount
 
       firstRow colCount = do