hadrian: Fully implement source distributions (#19317)

We use `git ls-files` to get the list of files to include in the source distribution.

Also implements the `-testsuite` and `-extra-tarballs` distributions.

11 files changed, 215 insertions, 112 deletions

diff --git a/configure.ac b/configure.ac
index a66c5c508a..a4694df27a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -923,6 +923,7 @@ fi
 dnl ** check for xelatex
 AC_PATH_PROG(XELATEX,xelatex)
 AC_PATH_PROG(MAKEINDEX,makeindex)
+AC_PATH_PROG(GIT,git)
 
 dnl ** check for makeinfo
 AC_PATH_PROG(MAKEINFO,makeinfo)
@@ -1395,6 +1396,7 @@ echo "\
    sphinx-build : $SPHINXBUILD
    xelatex      : $XELATEX
    makeinfo     : $MAKEINFO
+   git          : $GIT
 
    Using LLVM tools
       clang : $ClangCmd
diff --git a/hadrian/cfg/system.config.in b/hadrian/cfg/system.config.in
index 860c12fbec..003d9d0029 100644
--- a/hadrian/cfg/system.config.in
+++ b/hadrian/cfg/system.config.in
@@ -29,6 +29,7 @@ xelatex        = @XELATEX@
 makeindex      = @MAKEINDEX@
 makeinfo       = @MAKEINFO@
 bourne-shell   = @SH@
+git            = @GIT@
 
 # Python 3 is required to run test driver.
 # See: https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk#L220
diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal
index 1fd2787a5b..13ac5d1362 100644
--- a/hadrian/hadrian.cabal
+++ b/hadrian/hadrian.cabal
@@ -43,6 +43,7 @@ executable hadrian
                        , Hadrian.Builder.Ar
                        , Hadrian.Builder.Sphinx
                        , Hadrian.Builder.Tar
+                       , Hadrian.Builder.Git
                        , Hadrian.BuildPath
                        , Hadrian.Expression
                        , Hadrian.Haskell.Cabal
@@ -103,6 +104,7 @@ executable hadrian
                        , Settings.Builders.Make
                        , Settings.Builders.MergeObjects
                        , Settings.Builders.RunTest
+                       , Settings.Builders.Win32Tarballs
                        , Settings.Builders.Xelatex
                        , Settings.Default
                        , Settings.Flavours.Benchmark
diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs
index 8ef2f2b411..6da009bda1 100644
--- a/hadrian/src/Builder.hs
+++ b/hadrian/src/Builder.hs
@@ -3,7 +3,7 @@ module Builder (
     -- * Data types
     ArMode (..), CcMode (..), ConfigurationInfo (..), DependencyType (..),
     GhcMode (..), GhcPkgMode (..), HaddockMode (..), TestMode(..), SphinxMode (..),
-    TarMode (..), Builder (..),
+    TarMode (..), GitMode (..), Builder (..), Win32TarballsMode(..),
 
     -- * Builder properties
     builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder,
@@ -38,6 +38,10 @@ import Oracles.Flag
 import Oracles.Setting (setting, Setting(..))
 import Packages
 
+import GHC.IO.Encoding (getFileSystemEncoding)
+import qualified Data.ByteString as BS
+import qualified GHC.Foreign as GHC
+
 -- | C compiler can be used in two different modes:
 -- * Compile or preprocess a source file.
 -- * Extract source dependencies by passing @-MM@ command line argument.
@@ -123,6 +127,21 @@ instance Binary   TestMode
 instance Hashable TestMode
 instance NFData   TestMode
 
+-- | Git is used to create source distributions
+data GitMode = ListFiles deriving (Eq, Generic, Show)
+
+instance Binary   GitMode
+instance Hashable GitMode
+instance NFData   GitMode
+
+data Win32TarballsMode = ListTarballs | VerifyTarballs | DownloadTarballs deriving (Eq, Generic, Show)
+
+instance Binary   Win32TarballsMode
+instance Hashable Win32TarballsMode
+instance NFData   Win32TarballsMode
+
+
+
 -- | A 'Builder' is a (usually external) command invoked in a separate process
 -- via 'cmd'. Here are some examples:
 -- * 'Alex' is a lexical analyser generator that builds @Lexer.hs@ from @Lexer.x@.
@@ -163,6 +182,8 @@ data Builder = Alex
              | Unlit
              | Xelatex
              | Makeindex  -- ^ from xelatex
+             | Git GitMode
+             | Win32Tarballs Win32TarballsMode
              deriving (Eq, Generic, Show)
 
 instance Binary   Builder
@@ -255,6 +276,19 @@ instance H.Builder Builder where
               withTempFile $ \temp -> do
                 () <- cmd' [path] (buildArgs ++ ["--only-report-hadrian-deps", temp])
                 readFile' temp
+        Git ListFiles -> do
+          path <- builderPath builder
+          withResources buildResources $ do
+              -- NUL separated list of files
+              -- We need to read this in the filesystem encoding
+              enc <- liftIO getFileSystemEncoding
+              Stdout stdout <- cmd' BinaryPipes [path] buildArgs
+              liftIO $ BS.useAsCStringLen stdout $ \fp -> GHC.peekCStringLen enc fp
+        Win32Tarballs ListTarballs -> do
+          path <- builderPath builder
+          withResources buildResources $ do
+              Stdout stdout <- cmd' [path] buildArgs
+              pure stdout
         _ -> error $ "Builder " ++ show builder ++ " can not be asked!"
 
     runBuilderWith :: Builder -> BuildInfo -> Action ()
@@ -388,8 +422,10 @@ systemBuilderPath builder = case builder of
     Testsuite _     -> fromKey "python"
     Sphinx _        -> fromKey "sphinx-build"
     Tar _           -> fromKey "tar"
+    Git _           -> fromKey "git"
     Xelatex         -> fromKey "xelatex"
     Makeindex       -> fromKey "makeindex"
+    Win32Tarballs _ -> fromKey "python"
     _               -> error $ "No entry for " ++ show builder ++ inCfg
   where
     inCfg = " in " ++ quote configFile ++ " file."
diff --git a/hadrian/src/Hadrian/Builder/Git.hs b/hadrian/src/Hadrian/Builder/Git.hs
new file mode 100644
index 0000000000..6875a48fbd
--- /dev/null
+++ b/hadrian/src/Hadrian/Builder/Git.hs
@@ -0,0 +1,13 @@
+module Hadrian.Builder.Git (gitArgs) where
+
+import Expression
+
+-- | Default command line arguments for invoking the archiving utility @tar@.
+gitArgs :: Args
+gitArgs = mconcat
+  [ builder (Git ListFiles) ? mconcat
+      [ arg "ls-files"
+      , arg "--recurse-submodules"
+      , arg "-z"
+      ]
+  ]
diff --git a/hadrian/src/Hadrian/Utilities.hs b/hadrian/src/Hadrian/Utilities.hs
index bbb61f68f1..a7d8bacc15 100644
--- a/hadrian/src/Hadrian/Utilities.hs
+++ b/hadrian/src/Hadrian/Utilities.hs
@@ -18,7 +18,7 @@ module Hadrian.Utilities (
     -- * File system operations
     copyFile, copyFileUntracked, createFileLink, fixFile,
     makeExecutable, moveFile, removeFile, createDirectory, copyDirectory,
-    moveDirectory, removeDirectory,
+    moveDirectory, removeDirectory, removeFile_,
 
     -- * Diagnostic info
     Colour (..), ANSIColour (..), putColoured, shouldUseColor,
@@ -54,6 +54,7 @@ import qualified Data.HashMap.Strict    as Map
 import qualified System.Directory.Extra as IO
 import qualified System.Info.Extra      as IO
 import qualified System.IO              as IO
+import System.IO.Error (isPermissionError)
 
 -- | Extract a value from a singleton list, or terminate with an error message
 -- if the list does not contain exactly one value.
@@ -322,6 +323,15 @@ copyFile source target = do
     putProgressInfo =<< renderAction "Copy file" source target
     quietly $ copyFileChanged source target
 
+-- | Remove a file or a link, but don't worry if it fails
+removeFile_ :: FilePath -> IO ()
+removeFile_ x =
+    (IO.removeFile x >> IO.removeDirectoryLink x) `IO.catch` \e ->
+        when (isPermissionError e) $ IO.handle (\(_ :: IO.IOException) -> pure ()) $ do
+            perms <- IO.getPermissions x
+            IO.setPermissions x perms{IO.readable = True, IO.searchable = True, IO.writable = True}
+            IO.removeFile x
+
 -- | Copy a file without tracking the source. Create the target directory if missing.
 copyFileUntracked :: FilePath -> FilePath -> Action ()
 copyFileUntracked source target = do
@@ -347,6 +357,7 @@ makeExecutable file = do
     putProgressInfo $ "| Make " ++ quote file ++ " executable."
     quietly $ cmd "chmod +x " [file]
 
+
 -- | Move a file. Note that we cannot track the source, because it is moved.
 moveFile :: FilePath -> FilePath -> Action ()
 moveFile source target = do
diff --git a/hadrian/src/Oracles/ModuleFiles.hs b/hadrian/src/Oracles/ModuleFiles.hs
index d2f0299563..b53a5901e1 100644
--- a/hadrian/src/Oracles/ModuleFiles.hs
+++ b/hadrian/src/Oracles/ModuleFiles.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE TypeFamilies #-}
 module Oracles.ModuleFiles (
     decodeModule, encodeModule, findGenerator, hsSources, hsObjects,
+    determineBuilder,
     moduleFilesOracle
     ) where
 
diff --git a/hadrian/src/Rules/SourceDist.hs b/hadrian/src/Rules/SourceDist.hs
index de35922ae1..4cb9baab5a 100644
--- a/hadrian/src/Rules/SourceDist.hs
+++ b/hadrian/src/Rules/SourceDist.hs
@@ -1,142 +1,152 @@
 module Rules.SourceDist (sourceDistRules) where
 
-import Hadrian.Oracles.DirectoryContents
-
 import Base
 import Builder
 import Context
 import Oracles.Setting
 import Packages
-import Rules.Clean
+import Utilities (askWithResources, build)
+import Hadrian.Target (target)
+import qualified System.Directory.Extra as IO
+import qualified Control.Exception.Base as IO
+import Oracles.ModuleFiles (determineBuilder)
 
 sourceDistRules :: Rules ()
-sourceDistRules = do
+sourceDistRules = alternatives $ do
     root <- buildRootRules
     "source-dist" ~> do
-        -- We clean the source tree first.
-        -- See https://github.com/snowleopard/hadrian/issues/384.
-        -- TODO: Do we still need to clean the tree?
-        cleanSourceTree
         version <- setting ProjectVersion
         need [root -/- "source-dist" -/- ("ghc-" ++ version ++ "-src.tar.xz")]
+        need [root -/- "source-dist" -/- ("ghc-" ++ version ++ "-testsuite.tar.xz")]
+        need [root -/- "source-dist" -/- ("ghc-" ++ version ++ "-windows-extra-src.tar.xz")]
         putSuccess "| Done"
-    root -/- "source-dist" -/- "ghc-*-src.tar.xz" %> \fname -> do
-        let tarName   = takeFileName fname
-            dropTarXz = dropExtension . dropExtension
-            treeDir   = dropTarXz tarName
-            treePath  = root -/- "source-dist" -/- treeDir
-        prepareTree treePath
-        runBuilderWithCmdOptions
-            [Cwd $ root -/- "source-dist"]
-            (Tar Create)
-            ["cJf", tarName,  treeDir]
-            ["cJf", tarName] [treeDir]
+
+    -- Ordering of rules is important so that windows-extra-src matches before src
+    root -/- "source-dist" -/- "ghc-*-windows-extra-src.tar.xz" %>
+      archiveSourceTree prepareWindowsExtraTree
+    root -/- "source-dist" -/- "ghc-*-testsuite.tar.xz" %>
+      archiveSourceTree prepareTestsuiteTree
+    root -/- "source-dist" -/- "ghc-*-src.tar.xz" %>
+      archiveSourceTree prepareTree
     "GIT_COMMIT_ID" %> \fname ->
         writeFileChanged fname =<< setting ProjectGitCommitId
     "VERSION" %> \fname ->
         writeFileChanged fname =<< setting ProjectVersion
 
+    -- Rules to download mingw tarballs
+    let mingw_tarballs_stamp = "ghc-tarballs/mingw-w64/.mingw-w64.download.stamp"
+    ["ghc-tarballs/mingw-w64/*/*.tar.*","ghc-tarballs/mingw-w64/*/SHA256SUMS"]  |%> \_ ->
+      need [mingw_tarballs_stamp]
+    mingw_tarballs_stamp %> \stamp -> do
+      build (target (vanillaContext Stage1 compiler) (Win32Tarballs DownloadTarballs) [] [])
+      writeFile' stamp "OK"
+
+
+archiveSourceTree :: (FilePath -> Action ()) -> FilePath -> Action ()
+archiveSourceTree prepare fname = do
+  root <- buildRoot
+  version <- setting ProjectVersion
+  let dropTarXz = dropExtension . dropExtension
+      tarName   = takeFileName fname
+      dirName   = dropTarXz tarName
+      baseName  = "ghc-" ++ version
+      treeDir   = dirName -/- baseName
+      treePath  = sourceDistRoot -/- treeDir
+      sourceDistRoot = root -/- "source-dist"
+  removeDirectory treePath
+  prepare treePath
+  runBuilderWithCmdOptions
+      [Cwd $ sourceDistRoot -/- dirName]
+      (Tar Create)
+      ["chJf", ".." -/- tarName,  baseName]
+      ["chJf", ".." -/- tarName] [baseName]
+
+
+-- | This creates a symlink to the 'source' at 'target'
+-- $tar -h$ will eventually copy the source into the tarball
+-- This is also how `make sdist` works.
+-- 1. It preserves relative symlinks
+-- 2. It copies non-empty directories also. This is because git includes
+--    directories in its output if they are non empty.
+copyFileSourceDist :: FilePath -> FilePath -> Action ()
+copyFileSourceDist source target = do
+  isSymlink <- liftIO $ IO.pathIsSymbolicLink source
+  if isSymlink then do
+    link_target <- liftIO $ IO.getSymbolicLinkTarget source
+    when (not $ isRelative link_target) $
+      error ("source-dist: tried to create non-relative symlink in source dist: " ++ show link_target)
+    putProgressInfo =<< renderAction ("Create symlink (" ++ link_target ++ ")") source target
+    isDirectory <- liftIO $ IO.doesDirectoryExist source
+    when (not isDirectory) $
+      need [source]
+    let createLink src tgt
+          | isDirectory = liftIO $ IO.createDirectoryLink src tgt
+          | otherwise = liftIO $ IO.createFileLink src tgt
+    let dir = takeDirectory target
+    liftIO $ IO.createDirectoryIfMissing True dir
+    liftIO $ removeFile_ target
+    createLink link_target target
+  else do
+    isDirectory <- liftIO $ IO.doesDirectoryExist source
+    if isDirectory then do
+      contents <- liftIO $ IO.listDirectory source
+      when (not $ null contents) $ -- Git only includes directories in the output if they are empty
+        error ("source-dist: non-empty dir" ++ show source)
+      createDirectory target
+    else createFileLink source target
+
+prepareTestsuiteTree :: FilePath -> Action ()
+prepareTestsuiteTree dest = do
+  top <- topDirectory
+  let testsuiteFiles = filter testFilter . split (=='\NUL')
+      testFilter file = not (null file) && ("testsuite//" ?== file)
+  files <- testsuiteFiles <$> askWithResources [] (target (vanillaContext Stage1 compiler) (Git ListFiles) [] [])
+  forM_ files $ \source -> do
+    let target = dest -/- source
+    copyFileSourceDist (top -/- source) target
+
+prepareWindowsExtraTree :: FilePath -> Action ()
+prepareWindowsExtraTree dest = do
+  top <- topDirectory
+
+  files <- lines <$> askWithResources [] (target (vanillaContext Stage1 compiler) (Win32Tarballs ListTarballs) [] [])
+  need files
+  build (target (vanillaContext Stage1 compiler) (Win32Tarballs VerifyTarballs) [] [])
+
+  createDirectory dest
+  liftIO $ IO.createFileLink (top -/- "ghc-tarballs") (dest -/- "ghc-tarballs")
+
 prepareTree :: FilePath -> Action ()
 prepareTree dest = do
-    root <- buildRoot
-    mapM_ cpDir  srcDirs
-    mapM_ cpFile srcFiles
-    copyAlexHappyFiles root
+    out <- askWithResources [] (target (vanillaContext Stage1 compiler) (Git ListFiles) [] [])
+    top <- topDirectory
+    let files = ["GIT_COMMIT_ID", "VERSION"] ++ getFiles out
+    need ["GIT_COMMIT_ID", "VERSION"]
+    forM_ files $ \source -> do
+      let target = dest -/- source
+      copyFileSourceDist (top -/- source) target
+    copyAlexHappyFiles
   where
 
-    copyAlexHappyFiles root =
+    getFiles = filter treeFilter . split (=='\NUL')
+    treeFilter file = not (null file) && not ("testsuite//" ?== file)
+
+    copyAlexHappyFiles =
       forM_ alexHappyFiles $ \(stg, pkg, inp, out) -> do
-        let dir = root -/- buildDir (Context stg pkg vanilla)
+        let ctx = Context stg pkg vanilla
             srcInputFile = dest -/- pkgPath pkg -/- inp
+            generatedFile = dest -/- pkgPath pkg -/- out
+            Just builder = determineBuilder stg inp
+
         -- We first make sure that the generated file is... generated.
-        need [ dir -/- out ]
-        -- We then copy the generated file in the source dist, right
-        -- next to the input file.
-        copyFile (dir -/- out)
-                 (dest -/- pkgPath pkg -/- out)
+        build $ target ctx builder [srcInputFile] [generatedFile]
+
         -- We finally add a ".source" suffix to the input file to
         -- prevent it from being used when building GHC, since the
         -- generated file being there already should prevent
         -- the need for the original input.
         moveFile srcInputFile (srcInputFile <.> "source")
 
-    cpFile a = copyFile a (dest -/- a)
-    cpDir  a = copyDirectoryContents (Not excluded) a (dest -/- a)
-    excluded = Or
-        [ Test "**/.*"
-        , Test "**/#*"
-        , Test "**/*-SAVE"
-        , Test "**/*.orig"
-        , Test "**/*.rej"
-        , Test "**/*~"
-        , Test "**/autom4te*"
-        , Test "**/dist"
-        , Test "**/dist-install"
-        , Test "**/log"
-        , Test "**/stage0"
-        , Test "**/stage1"
-        , Test "**/stage2"
-        , Test "**/stage3"
-        , Test "hadrian/.cabal-sandbox"
-        , Test "hadrian/.stack-work"
-        , Test "hadrian/UserSettings.hs"
-        , Test "hadrian/cabal.sandbox.config"
-        , Test "hadrian/cfg/system.config"
-        , Test "hadrian/bin"
-        , Test "hadrian/dist"
-        , Test "hadrian/dist-newstyle"
-        , Test "libraries/**/*.buildinfo"
-        , Test "libraries/**/GNUmakefile"
-        , Test "libraries/**/config.log"
-        , Test "libraries/**/config.status"
-        , Test "libraries/**/ghc.mk"
-        , Test "libraries/**/include/Hs*Config.h"
-        , Test "libraries/dph"
-        , Test "libraries/primitive"
-        , Test "libraries/random"
-        , Test "libraries/vector"
-        , Test "rts/rts.cabal"
-        , Test "mk/build.mk" ]
-    srcDirs =
-        [ "bindisttest"
-        , "compiler"
-        , "distrib"
-        , "docs"
-        , "docs"
-        , "driver"
-        , "ghc"
-        , "hadrian"
-        , "includes"
-        , "libffi"
-        , "libffi-tarballs"
-        , "libraries"
-        , "mk"
-        , "rts"
-        , "rules"
-        , "utils"
-        , "m4" ]
-    srcFiles =
-        [ "GIT_COMMIT_ID"
-        , "HACKING.md"
-        , "INSTALL.md"
-        , "LICENSE"
-        , "MAKEHELP.md"
-        , "Makefile"
-        , "README.md"
-        , "VERSION"
-        , "aclocal.m4"
-        , "boot"
-        , "config.guess"
-        , "config.sub"
-        , "configure"
-        , "configure.ac"
-        , "ghc.mk"
-        , "install-sh"
-        , "packages"
-        , "llvm-targets"
-        , "llvm-passes"
-        ]
-
     -- (stage, package, input file, output file)
     alexHappyFiles =
         [ (Stage0, compiler,      "GHC/Cmm/Parser.y",   "GHC/Cmm/Parser.hs")
diff --git a/hadrian/src/Settings/Builders/Win32Tarballs.hs b/hadrian/src/Settings/Builders/Win32Tarballs.hs
new file mode 100644
index 0000000000..7be63d4f86
--- /dev/null
+++ b/hadrian/src/Settings/Builders/Win32Tarballs.hs
@@ -0,0 +1,13 @@
+module Settings.Builders.Win32Tarballs (win32TarballsArgs) where
+
+import Settings.Builders.Common
+
+win32TarballsArgs :: Args
+win32TarballsArgs = do
+  scriptPath <- expr $ (-/- "mk" -/- "get-win32-tarballs.py") <$> topDirectory
+  expr $ need [scriptPath]
+  mconcat
+    [ builder (Win32Tarballs DownloadTarballs) ? pure [scriptPath, "download", "all"]
+    , builder (Win32Tarballs ListTarballs) ? pure [scriptPath, "list", "all"]
+    , builder (Win32Tarballs VerifyTarballs) ? pure [scriptPath, "verify", "all"]
+    ]
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index a20a1d821d..93b14d0f7e 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -43,6 +43,8 @@ import Settings.Builders.RunTest
 import Settings.Builders.Xelatex
 import Settings.Packages
 import Settings.Warnings
+import qualified Hadrian.Builder.Git
+import Settings.Builders.Win32Tarballs
 
 -- | Packages that are built by default. You can change this in "UserSettings".
 defaultPackages :: Stage -> Action [Package]
@@ -261,6 +263,7 @@ defaultBuilderArgs = mconcat
     , runTestBuilderArgs
     , validateBuilderArgs
     , xelatexBuilderArgs
+    , win32TarballsArgs
     -- Generic builders from the Hadrian library:
     , builder (Ar Pack         ) ? Hadrian.Builder.Ar.args Pack
     , builder (Ar Unpack       ) ? Hadrian.Builder.Ar.args Unpack
@@ -269,7 +272,9 @@ defaultBuilderArgs = mconcat
     , builder (Sphinx ManMode  ) ? Hadrian.Builder.Sphinx.args ManMode
     , builder (Sphinx InfoMode ) ? Hadrian.Builder.Sphinx.args InfoMode
     , builder (Tar Create      ) ? Hadrian.Builder.Tar.args Create
-    , builder (Tar Extract     ) ? Hadrian.Builder.Tar.args Extract ]
+    , builder (Tar Extract     ) ? Hadrian.Builder.Tar.args Extract
+    , Hadrian.Builder.Git.gitArgs
+    ]
 
 -- | All 'Package'-dependent command line arguments.
 defaultPackageArgs :: Args
diff --git a/mk/get-win32-tarballs.py b/mk/get-win32-tarballs.py
index 025e661b22..f1ada96b48 100755
--- a/mk/get-win32-tarballs.py
+++ b/mk/get-win32-tarballs.py
@@ -38,6 +38,15 @@ def fetch_arch(arch: str):
 
     verify(arch)
 
+def list_arch(arch: str):
+    d = DEST / arch
+    manifest_url = file_url(arch, 'MANIFEST')
+    req = urllib.request.urlopen(manifest_url)
+    files = req.read().decode('UTF-8').split('\n')
+    print(d / 'SHA256SUMS')
+    for fname in files:
+      print(d / fname)
+
 def verify(arch: str):
     if not Path(DEST / arch / "SHA256SUMS").is_file():
         print("SHA256SUMS doesn't exist; have you fetched?", file=stderr)
@@ -48,14 +57,14 @@ def verify(arch: str):
 
 def main() -> None:
     parser = argparse.ArgumentParser()
-    parser.add_argument('mode', choices=['verify', 'download'])
+    parser.add_argument('mode', choices=['verify', 'download', 'list'])
     parser.add_argument(
         'arch',
         choices=ARCHS + ['all'],
         help="Architecture to fetch (either i686, x86_64, sources, or all)")
     args = parser.parse_args()
 
-    action = fetch_arch if args.mode == 'download' else verify
+    action = { 'download' : fetch_arch, 'verify' : verify, 'list' : list_arch }[args.mode]
     if args.arch == 'all':
         for arch in ARCHS:
             action(arch)