Merge pull request haskell#1474 from TuongNM/delete-candidate-after-publish

Delete matching candidate after publish

Author: gbaz

src/Distribution/Server/Features/PackageCandidates.hs

@@ -139,14 +139,16 @@ initPackageCandidatesFeature :: ServerEnv
 initPackageCandidatesFeature env@ServerEnv{serverStateDir} = do
     candidatesState <- candidatesStateComponent False serverStateDir
 
-    return $ \user core upload tarIndexCache -> do
+    return $ \user core upload@UploadFeature{..} tarIndexCache -> do
       -- one-off migration
       CandidatePackages{candidateMigratedPkgTarball = migratedPkgTarball} <-
         queryState candidatesState GetCandidatePackages
       unless migratedPkgTarball $ do
         migrateCandidatePkgTarball_v1_to_v2 env candidatesState
         updateState candidatesState SetMigratedPkgTarball
 
+      registerHook packageUploaded $ updateState candidatesState . DeleteCandidate
+
       let feature = candidatesFeature env
                                       user core upload tarIndexCache
                                       candidatesState

src/Distribution/Server/Features/Upload.hs

@@ -49,6 +49,9 @@ data UploadFeature = UploadFeature {
     -- For new pacakges lifecycle, this should be removed
     uploadPackage      :: ServerPartE UploadResult,
 
+    -- | Notification that a new package was uploaded.
+    packageUploaded    :: Hook PackageId (),
+
     --TODO: consider moving the trustee and/or per-package maintainer groups
     --      lower down in the feature hierarchy; many other features want to
     --      use the trustee group purely for auth decisions
@@ -110,6 +113,8 @@ initUploadFeature env@ServerEnv{serverStateDir} = do
     uploadersState   <- uploadersStateComponent   serverStateDir
     maintainersState <- maintainersStateComponent serverStateDir
 
+    packageUploaded  <- newHook
+
     return $ \user@UserFeature{..} core@CoreFeature{..} -> do
 
       -- Recusively tie the knot: the feature contains new user group resources
@@ -122,6 +127,7 @@ initUploadFeature env@ServerEnv{serverStateDir} = do
                                 trusteesState    trusteesGroup    trusteesGroupResource
                                 uploadersState   uploadersGroup   uploadersGroupResource
                                 maintainersState maintainersGroup maintainersGroupResource
+                                packageUploaded
 
           (trusteesGroup,  trusteesGroupResource) <-
             groupResourceAt "/packages/trustees"  trusteesGroupDescription
@@ -184,6 +190,7 @@ uploadFeature :: ServerEnv
               -> StateComponent AcidState HackageTrustees    -> UserGroup -> GroupResource
               -> StateComponent AcidState HackageUploaders   -> UserGroup -> GroupResource
               -> StateComponent AcidState PackageMaintainers -> (PackageName -> UserGroup) -> GroupResource
+              -> Hook PackageId ()
               -> (UploadFeature,
                   UserGroup,
                   UserGroup,
@@ -198,6 +205,7 @@ uploadFeature ServerEnv{serverBlobStore = store}
               trusteesState    trusteesGroup    trusteesGroupResource
               uploadersState   uploadersGroup   uploadersGroupResource
               maintainersState maintainersGroup maintainersGroupResource
+              packageUploaded
    = ( UploadFeature {..}
      , trusteesGroupDescription, uploadersGroupDescription, maintainersGroupDescription)
    where
@@ -314,6 +322,7 @@ uploadFeature ServerEnv{serverBlobStore = store}
                 liftIO $ addUserToGroup group uid
                 runHook_ groupChangedHook (groupDesc group, True,uid,uid,"initial upload")
 
+            runHook_ packageUploaded pkgid
             return uresult
           -- this is already checked in processUpload, and race conditions are highly unlikely but imaginable
           else errForbidden "Upload failed" [MText "Package already exists."]

tests/HackageClientUtils.hs

@@ -351,12 +351,14 @@ getJSONStrings :: RelativeURL -> IO [String]
 getJSONStrings url = getUrl NoAuth url >>= decodeJSON
 
 checkIsForbidden :: Authorization -> RelativeURL -> IO ()
-checkIsForbidden auth url = void $
-  Http.execRequest' auth (mkGetReq url) isForbidden
+checkIsForbidden = checkIsExpectedCode isForbidden
 
 checkIsUnauthorized :: Authorization -> RelativeURL -> IO ()
-checkIsUnauthorized auth url = void $
-  Http.execRequest' auth (mkGetReq url) isUnauthorized
+checkIsUnauthorized = checkIsExpectedCode isUnauthorized
+
+checkIsExpectedCode :: ExpectedCode -> Authorization -> RelativeURL -> IO ()
+checkIsExpectedCode expectedCode auth url = void $
+  Http.execRequest' auth (mkGetReq url) expectedCode
 
 delete :: ExpectedCode -> Authorization -> RelativeURL -> IO ()
 delete expectedCode auth url = void $

tests/HighLevelTest.hs

@@ -28,6 +28,8 @@ import Util
 import HttpUtils ( isOk
                  , isNoContent
                  , isForbidden
+                 , isSeeOther
+                 , isNotFound
                  , Authorization(..)
                  )
 import HackageClientUtils
@@ -158,6 +160,15 @@ runPackageUploadTests = do
        post (Auth "admin" "admin") "/packages/uploaders/" [
            ("user", "HackageTestUser1")
          ]
+    do info "Uploading testpackage candidate"
+       postFile isSeeOther
+                (Auth "HackageTestUser1" "testpass1")
+                "/packages/candidates" "package"
+                (testpackageTarFilename, testpackageTarFileContent)
+    do info "Checking Package Candidate Exists"
+       xs <- validate NoAuth "/package/testpackage-1.0.0.0/candidate"
+       unless (">testpackage: <small>test package testpackage</small></h1>" `isInfixOf` xs) $
+           die ("Bad package candidate info: " ++ show xs)
     do info "Uploading testpackage"
        postFile isOk
                 (Auth "HackageTestUser1" "testpass1")
@@ -171,6 +182,8 @@ runPackageUploadTests = do
        xs <- validate NoAuth "/package/testpackage-1.0.0.0"
        unless (">testpackage</a>: <small>test package testpackage</small></h1>" `isInfixOf` xs) $
            die ("Bad package info: " ++ show xs)
+    do info "Checking Package Candidate no longer exists after package upload"
+       checkIsExpectedCode isNotFound NoAuth "/package/testpackage-1.0.0.0/candidate"
     do info "Setting upload time"
        putText (Auth "HackageTestUser1" "testpass1")
            "/package/testpackage-1.0.0.0/upload-time"

tests/HttpUtils.hs

@@ -11,6 +11,7 @@ module HttpUtils (
   , isNotModified
   , isUnauthorized
   , isForbidden
+  , isNotFound
   , parseQuery
   -- * Stateful functions
   , Authorization(..)
@@ -51,13 +52,15 @@ type ExpectedCode = (Int, Int, Int) -> Bool
 
 isOk, isAccepted, isNoContent, isSeeOther :: ExpectedCode
 isNotModified, isUnauthorized, isForbidden :: ExpectedCode
+isNotFound :: ExpectedCode
 isOk           = (== (2, 0, 0))
 isAccepted     = (== (2, 0, 2))
 isNoContent    = (== (2, 0, 4))
 isSeeOther     = (== (3, 0, 3))
 isNotModified  = (== (3, 0, 4))
 isUnauthorized = (== (4, 0, 1))
 isForbidden    = (== (4, 0, 3))
+isNotFound     = (== (4, 0, 4))
 
 parseQuery :: String -> [(String, String)]
 parseQuery = map parseAssignment . explode '&'