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