content: -----------------------------------------------------------------------------
  -- |
  -- Module      :  Distribution.Client.FetchUtils
  -- Copyright   :  (c) David Himmelstrup 2005
  --                    Duncan Coutts 2011
  -- License     :  BSD-like
  --
  -- Maintainer  :  cabal-devel@gmail.com
  -- Stability   :  provisional
  -- Portability :  portable
  --
  -- Functions for fetching packages
  -----------------------------------------------------------------------------
  {-# LANGUAGE RecordWildCards #-}
  module Distribution.Client.FetchUtils (
  
      -- * fetching packages
      fetchPackage,
      isFetched,
      checkFetched,
  
      -- ** specifically for repo packages
      checkRepoTarballFetched,
      fetchRepoTarball,
      fetchSourceRepo,
      downloadSourceRepo,
  
      -- ** fetching packages asynchronously
      asyncFetchPackages,
      waitAsyncFetchPackage,
      AsyncFetchMap,
  
      -- * fetching other things
      downloadIndex,
    ) where
  
  import Distribution.Client.Types
  import {-# SOURCE #-} Distribution.Client.BinaryUtils
  import Distribution.Client.HttpUtils
           ( downloadURI, isOldHackageURI, DownloadResult(..)
           , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )
  
  import Distribution.Package
           ( PackageId, packageName, packageVersion )
  import Distribution.Simple.Utils
           ( notice, info, debug, setupMessage )
  import Distribution.Text
           ( display )
  import Distribution.Verbosity
           ( Verbosity, verboseUnmarkOutput )
  import Distribution.Client.GlobalFlags
           ( RepoContext(..) )
  import Distribution.Client.Brancher
  import Distribution.Version
  import Distribution.Simple.Program
  import qualified Distribution.PackageDescription as PD
  import Data.Maybe
  import Data.Map (Map)
  import qualified Data.Map as Map
  import Control.Monad
  import Control.Exception
  import Control.Concurrent.Async
  import Control.Concurrent.MVar
  import System.Directory
           ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory,
             doesDirectoryExist )
  import System.IO
           ( openTempFile, hClose )
  import System.FilePath
           ( (</>), (<.>) )
  import qualified System.FilePath.Posix as FilePath.Posix
           ( combine, joinPath )
  import Network.URI
           ( URI(uriPath) )
  
  import qualified Hackage.Security.Client as Sec
  
  -- ------------------------------------------------------------
  -- * Actually fetch things
  -- ------------------------------------------------------------
  
  -- | Returns @True@ if the package has already been fetched
  -- or does not need fetching.
  --
  isFetched :: UnresolvedPkgLoc -> IO Bool
  isFetched loc = case loc of
      LocalUnpackedPackage _dir        -> return True
      LocalTarballPackage  _file  _    -> return True
      RemoteTarballPackage _uri local  -> return (isJust local)
      RepoTarballPackage repo pkgid _  -> doesFileExist (packageFile repo pkgid)
      ScmPackage (Just repo) _ pkgid _ ->
        doesDirectoryExist (packageDir repo pkgid)
      ScmPackage Nothing _ _pkgid _ ->
        error "isFetched: ScmPackage Nothing"
  
  -- | Checks if the package has already been fetched (or does not need
  -- fetching) and if so returns evidence in the form of a 'PackageLocation'
  -- with a resolved local file location.
  --
  checkFetched :: UnresolvedPkgLoc
               -> IO (Maybe ResolvedPkgLoc)
  checkFetched loc = case loc of
      LocalUnpackedPackage dir  ->
        return (Just $ LocalUnpackedPackage dir)
      LocalTarballPackage  file isBinary ->
        return (Just $ LocalTarballPackage  file isBinary)
      RemoteTarballPackage uri (Just file) ->
        return (Just $ RemoteTarballPackage uri file)
      RepoTarballPackage repo pkgid (Just file) ->
        return (Just $ RepoTarballPackage repo pkgid file)
      ScmPackage maybeRepo srcRepos pkgid (Just file) ->
        return (Just $ ScmPackage maybeRepo srcRepos pkgid file)
  
      RemoteTarballPackage _uri Nothing -> return Nothing
      RepoTarballPackage repo pkgid Nothing ->
        fmap (fmap (RepoTarballPackage repo pkgid))
             (checkRepoTarballFetched repo pkgid)
  
      ScmPackage (Just repo) srcRepos pkgid Nothing -> do
        let dir = packageDir repo pkgid
        exists <- doesDirectoryExist dir
        if exists
          then return (Just $ ScmPackage (Just repo) srcRepos pkgid dir)
          else return Nothing
  
      ScmPackage Nothing _ _ Nothing ->
        error "checkFetched: ScmPackage Nothing"
  
  -- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.
  --
  checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)
  checkRepoTarballFetched repo pkgid = do
      let file = packageFile repo pkgid
      exists <- doesFileExist file
      if exists
        then return (Just file)
        else return Nothing
  
  
  -- | Fetch a package if we don't have it already.
  --
  fetchPackage :: Verbosity
               -> RepoContext
               -> UnresolvedPkgLoc
               -> IO ResolvedPkgLoc
  fetchPackage verbosity repoCtxt loc = case loc of
      LocalUnpackedPackage dir  ->
        return (LocalUnpackedPackage dir)
      LocalTarballPackage  file isBinary ->
        return (LocalTarballPackage  file isBinary)
      RemoteTarballPackage uri (Just file) ->
        return (RemoteTarballPackage uri file)
      RepoTarballPackage repo pkgid (Just file) ->
        return (RepoTarballPackage repo pkgid file)
      ScmPackage maybeRepo sourceRepos pkgid (Just file) ->
        return (ScmPackage maybeRepo sourceRepos pkgid file)
  
      RemoteTarballPackage uri Nothing -> do
        path <- downloadTarballPackage uri
        return (RemoteTarballPackage uri path)
      RepoTarballPackage repo pkgid Nothing -> do
        local <- fetchRepoTarball verbosity repoCtxt repo pkgid
        return (RepoTarballPackage repo pkgid local)
      ScmPackage (Just repo) sourceRepos pkgid Nothing -> do
        local <- fetchSourceRepo verbosity repo pkgid sourceRepos
        return (ScmPackage (Just repo) sourceRepos pkgid local)
  
      ScmPackage Nothing _ _ Nothing -> do
        error "fetchPackage: ScmPackage Nothing"
    where
      downloadTarballPackage uri = do
        transport <- repoContextGetTransport repoCtxt
        transportCheckHttps verbosity transport uri
        notice verbosity ("Downloading " ++ show uri)
        tmpdir <- getTemporaryDirectory
        (path, hnd) <- openTempFile tmpdir "etlas-.tar.gz"
        hClose hnd
        _ <- downloadURI transport verbosity uri path
        return path
  
  
  -- | Fetch a source control management repo package if we don't have it already.
  --
  fetchSourceRepo :: Verbosity -> Repo -> PackageId
                  -> [PD.SourceRepo] -> IO FilePath
  fetchSourceRepo verbosity repo pkgid sourceRepos = do
    fetched <- doesDirectoryExist repoDir
    if fetched
      then do info verbosity $ repoDir ++ " has already been downloaded."
              return repoDir
      else do notice verbosity $ "Downloading " ++ display pkgid ++ "..."
              downloadSourceRepo verbosity repoDir (Right pkgid) sourceRepos
              return repoDir
    where
      repoDir = packageDir repo pkgid
  
  downloadSourceRepo :: Verbosity -> FilePath -> Either String PackageId
                     -> [PD.SourceRepo] -> IO ()
  downloadSourceRepo verbosity targetDir ePkgDesc sourceRepos = do
    branchers <- findUsableBranchers
    forkPackage verbosity branchers targetDir Nothing ePkgDesc sourceRepos
  
  -- | Fetch a repo package if we don't have it already.
  --
  fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath
  fetchRepoTarball verbosity repoCtxt repo pkgid = do
    fetched <- doesFileExist (packageFile repo pkgid)
    if fetched
      then do info verbosity $ display pkgid ++ " has already been downloaded."
              return (packageFile repo pkgid)
      else do setupMessage verbosity "Downloading [source]" pkgid
              downloadRepoPackage
    where
      downloadRepoPackage = case repo of
        RepoLocal{..} -> return (packageFile repo pkgid)
  
        RepoRemote{..} -> do
          transport <- repoContextGetTransport repoCtxt
          remoteRepoCheckHttps verbosity transport repoRemote
          let uri  = packageURI  repoRemote pkgid
              dir  = packageDir  repo       pkgid
              path = packageFile repo       pkgid
          createDirectoryIfMissing True dir
          _ <- downloadURI transport verbosity uri path
          return path
  
        RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do
          let dir  = packageDir  repo pkgid
              path = packageFile repo pkgid
          createDirectoryIfMissing True dir
          Sec.uncheckClientErrors $ do
            info verbosity ("writing " ++ path)
            Sec.downloadPackage' rep pkgid path
          return path
  
  -- | Downloads an index file to [config-dir/packages/serv-id] without
  -- hackage-security. You probably don't want to call this directly;
  -- use 'updateRepo' instead.
  --
  downloadIndex :: Verbosity -> HttpTransport -> RemoteRepo -> FilePath -> FilePath
                -> IO DownloadResult
  downloadIndex verbosity transport remoteRepo cacheDir binariesPath
    | remoteRepoGitIndexed remoteRepo = do
      exists <- doesDirectoryExist cacheDir
      (gitProg, _, _) <- requireProgramVersion verbosity
                            gitProgram
                            (orLaterVersion (mkVersion [1,8,5]))
                            defaultProgramDb
      let runGit args =
            getProgramInvocationOutput verbosity (programInvocation gitProg args) >>=
              info verbosity
      if exists
      then runGit ["-C", cacheDir, "pull"]
      else runGit ["clone", "--depth=1", show (remoteRepoURI remoteRepo), cacheDir]
      updateBinaryPackageCaches verbosity transport cacheDir binariesPath
      return FileAlreadyInCache
  
    | otherwise = do
      remoteRepoCheckHttps verbosity transport remoteRepo
      let uri = (remoteRepoURI remoteRepo) {
                  uriPath = uriPath (remoteRepoURI remoteRepo)
                              `FilePath.Posix.combine` "00-index.tar.gz"
                }
          path = cacheDir </> "00-index" <.> "tar.gz"
      createDirectoryIfMissing True cacheDir
      downloadURI transport verbosity uri path
  
  
  -- ------------------------------------------------------------
  -- * Async fetch wrapper utilities
  -- ------------------------------------------------------------
  
  type AsyncFetchMap = Map UnresolvedPkgLoc
                           (MVar (Either SomeException ResolvedPkgLoc))
  
  -- | Fork off an async action to download the given packages (by location).
  --
  -- The downloads are initiated in order, so you can arrange for packages that
  -- will likely be needed sooner to be earlier in the list.
  --
  -- The body action is passed a map from those packages (identified by their
  -- location) to a completion var for that package. So the body action should
  -- lookup the location and use 'asyncFetchPackage' to get the result.
  --
  asyncFetchPackages :: Verbosity
                     -> RepoContext
                     -> [UnresolvedPkgLoc]
                     -> (AsyncFetchMap -> IO a)
                     -> IO a
  asyncFetchPackages verbosity repoCtxt pkglocs body = do
      --TODO: [nice to have] use parallel downloads?
  
      asyncDownloadVars <- sequence [ do v <- newEmptyMVar
                                         return (pkgloc, v)
                                    | pkgloc <- pkglocs ]
  
      let fetchPackages :: IO ()
          fetchPackages =
            forM_ asyncDownloadVars $ \(pkgloc, var) -> do
              -- Suppress marking here, because 'withAsync' means
              -- that we get nondeterministic interleaving
              result <- try $ fetchPackage (verboseUnmarkOutput verbosity)
                                  repoCtxt pkgloc
              putMVar var result
  
      withAsync fetchPackages $ \_ ->
        body (Map.fromList asyncDownloadVars)
  
  
  -- | Expect to find a download in progress in the given 'AsyncFetchMap'
  -- and wait on it to finish.
  --
  -- If the download failed with an exception then this will be thrown.
  --
  -- Note: This function is supposed to be idempotent, as our install plans
  -- can now use the same tarball for many builds, e.g. different
  -- components and/or qualified goals, and these all go through the
  -- download phase so we end up using 'waitAsyncFetchPackage' twice on
  -- the same package. C.f. #4461.
  waitAsyncFetchPackage :: Verbosity
                        -> AsyncFetchMap
                        -> UnresolvedPkgLoc
                        -> IO ResolvedPkgLoc
  waitAsyncFetchPackage verbosity downloadMap srcloc =
      case Map.lookup srcloc downloadMap of
        Just hnd -> do
          debug verbosity $ "Waiting for download of " ++ show srcloc
          either throwIO return =<< readMVar hnd
        Nothing -> fail "waitAsyncFetchPackage: package not being downloaded"
  
  
  -- ------------------------------------------------------------
  -- * Path utilities
  -- ------------------------------------------------------------
  
  -- | Generate the full path to the locally cached copy of
  -- the tarball for a given @PackageIdentifer@.
  --
  packageFile :: Repo -> PackageId -> FilePath
  packageFile repo pkgid = packageDir repo pkgid
                       </> display pkgid
                       <.> "tar.gz"
  
  -- | Generate the full path to the directory where the local cached copy of
  -- the tarball for a given @PackageIdentifer@ is stored.
  --
  packageDir :: Repo -> PackageId -> FilePath
  packageDir repo pkgid = repoLocalDir repo
                      </> display (packageName    pkgid)
                      </> display (packageVersion pkgid)
  
  -- | Generate the URI of the tarball for a given package.
  --
  packageURI :: RemoteRepo -> PackageId -> URI
  packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =
    (remoteRepoURI repo) {
      uriPath = FilePath.Posix.joinPath
        [uriPath (remoteRepoURI repo)
        ,display (packageName    pkgid)
        ,display (packageVersion pkgid)
        ,display pkgid <.> "tar.gz"]
    }
  packageURI repo pkgid =
    (remoteRepoURI repo) {
      uriPath = FilePath.Posix.joinPath
        [uriPath (remoteRepoURI repo)
        ,"package"
        ,display pkgid <.> "tar.gz"]
    }
  