Merge pull request #1485 from haskell/master

master2central 4/5/26

Author: gbaz

.github/workflows/nix-flake.yml

@@ -30,7 +30,7 @@ jobs:
         extra_nix_config: |
           trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hackage-server.cachix.org-1:iw0iRh6+gsFIrxROFaAt5gKNgIHejKjIfyRdbpPYevY=
           substituters = https://cache.nixos.org/ https://hackage-server.cachix.org/
-    - uses: cachix/cachix-action@v16
+    - uses: cachix/cachix-action@v17
       with:
         # https://nix.dev/tutorials/continuous-integration-github-actions#setting-up-github-actions
         name: hackage-server
@@ -65,7 +65,7 @@ jobs:
         extra_nix_config: |
           trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= hackage-server.cachix.org-1:iw0iRh6+gsFIrxROFaAt5gKNgIHejKjIfyRdbpPYevY=
           substituters = https://cache.nixos.org/ https://hackage-server.cachix.org/
-    - uses: cachix/cachix-action@v16
+    - uses: cachix/cachix-action@v17
       with:
         # https://nix.dev/tutorials/continuous-integration-github-actions#setting-up-github-actions
         name: hackage-server

exes/BuildClient.hs

@@ -611,7 +611,7 @@ processPkg verbosity opts config docInfo = do
       createDirectoryIfMissing True $ resultsDirectory opts
       notice verbosity $ "Writing cabal.project for " ++ display (docInfoPackage docInfo)
       let projectFile = installDirectory opts </> "cabal.project"
-      cabal opts "unpack" [show (docInfoTarGzURI config docInfo)] Nothing
+      cabal opts "unpack" [cabalPackageTarget config docInfo] Nothing
       writeFile projectFile $ "packages: */*.cabal" -- ++ show (docInfoTarGzURI config docInfo)
 
     setTestOutcome :: String -> [String] -> [String]
@@ -756,14 +756,7 @@ buildPackage verbosity opts config docInfo = do
              "--haddock-hoogle",
              -- Generate the quickjump index files
              "--haddock-option=--quickjump",
-             -- For candidates we need to use the full URL, because
-             -- otherwise cabal-install will not find the package.
-             -- For regular packages however we need to use just the
-             -- package name, otherwise cabal-install will not
-             -- generate a report
-             if docInfoIsCandidate docInfo
-               then show (docInfoTarGzURI config docInfo)
-               else display pkgid
+             cabalPackageTarget config docInfo
              ]
 
     -- The installDirectory is purely temporary, while the resultsDirectory is
@@ -830,6 +823,18 @@ cabal opts cmd args moutput = do
                         Nothing Nothing moutput moutput
     waitForProcess ph
 
+cabalPackageTarget :: BuildConfig -> DocInfo -> String
+cabalPackageTarget config docInfo =
+    -- For candidates we need to use the full URL, because
+    -- otherwise cabal install/unpack will not find the package.
+    -- For regular packages however we need to use just the
+    -- package name, otherwise cabal install will not
+    -- generate a report and cabal unpack will not use the
+    -- latest cabal file revision from the package archive.
+    if docInfoIsCandidate docInfo
+        then show (docInfoTarGzURI config docInfo)
+        else display (docInfoPackage docInfo)
+
 pruneHaddockFiles :: FilePath -> IO ()
 pruneHaddockFiles dir = do
     -- Hackage doesn't support the haddock frames view, so remove it

flake.lock

@@ -49,9 +49,9 @@
             hackage-server.check = false;
 
             Cabal-syntax = { super, ... }:
-              { custom = _: super.Cabal-syntax_3_16_0_0; };
+              { custom = _: super.Cabal-syntax_3_16_1_0; };
             Cabal = { super, ... }:
-              { custom = _: super.Cabal_3_16_0_0; };
+              { custom = _: super.Cabal_3_16_1_0; };
 
             sandwich.check = false;
 

flake.nix

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-}
+{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, RecursiveDo #-}
 module Distribution.Server.Features.Distro (
     DistroFeature(..),
     DistroResource(..),
@@ -20,6 +20,7 @@ import Distribution.Text (display, simpleParse)
 import Distribution.Package
 
 import Data.List (intercalate)
+import qualified Data.Text as T
 import Text.CSV (parseCSV)
 
 -- TODO:
@@ -29,7 +30,6 @@ import Text.CSV (parseCSV)
 data DistroFeature = DistroFeature {
     distroFeatureInterface :: HackageFeature,
     distroResource   :: DistroResource,
-    maintainersGroup :: DynamicPath -> IO (Maybe UserGroup),
     queryPackageStatus :: forall m. MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)]
 }
 
@@ -48,8 +48,28 @@ initDistroFeature :: ServerEnv
 initDistroFeature ServerEnv{serverStateDir} = do
     distrosState <- distrosStateComponent serverStateDir
 
