GSoC20 candidates workflow

Distribution/Server/Features/Documentation.hs

@@ -49,6 +49,7 @@ data DocumentationFeature = DocumentationFeature {
     uploadDocumentation :: DynamicPath -> ServerPartE Response,
     deleteDocumentation :: DynamicPath -> ServerPartE Response,
 
+
     documentationResource :: DocumentationResource,
 
     -- | Notification of documentation changes

Distribution/Server/Features/Html/HtmlUtilities.hs

@@ -8,6 +8,7 @@ import Text.XHtml.Strict
 import qualified Data.Set as Set
 import Distribution.Server.Features.Tags
 import Distribution.Server.Features.Core
+import Distribution.Server.Features.PackageCandidates
 import Distribution.Text (display)
 import Data.List (intersperse, intercalate)
 import Data.Set (Set)
@@ -20,20 +21,25 @@ import Distribution.Server.Features.Users
 
 data HtmlUtilities = HtmlUtilities {
     packageLink :: PackageId -> Html
+  , candidateLink :: PackageId -> Html
   , packageNameLink :: PackageName -> Html
   , renderItem :: PackageItem -> Html
   , makeRow :: PackageItem -> Html
   , renderTags :: Set Tag -> [Html]
   , renderReviewTags :: Set Tag -> (Set Tag, Set Tag) -> PackageName -> [Html]
   }
 
-htmlUtilities :: CoreFeature -> TagsFeature -> UserFeature -> HtmlUtilities
+htmlUtilities :: CoreFeature -> PackageCandidatesFeature -> TagsFeature -> UserFeature -> HtmlUtilities
 htmlUtilities CoreFeature{coreResource}
+              PackageCandidatesFeature{candidatesCoreResource}
               TagsFeature{tagsResource} UserFeature{userResource} = HtmlUtilities{..}
   where
     packageLink :: PackageId -> Html
     packageLink pkgid = anchor ! [href $ corePackageIdUri cores "" pkgid] << display pkgid
 
+    candidateLink :: PackageId -> Html
+    candidateLink pkgid = anchor ! [href $ corePackageIdUri candidatesCoreResource "" pkgid] << display pkgid
+
     packageNameLink :: PackageName -> Html
     packageNameLink pkgname = anchor ! [href $ corePackageNameUri cores "" pkgname] << display pkgname
 

Distribution/Server/Features/PackageCandidates.hs

@@ -70,6 +70,7 @@ data PackageCandidatesFeature = PackageCandidatesFeature {
     postPackageCandidate  :: DynamicPath -> ServerPartE Response,
     putPackageCandidate   :: DynamicPath -> ServerPartE Response,
     doDeleteCandidate     :: DynamicPath -> ServerPartE Response,
+    doDeleteCandidates    :: DynamicPath -> ServerPartE Response,
     uploadCandidate       :: (PackageId -> Bool) -> ServerPartE CandPkgInfo,
     publishCandidate      :: DynamicPath -> Bool -> ServerPartE UploadResult,
     checkPublish          :: forall m. MonadIO m => Users.UserId -> PackageIndex PkgInfo -> CandPkgInfo -> m (Maybe ErrorResponse),
@@ -110,9 +111,11 @@ data PackageCandidatesResource = PackageCandidatesResource {
     packageCandidatesPage :: Resource,
     publishPage           :: Resource,
     deletePage            :: Resource,
+    deleteCandidatesPage  :: Resource,
     packageCandidatesUri  :: String -> PackageName -> String,
     publishUri            :: String -> PackageId -> String,
     deleteUri             :: String -> PackageId -> String,
+    deleteCandidatesUri   :: String -> PackageName -> String,
 
     -- TODO: Why don't the following entries have a corresponding entry
     -- in CoreResource?
@@ -248,6 +251,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
           }
       , publishPage = resourceAt "/package/:package/candidate/publish.:format"
       , deletePage = resourceAt "/package/:package/candidate/delete.:format"
+      , deleteCandidatesPage = resourceAt "/package/:package/candidates/delete.:format"
       , candidateContents = (resourceAt "/package/:package/candidate/src/..") {
             resourceGet = [("", serveContents)]
           }
@@ -261,6 +265,8 @@ candidatesFeature ServerEnv{serverBlobStore = store}
           renderResource (publishPage r) [display pkgid, format]
       , deleteUri = \format pkgid ->
           renderResource (deletePage r) [display pkgid, format]
+      , deleteCandidatesUri = \format pkgname ->
+          renderResource (deleteCandidatesPage r) [display pkgname, format]
       , candidateChangeLogUri = \pkgid ->
           renderResource (candidateChangeLog candidatesResource) [display pkgid, display (packageName pkgid)]
       }
@@ -341,6 +347,13 @@ candidatesFeature ServerEnv{serverBlobStore = store}
       void $ updateState candidatesState $ DeleteCandidate (packageId candidate)
       seeOther (packageCandidatesUri candidatesResource "" $ packageName candidate) $ toResponse ()
 
+    doDeleteCandidates :: DynamicPath -> ServerPartE Response
+    doDeleteCandidates dpath = do
+      pkgname <- packageInPath dpath
+      guardAuthorisedAsMaintainer pkgname
+      void $ updateState candidatesState $ DeleteCandidates pkgname
+      seeOther (packageCandidatesUri candidatesResource "" $ pkgname) $ toResponse ()
+
     serveCandidateTarball :: DynamicPath -> ServerPartE Response
     serveCandidateTarball dpath = do
       pkgid <- packageTarballInPath dpath

Distribution/Server/Features/Upload.hs

@@ -46,6 +46,7 @@ data UploadFeature = UploadFeature {
     uploadResource     :: UploadResource,
     -- | The main upload routine. This uses extractPackage on a multipart
     -- request to get contextual information.
+    -- For new pacakges lifecycle, this should be removed
     uploadPackage      :: ServerPartE UploadResult,
 
     --TODO: consider moving the trustee and/or per-package maintainer groups

Distribution/Server/Pages/Group.hs

@@ -2,6 +2,7 @@
 module Distribution.Server.Pages.Group (
     groupPage,
     renderGroupName
+    -- renderGroupNameWithCands
   ) where
 
 import Text.XHtml.Strict
@@ -17,8 +18,11 @@ renderGroupName :: GroupDescription -> Maybe String -> Html
 renderGroupName desc murl =
     maybeUrl (groupTitle desc) murl
       +++
-    maybe noHtml (\(for, mfor) -> " for " +++ maybeUrl for mfor) (groupEntity desc)
+    maybe noHtml (\(for, mfor) -> " for " +++ maybeUrl for mfor ) (groupEntity desc)
+      +++
+    maybe noHtml (\(_, mfor) -> " : " +++ candUrl "No Candidates" mfor ) (groupEntity desc)
   where maybeUrl text = maybe (toHtml text) (\url -> anchor ! [href url] << text)
+        candUrl text = maybe (toHtml text) (\url -> anchor ! [href $ url ++ "/candidates"] << "candidates")
 
 -- Primitive access control: the URI to post a new user request to, or the the URI/user/<username> to DELETE
 -- if neither adding or removing is enabled, a link to a URI/edit page is provided

Distribution/Server/Pages/PackageFromTemplate.hs

@@ -1,15 +1,22 @@
 {-# LANGUAGE PatternGuards, RecordWildCards #-}
 module Distribution.Server.Pages.PackageFromTemplate
   ( packagePageTemplate
+  , candidatesPageTemplate
   , renderVersion
   , latestVersion
+  , commaList
   ) where
 
 import Distribution.Server.Framework.Templating
 import Distribution.Server.Features.PreferredVersions
+import Distribution.Server.Features.Core
 
 import Distribution.Server.Util.DocMeta
 import Distribution.Server.Packages.Render
+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
+import Distribution.Server.Packages.PackageIndex (PackageIndex)
+import Distribution.Server.Packages.Types
+import Distribution.Server.Features.PackageCandidates
 import Distribution.Server.Users.Types (userStatus, userName, isActiveAccount)
 import Data.TarIndex (TarIndex)
 import Distribution.Server.Features.Distro.Types
@@ -75,54 +82,81 @@ packagePageTemplate :: PackageRender
             -> URL -> [(DistroName, DistroPackageInfo)]
             -> Maybe [PackageName]
             -> HtmlUtilities
+            -> Bool
             -> [TemplateAttr]
 packagePageTemplate render
             mdocIndex mdocMeta mreadme
             docURL distributions
-            deprs utilities =
-  -- The main two namespaces
-  [ "package"           $= packageFieldsTemplate
-  , "hackage"           $= hackageFieldsTemplate
-  , "doc"               $= docFieldsTemplate
-  ] ++
-
-  -- Miscellaneous things that could still stand to be refactored a bit.
-  [ "moduleList"        $= Old.moduleSection render mdocIndex docURL hasQuickNav
-  , "executables"       $= (commaList . map toHtml $ rendExecNames render)
-  , "downloadSection"   $= Old.downloadSection render
-  , "stability"         $= renderStability desc
-  , "isDeprecated"      $= (if deprs == Nothing then False else True)
-  , "deprecatedMsg"     $= (deprHtml deprs)
-  ]
+            deprs utilities isCandidate =
+  if isCandidate
+    then
+    -- The main two namespaces
+    [ "package"           $= packageFieldsTemplate
+    , "hackage"           $= hackageFieldsTemplate
+    , "doc"               $= docFieldsTemplate
+    ] ++
+    -- Miscellaneous things that could still stand to be refactored a bit.
+    [ "moduleList"        $= Old.moduleSection render mdocIndex docURL False
+    , "downloadSection"   $= Old.downloadSection render
+    ]
+    else
+    -- The main two namespaces
+    [ "package"           $= packageFieldsTemplate
+    , "hackage"           $= hackageFieldsTemplate
+    , "doc"               $= docFieldsTemplate
+    ] ++
+    -- Miscellaneous things that could still stand to be refactored a bit.
+    [ "moduleList"        $= Old.moduleSection render mdocIndex docURL hasQuickNav
+    , "executables"       $= (commaList . map toHtml $ rendExecNames render)
+    , "downloadSection"   $= Old.downloadSection render
+    , "stability"         $= renderStability desc
+    , "isDeprecated"      $= (if deprs == Nothing then False else True)
+    , "deprecatedMsg"     $= (deprHtml deprs)
+    ]
   where
     -- Access via "$hackage.varName$"
-    hackageFieldsTemplate = templateDict $
-      [ templateVal "uploadTime"
-          (uncurry renderUploadInfo $ rendUploadInfo render)
-      ] ++
-
-      [ templateVal "hasUpdateTime"
-          (case rendUpdateInfo render of Nothing -> False; _ -> True)
-      , templateVal "updateTime" [ renderUpdateInfo revisionNo utime uinfo
-          | (revisionNo, utime, uinfo) <- maybeToList (rendUpdateInfo render) ]
-      ] ++
-
-      [ templateVal "hasDistributions"
-          True
-          {-(if distributions == [] then False else True)-}
-      , templateVal "distributions"
-          (concatHtml . intersperse (toHtml ", ") $ map showDist distributions)
-      ] ++
-
-      [ templateVal "hasFlags"
-          (if rendFlags render == [] then False else True)
-      , templateVal "flagsSection"
-          (Old.renderPackageFlags render docURL)
-      ]
-      where
-        showDist (dname, info) = toHtml (display dname ++ ":") +++
+    hackageFieldsTemplate = 
+      if isCandidate
+        then templateDict $
+        [ templateVal "uploadTime"
+            (uncurry renderUploadInfo $ rendUploadInfo render)
+        ] ++
+        [ templateVal "hasUpdateTime"
+            (case rendUpdateInfo render of Nothing -> False; _ -> True)
+        , templateVal "updateTime" [ renderUpdateInfo revisionNo utime uinfo
+            | (revisionNo, utime, uinfo) <- maybeToList (rendUpdateInfo render) ]
+        ] ++
+        [ templateVal "hasFlags"
+            (if rendFlags render == [] then False else True)
+        , templateVal "flagsSection"
+            (Old.renderPackageFlags render docURL)
+        ]
+        else templateDict $ 
+        [ templateVal "uploadTime"
+            (uncurry renderUploadInfo $ rendUploadInfo render)
+        ] ++
+
+        [ templateVal "hasUpdateTime"
+            (case rendUpdateInfo render of Nothing -> False; _ -> True)
+        , templateVal "updateTime" [ renderUpdateInfo revisionNo utime uinfo
+            | (revisionNo, utime, uinfo) <- maybeToList (rendUpdateInfo render) ]
+        ] ++        
+        [ templateVal "hasDistributions"
+            True
+            {-(if distributions == [] then False else True)-}
+        , templateVal "distributions"
+            (concatHtml . intersperse (toHtml ", ") $ map showDist distributions)
+        ] ++
+        [ templateVal "hasFlags"
+            (if rendFlags render == [] then False else True)
+        , templateVal "flagsSection"
+            (Old.renderPackageFlags render docURL)
+        ]
+        where
+          showDist (dname, info) = toHtml (display dname ++ ":") +++
             anchor ! [href $ distroUrl info] << toHtml (display $ distroVersion info)
 
+
     -- Fields from the .cabal file.
     -- Access via "$package.varName$"
     packageFieldsTemplate = templateDict $
@@ -133,12 +167,15 @@ packagePageTemplate render
       , templateVal "maintainer"    (Old.maintainField $ rendMaintainer render)
       , templateVal "buildDepends"  (snd (Old.renderDependencies render))
       , templateVal "optional"      optionalPackageInfoTemplate
+      , templateVal "candidateBanner" candidateBanner
       ]
 
-    docFieldsTemplate = templateDict $
-      [ templateVal "hasQuickNavV1" hasQuickNavV1
-      , templateVal "baseUrl" docURL
-      ]
+    docFieldsTemplate =
+      if isCandidate
+        then templateDict $ [ templateVal "baseUrl" docURL ]
+        else templateDict $ [ templateVal "hasQuickNavV1" hasQuickNavV1
+        , templateVal "baseUrl" docURL
+        ]
 
     -- Fields that may be empty, along with booleans to see if they're present.
     -- Access via "$package.optional.varname$"
@@ -205,6 +242,17 @@ packagePageTemplate render
 
     desc = rendOther render
 
+    candidateBanner
+      | isCandidate = [ thediv ! [theclass "candidate-info"]
+                        << [ paragraph << [ strong (toHtml "This is a package candidate release!")
+                                          , toHtml " Here you can preview how this package release will appear once published to the main package index (which can be accomplished via the 'maintain' link below)."
+                                          , toHtml " Please note that once a package has been published to the main package index it cannot be undone!"
+                                          , toHtml " Please consult the "
+                                          , anchor ! [href "/upload"] << "package uploading documentation"
+                                          , toHtml " for more information."
+                                          ] ] ]
+      | otherwise = []
+
     renderCopyright :: Html
     renderCopyright = toHtml $ case text of
       "" -> "None provided"
@@ -264,6 +312,33 @@ packagePageTemplate render
     hasQuickNav :: Bool
     hasQuickNav = hasQuickNavV1
 
+candidatesPageTemplate :: (PackageIndex CandPkgInfo) -> PackageCandidatesResource -> CoreResource -> [TemplateAttr]
+candidatesPageTemplate cands candidates candidatesCore=
+  ["heading" $= "Package candidates"
+  ,"content" $= (paragraph <<
+    [ toHtml "Here follow all the candidate package versions on Hackage. "
+      , thespan ! [thestyle "color: gray"] <<
+          [ toHtml "["
+          , anchor ! [href "/packages/candidates/upload"] << "upload"
+          , toHtml "]" ]
+      ])
+  ,"list"   $= (unordList $ map showCands $ PackageIndex.allPackagesByName cands)
+  ]
+  where showCands pkgs =
+                -- TODO: Duncan changed this to packageSynopsis but without an
+                -- accomponaying definition of packageSynposis. Changed back for now.
+                let desc = packageDescription . pkgDesc . candPkgInfo $ last pkgs
+                    pkgname = packageName desc
+                    -- candidates     = candidatesResource
+                    -- candidatesCore = candidatesCoreResource
+                in  [ anchor ! [href $ packageCandidatesUri candidates "" pkgname ] << display pkgname
+                    , toHtml ": "
+                    , toHtml $ intersperse (toHtml ", ") $ flip map pkgs $ \pkg ->
+                         anchor ! [href $ corePackageIdUri candidatesCore "" (packageId pkg)] << display (packageVersion pkg)
+                    , toHtml $ ". " ++ synopsis desc
+                    ]
+
+
 -- #ToDo: Pick out several interesting versions to display, with a link to
 -- display all versions.
 renderVersion :: PackageId -> [(Version, VersionStatus)] -> Maybe String -> Html