diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index d0550ebb..82dda6bd 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -407,10 +407,13 @@ candidatesFeature ServerEnv{serverBlobStore = store} candWarnings = uploadWarnings uresult, candPublic = True -- do withDataFn } - void $ updateState candidatesState $ AddCandidate candidate - let group = maintainersGroup (packageName pkgid) - liftIO $ Group.addUserToGroup group uid - return candidate + checkCandidate "Upload failed" uid regularIndex candidate >>= \case + Just failed -> throwError failed + Nothing -> do + void $ updateState candidatesState $ AddCandidate candidate + let group = maintainersGroup (packageName pkgid) + liftIO $ Group.addUserToGroup group uid + return candidate -- | Helper function for uploadCandidate. processCandidate :: (PackageId -> Bool) -> PackageIndex PkgInfo -> Users.UserId -> UploadResult -> IO (Maybe ErrorResponse) @@ -474,12 +477,16 @@ candidatesFeature ServerEnv{serverBlobStore = store} -- | Helper function for publishCandidate that ensures it's safe to insert into the main index. + checkPublish :: forall m. MonadIO m => Users.UserId -> PackageIndex PkgInfo -> CandPkgInfo -> m (Maybe ErrorResponse) + checkPublish = checkCandidate "Publish failed" + + -- | Helper function that ensures it would be safe to insert a package candidate into the main index. -- -- TODO: share code w/ 'Distribution.Server.Features.Upload.processUpload' - checkPublish :: forall m. MonadIO m => Users.UserId -> PackageIndex PkgInfo -> CandPkgInfo -> m (Maybe ErrorResponse) - checkPublish uid packages candidate + checkCandidate :: forall m. MonadIO m => String -> Users.UserId -> PackageIndex PkgInfo -> CandPkgInfo -> m (Maybe ErrorResponse) + checkCandidate errorTitle uid packages candidate | Just _ <- find ((== candVersion) . packageVersion) pkgs - = return $ Just $ ErrorResponse 403 [] "Publish failed" [MText "Package name and version already exist in the database"] + = return $ Just $ ErrorResponse 403 [] errorTitle [MText "Package name and version already exist in the database"] | packageExists packages candidate = return Nothing @@ -488,7 +495,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} PackageIndex.Unambiguous (mp:_) -> do group <- liftIO $ (Group.queryUserGroup . maintainersGroup . packageName) mp if not $ uid `Group.member` group - then return $ Just $ ErrorResponse 403 [] "Publish failed" (caseClash [mp]) + then return $ Just $ ErrorResponse 403 [] errorTitle (caseClash [mp]) else return Nothing PackageIndex.Unambiguous [] -> return Nothing -- can this ever occur? @@ -497,7 +504,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} let matchingPackages = concatMap (take 1) mps groups <- mapM (liftIO . Group.queryUserGroup . maintainersGroup . packageName) matchingPackages if not . any (uid `Group.member`) $ groups - then return $ Just $ ErrorResponse 403 [] "Publish failed" (caseClash matchingPackages) + then return $ Just $ ErrorResponse 403 [] errorTitle (caseClash matchingPackages) else return Nothing -- no case-neighbors diff --git a/tests/HighLevelTest.hs b/tests/HighLevelTest.hs index 195558e4..296950bd 100644 --- a/tests/HighLevelTest.hs +++ b/tests/HighLevelTest.hs @@ -185,9 +185,27 @@ runPackageUploadTests = do xs <- getUrl NoAuth "/package/testpackage-1.0.0.0/upload-time" unless (xs == uploadTimeISO2) $ die ("Bad upload time: " ++ show xs) + do info "Trying to upload existing testpackage as candidate" + postFile isForbidden + (Auth "HackageTestUser1" "testpass1") + "/packages/candidates/" "package" + (testpackageTarFilename, testpackageTarFileContent) + do info "Trying to upload testPackage case-variant as candidate" + -- Upload as another user as maintainers of an existing package are + -- allowed to upload case-variants of it. + createUserDirect (Auth "admin" "admin") "HackageTestUser2" "testpass2" + post (Auth "admin" "admin") "/packages/uploaders/" [ + ("user", "HackageTestUser2") + ] + postFile isForbidden + (Auth "HackageTestUser2" "testpass2") + "/packages/candidates/" "package" + (testpackageTarFilenameVariant, testpackageTarFileContentVariant) where (testpackageTarFilename, testpackageTarFileContent, _, _, _, _) = testpackage + (testpackageTarFilenameVariant, testpackageTarFileContentVariant, _, _, _, _) = + mkPackage "testPackage" uploadTime = "Tue Oct 18 20:54:28 UTC 2010" uploadTimeISO = "2010-10-18T20:54:28Z" uploadTimeISO2 = "2020-10-18T20:54:28Z"