Exhibits a libpq bug.

_README.md

This script shows an error with the persistent-postgresql Haskell library. It reliably crashes with this output:

libpq-error: libpq: failed (another command is already in progress)

yesodweb/persistent#1199

---

As far as I can tell this only affects PostgreSQL while using a pool. If withPostgresqlPool is changed to withPostgresqlConn, this error does not happen.

---

Switching from forkIO to async appears to make this problem go away.

---

I cannot reproduce this problem using postgresql-simple and resource-pool directly.

---

I don't get the error if I use rawSql instead of rawExecute.

docker-compose.yaml

version: '3.7'
services:
  haskell:
    build: .
    command: stack build --file-watch --exec libpq-error
    depends_on:
      - postgres
    environment:
      PGHOST: postgres
      PGUSER: postgres
      STACK_ROOT: $PWD/.stack/root
      STACK_WORK: .stack/work
    init: true
    tty: true
    volumes:
      - .:$PWD
    working_dir: $PWD
  postgres:
    environment:
      POSTGRES_HOST_AUTH_METHOD: trust
    image: postgres:11.11

Dockerfile

FROM haskell:8.10
RUN apt-get update && apt-get install --yes libpq-dev
ARG USER=haskell
RUN useradd --create-home "$USER"
USER $USER

libpq-error.cabal

build-type: Simple
cabal-version: >= 1.2
name: libpq-error
version: 2021.3.10
executable libpq-error
  build-depends: base, monad-logger, persistent-postgresql
  ghc-options:
    -Weverything
    -Wno-all-missed-specialisations
    -Wno-implicit-prelude
    -Wno-missing-exported-signatures
    -Wno-missing-safe-haskell-mode
    -Wno-prepositive-qualified-module
    -Wno-unsafe
  main-is: Main.hs

Main.hs

{-# language OverloadedStrings #-}

import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (runStdoutLoggingT)
import Database.Persist.Postgresql (rawExecute, runSqlPool, withPostgresqlPool)

main :: IO ()
main = runStdoutLoggingT . withPostgresqlPool "" 1 $ \ pool -> liftIO $ do
  threadId <- forkIO
    . runStdoutLoggingT
    $ runSqlPool (rawExecute "select pg_sleep(1)" []) pool

  putStrLn "Waiting for the thread to start ..."
  threadDelay 500000

  putStrLn "Killing the thread ..."
  killThread threadId

  -- Wait around a little bit for the error to be output.
  threadDelay 500000
  putStrLn "Done."

stack.yaml

allow-different-user: true
compiler: ghc-8.10.2
resolver: lts-17.5
system-ghc: true