CloseDuringUpdate.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Main(main) where

import           Control.Concurrent
import           Control.Exception
import           Control.Monad.Reader
import           Control.Monad.State
import           Data.Acid
import           Data.SafeCopy
import qualified Data.Map as Map
import           Data.Typeable

data KeyValue = KeyValue !(Map.Map Int String)
    deriving (Eq, Show, Typeable)

$(deriveSafeCopy 0 'base ''KeyValue)

insertKey :: Int -> String -> Update KeyValue ()
insertKey key value
    = do KeyValue m <- get
         put (KeyValue (Map.insert key value m))

$(makeAcidic ''KeyValue ['insertKey])

-- This will eventually fail with "FileLog has been closed" followed
-- by "thread blocked indefinitely in an MVar operation".  I believe
-- the update never returns, probably because the background thread
-- has died at the wrong point.
main :: IO ()
main = forever $ do
    children <- newMVar []
    st <- openLocalStateFrom "test-state/CloseDuringUpdate" (KeyValue Map.empty)
    _ <- forkChild children $ handle hdl $ putStr "U" >> update st (InsertKey 1 "foobar") >> putStr "V"
    _ <- forkChild children $ putStr "C" >> closeAcidState st  >> putStr "X"
    waitForChildren children
  where
    hdl (ErrorCall "Access failure: Core closed.") = putStr "A"
    hdl e = throw e


-- The following are trivially adapted from the "Control.Concurrent"
-- documentation...
waitForChildren :: MVar [MVar ()] -> IO ()
waitForChildren children = do
  cs <- takeMVar children
  case cs of
    []   -> return ()
    m:ms -> do
       putMVar children ms
       takeMVar m
       waitForChildren children

forkChild :: MVar [MVar ()] -> IO () -> IO ThreadId
forkChild children io = do
    mvar <- newEmptyMVar
    childs <- takeMVar children
    putMVar children (mvar:childs)
    forkFinally io (\_ -> putMVar mvar ())

Typical output:

UCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCVXUCCloseDuringUpdate.hs: FileLog has been closed
CallStack (from HasCallStack):
  error, called at src/Data/Acid/Log.hs:150:14 in acid-state-0.16.0-inplace:Data.Acid.Log
XCloseDuringUpdate.hs: thread blocked indefinitely in an MVar operation