Commit 89fb258f authored by Edsko de Vries's avatar Edsko de Vries

Introduce ignore-expiry cmdline arg

If used, this will instruct the hackage-security library to ignore expiry dates
on TUF metadata (to be used only if, say, the main server is down and we need
to rely on mirrors that have not been updated for longer than the expiry period
on the timestamp).
parent 42ab5ea5
......@@ -225,6 +225,7 @@ instance Monoid SavedConfig where
globalWorldFile = combine globalWorldFile,
globalRequireSandbox = combine globalRequireSandbox,
globalIgnoreSandbox = combine globalIgnoreSandbox,
globalIgnoreExpiry = combine globalIgnoreExpiry,
globalHttpTransport = combine globalHttpTransport
}
where
......
......@@ -129,6 +129,7 @@ data GlobalFlags = GlobalFlags {
globalWorldFile :: Flag FilePath,
globalRequireSandbox :: Flag Bool,
globalIgnoreSandbox :: Flag Bool,
globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates
globalHttpTransport :: Flag String
}
......@@ -146,6 +147,7 @@ defaultGlobalFlags = GlobalFlags {
globalWorldFile = mempty,
globalRequireSandbox = Flag False,
globalIgnoreSandbox = Flag False,
globalIgnoreExpiry = Flag False,
globalHttpTransport = mempty
}
......@@ -309,6 +311,11 @@ globalCommand commands = CommandUI {
globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })
trueArg
,option [] ["ignore-expiry"]
"Ignore expiry dates on signed metadata (use only in exception circumstances)"
globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })
trueArg
,option [] ["http-transport"]
"Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
globalConfigFile (\v flags -> flags { globalHttpTransport = v })
......@@ -358,6 +365,7 @@ instance Monoid GlobalFlags where
globalWorldFile = mempty,
globalRequireSandbox = mempty,
globalIgnoreSandbox = mempty,
globalIgnoreExpiry = mempty,
globalHttpTransport = mempty
}
mappend a b = GlobalFlags {
......@@ -373,6 +381,7 @@ instance Monoid GlobalFlags where
globalWorldFile = combine globalWorldFile,
globalRequireSandbox = combine globalRequireSandbox,
globalIgnoreSandbox = combine globalIgnoreSandbox,
globalIgnoreExpiry = combine globalIgnoreExpiry,
globalHttpTransport = combine globalHttpTransport
}
where combine field = field a `mappend` field b
......
......@@ -37,11 +37,11 @@ import System.FilePath (dropExtension)
import Data.Maybe (catMaybes)
-- | 'update' downloads the package list from all known servers
update :: HttpTransport -> Verbosity -> [Repo] -> IO ()
update _ verbosity [] =
update :: HttpTransport -> Verbosity -> Bool -> [Repo] -> IO ()
update _ verbosity _ [] =
warn verbosity $ "No remote package servers have been specified. Usually "
++ "you would have one specified in the config file."
update transport verbosity repos = do
update transport verbosity ignoreExpiry repos = do
jobCtrl <- newParallelJobControl
let remoteRepos = catMaybes (map maybeRepoRemote repos)
case remoteRepos of
......@@ -52,11 +52,11 @@ update transport verbosity repos = do
_ -> notice verbosity . unlines
$ "Downloading the latest package lists from: "
: map (("- " ++) . remoteRepoName) remoteRepos
mapM_ (spawnJob jobCtrl . updateRepo transport verbosity) repos
mapM_ (spawnJob jobCtrl . updateRepo transport verbosity ignoreExpiry) repos
mapM_ (\_ -> collectJob jobCtrl) repos
updateRepo :: HttpTransport -> Verbosity -> Repo -> IO ()
updateRepo transport verbosity repo = case repo of
updateRepo :: HttpTransport -> Verbosity -> Bool -> Repo -> IO ()
updateRepo transport verbosity _ignoreExpiry repo = case repo of
RepoLocal{..} -> return ()
RepoRemote{..} -> do
downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir
......
......@@ -940,8 +940,9 @@ updateAction verbosityFlag extraArgs globalFlags = do
(globalFlags { globalRequireSandbox = Flag False })
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
transport <- configureTransport verbosity (flagToMaybe (globalHttpTransport globalFlags'))
withGlobalRepos verbosity globalFlags' $ \globalRepos ->
update transport verbosity globalRepos
withGlobalRepos verbosity globalFlags' $ \globalRepos -> do
let ignoreExpiry = fromFlagOrDefault False (globalIgnoreExpiry globalFlags)
update transport verbosity ignoreExpiry globalRepos
upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> Action
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment