1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, GeneralizedNewtypeDeriving, DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings, QuantifiedConstraints #-}
{-# LANGUAGE TypeApplications #-}
{-# language OverloadedStrings #-}
-- | This executable is a test of the issue raised in #1199.
module Main where
import Prelude hiding (show)
import qualified Prelude
import qualified Data.Text as Text
import Control.Monad.IO.Class
import qualified Control.Monad as Monad
import qualified UnliftIO.Concurrent as Concurrent
import qualified UnliftIO.Exception as Exception
import qualified Database.Persist as Persist
import qualified Database.Persist.Sql as Persist
import qualified Database.Persist.Postgresql as Persist
import qualified Control.Monad.Logger as Logger
import Control.Monad.Logger
import qualified Data.ByteString as BS
import qualified Data.Pool as Pool
import Data.Time
import UnliftIO
import Data.Coerce
import Control.Monad.Trans.Reader
import Control.Monad.Trans
newtype LogPrefixT m a = LogPrefixT { runLogPrefixT :: ReaderT LogStr m a }
deriving newtype
(Functor, Applicative, Monad, MonadIO, MonadTrans)
instance MonadLogger m => MonadLogger (LogPrefixT m) where
monadLoggerLog loc src lvl msg = LogPrefixT $ ReaderT $ \prefix ->
monadLoggerLog loc src lvl (toLogStr prefix <> toLogStr msg)
deriving newtype instance (forall a b. Coercible a b => Coercible (m a) (m b), MonadUnliftIO m) => MonadUnliftIO (LogPrefixT m)
prefixLogs :: Text.Text -> LogPrefixT m a -> m a
prefixLogs prefix =
flip runReaderT (toLogStr $! mconcat ["[", prefix, "] "]) . runLogPrefixT
infixr 5 `prefixLogs`
show :: Show a => a -> Text.Text
show = Text.pack . Prelude.show
main :: IO ()
main = runStdoutLoggingT $ Concurrent.myThreadId >>= \tid -> prefixLogs (show tid) $ do
-- I started a postgres server with:
-- docker run --rm --name some-postgres -p 5432:5432 -e POSTGRES_PASSWORD=secret postgres
pool <- Logger.runNoLoggingT $ Persist.createPostgresqlPool "postgresql://postgres:secret@localhost:5433/postgres" 1
logInfoN "creating table..."
Monad.void $ liftIO $ createTableFoo pool
liftIO getCurrentTime >>= \now ->
simulateFailedLongRunningPostgresCall pool
-- logInfoN "destroying resources"
-- liftIO $ Pool.destroyAllResources pool
logInfoN "pg_sleep"
result :: Either Exception.SomeException [Persist.Single (Maybe String)] <-
Exception.try . (liftIO . (flip Persist.runSqlPersistMPool) pool) $ do
Persist.rawSql @(Persist.Single (Maybe String)) "select pg_sleep(2)" []
-- when we try the above we get back:
-- 'result: Left libpq: failed (another command is already in progress'
-- this is because the connection went back into the pool before it was ready
-- or perhaps it should have been destroyed and a new connection created and put into the pool?
logInfoN $ "result: " <> show result
createTableFoo :: Pool.Pool Persist.SqlBackend -> IO ()
createTableFoo pool = (flip Persist.runSqlPersistMPool) pool $ do
Persist.rawExecute "CREATE table if not exists foo(id int);" []
simulateFailedLongRunningPostgresCall
:: (MonadLogger m, MonadUnliftIO m, forall a b. Coercible a b => Coercible (m a) (m b)) => Pool.Pool Persist.SqlBackend -> m ()
simulateFailedLongRunningPostgresCall pool = do
threadId <- Concurrent.forkIO
$ (do
me <- Concurrent.myThreadId
prefixLogs (show me) $ do
let numThings :: Int = 100000000
logInfoN $ "start inserting " <> show numThings <> " things"
(`Persist.runSqlPool` pool) $ do
logInfoN "inside of thing"
Monad.forM_ [1 .. numThings] $ \i -> do
Monad.when (i `mod` 1000 == 0) $
logInfoN $ "Thing #: " <> show i
Persist.rawExecute "insert into foo values(1);" []
)
Concurrent.threadDelay 1000000
Monad.void $ Concurrent.killThread threadId
logInfoN "killed thread"
|
