Merge pull request #7934 from andreabedini/andrea/fix-update-message-…

…timestamp

Fix the timestamp shown during cabal update

.github/workflows/validate.yml

@@ -86,6 +86,17 @@ jobs:
           cabal install cabal-plan --constraint='cabal-plan +exe'
           echo "$HOME/.cabal/bin" >> $GITHUB_PATH
 
+      # The tool is not essential to the rest of the test suite. If
+      # hackage-repo-tool is not present, any test that requires it will
+      # be skipped.
+      # We want to keep this in the loop but we don't want to fail if
+      # hackage-repo-tool breaks or fails to support a newer GHC version.
+      - name: Install hackage-repo-tool
+        continue-on-error: true
+        run: |
+          cd $(mktemp -d)
+          cabal install hackage-repo-tool
+
       # Needed by cabal-testsuite/PackageTests/Configure/setup.test.hs
       - name: Install Autotools
         if: runner.os == 'macOS'

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

@@ -47,7 +47,6 @@ import Distribution.Simple.Utils
          ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, warn )
 import Distribution.Verbosity
          ( normal, lessVerbose )
-import Distribution.Client.IndexUtils.Timestamp
 import Distribution.Client.IndexUtils.IndexState
 import Distribution.Client.IndexUtils
          ( updateRepoIndexCache, Index(..), writeIndexTimestamp
@@ -203,7 +202,8 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
               then Just `fmap` getCurrentTime
               else return Nothing
       updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce
-
+      -- this resolves indexState (which could be HEAD) into a timestamp
+      new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo
       let rname = remoteRepoName (repoRemote repo)
 
       -- Update cabal's internal index as well so that it's not out of sync
@@ -214,20 +214,20 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
           setModificationTime (indexBaseName repo <.> "tar") now `catchIO`
              (\e -> warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e)
           noticeNoWrap verbosity $
-            "Package list of " ++ prettyShow rname ++
-            " is up to date at index-state " ++ prettyShow (IndexStateTime current_ts)
+            "Package list of " ++ prettyShow rname ++ " is up to date."
 
         Sec.HasUpdates -> do
           updateRepoIndexCache verbosity index
-          new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo
           noticeNoWrap verbosity $
-            "Updated package list of " ++ prettyShow rname ++
-            " to the index-state " ++ prettyShow (IndexStateTime new_ts)
-
-          -- 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.
-          when (current_ts /= nullTimestamp) $
-            noticeNoWrap verbosity $
-              "To revert to previous state run:\n" ++
-              "    cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"
+            "Package list of " ++ prettyShow rname ++ " has been updated."
+
+      noticeNoWrap verbosity $
+        "The index-state is set to " ++ prettyShow (IndexStateTime new_ts) ++ "."
+
+      -- 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.
+      when (new_ts /= current_ts) $
+        noticeNoWrap verbosity $
+          "To revert to previous state run:\n" ++
+          "    cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"

cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/repo/pkg-1.0/pkg.cabal

@@ -0,0 +1,8 @@
+name: pkg
+version: 1.0
+build-type: Simple
+cabal-version: >= 1.2
+
+executable my-exe
+  main-is: Main.hs
+  build-depends: base

cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.out

@@ -0,0 +1,20 @@
+# cabal update
+Warning: Caught exception during _mirrors lookup:user error (res_query(3) failed)
+Warning: No mirrors found for http://localhost:8000/
+Downloading the latest package list from repository.localhost
+Package list of repository.localhost has been updated.
+The index-state is set to 2022-01-28T02:36:41Z.
+To revert to previous state run:
+    cabal v2-update 'repository.localhost,'
+# cabal update
+Downloading the latest package list from repository.localhost
+Package list of repository.localhost is up to date.
+The index-state is set to 2016-09-24T17:47:48Z.
+To revert to previous state run:
+    cabal v2-update 'repository.localhost,2022-01-28T02:36:41Z'
+# cabal update
+Downloading the latest package list from repository.localhost
+Package list of repository.localhost is up to date.
+The index-state is set to 2022-01-28T02:36:41Z.
+To revert to previous state run:
+    cabal v2-update 'repository.localhost,2016-09-24T17:47:48Z'

cabal-testsuite/PackageTests/NewUpdate/UpdateIndexState/update-index-state.test.hs

@@ -0,0 +1,9 @@
+import Test.Cabal.Prelude
+
+main = cabalTest $ withRemoteRepo "repo" $ do
+  -- This test causes a warning about missing mirrors, the warning is
+  -- included in the expected output to make the test pass but it's not
+  -- part of the test expectations.
+  cabal "update" ["repository.localhost,2022-01-28T02:36:41Z"]
+  cabal "update" ["repository.localhost,2016-09-24T17:47:48Z"]
+  cabal "update" ["repository.localhost,2022-01-28T02:36:41Z"]

cabal-testsuite/cabal-testsuite.cabal

@@ -67,10 +67,12 @@ library
     , directory             ^>= 1.2.0.1 || ^>= 1.3.0.0
     , exceptions            ^>= 0.10.0
     , filepath              ^>= 1.3.0.1 || ^>= 1.4.0.0
+    , network-wait          ^>= 0.1.2.0
     , optparse-applicative  ^>= 0.14.3.0 || ^>=0.15.1.0 || ^>=0.16.0.0
     , process               ^>= 1.2.1.0 || ^>= 1.4.2.0 || ^>= 1.6.1.0
     , regex-base            ^>= 0.94.0.1
     , regex-tdfa            ^>= 1.2.3.1 || ^>=1.3.1.0
+    , retry                 ^>= 0.9.1.0
     , array                 ^>= 0.4.0.1 || ^>= 0.5.0.0
     , temporary             ^>= 1.3
     , text                  ^>= 1.2.3.1

cabal-testsuite/src/Test/Cabal/Monad.hs

@@ -18,6 +18,7 @@ module Test.Cabal.Monad (
     gitProgram,
     cabalProgram,
     diffProgram,
+    python3Program,
     -- * The test environment
     TestEnv(..),
     getTestEnv,
@@ -215,6 +216,9 @@ cabalProgram = (simpleProgram "cabal") {
 diffProgram :: Program
 diffProgram = simpleProgram "diff"
 
+python3Program :: Program
+python3Program = simpleProgram "python3"
+
 -- | Run a test in the test monad according to program's arguments.
 runTestM :: String -> TestM a -> IO a
 runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
@@ -229,7 +233,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
     -- Add test suite specific programs
     let program_db0 =
             addKnownPrograms
-                ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram] ++ builtinPrograms)
+                ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram, python3Program] ++ builtinPrograms)
                 (runnerProgramDb senv)
     -- Reconfigure according to user flags
     let cargs = testCommonArgs args

