Commit e1760ce4 authored by Benno Fünfstück's avatar Benno Fünfstück
Browse files

cabal upload: support package candidates

This adds support for uploading package candidates by introducing a new flag to `cabal upload`,
--candidate. With this flag, `cabal upload` will upload all supplied tarballs as package candidates.
If combined with `--documentation`, the flag can also be used to upload documentation for a package
candidate to hackage.

Fixes #3418
parent 94f4ac24
......@@ -350,6 +350,7 @@ instance Semigroup SavedConfig where
`mappend` savedGlobalInstallDirs b
combinedSavedUploadFlags = UploadFlags {
uploadCandidate = combine uploadCandidate,
uploadCheck = combine uploadCheck,
uploadDoc = combine uploadDoc,
uploadUsername = combine uploadUsername,
......
......@@ -1427,6 +1427,7 @@ instance Semigroup InstallFlags where
-- ------------------------------------------------------------
data UploadFlags = UploadFlags {
uploadCandidate :: Flag Bool,
uploadCheck :: Flag Bool,
uploadDoc :: Flag Bool,
uploadUsername :: Flag Username,
......@@ -1437,6 +1438,7 @@ data UploadFlags = UploadFlags {
defaultUploadFlags :: UploadFlags
defaultUploadFlags = UploadFlags {
uploadCandidate = toFlag False,
uploadCheck = toFlag False,
uploadDoc = toFlag False,
uploadUsername = mempty,
......@@ -1459,13 +1461,19 @@ uploadCommand = CommandUI {
commandOptions = \_ ->
[optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })
,option ['C'] ["candidate"]
"Upload the package as candidate."
uploadCandidate (\v flags -> flags { uploadCandidate = v })
trueArg
,option ['c'] ["check"]
"Do not upload, just do QA checks."
uploadCheck (\v flags -> flags { uploadCheck = v })
trueArg
,option ['d'] ["documentation"]
"Upload documentation instead of a source package. Cannot be used together with --check."
"Upload documentation instead of a source package. Cannot be used together with --check. \
\\nWhen combined with --candidate, uploads docuementation for a package candidate."
uploadDoc (\v flags -> flags { uploadDoc = v })
trueArg
......
......@@ -34,9 +34,9 @@ Just checkURI = parseURI $ "http://hackage.haskell.org/cgi-bin/"
++ "hackage-scripts/check-pkg"
upload :: Verbosity -> RepoContext
-> Maybe Username -> Maybe Password -> [FilePath]
-> Maybe Username -> Maybe Password -> Bool -> [FilePath]
-> IO ()
upload verbosity repoCtxt mUsername mPassword paths = do
upload verbosity repoCtxt mUsername mPassword candidate paths = do
let repos = repoContextRepos repoCtxt
transport <- repoContextGetTransport repoCtxt
targetRepo <-
......@@ -46,8 +46,10 @@ upload verbosity repoCtxt mUsername mPassword paths = do
let targetRepoURI = remoteRepoURI targetRepo
rootIfEmpty x = if null x then "/" else x
uploadURI = targetRepoURI {
uriPath = rootIfEmpty (uriPath targetRepoURI)
FilePath.Posix.</> "upload"
uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>
if candidate
then "packages/candidates"
else "upload"
}
Username username <- maybe promptUsername return mUsername
Password password <- maybe promptPassword return mPassword
......@@ -57,9 +59,9 @@ upload verbosity repoCtxt mUsername mPassword paths = do
handlePackage transport verbosity uploadURI auth path
uploadDoc :: Verbosity -> RepoContext
-> Maybe Username -> Maybe Password -> FilePath
-> Maybe Username -> Maybe Password -> Bool -> FilePath
-> IO ()
uploadDoc verbosity repoCtxt mUsername mPassword path = do
uploadDoc verbosity repoCtxt mUsername mPassword candidate path = do
let repos = repoContextRepos repoCtxt
transport <- repoContextGetTransport repoCtxt
targetRepo <-
......@@ -69,8 +71,11 @@ uploadDoc verbosity repoCtxt mUsername mPassword path = do
let targetRepoURI = remoteRepoURI targetRepo
rootIfEmpty x = if null x then "/" else x
uploadURI = targetRepoURI {
uriPath = rootIfEmpty (uriPath targetRepoURI)
FilePath.Posix.</> "package/" ++ pkgid ++ "/docs"
uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</> mconcat
[ "package/", pkgid
, if candidate then "/candidate" else ""
, "/docs"
]
}
(reverseSuffix, reversePkgid) = break (== '-')
(reverse (takeFileName path))
......
......@@ -1078,12 +1078,14 @@ uploadAction uploadFlags extraArgs globalFlags = do
repoContext
(flagToMaybe $ uploadUsername uploadFlags')
maybe_password
(fromFlag (uploadCandidate uploadFlags'))
tarfile
else do
Upload.upload verbosity
repoContext
(flagToMaybe $ uploadUsername uploadFlags')
maybe_password
(fromFlag (uploadCandidate uploadFlags'))
tarfiles
where
verbosity = fromFlag (uploadVerbosity uploadFlags)
......
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