-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Update
-- Copyright   :  (c) David Himmelstrup 2005
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
--
-----------------------------------------------------------------------------
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.Update
    ( update
    ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Simple.Setup
         ( fromFlag )
import Distribution.Client.Compat.Directory
         ( setModificationTime )
import Distribution.Client.Types
         ( Repo(..), RepoName (..), RemoteRepo(..), maybeRepoRemote, unRepoName )
import Distribution.Client.HttpUtils
         ( DownloadResult(..) )
import Distribution.Client.FetchUtils
         ( downloadIndex )
import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.IndexUtils
         ( updateRepoIndexCache, Index(..), writeIndexTimestamp
         , currentIndexTimestamp, indexBaseName )
import Distribution.Client.JobControl
         ( newParallelJobControl, spawnJob, collectJob )
import Distribution.Client.Setup
         ( RepoContext(..), UpdateFlags(..) )
import Distribution.Verbosity (lessVerbose)

import Distribution.Simple.Utils
         ( writeFileAtomic, warn, notice, noticeNoWrap )

import qualified Data.ByteString.Lazy       as BS
import Distribution.Client.GZipUtils (maybeDecompress)
import System.FilePath ((<.>), dropExtension)
import Data.Time (getCurrentTime)

import qualified Hackage.Security.Client as Sec

-- | 'update' downloads the package list from all known servers
update :: Verbosity -> UpdateFlags -> RepoContext -> IO ()
update :: Verbosity -> UpdateFlags -> RepoContext -> IO ()
update Verbosity
verbosity UpdateFlags
_ RepoContext
repoCtxt | [Repo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RepoContext -> [Repo]
repoContextRepos RepoContext
repoCtxt) = do
  Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No remote package servers have been specified. Usually "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"you would have one specified in the config file."
update Verbosity
verbosity UpdateFlags
updateFlags RepoContext
repoCtxt = do
  let repos :: [Repo]
repos       = RepoContext -> [Repo]
repoContextRepos RepoContext
repoCtxt
      remoteRepos :: [RemoteRepo]
remoteRepos = (Repo -> Maybe RemoteRepo) -> [Repo] -> [RemoteRepo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Repo -> Maybe RemoteRepo
maybeRepoRemote [Repo]
repos
  case [RemoteRepo]
remoteRepos of
    [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [RemoteRepo
remoteRepo] ->
        Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Downloading the latest package list from "
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoName -> String
unRepoName (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
remoteRepo)
    [RemoteRepo]
_ -> Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
            ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Downloading the latest package lists from: "
            String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (RemoteRepo -> String) -> [RemoteRepo] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (RemoteRepo -> String) -> RemoteRepo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoName -> String
unRepoName (RepoName -> String)
-> (RemoteRepo -> RepoName) -> RemoteRepo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteRepo -> RepoName
remoteRepoName) [RemoteRepo]
remoteRepos
  JobControl IO ()
jobCtrl <- Int -> IO (JobControl IO ())
forall a. Int -> IO (JobControl IO a)
newParallelJobControl ([Repo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Repo]
repos)
  (Repo -> IO ()) -> [Repo] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (JobControl IO () -> IO () -> IO ()
forall (m :: * -> *) a. JobControl m a -> m a -> m ()
spawnJob JobControl IO ()
jobCtrl (IO () -> IO ()) -> (Repo -> IO ()) -> Repo -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO ()
updateRepo Verbosity
verbosity UpdateFlags
updateFlags RepoContext
repoCtxt) [Repo]
repos
  (Repo -> IO ()) -> [Repo] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\Repo
_ -> JobControl IO () -> IO ()
forall (m :: * -> *) a. JobControl m a -> m a
collectJob JobControl IO ()
jobCtrl) [Repo]
repos

updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO ()
updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO ()
updateRepo Verbosity
verbosity UpdateFlags
updateFlags RepoContext
repoCtxt Repo
repo = do
  HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
  case Repo
repo of
    RepoLocalNoIndex{} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    RepoRemote{String
RemoteRepo
repoRemote :: Repo -> RemoteRepo
repoLocalDir :: Repo -> String
repoLocalDir :: String
repoRemote :: RemoteRepo
..} -> do
      DownloadResult
downloadResult <- HttpTransport
-> Verbosity -> RemoteRepo -> String -> IO DownloadResult
downloadIndex HttpTransport
transport Verbosity
verbosity RemoteRepo
repoRemote String
repoLocalDir
      case DownloadResult
downloadResult of
        DownloadResult
FileAlreadyInCache ->
          String -> UTCTime -> IO ()
setModificationTime (Repo -> String
indexBaseName Repo
repo String -> String -> String
<.> String
"tar") (UTCTime -> IO ()) -> IO UTCTime -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
        FileDownloaded String
indexPath -> do
          String -> ByteString -> IO ()
writeFileAtomic (String -> String
dropExtension String
indexPath) (ByteString -> IO ())
-> (ByteString -> ByteString) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
maybeDecompress
                                                  (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BS.readFile String
indexPath
          Verbosity -> Index -> IO ()
updateRepoIndexCache Verbosity
verbosity (RepoContext -> Repo -> Index
RepoIndex RepoContext
repoCtxt Repo
repo)
    RepoSecure RemoteRepo
remote String
_ -> RepoContext
-> Repo
-> (forall (down :: * -> *). Repository down -> IO ())
-> IO ()
RepoContext
-> forall a.
   Repo -> (forall (down :: * -> *). Repository down -> IO a) -> IO a
repoContextWithSecureRepo RepoContext
repoCtxt Repo
repo ((forall (down :: * -> *). Repository down -> IO ()) -> IO ())
-> (forall (down :: * -> *). Repository down -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Repository down
repoSecure -> do
      let index :: Index
index = RepoContext -> Repo -> Index
RepoIndex RepoContext
repoCtxt Repo
repo
      -- NB: This may be a nullTimestamp if we've never updated before
      Timestamp
current_ts <- Verbosity -> RepoContext -> Repo -> IO Timestamp
currentIndexTimestamp (Verbosity -> Verbosity
lessVerbose Verbosity
verbosity) RepoContext
repoCtxt Repo
repo

      -- NB: always update the timestamp, even if we didn't actually
      -- download anything
      let rname :: RepoName
          rname :: RepoName
rname = RemoteRepo -> RepoName
remoteRepoName RemoteRepo
remote

      let repoIndexState :: RepoIndexState
          repoIndexState :: RepoIndexState
repoIndexState = RepoName -> TotalIndexState -> RepoIndexState
lookupIndexState RepoName
rname (Flag TotalIndexState -> TotalIndexState
forall a. WithCallStack (Flag a -> a)
fromFlag (UpdateFlags -> Flag TotalIndexState
updateIndexState UpdateFlags
updateFlags))
      Index -> RepoIndexState -> IO ()
writeIndexTimestamp Index
index RepoIndexState
repoIndexState

      Maybe UTCTime
ce <- if RepoContext -> Bool
repoContextIgnoreExpiry RepoContext
repoCtxt
              then UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> IO UTCTime -> IO (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO UTCTime
getCurrentTime
              else Maybe UTCTime -> IO (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
      HasUpdates
updated <- ((Throws VerificationError, Throws SomeRemoteError,
  Throws InvalidPackageException) =>
 IO HasUpdates)
-> IO HasUpdates
forall a.
((Throws VerificationError, Throws SomeRemoteError,
  Throws InvalidPackageException) =>
 IO a)
-> IO a
Sec.uncheckClientErrors (((Throws VerificationError, Throws SomeRemoteError,
   Throws InvalidPackageException) =>
  IO HasUpdates)
 -> IO HasUpdates)
-> ((Throws VerificationError, Throws SomeRemoteError,
     Throws InvalidPackageException) =>
    IO HasUpdates)
-> IO HasUpdates
forall a b. (a -> b) -> a -> b
$ Repository down -> Maybe UTCTime -> IO HasUpdates
forall (down :: * -> *).
(Throws VerificationError, Throws SomeRemoteError) =>
Repository down -> Maybe UTCTime -> IO HasUpdates
Sec.checkForUpdates Repository down
repoSecure Maybe UTCTime
ce
      -- Update cabal's internal index as well so that it's not out of sync
      -- (If all access to the cache goes through hackage-security this can go)
      case HasUpdates
updated of
        HasUpdates
Sec.NoUpdates  ->
          String -> UTCTime -> IO ()
setModificationTime (Repo -> String
indexBaseName Repo
repo String -> String -> String
<.> String
"tar") (UTCTime -> IO ()) -> IO UTCTime -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime
        HasUpdates
Sec.HasUpdates ->
          Verbosity -> Index -> IO ()
updateRepoIndexCache Verbosity
verbosity Index
index
      -- TODO: This will print multiple times if there are multiple
      -- repositories: main problem is we don't have a way of updating
      -- a specific repo.  Once we implement that, update this.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Timestamp
current_ts Timestamp -> Timestamp -> Bool
forall a. Eq a => a -> a -> Bool
/= Timestamp
nullTimestamp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"To revert to previous state run:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
"    cabal update --index-state='" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Timestamp -> String
forall a. Pretty a => a -> String
prettyShow Timestamp
current_ts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"