{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

-- | cabal-install CLI command: update
module Distribution.Client.CmdUpdate
  ( updateCommand
  , updateAction
  ) where

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

import Distribution.Client.Compat.Directory
  ( setModificationTime
  )
import Distribution.Client.FetchUtils
  ( downloadIndex
  )
import Distribution.Client.HttpUtils
  ( DownloadResult (..)
  )
import Distribution.Client.IndexUtils
  ( Index (..)
  , currentIndexTimestamp
  , indexBaseName
  , updatePackageIndexCacheFile
  , updateRepoIndexCache
  , writeIndexTimestamp
  )
import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.JobControl
  ( collectJob
  , newParallelJobControl
  , spawnJob
  )
import Distribution.Client.NixStyleOptions
  ( NixStyleFlags (..)
  , defaultNixStyleFlags
  , nixStyleOptions
  )
import Distribution.Client.ProjectConfig
  ( ProjectConfig (..)
  , ProjectConfigShared (projectConfigConfigFile)
  , projectConfigWithSolverRepoContext
  , withGlobalConfig
  , withProjectOrGlobalConfig
  )
import Distribution.Client.ProjectFlags
  ( ProjectFlags (..)
  )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.Setup
  ( CommonSetupFlags (..)
  , ConfigFlags (..)
  , GlobalFlags
  , RepoContext (..)
  , UpdateFlags
  , defaultUpdateFlags
  )
import Distribution.Client.Types
  ( RemoteRepo (..)
  , Repo (..)
  , RepoName (..)
  , repoName
  , unRepoName
  )
import Distribution.Simple.Flag
  ( fromFlagOrDefault
  )
import Distribution.Simple.Utils
  ( dieWithException
  , notice
  , noticeNoWrap
  , warn
  , wrapText
  , writeFileAtomic
  )
import Distribution.Verbosity
  ( lessVerbose
  , normal
  )

import qualified Data.Maybe as Unsafe (fromJust)
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp

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

import Distribution.Client.Errors
import Distribution.Client.IndexUtils.Timestamp (Timestamp (NoTimestamp))
import qualified Hackage.Security.Client as Sec

updateCommand :: CommandUI (NixStyleFlags ())
updateCommand :: CommandUI (NixStyleFlags ())
updateCommand =
  CommandUI
    { commandName :: String
commandName = String
"v2-update"
    , commandSynopsis :: String
commandSynopsis = String
"Updates list of known packages."
    , commandUsage :: String -> String
commandUsage = String -> [String] -> String -> String
usageAlternatives String
"v2-update" [String
"[FLAGS] [REPOS]"]
    , commandDescription :: Maybe (String -> String)
commandDescription = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
_ ->
        String -> String
wrapText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
          String
"For all known remote repositories, download the package list."
    , commandNotes :: Maybe (String -> String)
commandNotes = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pname ->
        String
"REPO has the format <repo-id>[,<index-state>] where index-state follows\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"the same format and syntax that is supported by the --index-state flag.\n\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Examples:\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-update\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Download the package list for all known remote repositories.\n\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-update hackage.haskell.org,@1474732068\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-update hackage.haskell.org,HEAD\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-update hackage.haskell.org\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Download hackage.haskell.org at a specific index state.\n\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-update hackage.haskell.org head.hackage\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Download hackage.haskell.org and head.hackage\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    head.hackage must be a known repo-id. E.g. from\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    your cabal.project(.local) file.\n"
    , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
commandOptions = (ShowOrParseArgs -> [OptionField ()])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ((ShowOrParseArgs -> [OptionField ()])
 -> ShowOrParseArgs -> [OptionField (NixStyleFlags ())])
-> (ShowOrParseArgs -> [OptionField ()])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags ())]
forall a b. (a -> b) -> a -> b
$ [OptionField ()] -> ShowOrParseArgs -> [OptionField ()]
forall a b. a -> b -> a
const []
    , commandDefaultFlags :: NixStyleFlags ()
commandDefaultFlags = () -> NixStyleFlags ()
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()
    }

data UpdateRequest = UpdateRequest
  { UpdateRequest -> RepoName
_updateRequestRepoName :: RepoName
  , UpdateRequest -> RepoIndexState
_updateRequestRepoState :: RepoIndexState
  }
  deriving (Int -> UpdateRequest -> String -> String
[UpdateRequest] -> String -> String
UpdateRequest -> String
(Int -> UpdateRequest -> String -> String)
-> (UpdateRequest -> String)
-> ([UpdateRequest] -> String -> String)
-> Show UpdateRequest
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UpdateRequest -> String -> String
showsPrec :: Int -> UpdateRequest -> String -> String
$cshow :: UpdateRequest -> String
show :: UpdateRequest -> String
$cshowList :: [UpdateRequest] -> String -> String
showList :: [UpdateRequest] -> String -> String
Show)