cabal-testsuite/src/Test/Cabal/Prelude.hs

@@ -63,6 +63,8 @@ import System.FilePath ((</>), takeExtensions, takeDrive, takeDirectory, normali
 import Control.Concurrent (threadDelay)
 import qualified Data.Char as Char
 import System.Directory (getTemporaryDirectory, getCurrentDirectory, canonicalizePath, copyFile, copyFile, doesDirectoryExist, doesFileExist, createDirectoryIfMissing, getDirectoryContents)
+import Control.Retry (exponentialBackoff, limitRetriesByCumulativeDelay)
+import Network.Wait (waitTcpVerbose)
 
 #ifndef mingw32_HOST_OS
 import Control.Monad.Catch ( bracket_ )
@@ -564,6 +566,79 @@ withRepo repo_dir m = do
   where
     repoUri env ="file+noindex://" ++ testRepoDir env
 
+-- | Given a directory (relative to the 'testCurrentDir') containing
+-- a series of directories representing packages, generate an
+-- remote repository corresponding to all of these packages
+withRemoteRepo :: FilePath -> TestM a -> TestM a
+withRemoteRepo repoDir m = do
+    -- https://github.com/haskell/cabal/issues/7065
+    -- you don't simply put a windows path into URL...
+    skipIfWindows
+
+    -- we rely on the presence of python3 for a simple http server
+    skipUnless "no python3" =<< isAvailableProgram python3Program
+    -- we rely on hackage-repo-tool to set up the secure repository
+    skipUnless "no hackage-repo-tool" =<< isAvailableProgram hackageRepoToolProgram
+
+    env <- getTestEnv
+
+    let workDir = testRepoDir env
+
+    -- 1. Initialize repo and repo_keys directory
+    let keysDir = workDir </> "keys"
+    let packageDir = workDir </> "package"
+
+    liftIO $ createDirectoryIfMissing True packageDir
+    liftIO $ createDirectoryIfMissing True keysDir
+
+    -- 2. Create tarballs
+    entries <- liftIO $ getDirectoryContents (testCurrentDir env </> repoDir)
+    forM_ entries $ \entry -> do
+        let srcPath = testCurrentDir env </> repoDir </> entry
+        let destPath = packageDir </> entry
+        isPreferredVersionsFile <- liftIO $
+            -- validate this is the "magic" 'preferred-versions' file
+            -- and perform a sanity-check whether this is actually a file
+            -- and not a package that happens to have the same name.
+            if entry == "preferred-versions"
+                then doesFileExist srcPath
+                else return False
+        case entry of
+            '.' : _ -> return ()
+            _
+                | isPreferredVersionsFile ->
+                      liftIO $ copyFile srcPath destPath
+                | otherwise ->
+                  archiveTo srcPath (destPath <.> "tar.gz")
+
+    -- 3. Create keys and bootstrap repository
+    hackageRepoTool "create-keys" $ ["--keys", keysDir ]
+    hackageRepoTool "bootstrap" $ ["--keys", keysDir, "--repo", workDir]
+
+    -- 4. Wire it up in .cabal/config
+    -- TODO: libify this
+    let package_cache = testCabalDir env </> "packages"
+
+    liftIO $ do
+        appendFile (testUserCabalConfigFile env) $
+            unlines [ "repository repository.localhost"
+                    , "  url: http://localhost:8000/"
+                    , "  secure: True"
+                    , "  root-keys:"
+                    , "  key-threshold: 0"
+                    , "remote-repo-cache: " ++ package_cache ]
+        putStrLn $ testUserCabalConfigFile env
+        putStrLn =<< readFile (testUserCabalConfigFile env)
+
+        withAsync
+          (runReaderT (python3 ["-m", "http.server", "-d", workDir, "--bind", "localhost", "8000"]) env)
+          (\_ -> do
+            -- wait for the python webserver to come up with a exponential
+            -- backoff starting from 50ms, up to a maximum wait of 60s
+            waitTcpVerbose putStrLn (limitRetriesByCumulativeDelay 60000000 $ exponentialBackoff 50000) "localhost" "8000"
+            runReaderT m (env { testHaveRepo = True }))
+
+
 ------------------------------------------------------------------------
 -- * Subprocess run results
 
@@ -911,6 +986,14 @@ ghc' args = do
     recordHeader ["ghc"]
     runProgramM ghcProgram args Nothing
 
+python3 :: [String] -> TestM ()
+python3 args = void $ python3' args
+
+python3' :: [String] -> TestM Result
+python3' args = do
+    recordHeader ["python3"]
+    runProgramM python3Program args Nothing
+
 -- | If a test needs to modify or write out source files, it's
 -- necessary to make a hermetic copy of the source files to operate
 -- on.  This function arranges for this to be done.

cabal-testsuite/src/Test/Cabal/Run.hs

@@ -69,7 +69,8 @@ runAction _verbosity mb_cwd env_overrides path0 args input action = do
           , std_out = UseHandle writeh
           , std_err = UseHandle writeh
           }
-    (stdin_h, _, _, procHandle) <- createProcess prc
+
+    withCreateProcess prc $ \stdin_h _ _ procHandle -> do
 
     case input of
       Just x ->

changelog.d/pr-7934

@@ -0,0 +1,3 @@
+synopsis: Fix the timestamp shown during cabal update
+packages: cabal-install
+prs: #7934