content: {-# LANGUAGE TemplateHaskell    #-}
  {-# LANGUAGE TypeFamilies       #-}
  
  -- With optimizations enabled, serializing the checkpoint can happen too quickly
  {-# OPTIONS_GHC -O0 #-}
  
  module SlowCheckpoint (main) where
  
  import           Data.Acid
  
  import           Control.Concurrent
  import           Control.Monad
  import           Control.Monad.Reader  (ask)
  import           Control.Monad.State   (get, put)
  import           Data.SafeCopy
  import           Data.Time
  import           System.Directory
  import           System.IO
  
  ------------------------------------------------------
  -- The Haskell structure that we want to encapsulate
  
  data SlowCheckpoint = SlowCheckpoint Int Int
  
  $(deriveSafeCopy 0 'base ''SlowCheckpoint)
  
  ------------------------------------------------------
  -- The transaction we will execute over the state.
  
  -- This transaction adds a very computationally heavy entry
  -- into our state. However, since the state is lazy, the
  -- chunk will not be forced until we create a checkpoint.
  -- Computing 'last [0..100000000]' takes roughly 2 seconds
  -- on my machine.       XXX Lemmih, 2011-04-26
  setComputationallyHeavyData :: Update SlowCheckpoint ()
  setComputationallyHeavyData = do SlowCheckpoint _slow tick <- get
                                   put $ SlowCheckpoint (last [0..100000000]) tick
  
  tick :: Update SlowCheckpoint Int
  tick = do SlowCheckpoint slow tick <- get
            put $ SlowCheckpoint slow (tick+1)
            return tick
  
  askTick :: Query SlowCheckpoint Int
  askTick = do SlowCheckpoint _ tick <- ask
               return tick
  
  $(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick, 'askTick])
  
  ------------------------------------------------------
  -- This is how AcidState is used:
  
  main :: IO ()
  main = do putStrLn "SlowCheckpoint test"
            exists <- doesDirectoryExist fp
            when exists $ removeDirectoryRecursive fp
            acid <- openLocalStateFrom fp (SlowCheckpoint 0 0)
            putStrLn "This example illustrates that the state is still accessible while"
            putStrLn "a checkpoint is being serialized. This is an important property when"
            putStrLn "the size of a checkpoint reaches several hundred megabytes."
            putStrLn "If you don't see any ticks while the checkpoint is being created, something"
            putStrLn "has gone awry."
            putStrLn ""
            doTick acid
            update acid SetComputationallyHeavyData
            forkIO $ do putStrLn "Serializing checkpoint..."
                        t <- timeIt $ createCheckpoint acid
                        n <- query acid AskTick
                        putStrLn $ "Checkpoint created in: " ++ show t ++ " (saw " ++ show n ++ " ticks)"
                        when (n < threshold) $ error $ "Not enough ticks! Expected at least " ++ show threshold
            replicateM_ 20 $
              do doTick acid
                 threadDelay (10^5)
            putStrLn "SlowCheckpoint done"
    where
      fp = "state/SlowCheckpoint"
  
      -- We must see at least this many ticks for the test to be considered a success
      threshold = 5
  
  doTick acid
      = do tick <- update acid Tick
           putStrLn $ "Tick: " ++ show tick
  
  timeIt action
      = do t1 <- getCurrentTime
           ret <- action
           t2 <- getCurrentTime
           return (diffUTCTime t2 t1)
  