instance Pretty UpdateRequest where
  pretty :: UpdateRequest -> Doc
pretty (UpdateRequest RepoName
n RepoIndexState
s) = RepoName -> Doc
forall a. Pretty a => a -> Doc
pretty RepoName
n Doc -> Doc -> Doc
<<>> Doc
Disp.comma Doc -> Doc -> Doc
<<>> RepoIndexState -> Doc
forall a. Pretty a => a -> Doc
pretty RepoIndexState
s

instance Parsec UpdateRequest where
  parsec :: forall (m :: * -> *). CabalParsing m => m UpdateRequest
parsec = do
    RepoName
name <- m RepoName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m RepoName
parsec
    RepoIndexState
state <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
',' m Char -> m RepoIndexState -> m RepoIndexState
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m RepoIndexState
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m RepoIndexState
parsec m RepoIndexState -> m RepoIndexState -> m RepoIndexState
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RepoIndexState -> m RepoIndexState
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RepoIndexState
IndexStateHead
    UpdateRequest -> m UpdateRequest
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RepoName -> RepoIndexState -> UpdateRequest
UpdateRequest RepoName
name RepoIndexState
state)

updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
updateAction flags :: NixStyleFlags ()
flags@NixStyleFlags{()
TestFlags
HaddockFlags
ConfigFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ()
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
extraFlags :: forall a. NixStyleFlags a -> a
..} [String]
extraArgs GlobalFlags
globalFlags = do
  let ignoreProject :: Flag Bool
ignoreProject = ProjectFlags -> Flag Bool
flagIgnoreProject ProjectFlags
projectFlags

  ProjectConfig
projectConfig <-
    Flag Bool
-> IO ProjectConfig -> IO ProjectConfig -> IO ProjectConfig
forall a. Flag Bool -> IO a -> IO a -> IO a
withProjectOrGlobalConfig
      Flag Bool
ignoreProject
      (ProjectBaseContext -> ProjectConfig
projectConfig (ProjectBaseContext -> ProjectConfig)
-> IO ProjectBaseContext -> IO ProjectConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
OtherCommand)
      (Verbosity
-> Flag String
-> (ProjectConfig -> IO ProjectConfig)
-> IO ProjectConfig
forall a.
Verbosity -> Flag String -> (ProjectConfig -> IO a) -> IO a
withGlobalConfig Verbosity
verbosity Flag String
globalConfigFlag ((ProjectConfig -> IO ProjectConfig) -> IO ProjectConfig)
-> (ProjectConfig -> IO ProjectConfig) -> IO ProjectConfig
forall a b. (a -> b) -> a -> b
$ \ProjectConfig
globalConfig -> ProjectConfig -> IO ProjectConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProjectConfig -> IO ProjectConfig)
-> ProjectConfig -> IO ProjectConfig
forall a b. (a -> b) -> a -> b
$ ProjectConfig
globalConfig ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig)

  Verbosity
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> (RepoContext -> IO ())
-> IO ()
forall a.
Verbosity
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> (RepoContext -> IO a)
-> IO a
projectConfigWithSolverRepoContext
    Verbosity
verbosity
    (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
projectConfig)
    (ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
projectConfig)
    ((RepoContext -> IO ()) -> IO ())
-> (RepoContext -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RepoContext
repoCtxt -> do
      let repos :: [Repo]
          repos :: [Repo]
repos = RepoContext -> [Repo]
repoContextRepos RepoContext
repoCtxt

          parseArg :: String -> IO UpdateRequest
          parseArg :: String -> IO UpdateRequest
parseArg String
s = case String -> Maybe UpdateRequest
forall a. Parsec a => String -> Maybe a
simpleParsec String
s of
            Just UpdateRequest
r -> UpdateRequest -> IO UpdateRequest
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UpdateRequest
r
            Maybe UpdateRequest
Nothing ->
              Verbosity -> CabalInstallException -> IO UpdateRequest
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO UpdateRequest)
-> CabalInstallException -> IO UpdateRequest
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
UnableToParseRepo String
s

      [UpdateRequest]
