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

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2
   3 module UnitTests.Distribution.Client.FetchUtils
   4   ( tests
   5   )
   6 where
   7
   8 import Control.Concurrent (threadDelay)
   9 import Control.Exception
  10 import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
  11 import Distribution.Client.FetchUtils
  12 import Distribution.Client.GlobalFlags (RepoContext (..))
  13 import Distribution.Client.HttpUtils (HttpCode, HttpTransport (..))
  14 import Distribution.Client.Types.PackageLocation (PackageLocation (..), ResolvedPkgLoc)
  15 import Distribution.Client.Types.Repo (Repo (..), emptyRemoteRepo)
  16 import Distribution.Client.Types.RepoName (RepoName (..))
  17 import Distribution.Types.PackageId (PackageIdentifier (..))
  18 import Distribution.Types.PackageName (mkPackageName)
  19 import qualified Distribution.Verbosity as Verbosity
  20 import Distribution.Version (mkVersion)
  21 import Network.URI (URI, uriPath)
  22 import Test.Tasty
  23 import Test.Tasty.HUnit
  24 import Test.Utils.TempTestDir (withTestDir)
  25
  26 tests :: [TestTree]
  27 tests =
  28   [ testGroup
  29       "asyncFetchPackages"
  30       [ testCase "handles an empty package list" testEmpty
  31       , testCase "passes an unpacked local package through" testPassLocalPackage
  32       , testCase "handles http" testHttp
  33       , testCase "aborts on interrupt in GET" $ testGetInterrupt
  34       , testCase "aborts on other exception in GET" $ testGetException
  35       , testCase "aborts on interrupt in GET (uncollected download)" $ testUncollectedInterrupt
  36       , testCase "continues on other exception in GET (uncollected download)" $ testUncollectedException
  37       ]
  38   ]
  39
  40 verbosity :: Verbosity.Verbosity
  41 verbosity = Verbosity.silent
  42
  43 -- | An interval that we use to assert that something happens "immediately".
  44 -- Must be shorter than 'longSleep' to ensure those are interrupted.
  45 -- 1s would be a reasonable value, but failed tempfile cleanup on Windows CI
  46 -- takes ~1s.
  47 shortDelta :: NominalDiffTime
  48 shortDelta = 5 -- 5s
  49
  50 longSleep :: IO ()
  51 longSleep = threadDelay 10000000 -- 10s
  52
  53 testEmpty :: Assertion
  54 testEmpty = do
  55   let repoCtxt = undefined
  56       pkgLocs = []
  57   res <- asyncFetchPackages verbosity repoCtxt pkgLocs $ \_ ->
  58     return ()
  59   res @?= ()
  60
  61 testPassLocalPackage :: Assertion
  62 testPassLocalPackage = do
  63   let repoCtxt = error "repoCtxt undefined"
  64       loc = LocalUnpackedPackage "a"
  65   res <- asyncFetchPackages verbosity repoCtxt [loc] $ \downloadMap ->
  66     waitAsyncFetchPackage verbosity downloadMap loc
  67   res @?= LocalUnpackedPackage "a"
  68
  69 testHttp :: Assertion
  70 testHttp = withFakeRepoCtxt get200 $ \repoCtxt repo -> do
  71   let pkgId = mkPkgId "foo"
  72       loc = RepoTarballPackage repo pkgId Nothing
  73   res <- asyncFetchPackages verbosity repoCtxt [loc] $ \downloadMap ->
  74     waitAsyncFetchPackage verbosity downloadMap loc
  75   case res of
  76     RepoTarballPackage repo' pkgId' _ -> do
  77       repo' @?= repo
  78       pkgId' @?= pkgId
  79     _ -> assertFailure $ "expected RepoTarballPackage, got " ++ show res
  80   where
  81     get200 = \_uri -> return 200
  82
  83 testGetInterrupt :: Assertion
  84 testGetInterrupt = testGetAny UserInterrupt
  85
  86 testGetException :: Assertion
  87 testGetException = testGetAny $ userError "some error"
  88
  89 -- | Test that if a GET request fails with the given exception,
  90 -- we exit promptly. We queue two slow downloads after the failing
  91 -- download to cover a buggy scenario where
  92 -- 1. first download throws
  93 -- 2. second download is cancelled, but swallows AsyncCancelled
  94 -- 3. third download keeps running
  95 testGetAny :: Exception e => e -> Assertion
  96 testGetAny exc = withFakeRepoCtxt get $ \repoCtxt repo -> do
  97   let loc pkgId = RepoTarballPackage repo pkgId Nothing
  98       pkgLocs = [loc throws, loc slowA, loc slowB]
  99
 100   start <- getCurrentTime
 101   res :: Either SomeException ResolvedPkgLoc <-
 102     try $
 103       asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do
 104         waitAsyncFetchPackage verbosity downloadMap (loc throws)
 105   assertFaster start shortDelta
 106   case res of
 107     Left _ -> pure ()
 108     Right _ -> assertFailure $ "expected an exception, got " ++ show res
 109   where
 110     throws = mkPkgId "throws"
 111     slowA = mkPkgId "slowA"
 112     slowB = mkPkgId "slowB"
 113     get uri = case uriPath uri of
 114       "package/throws-1.0.tar.gz" -> throwIO exc
 115       "package/slowA-1.0.tar.gz" -> longSleep >> return 200
 116       "package/slowB-1.0.tar.gz" -> longSleep >> return 200
 117       _ -> assertFailure $ "unexpected URI: " ++ show uri
 118
 119 -- | Test that when an undemanded download is interrupted (Ctrl-C),
 120 -- we still abort directly.
 121 testUncollectedInterrupt :: Assertion
 122 testUncollectedInterrupt = withFakeRepoCtxt get $ \repoCtxt repo -> do
 123   let loc pkgId = RepoTarballPackage repo pkgId Nothing
 124       pkgLocs = [loc throws, loc slowA, loc slowB]
 125
 126   start <- getCurrentTime
 127   res :: Either SomeException ResolvedPkgLoc <-
 128     try $
 129       asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do
 130         waitAsyncFetchPackage verbosity downloadMap (loc slowA)
 131   assertFaster start shortDelta
 132   case res of
 133     Left _ -> pure ()
 134     Right _ -> assertFailure $ "expected an exception, got " ++ show res
 135   where
 136     throws = mkPkgId "throws"
 137     slowA = mkPkgId "slowA"
 138     slowB = mkPkgId "slowB"
 139     get uri = case uriPath uri of
 140       "package/throws-1.0.tar.gz" -> throwIO UserInterrupt
 141       "package/slowA-1.0.tar.gz" -> longSleep >> return 200
 142       "package/slowB-1.0.tar.gz" -> longSleep >> return 200
 143       _ -> assertFailure $ "unexpected URI: " ++ show uri
 144
 145 -- | Test that a download failure doesn't automatically abort things,
 146 -- e.g. if we don't collect the download. (In practice, we might collect
 147 -- the download and handle its exception.)
 148 testUncollectedException :: Assertion
 149 testUncollectedException = withFakeRepoCtxt get $ \repoCtxt repo -> do
 150   let loc pkgId = RepoTarballPackage repo pkgId Nothing
 151       pkgLocs = [loc throws, loc foo]
 152
 153   start <- getCurrentTime
 154   res <- asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do
 155     waitAsyncFetchPackage verbosity downloadMap (loc foo)
 156   assertFaster start shortDelta
 157   case res of
 158     RepoTarballPackage repo' pkgId' _ -> do
 159       repo' @?= repo
 160       pkgId' @?= foo
 161     _ -> assertFailure $ "expected RepoTarballPackage, got " ++ show res
 162   where
 163     throws = mkPkgId "throws"
 164     foo = mkPkgId "foo"
 165     get uri = case uriPath uri of
 166       "package/throws-1.0.tar.gz" -> throwIO $ userError "failed download"
 167       "package/foo-1.0.tar.gz" -> return 200
 168       _ -> assertFailure $ "unexpected URI: " ++ show uri
 169
 170 assertFaster :: UTCTime -> NominalDiffTime -> Assertion
 171 assertFaster start delta = do
 172   t <- getCurrentTime
 173   assertBool ("took longer than " ++ show delta) (diffUTCTime t start < delta)
 174
 175 mkPkgId :: String -> PackageIdentifier
 176 mkPkgId name = PackageIdentifier (mkPackageName name) (mkVersion [1, 0])
 177
 178 -- | Provide a repo and a repo context with the given GET handler.
 179 withFakeRepoCtxt
 180   :: (URI -> IO HttpCode)
 181   -> (RepoContext -> Repo -> IO a)
 182   -> IO a
 183 withFakeRepoCtxt handleGet action =
 184   withTestDir verbosity "fake repo" $ \tmpDir ->
 185     let repo =
 186           RepoRemote
 187             { repoRemote = emptyRemoteRepo $ RepoName "fake"
 188             , repoLocalDir = tmpDir
 189             }
 190         repoCtxt =
 191           RepoContext
 192             { repoContextRepos = [repo]
 193             , repoContextGetTransport = return httpTransport
 194             , repoContextWithSecureRepo = \_ _ ->
 195                 error "fake repo ctxt: repoContextWithSecureRepo not implemented"
 196             , repoContextIgnoreExpiry = error "fake repo ctxt: repoContextIgnoreExpiry not implemented"
 197             }
 198      in action repoCtxt repo
 199   where
 200     httpTransport =
 201       HttpTransport
 202         { getHttp = \_verbosity uri _etag _filepath _headers -> do
 203             code <- handleGet uri
 204             return (code, Nothing)
 205         , postHttp = error "fake transport: postHttp not implemented"
 206         , postHttpFile = error "fake transport: postHttpFile not implemented"
 207         , putHttpFile = error "fake transport: putHttp not implemented"
 208         , transportSupportsHttps = error "fake transport: transportSupportsHttps not implemented"
 209         , transportManuallySelected = True
 210         }