-    return $ \user core -> do
-      let feature = distroFeature user core distrosState
+    return $ \user@UserFeature{adminGroup, groupResourcesAt} core@CoreFeature{coreResource} -> do
+      rec
+        let
+          maintainersUserGroup :: DistroName -> UserGroup
+          maintainersUserGroup name =
+            UserGroup {
+              groupDesc             = maintainerGroupDescription name,
+              queryUserGroup        = queryState  distrosState $ GetDistroMaintainers name,
+              addUserToGroup        = updateState distrosState . AddDistroMaintainer name,
+              removeUserFromGroup   = updateState distrosState . RemoveDistroMaintainer name,
+              groupsAllowedToAdd    = [adminGroup],
+              groupsAllowedToDelete = [adminGroup]
+            }
+          feature = distroFeature user core distrosState maintainersGroupResource maintainersUserGroup
+        distroNames <- queryState distrosState EnumerateDistros
+        (_maintainersGroup, maintainersGroupResource) <-
+          groupResourcesAt "/distro/:package/maintainers"
+                           maintainersUserGroup
+                           (\distroName -> [("package", display distroName)])
+                           (packageInPath coreResource)
+                           distroNames
+
       return feature
 
 distrosStateComponent :: FilePath -> IO (StateComponent AcidState Distros)
@@ -68,15 +88,21 @@ distrosStateComponent stateDir = do
 distroFeature :: UserFeature
               -> CoreFeature
               -> StateComponent AcidState Distros
+              -> GroupResource
+              -> (DistroName -> UserGroup)
               -> DistroFeature
 distroFeature UserFeature{..}
               CoreFeature{coreResource=CoreResource{packageInPath}}
               distrosState
+              maintainersGroupResource
+              distroGroup
   = DistroFeature{..}
   where
     distroFeatureInterface = (emptyHackageFeature "distro") {
         featureResources =
-          map ($ distroResource) [
+         groupResource maintainersGroupResource
+         : groupUserResource maintainersGroupResource
+         : map ($ distroResource) [
               distroIndexPage
             , distroAllPage
             , distroPackages
@@ -109,10 +135,6 @@ distroFeature UserFeature{..}
               }
           }
 
-    maintainersGroup = \dpath -> case simpleParse =<< lookup "distro" dpath of
-            Nothing -> return Nothing
-            Just dname -> getMaintainersGroup adminGroup dname
-
     textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState EnumerateDistros)
     textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do
         let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) pkgs
@@ -124,15 +146,15 @@ distroFeature UserFeature{..}
     -- result: see-other uri, or an error: not authenticated or not found (todo)
     distroDelete dpath =
       withDistroNamePath dpath $ \distro -> do
-        guardAuthorised_ [InGroup adminGroup] --TODO: use the per-distro maintainer groups
+        guardAuthorised_ [InGroup adminGroup]
         -- should also check for existence here of distro here
         void $ updateState distrosState $ RemoveDistro distro
         seeOther "/distros/" (toResponse ())
 
     -- result: ok response or not-found error
     distroPackageDelete dpath =
       withDistroPackagePath dpath $ \dname pkgname info -> do
-        guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
+        guardAuthorised_ [InGroup $ distroGroup dname]
         case info of
             Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname
             Just {} -> do
@@ -142,30 +164,30 @@ distroFeature UserFeature{..}
     -- result: see-other response, or an error: not authenticated or not found (todo)
     distroPackagePut dpath =
       withDistroPackagePath dpath $ \dname pkgname _ -> lookPackageInfo $ \newPkgInfo -> do
-        guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
+        guardAuthorised_ [InGroup $ distroGroup dname]
         void $ updateState distrosState $ AddPackage dname pkgname newPkgInfo
         seeOther ("/distro/" ++ display dname ++ "/" ++ display pkgname) $ toResponse "Ok!"
 
     -- result: see-other response, or an error: not authentcated or bad request
     distroPostNew _ =
       lookDistroName $ \dname -> do
-        guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
+        guardAuthorised_ [InGroup adminGroup]
         success <- updateState distrosState $ AddDistro dname
         if success
             then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!"
             else badRequest $ toResponse "Selected distribution name is already in use"
 
     distroPutNew dpath =
       withDistroNamePath dpath $ \dname -> do
-        guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
+        guardAuthorised_ [InGroup adminGroup]
         _success <- updateState distrosState $ AddDistro dname
         -- it doesn't matter if it exists already or not
         ok $ toResponse "Ok!"
 
     -- result: ok repsonse or not-found error
     distroPackageListPut dpath =
       withDistroPath dpath $ \dname _pkgs -> do
-        guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
+        guardAuthorised_ [InGroup $ distroGroup dname]
         lookCSVFile $ \csv ->
             case csvToPackageList csv of
                 Left  msg  ->
@@ -205,8 +227,8 @@ distroFeature UserFeature{..}
             pVerStr <- look "version"
             pUriStr  <- look "uri"
             case simpleParse pVerStr of