updateRepoRequests <- (String -> IO UpdateRequest) -> [String] -> IO [UpdateRequest]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> IO UpdateRequest
parseArg [String]
extraArgs

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([UpdateRequest] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UpdateRequest]
updateRepoRequests) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let remoteRepoNames :: [RepoName]
remoteRepoNames = (Repo -> RepoName) -> [Repo] -> [RepoName]
forall a b. (a -> b) -> [a] -> [b]
map Repo -> RepoName
repoName [Repo]
repos
            unknownRepos :: [RepoName]
unknownRepos =
              [ RepoName
r | (UpdateRequest RepoName
r RepoIndexState
_) <- [UpdateRequest]
updateRepoRequests, Bool -> Bool
not (RepoName
r RepoName -> [RepoName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [RepoName]
remoteRepoNames)
              ]
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RepoName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RepoName]
unknownRepos) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
            [String] -> [String] -> CabalInstallException
NullUnknownrepos ((RepoName -> String) -> [RepoName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map RepoName -> String
unRepoName [RepoName]
unknownRepos) ((RepoName -> String) -> [RepoName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map RepoName -> String
unRepoName [RepoName]
remoteRepoNames)

      let reposToUpdate :: [(Repo, RepoIndexState)]
          reposToUpdate :: [(Repo, RepoIndexState)]
reposToUpdate = case [UpdateRequest]
updateRepoRequests of
            -- If we are not given any specific repository, update all
            -- repositories to HEAD.
            [] -> (Repo -> (Repo, RepoIndexState))
-> [Repo] -> [(Repo, RepoIndexState)]
forall a b. (a -> b) -> [a] -> [b]
map (,RepoIndexState
IndexStateHead) [Repo]
repos
            [UpdateRequest]
updateRequests ->
              let repoMap :: [(RepoName, Repo)]
repoMap = [(Repo -> RepoName
repoName Repo
r, Repo
r) | Repo
r <- [Repo]
repos]
                  lookup' :: RepoName -> Repo
lookup' RepoName
k = Maybe Repo -> Repo
forall a. HasCallStack => Maybe a -> a
Unsafe.fromJust (RepoName -> [(RepoName, Repo)] -> Maybe Repo
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup RepoName
k [(RepoName, Repo)]
repoMap)
               in [ (RepoName -> Repo
lookup' RepoName
name, RepoIndexState
state)
                  | (UpdateRequest RepoName
name RepoIndexState
state) <- [UpdateRequest]
updateRequests
                  ]

      case [(Repo, RepoIndexState)]
reposToUpdate of
        [] ->
          Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"No remote repositories configured"
        [(Repo
remoteRepo, RepoIndexState
_)] ->
          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 (Repo -> RepoName
repoName Repo
remoteRepo)
        [(Repo, RepoIndexState)]
_ ->
          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]
: ((Repo, RepoIndexState) -> String)
-> [(Repo, RepoIndexState)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ((Repo, RepoIndexState) -> String)
-> (Repo, RepoIndexState)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoName -> String
unRepoName (RepoName -> String)
-> ((Repo, RepoIndexState) -> RepoName)
-> (Repo, RepoIndexState)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repo -> RepoName
repoName (Repo -> RepoName)
-> ((Repo, RepoIndexState) -> Repo)
-> (Repo, RepoIndexState)
-> RepoName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Repo, RepoIndexState) -> Repo
forall a b. (a, b) -> a
fst) [(Repo, RepoIndexState)]
reposToUpdate

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Repo, RepoIndexState)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Repo, RepoIndexState)]
reposToUpdate) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        JobControl IO ()
jobCtrl <- Int -> IO (JobControl IO ())
forall a. WithCallStack (Int -> IO (JobControl IO a))
newParallelJobControl ([(Repo, RepoIndexState)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Repo, RepoIndexState)]
reposToUpdate)
        ((Repo, RepoIndexState) -> IO ())
-> [(Repo, RepoIndexState)] -> 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, RepoIndexState) -> IO ())
-> (Repo, RepoIndexState)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity
-> UpdateFlags -> RepoContext -> (Repo, RepoIndexState) -> IO ()
updateRepo Verbosity
verbosity UpdateFlags
defaultUpdateFlags RepoContext
repoCtxt)
          [(Repo, RepoIndexState)]
reposToUpdate
        ((Repo, RepoIndexState) -> IO ())
