From c2f2898ae0b0843628f21e32368468b7c0260c16 Mon Sep 17 00:00:00 2001
From: Gershom Bazerman <gershom@arista.com>
Date: Wed, 6 Dec 2023 01:47:06 -0500
Subject: [PATCH] pathinfo ad-hoc check, [and email fix]

---
 .../Server/Features/UserSignup.hs             |  2 +-
 src/Distribution/Server/Packages/Unpack.hs    | 20 +++++++++++++++++++
 2 files changed, 21 insertions(+), 1 deletion(-)

diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs
index 0e49d5c3..ef120a54 100644
--- a/src/Distribution/Server/Features/UserSignup.hs
+++ b/src/Distribution/Server/Features/UserSignup.hs
@@ -491,7 +491,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron}
                                    uriPath = "/users/register-request/"
                                           ++ renderNonce nonce
                                  }
-              , "endorselink" $- serverBaseURI {uriPath = "/user/" ++ username ++ "/endorse"
+              , "endorselink" $= serverBaseURI {uriPath = "/user/" ++ T.unpack username ++ "/endorse"}
               , "serverhost"  $= serverBaseURI
               ]
             Just ourHost = uriAuthority serverBaseURI
diff --git a/src/Distribution/Server/Packages/Unpack.hs b/src/Distribution/Server/Packages/Unpack.hs
index abc6895d..4440b2d7 100644
--- a/src/Distribution/Server/Packages/Unpack.hs
+++ b/src/Distribution/Server/Packages/Unpack.hs
@@ -82,6 +82,10 @@ import qualified System.FilePath.Posix
 import Text.Printf
          ( printf )
 
+import Distribution.Types.BuildInfo.Lens
+import Distribution.Compat.Lens
+import Distribution.ModuleName
+
 -- Whether to allow upload of "all rights reserved" packages
 allowAllRightsReserved :: Bool
 allowAllRightsReserved = False
@@ -284,6 +288,14 @@ tarOps pkgId tarIndex = CheckPackageContentOps {
         Just (Link fp) -> fileContents fp
         _ -> throwError ("getFileContents: file does not exist: " ++ path)
 
+checkPathInfo :: PackageDescription -> UploadMonad ()
+checkPathInfo desc =
+   let autogens = concat $ toListOf (traverseBuildInfos . autogenModules) desc
+       matches x = case components x of
+           [m] -> "PackageInfo_" `isPrefixOf` m
+           _ -> False
+   in if any matches autogens then throwError $ "Hackage does not yet allow uploads of packages with autogenerated module PackageInfo_*" else pure ()
+
 -- Miscellaneous checks on package description
 extraChecks :: GenericPackageDescription
             -> PackageIdentifier
@@ -293,8 +305,16 @@ extraChecks genPkgDesc pkgId tarIndex = do
   let pkgDesc = flattenPackageDescription genPkgDesc
   fileChecks <- checkPackageContent (tarOps pkgId tarIndex) pkgDesc
 
+
+  -- this path info check is just until we can depend on cabal 3.12 for PathInfo autogen modules.
+  -- https://github.com/haskell/cabal/issues/9331
+  checkPathInfo pkgDesc
+
   let pureChecks = checkPackage genPkgDesc (Just pkgDesc)
       checks = pureChecks ++ fileChecks
+
+
+
       isDistError (PackageDistSuspicious     {}) = False -- just a warning
       isDistError (PackageDistSuspiciousWarn {}) = False -- just a warning
       isDistError _                              = True