1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
{-
This example is mostly just to test that this bug is fixed:
https://github.com/acid-state/acid-state/issues/73
At the end of a run, the checkpoint file should contain a single
checkpoint and the event file should be empty. The old checkpoints and
events should be in the Archive directory.
In the Acrhive directory, each checkpoint file should contain one
checkpoint, and each event file should contain 10 events.
If you comment out the 'createArchive' line below, then the checkpoint
files should contain 10 checkpoints each.
-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module CheckpointCutsEvent (main) where
-- import Control.Concurrent
import Control.Applicative
import Control.Monad
import Control.Monad.State ( get, put )
import Data.Acid
import Data.List ( sort )
import Data.SafeCopy
import System.Directory
import System.Environment
------------------------------------------------------
-- The Haskell structure that we want to encapsulate
newtype Counter = Counter { unCounter :: Integer }
deriving (Show)
$(deriveSafeCopy 0 'base ''Counter)
incCounter :: Update Counter Integer
incCounter =
do (Counter c) <- get
let c' = succ c
put (Counter c')
return c'
$(makeAcidic ''Counter ['incCounter])
main :: IO ()
main = do
putStrLn "CheckpointCutsEvent test"
exists <- doesDirectoryExist fp
when exists $ removeDirectoryRecursive fp
acid <- openLocalStateFrom fp (Counter 0)
replicateM_ 10 $ do is <- replicateM 10 (update acid IncCounter)
print is
createCheckpoint acid
createArchive acid
closeAcidState acid
checkDirectoryContents fp expected_state
checkDirectoryContents (fp ++ "/Archive") expected_archive
s <- readFile (fp ++ "/events-0000000100.log")
unless (s == "") $ error "non-empty events file"
putStrLn "CheckpointCutsEvent done"
where
fp = "state/CheckpointCutsEvent"
expected_state = [".","..","Archive","checkpoints-0000000009.log","checkpoints-0000000010.log"
,"checkpoints.version","events-0000000100.log","events.version","open.lock"]
expected_archive = [".","..","checkpoints-0000000000.log","checkpoints-0000000001.log"
,"checkpoints-0000000002.log","checkpoints-0000000003.log","checkpoints-0000000004.log"
,"checkpoints-0000000005.log","checkpoints-0000000006.log","checkpoints-0000000007.log"
,"checkpoints-0000000008.log","events-0000000000.log","events-0000000010.log"
,"events-0000000020.log","events-0000000030.log","events-0000000040.log"
,"events-0000000050.log","events-0000000060.log","events-0000000070.log"
,"events-0000000080.log","events-0000000090.log"]
checkDirectoryContents :: FilePath -> [FilePath] -> IO ()
checkDirectoryContents fp expected_fs = do
putStrLn $ "Checking contents of " ++ fp
fs <- sort <$> getDirectoryContents fp
unless (fs == expected_fs) $ error $ "bad contents of " ++ fp ++ ": expected "
++ show expected_fs ++ " but got " ++ show fs
|
