1module UnitTests.Distribution.Client.Store (tests) where
2
3--import Control.Monad
4--import Control.Concurrent (forkIO, threadDelay)
5--import Control.Concurrent.MVar
6import qualified Data.Set as Set
7import System.FilePath
8import System.Directory
9--import System.Random
10
11import Distribution.Package (UnitId, mkUnitId)
12import Distribution.Compiler (CompilerId(..), CompilerFlavor(..))
13import Distribution.Version  (mkVersion)
14import Distribution.Verbosity (Verbosity, silent)
15import Distribution.Simple.Utils (withTempDirectory)
16
17import Distribution.Client.Store
18import Distribution.Client.RebuildMonad
19
20import Test.Tasty
21import Test.Tasty.HUnit
22
23
24tests :: [TestTree]
25tests =
26  [ testCase "list content empty"  testListEmpty
27  , testCase "install serial"      testInstallSerial
28--, testCase "install parallel"    testInstallParallel
29    --TODO: figure out some way to do a parallel test, see issue below
30  ]
31
32
33testListEmpty :: Assertion
34testListEmpty =
35  withTempDirectory verbosity "." "store-" $ \tmp -> do
36    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")
37
38    assertStoreEntryExists storeDirLayout compid unitid False
39    assertStoreContent tmp storeDirLayout compid        Set.empty
40  where
41    compid = CompilerId GHC (mkVersion [1,0])
42    unitid = mkUnitId "foo-1.0-xyz"
43
44
45testInstallSerial :: Assertion
46testInstallSerial =
47  withTempDirectory verbosity "." "store-" $ \tmp -> do
48    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")
49        copyFiles file content dir = do
50          -- we copy into a prefix inside the tmp dir and return the prefix
51          let destprefix = dir </> "prefix"
52          createDirectory destprefix
53          writeFile (destprefix </> file) content
54          return (destprefix,[])
55
56    assertNewStoreEntry tmp storeDirLayout compid unitid1
57                        (copyFiles "file1" "content-foo") (return ())
58                        UseNewStoreEntry
59
60    assertNewStoreEntry tmp storeDirLayout compid unitid1
61                        (copyFiles "file1" "content-foo") (return ())
62                        UseExistingStoreEntry
63
64    assertNewStoreEntry tmp storeDirLayout compid unitid2
65                        (copyFiles "file2" "content-bar") (return ())
66                        UseNewStoreEntry
67
68    let pkgDir :: UnitId -> FilePath
69        pkgDir = storePackageDirectory storeDirLayout compid
70    assertFileEqual (pkgDir unitid1 </> "file1") "content-foo"
71    assertFileEqual (pkgDir unitid2 </> "file2") "content-bar"
72  where
73    compid  = CompilerId GHC (mkVersion [1,0])
74    unitid1 = mkUnitId "foo-1.0-xyz"
75    unitid2 = mkUnitId "bar-2.0-xyz"
76
77
78{-
79-- unfortunately a parallel test like the one below is thwarted by the normal
80-- process-internal file locking. If that locking were not in place then we
81-- ought to get the blocking behaviour, but due to the normal Handle locking
82-- it just fails instead.
83
84testInstallParallel :: Assertion
85testInstallParallel =
86  withTempDirectory verbosity "." "store-" $ \tmp -> do
87    let storeDirLayout = defaultStoreDirLayout (tmp </> "store")
88
89    sync1 <- newEmptyMVar
90    sync2 <- newEmptyMVar
91    outv  <- newEmptyMVar
92    regv  <- newMVar (0 :: Int)
93
94    sequence_
95      [ do forkIO $ do
96             let copyFiles dir = do
97                   delay <- randomRIO (1,100000)
98                   writeFile (dir </> "file") (show n)
99                   putMVar  sync1 ()
100                   readMVar sync2
101                   threadDelay delay
102                 register = do
103                   modifyMVar_ regv (return . (+1))
104                   threadDelay 200000
105             o <- newStoreEntry verbosity storeDirLayout
106                                compid unitid
107                                copyFiles register
108             putMVar outv (n, o)
109      | n <- [0..9 :: Int] ]
110
111    replicateM_ 10 (takeMVar sync1)
112    -- all threads are in the copyFiles action concurrently, release them:
113    putMVar  sync2 ()
114
115    outcomes <- replicateM 10 (takeMVar outv)
116    regcount <- readMVar regv
117    let regcount' = length [ () | (_, UseNewStoreEntry) <- outcomes ]
118
119    assertEqual "num registrations" 1 regcount
120    assertEqual "num registrations" 1 regcount'
121
122    assertStoreContent tmp storeDirLayout compid (Set.singleton unitid)
123
124    let pkgDir :: UnitId -> FilePath
125        pkgDir = storePackageDirectory storeDirLayout compid
126    case [ n | (n, UseNewStoreEntry) <- outcomes ] of
127      [n] -> assertFileEqual (pkgDir unitid </> "file") (show n)
128      _   -> assertFailure "impossible"
129
130  where
131    compid  = CompilerId GHC (mkVersion [1,0])
132    unitid = mkUnitId "foo-1.0-xyz"
133-}
134
135-------------
136-- Utils
137
138assertNewStoreEntry :: FilePath -> StoreDirLayout
139                    -> CompilerId -> UnitId
140                    -> (FilePath -> IO (FilePath,[FilePath])) -> IO ()
141                    -> NewStoreEntryOutcome
142                    -> Assertion
143assertNewStoreEntry tmp storeDirLayout compid unitid
144                    copyFiles register expectedOutcome = do
145    entries <- runRebuild tmp $ getStoreEntries storeDirLayout compid
146    outcome <- newStoreEntry verbosity storeDirLayout
147                             compid unitid
148                             copyFiles register
149    assertEqual "newStoreEntry outcome" expectedOutcome outcome
150    assertStoreEntryExists storeDirLayout compid unitid True
151    let expected = Set.insert unitid entries
152    assertStoreContent tmp storeDirLayout compid expected
153
154
155assertStoreEntryExists :: StoreDirLayout
156                       -> CompilerId -> UnitId -> Bool
157                       -> Assertion
158assertStoreEntryExists storeDirLayout compid unitid expected = do
159    actual <- doesStoreEntryExist storeDirLayout compid unitid
160    assertEqual "store entry exists" expected actual
161
162
163assertStoreContent :: FilePath -> StoreDirLayout
164                   -> CompilerId -> Set.Set UnitId
165                   -> Assertion
166assertStoreContent tmp storeDirLayout compid expected = do
167    actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid
168    assertEqual "store content" actual expected
169
170
171assertFileEqual :: FilePath -> String -> Assertion
172assertFileEqual path expected = do
173    exists <- doesFileExist path
174    assertBool ("file does not exist:\n" ++ path) exists
175    actual <- readFile path
176    assertEqual ("file content for:\n" ++ path) expected actual
177
178
179verbosity :: Verbosity
180verbosity = silent
181
182