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