cabal-install/tests/UnitTests/Distribution/Client/Store.hs

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