cabal-install/src/Distribution/Client/FetchUtils.hs

   1 -----------------------------------------------------------------------------
   2 -----------------------------------------------------------------------------
   3 {-# LANGUAGE RecordWildCards #-}
   4 -----------------------------------------------------------------------------
   5 -----------------------------------------------------------------------------
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7
   8 -- |
   9 -- Module      :  Distribution.Client.FetchUtils
  10 -- Copyright   :  (c) David Himmelstrup 2005
  11 --                    Duncan Coutts 2011
  12 -- License     :  BSD-like
  13 --
  14 -- Maintainer  :  cabal-devel@gmail.com
  15 -- Stability   :  provisional
  16 -- Portability :  portable
  17 --
  18 -- Functions for fetching packages
  19 module Distribution.Client.FetchUtils
  20   ( -- * fetching packages
  21     fetchPackage
  22   , isFetched
  23   , checkFetched
  24
  25     -- ** specifically for repo packages
  26   , checkRepoTarballFetched
  27   , fetchRepoTarball
  28   , verifyFetchedTarball
  29
  30     -- ** fetching packages asynchronously
  31   , asyncFetchPackages
  32   , waitAsyncFetchPackage
  33   , AsyncFetchMap
  34
  35     -- * fetching other things
  36   , downloadIndex
  37   ) where
  38
  39 import Distribution.Client.Compat.Prelude
  40 import Prelude ()
  41
  42 import Distribution.Client.HttpUtils
  43   ( DownloadResult (..)
  44   , HttpTransport (..)
  45   , downloadURI
  46   , isOldHackageURI
  47   , remoteRepoCheckHttps
  48   , transportCheckHttps
  49   )
  50 import Distribution.Client.Types
  51
  52 import Distribution.Client.GlobalFlags
  53   ( RepoContext (..)
  54   )
  55 import Distribution.Client.Utils
  56   ( ProgressPhase (..)
  57   , progressMessage
  58   )
  59 import Distribution.Package
  60   ( PackageId
  61   , packageName
  62   , packageVersion
  63   )
  64 import Distribution.Simple.Utils
  65   ( debug
  66   , dieWithException
  67   , info
  68   , notice
  69   , warn
  70   )
  71 import Distribution.Verbosity
  72   ( verboseUnmarkOutput
  73   )
  74
  75 import Control.Concurrent.Async
  76 import Control.Concurrent.MVar
  77 import qualified Control.Exception.Safe as Safe
  78 import qualified Data.Map as Map
  79 import Network.URI
  80   ( URI (uriPath)
  81   )
  82 import System.Directory
  83   ( createDirectoryIfMissing
  84   , doesFileExist
  85   , getFileSize
  86   , getTemporaryDirectory
  87   )
  88 import System.FilePath
  89   ( (<.>)
  90   , (</>)
  91   )
  92 import qualified System.FilePath.Posix as FilePath.Posix
  93   ( combine
  94   , joinPath
  95   )
  96 import System.IO
  97   ( hClose
  98   , openTempFile
  99   )
 100
 101 import Distribution.Client.Errors
 102 import qualified Hackage.Security.Client as Sec
 103 import qualified Hackage.Security.Util.Checked as Sec
 104 import qualified Hackage.Security.Util.Path as Sec
 105
 106 -- ------------------------------------------------------------
 107
 108 -- * Actually fetch things
 109
 110 -- ------------------------------------------------------------
 111
 112 -- | Returns @True@ if the package has already been fetched
 113 -- or does not need fetching.
 114 isFetched :: UnresolvedPkgLoc -> IO Bool
 115 isFetched loc = case loc of
 116   LocalUnpackedPackage _dir -> return True
 117   LocalTarballPackage _file -> return True
 118   RemoteTarballPackage _uri local -> return (isJust local)
 119   RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)
 120   RemoteSourceRepoPackage _ local -> return (isJust local)
 121
 122 -- | Checks if the package has already been fetched (or does not need
 123 -- fetching) and if so returns evidence in the form of a 'PackageLocation'
 124 -- with a resolved local file location.
 125 checkFetched
 126   :: UnresolvedPkgLoc
 127   -> IO (Maybe ResolvedPkgLoc)
 128 checkFetched loc = case loc of
 129   LocalUnpackedPackage dir ->
 130     return (Just $ LocalUnpackedPackage dir)
 131   LocalTarballPackage file ->
 132     return (Just $ LocalTarballPackage file)
 133   RemoteTarballPackage uri (Just file) ->
 134     return (Just $ RemoteTarballPackage uri file)
 135   RepoTarballPackage repo pkgid (Just file) ->
 136     return (Just $ RepoTarballPackage repo pkgid file)
 137   RemoteSourceRepoPackage repo (Just file) ->
 138     return (Just $ RemoteSourceRepoPackage repo file)
 139   RemoteTarballPackage _uri Nothing -> return Nothing
 140   RemoteSourceRepoPackage _repo Nothing -> return Nothing
 141   RepoTarballPackage repo pkgid Nothing ->
 142     fmap
 143       (fmap (RepoTarballPackage repo pkgid))
 144       (checkRepoTarballFetched repo pkgid)
 145
 146 -- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.
 147 checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)
 148 checkRepoTarballFetched repo pkgid = do
 149   let file = packageFile repo pkgid
 150   exists <- doesFileExist file
 151   if exists
 152     then return (Just file)
 153     else return Nothing
 154
 155 verifyFetchedTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO Bool
 156 verifyFetchedTarball verbosity repoCtxt repo pkgid =
 157   let file = packageFile repo pkgid
 158       handleError :: IO Bool -> IO Bool
 159       handleError act = do
 160         res <- Safe.try act
 161         case res of
 162           Left e -> warn verbosity ("Error verifying fetched tarball " ++ file ++ ", will redownload: " ++ show (e :: SomeException)) >> pure False
 163           Right b -> pure b
 164    in handleError $ do
 165         exists <- doesFileExist file
 166         if not exists
 167           then return True -- if the file does not exist, it vacuously passes validation, since it will be downloaded as necessary with what we will then check is a valid hash.
 168           else case repo of
 169             -- a secure repo has hashes we can compare against to confirm this is the correct file.
 170             RepoSecure{} ->
 171               repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
 172                 Sec.withIndex repoSecure $ \callbacks ->
 173                   let warnAndFail s = warn verbosity ("Fetched tarball " ++ file ++ " does not match server, will redownload: " ++ s) >> return False
 174                    in -- the do block in parens is due to dealing with the checked exceptions mechanism.
 175                       ( do
 176                           fileInfo <- Sec.indexLookupFileInfo callbacks pkgid
 177                           sz <- Sec.FileLength . fromInteger <$> getFileSize file
 178                           if sz /= Sec.fileInfoLength (Sec.trusted fileInfo)
 179                             then warnAndFail "file length mismatch"
 180                             else do
 181                               res <- Sec.compareTrustedFileInfo (Sec.trusted fileInfo) <$> Sec.computeFileInfo (Sec.Path file :: Sec.Path Sec.Absolute)
 182                               if res
 183                                 then pure True
 184                                 else warnAndFail "file hash mismatch"
 185                       )
 186                         `Sec.catchChecked` (\(e :: Sec.InvalidPackageException) -> warnAndFail (show e))
 187                         `Sec.catchChecked` (\(e :: Sec.VerificationError) -> warnAndFail (show e))
 188             _ -> pure True
 189
 190 -- | Fetch a package if we don't have it already.
 191 fetchPackage
 192   :: Verbosity
 193   -> RepoContext
 194   -> UnresolvedPkgLoc
 195   -> IO ResolvedPkgLoc
 196 fetchPackage verbosity repoCtxt loc = case loc of
 197   LocalUnpackedPackage dir ->
 198     return (LocalUnpackedPackage dir)
 199   LocalTarballPackage file ->
 200     return (LocalTarballPackage file)
 201   RemoteTarballPackage uri (Just file) ->
 202     return (RemoteTarballPackage uri file)
 203   RepoTarballPackage repo pkgid (Just file) ->
 204     return (RepoTarballPackage repo pkgid file)
 205   RemoteSourceRepoPackage repo (Just dir) ->
 206     return (RemoteSourceRepoPackage repo dir)
 207   RemoteTarballPackage uri Nothing -> do
 208     path <- downloadTarballPackage uri
 209     return (RemoteTarballPackage uri path)
 210   RepoTarballPackage repo pkgid Nothing -> do
 211     local <- fetchRepoTarball verbosity repoCtxt repo pkgid
 212     return (RepoTarballPackage repo pkgid local)
 213   RemoteSourceRepoPackage _repo Nothing ->
 214     dieWithException verbosity FetchPackageErr
 215   where
 216     downloadTarballPackage :: URI -> IO FilePath
 217     downloadTarballPackage uri = do
 218       transport <- repoContextGetTransport repoCtxt
 219       transportCheckHttps verbosity transport uri
 220       notice verbosity ("Downloading " ++ show uri)
 221       tmpdir <- getTemporaryDirectory
 222       (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"
 223       hClose hnd
 224       _ <- downloadURI transport verbosity uri path
 225       return path
 226
 227 -- | Fetch a repo package if we don't have it already.
 228 fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath
 229 fetchRepoTarball verbosity' repoCtxt repo pkgid = do
 230   fetched <- doesFileExist (packageFile repo pkgid)
 231   if fetched
 232     then do
 233       info verbosity $ prettyShow pkgid ++ " has already been downloaded."
 234       return (packageFile repo pkgid)
 235     else do
 236       progressMessage verbosity ProgressDownloading (prettyShow pkgid)
 237       res <- downloadRepoPackage
 238       progressMessage verbosity ProgressDownloaded (prettyShow pkgid)
 239       return res
 240   where
 241     -- whether we download or not is non-deterministic
 242     verbosity = verboseUnmarkOutput verbosity'
 243
 244     downloadRepoPackage :: IO FilePath
 245     downloadRepoPackage = case repo of
 246       RepoLocalNoIndex{} -> return (packageFile repo pkgid)
 247       RepoRemote{..} -> do
 248         transport <- repoContextGetTransport repoCtxt
 249         remoteRepoCheckHttps verbosity transport repoRemote
 250         let uri = packageURI repoRemote pkgid
 251             dir = packageDir repo pkgid
 252             path = packageFile repo pkgid
 253         createDirectoryIfMissing True dir
 254         _ <- downloadURI transport verbosity uri path
 255         return path
 256       RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do
 257         let dir = packageDir repo pkgid
 258             path = packageFile repo pkgid
 259         createDirectoryIfMissing True dir
 260         Sec.uncheckClientErrors $ do
 261           info verbosity ("Writing " ++ path)
 262           Sec.downloadPackage' rep pkgid path
 263         return path
 264
 265 -- | Downloads an index file to [config-dir/packages/serv-id] without
 266 -- hackage-security. You probably don't want to call this directly;
 267 -- use 'updateRepo' instead.
 268 downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
 269 downloadIndex transport verbosity remoteRepo cacheDir = do
 270   remoteRepoCheckHttps verbosity transport remoteRepo
 271   let uri =
 272         (remoteRepoURI remoteRepo)
 273           { uriPath =
 274               uriPath (remoteRepoURI remoteRepo)
 275                 `FilePath.Posix.combine` "00-index.tar.gz"
 276           }
 277       path = cacheDir </> "00-index" <.> "tar.gz"
 278   createDirectoryIfMissing True cacheDir
 279   downloadURI transport verbosity uri path
 280
 281 -- ------------------------------------------------------------
 282
 283 -- * Async fetch wrapper utilities
 284
 285 -- ------------------------------------------------------------
 286
 287 type AsyncFetchMap =
 288   Map
 289     UnresolvedPkgLoc
 290     (MVar (Either SomeException ResolvedPkgLoc))
 291
 292 -- | Fork off an async action to download the given packages (by location).
 293 --
 294 -- The downloads are initiated in order, so you can arrange for packages that
 295 -- will likely be needed sooner to be earlier in the list.
 296 --
 297 -- The body action is passed a map from those packages (identified by their
 298 -- location) to a completion var for that package. So the body action should
 299 -- lookup the location and use 'waitAsyncFetchPackage' to get the result.
 300 --
 301 -- Synchronous exceptions raised by the download actions are delivered
 302 -- via 'waitAsyncFetchPackage'.
 303 asyncFetchPackages
 304   :: Verbosity
 305   -> RepoContext
 306   -> [UnresolvedPkgLoc]
 307   -> (AsyncFetchMap -> IO a)
 308   -> IO a
 309 asyncFetchPackages verbosity repoCtxt pkglocs body = do
 310   -- TODO: [nice to have] use parallel downloads?
 311
 312   asyncDownloadVars <-
 313     sequenceA
 314       [ do
 315         v <- newEmptyMVar
 316         return (pkgloc, v)
 317       | pkgloc <- pkglocs
 318       ]
 319
 320   let fetchPackages :: IO ()
 321       fetchPackages =
 322         for_ asyncDownloadVars $ \(pkgloc, var) -> do
 323           -- Suppress marking here, because 'withAsync' means
 324           -- that we get nondeterministic interleaving.
 325           -- It is essential that we don't catch async exceptions here,
 326           -- specifically 'AsyncCancelled' thrown at us from 'concurrently'.
 327           result <-
 328             Safe.try $
 329               fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc
 330           putMVar var result
 331
 332   (_, res) <-
 333     concurrently
 334       fetchPackages
 335       (body $ Map.fromList asyncDownloadVars)
 336   pure res
 337
 338 -- | Expect to find a download in progress in the given 'AsyncFetchMap'
 339 -- and wait on it to finish.
 340 --
 341 -- If the download failed with an exception then this will be thrown.
 342 --
 343 -- Note: This function is supposed to be idempotent, as our install plans
 344 -- can now use the same tarball for many builds, e.g. different
 345 -- components and/or qualified goals, and these all go through the
 346 -- download phase so we end up using 'waitAsyncFetchPackage' twice on
 347 -- the same package. C.f. #4461.
 348 waitAsyncFetchPackage
 349   :: Verbosity
 350   -> AsyncFetchMap
 351   -> UnresolvedPkgLoc
 352   -> IO ResolvedPkgLoc
 353 waitAsyncFetchPackage verbosity downloadMap srcloc =
 354   case Map.lookup srcloc downloadMap of
 355     Just hnd -> do
 356       debug verbosity $ "Waiting for download of " ++ show srcloc
 357       either throwIO return =<< readMVar hnd
 358     Nothing -> fail "waitAsyncFetchPackage: package not being downloaded"
 359
 360 -- ------------------------------------------------------------
 361
 362 -- * Path utilities
 363
 364 -- ------------------------------------------------------------
 365
 366 -- | Generate the full path to the locally cached copy of
 367 -- the tarball for a given @PackageIdentifier@.
 368 packageFile :: Repo -> PackageId -> FilePath
 369 packageFile repo pkgid =
 370   packageDir repo pkgid
 371     </> prettyShow pkgid
 372     <.> "tar.gz"
 373
 374 -- | Generate the full path to the directory where the local cached copy of
 375 -- the tarball for a given @PackageIdentifier@ is stored.
 376 packageDir :: Repo -> PackageId -> FilePath
 377 packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir
 378 packageDir repo pkgid =
 379   repoLocalDir repo
 380     </> prettyShow (packageName pkgid)
 381     </> prettyShow (packageVersion pkgid)
 382
 383 -- | Generate the URI of the tarball for a given package.
 384 packageURI :: RemoteRepo -> PackageId -> URI
 385 packageURI repo pkgid
 386   | isOldHackageURI (remoteRepoURI repo) =
 387       (remoteRepoURI repo)
 388         { uriPath =
 389             FilePath.Posix.joinPath
 390               [ uriPath (remoteRepoURI repo)
 391               , prettyShow (packageName pkgid)
 392               , prettyShow (packageVersion pkgid)
 393               , prettyShow pkgid <.> "tar.gz"
 394               ]
 395         }
 396 packageURI repo pkgid =
 397   (remoteRepoURI repo)
 398     { uriPath =
 399         FilePath.Posix.joinPath
 400           [ uriPath (remoteRepoURI repo)
 401           , "package"
 402           , prettyShow pkgid <.> "tar.gz"
 403           ]
 404     }