content: {-# Language ScopedTypeVariables #-}
  module Main where
  
  import Prelude
  import System.Directory
  import System.FilePath
  import System.IO
  import Control.Monad (forM_, forever, when)
  import Control.Exception
  import Control.Concurrent
  --import Data.Time
  
  -- How many `openHandle` calls in the test
  -- On a laptop:
  -- * when set to 1k, it occasionally reproduces the failure
  -- * when set to 10k, it occasionally fails to reproduce
  n :: Int
  n = 10000
  
  main :: IO ()
  main = test "."
  
  test :: FilePath -> IO ()
  test dir' = do
    let dir = dir' </> "repro"
    createDirectoryIfMissing True dir
    availableNames <- newChan :: IO (Chan FilePath)
    writeList2Chan availableNames [ dir </> "repro" ++ show (i :: Int) | i <- [1..30]]
    toClose <- newChan :: IO (Chan (Handle, FilePath))
    maybeDelete <- newChan :: IO (Chan FilePath)
    deleter <- forkIO (getChanContents maybeDelete >>= mapM_ (recycle availableNames))
    closer <- forkIO (getChanContents toClose >>= mapM_ (keepClosing availableNames))
    resultMVar <- newEmptyMVar
    openingThread <- keepOpening availableNames toClose maybeDelete `forkFinally`
                        putMVar resultMVar
    interrupter <- forkIO $ forever $ do
      threadDelay (10^3)
      throwTo openingThread Interrupt
  
    result <- readMVar resultMVar
  
    -- cleanup
    mapM_ killThread [interrupter, deleter, closer]
    removeDirectoryRecursive dir
  
    either throwIO (const $ putStrLn "No failures observed - success") result
  
  
  keepOpening :: Chan FilePath -> Chan (Handle, FilePath) -> Chan FilePath -> IO ()
  keepOpening availableNames toClose maybeDelete =
    uninterruptibleMask $ \ restore -> do
      filepaths <- take n <$> getChanContents availableNames
      forM_ filepaths $ \filepath -> do
        --now <- getCurrentTime
        h <- (Just <$> restore (openFile filepath WriteMode)) `catch` \(_ :: Interrupt) -> do
              writeChan maybeDelete filepath
              pure Nothing
        --elapsed <- (`diffUTCTime` now) <$> getCurrentTime
        --print elapsed
        case h of
          Nothing -> pure ()
          Just h -> writeChan toClose (h, filepath)
  
  data Interrupt = Interrupt deriving (Show)
  instance Exception Interrupt
  
  recycle :: Chan FilePath -> FilePath -> IO ()
  recycle availableNames name = do
    exist <- doesFileExist name
    when exist $ removeFile name
    writeChan availableNames name
  
  keepClosing :: Chan FilePath -> (Handle, FilePath) -> IO ()
  keepClosing availableNames (handle, name) = do
    hClose handle
    removeFile name
    writeChan availableNames name
  