-> [(Repo, RepoIndexState)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\(Repo, RepoIndexState)
_ -> JobControl IO () -> IO ()
forall (m :: * -> *) a. JobControl m a -> m a
collectJob JobControl IO ()
jobCtrl) [(Repo, RepoIndexState)]
reposToUpdate
  where
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags)
    cliConfig :: ProjectConfig
cliConfig = GlobalFlags
-> NixStyleFlags () -> ClientInstallFlags -> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig GlobalFlags
globalFlags NixStyleFlags ()
flags ClientInstallFlags
forall a. Monoid a => a
mempty -- ClientInstallFlags, not needed here
    globalConfigFlag :: Flag String
globalConfigFlag = ProjectConfigShared -> Flag String
projectConfigConfigFile (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)

updateRepo
  :: Verbosity
  -> UpdateFlags
  -> RepoContext
  -> (Repo, RepoIndexState)
  -> IO ()
updateRepo :: Verbosity
-> UpdateFlags -> RepoContext -> (Repo, RepoIndexState) -> IO ()
updateRepo Verbosity
verbosity UpdateFlags
_updateFlags RepoContext
repoCtxt (Repo
repo, RepoIndexState
indexState) = do
  HttpTransport
transport <- RepoContext -> IO HttpTransport
repoContextGetTransport RepoContext
repoCtxt
  case Repo
repo of
    RepoLocalNoIndex{} -> do
      let index :: Index
index = RepoContext -> Repo -> Index
RepoIndex RepoContext
repoCtxt Repo
repo
      Verbosity -> Index -> IO ()
updatePackageIndexCacheFile Verbosity
verbosity Index
index
    RepoRemote{String
RemoteRepo
repoRemote :: RemoteRepo
repoLocalDir :: String
repoLocalDir :: Repo -> String
repoRemote :: Repo -> 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{} -> 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 NoTimestamp if we've never updated before
      Timestamp
current_ts <- Verbosity -> Index -> IO Timestamp
currentIndexTimestamp (Verbosity -> Verbosity
lessVerbose Verbosity
verbosity) Index
index
      -- NB: always update the timestamp, even if we didn't actually
      -- download anything
      Index -> RepoIndexState -> IO ()
writeIndexTimestamp Index
index RepoIndexState
indexState

      HasUpdates
updated <- do
        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
<$> IO UTCTime
getCurrentTime
            else Maybe UTCTime -> IO (Maybe UTCTime)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
        ((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

      let rname :: RepoName
rname = RemoteRepo -> RepoName
remoteRepoName (Repo -> RemoteRepo
repoRemote Repo
repo)

      -- 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 -> do
          UTCTime
now <- IO UTCTime
getCurrentTime
          String -> UTCTime -> IO ()
setModificationTime (Repo -> String
indexBaseName Repo
repo String -> String -> String
<.> String
"tar") UTCTime
now
            IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e ->
              Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Could not set modification time of index tarball -- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall e. Exception e => e -> String
displayException IOException
e
          Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Package list of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoName -> String
forall a. Pretty a => a -> String
prettyShow RepoName
rname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is up to date."
        HasUpdates
Sec.HasUpdates -> do
          Verbosity -> Index -> IO ()
updateRepoIndexCache Verbosity
verbosity Index
index
          Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Package list of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoName -> String
forall a. Pretty a => a -> String
prettyShow RepoName
rname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has been updated."

      -- This resolves indexState (which could be HEAD) into a timestamp
      -- This could be null but should not be, since the above guarantees
      -- we have an updated index.
      Timestamp
new_ts <- Verbosity -> Index -> IO Timestamp
currentIndexTimestamp (Verbosity -> Verbosity
lessVerbose Verbosity
verbosity) Index
index

      Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"The index-state is set to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RepoIndexState -> String
forall a. Pretty a => a -> String
prettyShow (Timestamp -> RepoIndexState
IndexStateTime Timestamp
new_ts) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

      -- 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.

      -- In case current_ts is a valid timestamp different from new_ts, let
      -- the user know how to go back to current_ts
      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
NoTimestamp Bool -> Bool -> Bool
&& Timestamp
new_ts Timestamp -> Timestamp -> Bool
forall a. Eq a => a -> a -> Bool
/= Timestamp
current_ts) (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 v2-update '"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ UpdateRequest -> String
forall a. Pretty a => a -> String
prettyShow (RepoName -> RepoIndexState -> UpdateRequest
UpdateRequest RepoName
rname (Timestamp -> RepoIndexState
IndexStateTime Timestamp
current_ts))
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'\n"