{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

-- | This executable is a test of the issue raised in #1199.
module Main where

import Prelude hiding (show)
import qualified Prelude

import qualified Control.Monad as Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import qualified Control.Monad.Logger as Logger
import Control.Monad.Trans
import Control.Monad.Trans.Reader
import qualified Data.ByteString as BS
import Data.Coerce
import qualified Data.Pool as Pool
import qualified Data.Text as Text
import Data.Time
import qualified Database.Persist as Persist
import qualified Database.Persist.Postgresql as Persist
import qualified Database.Persist.Sql as Persist
import UnliftIO
import qualified UnliftIO.Concurrent as Concurrent
import qualified UnliftIO.Exception as Exception

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"