-                Nothing -> mzero
-                Just pVer -> return $ DistroPackageInfo pVer pUriStr
+                Just pVer | isValidDistroURI pUriStr -> return $ DistroPackageInfo pVer pUriStr
+                _ -> mzero
         case mInfo of
             (Left errs) -> ok $ toResponse $ unlines $ "Sorry, something went wrong there." : errs
             (Right pInfo) -> func pInfo
@@ -216,21 +238,6 @@ distroFeature UserFeature{..}
         Just distro -> func distro
         _ -> badRequest $ toResponse "Not a valid distro name"
 
-    getMaintainersGroup :: UserGroup -> DistroName -> IO (Maybe UserGroup)
-    getMaintainersGroup admins dname = do
-        isDist <- queryState distrosState (IsDistribution dname)
-        case isDist of
-          False -> return Nothing
-          True  -> return . Just $ UserGroup
-            { groupDesc             = maintainerGroupDescription dname
-            , queryUserGroup        = queryState distrosState $ GetDistroMaintainers dname
-            , addUserToGroup        = updateState distrosState . AddDistroMaintainer dname
-            , removeUserFromGroup   = updateState distrosState . RemoveDistroMaintainer dname
-            , groupsAllowedToAdd    = [admins]
-            , groupsAllowedToDelete = [admins]
-            }
-
-
 maintainerGroupDescription :: DistroName -> GroupDescription
 maintainerGroupDescription dname = nullDescription
   { groupTitle = "Maintainers"
@@ -253,13 +260,18 @@ packageListToCSV :: [(PackageName, DistroPackageInfo)] -> CSVFile
 packageListToCSV entries
     = CSVFile $ map (\(pn,DistroPackageInfo version url) -> [display pn, display version, url]) entries
 
+isValidDistroURI :: String -> Bool
+isValidDistroURI uri =
+  T.pack "https:" `T.isPrefixOf` T.pack uri
+
 csvToPackageList :: CSVFile -> Either String [(PackageName, DistroPackageInfo)]
 csvToPackageList (CSVFile records)
     = mapM fromRecord records
  where
     fromRecord [packageStr, versionStr, uri]
       | Just package <- simpleParse packageStr
       , Just version <- simpleParse versionStr
+      , isValidDistroURI uri
       = return (package, DistroPackageInfo version uri)
-    fromRecord rec
-      = Left $ "Invalid distro package entry: " ++ show rec
+    fromRecord record
+      = Left $ "Invalid distro package entry: " ++ show record

src/Distribution/Server/Features/Distro.hs

@@ -8,6 +8,7 @@
 
 module Distribution.Server.Features.Distro.Types where
 
+import Distribution.Server.Framework (FromReqURI(..))
 import Distribution.Server.Framework.Instances ()
 import Distribution.Server.Framework.MemSize
 import Distribution.Server.Users.State()
@@ -22,6 +23,7 @@ import Distribution.Package
 import Distribution.Pretty (Pretty(..))
 import Distribution.Parsec (Parsec(..))
 import qualified Distribution.Compat.CharParsing as P
+import Distribution.Text (simpleParse)
 
 import qualified Text.PrettyPrint as Disp
 import qualified Data.Char as Char
@@ -39,6 +41,9 @@ instance Pretty DistroName where
 instance Parsec DistroName where
   parsec = DistroName <$> P.munch1 (\c -> Char.isAlphaNum c || c `elem` "-_()[]{}=$,;")
 
+instance FromReqURI DistroName where
+  fromReqURI = simpleParse
+
 -- | Listing of known distributions and their maintainers
 data Distributions = Distributions {
     nameMap :: !(Map.Map DistroName UserIdSet)

src/Distribution/Server/Features/Distro/Types.hs

@@ -24,6 +24,8 @@ isCsrfSafe req
             (`BS.isPrefixOf` ua)
             -- UA set by `cabal upload` and such
             [ BS.pack "cabal-install/"
+              -- UA set by Stack
+            , BS.pack "The Haskell Stack"
             , -- Add some other common CLI tools here too?
               BS.pack "curl/"
             , -- referenced in this repository. Unclear whether strictly needed, but whitelisting just in case:

src/Distribution/Server/Framework/CSRF.hs

@@ -250,21 +250,6 @@ checkFlag flagOld flagNew = do
     checkSame "Cannot change ordering of flags"
               (flagName flagOld) (flagName flagNew)
 
-    -- Automatic flags' defaults may be changed as they don't make new
-    -- configurations reachable by the solver that weren't before
-    --
-    -- Moreover, automatic flags may be converted into manual flags
-    -- but not the other way round.
-    --
-    -- NB: We always allow to change the flag description as it has
-    --     purely informational value
-    when (flagManual flagOld) $ do
-        checkSame "Cannot change the default of a manual flag"
-                  (flagDefault flagOld) (flagDefault flagNew)
-
-        checkSame "Cannot change a manual flag into an automatic flag"
-                  (flagManual flagOld) (flagManual flagNew)
-
     let fname = unFlagName (flagName flagOld)
 
     changesOk ("type of flag '" ++ fname ++ "'")