module Data.Disk.Swapper.HappstackCompat (
createSwapperCheckpoint,
) where
import Control.Concurrent.MVar
import Data.Binary
import Data.Binary.Get
import Happstack.Data
import Happstack.State
import System.IO.Unsafe
import Unsafe.Coerce
import Data.Disk.Swapper
import Data.Disk.Swapper.Snapshot
data X = forall a. X a
checkGet :: MVar [(FilePath, X)]
checkGet = unsafePerformIO $ newMVar []
checkPut :: MVar [(FilePath, Put)]
checkPut = unsafePerformIO newEmptyMVar
instance Snapshot (Swapper f a) => Serialize (Swapper f a) where
getCopy = contain . check $ getFromSnapshot
where check getIO = do
prefix <- lookAhead safeGet
load <- getIO
return . unsafePerformIO $ do
c <- takeMVar checkGet
case lookup prefix c of
Just (X x) -> putMVar checkGet c >> return (unsafeCoerce x)
Nothing -> do x <- load
putMVar checkGet ((prefix, X x) : c)
return x
putCopy sw = contain . check . putToSnapshot $ sw
where check ioPut = unsafePerformIO $ do
c <- takeMVar checkPut
let prefix = swapperDBPrefix sw
case lookup prefix c of
Just p -> putMVar checkPut c >> return p
Nothing -> do p <- ioPut
putMVar checkPut ((prefix, p) : c)
return p
createSwapperCheckpoint :: MVar TxControl -> IO ()
createSwapperCheckpoint txc = do
#ifdef TRACE_SAVING
putStrLn "createSwapperCheckpoint"
#endif
putMVar checkPut []
createCheckpoint txc
takeMVar checkPut
return ()