Skip to content

Commit aaecb6a

Browse files
borsboomborsboom
authored
Merge pull request #3149 from commercialhaskell/upload-pvp-revision
pvp-bounds -revision
2 parents 45e2ba5 + 07a0884 commit aaecb6a

File tree

7 files changed

+153
-43
lines changed

7 files changed

+153
-43
lines changed

‎ChangeLog.md‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,15 @@ Other enhancements:
3939
See [#3099](https://github.com/commercialhaskell/stack/issues/3099)
4040
* `stack ghci` will now skip building all local targets, even if they have
4141
downstream deps, as long as it's registered in the DB.
42+
* The pvp-bounds feature now supports adding `-revision` to the end of
43+
each value, e.g. `pvp-bounds: both-revision`. This means that, when
44+
uploading to Hackage, Stack will first upload your tarball with an
45+
unmodified `.cabal` file, and then upload a cabal file revision with
46+
the PVP bounds added. This can be useful—especially combined
47+
with the
48+
[Stackage no-revisions feature](http://www.snoyman.com/blog/2017/04/stackages-no-revisions-field)—as
49+
a method to ensure PVP compliance without having to proactively fix
50+
bounds issues for Stackage maintenance.
4251

4352
Bug fixes:
4453

‎doc/yaml_configuration.md‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -547,6 +547,16 @@ pvp-bounds: none
547547

548548
For more information, see [the announcement blog post](https://www.fpcomplete.com/blog/2015/09/stack-pvp).
549549

550+
__NOTE__ Since Stack 1.5.0, each of the values listed above supports
551+
adding `-revision` to the end of each value, e.g. `pvp-bounds:
552+
both-revision`. This means that, when uploading to Hackage, Stack will
553+
first upload your tarball with an unmodified `.cabal` file, and then
554+
upload a cabal file revision with the PVP bounds added. This can be
555+
useful—especially combined with the
556+
[Stackage no-revisions feature](http://www.snoyman.com/blog/2017/04/stackages-no-revisions-field)—as
557+
a method to ensure PVP compliance without having to proactively fix
558+
bounds issues for Stackage maintenance.
559+
550560
### modify-code-page
551561

552562
(Since 0.1.6)

‎src/Stack/Config.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -378,7 +378,7 @@ configFromConfigMonoid
378378
configScmInit = getFirst configMonoidScmInit
379379
configGhcOptions = configMonoidGhcOptions
380380
configSetupInfoLocations = configMonoidSetupInfoLocations
381-
configPvpBounds = fromFirst PvpBoundsNone configMonoidPvpBounds
381+
configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds
382382
configModifyCodePage = fromFirst True configMonoidModifyCodePage
383383
configExplicitSetupDeps = configMonoidExplicitSetupDeps
384384
configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions

‎src/Stack/SDist.hs‎

Lines changed: 49 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -26,8 +26,10 @@ import Control.Monad.Trans.Control (liftBaseWith)
2626
import qualified Data.ByteString as S
2727
import qualified Data.ByteString.Char8 as S8
2828
import qualified Data.ByteString.Lazy as L
29+
import Data.Char (toLower)
2930
import Data.Data (Data, Typeable, cast, gmapT)
3031
import Data.Either (partitionEithers)
32+
import Data.IORef (newIORef, readIORef, writeIORef)
3133
import Data.List
3234
import Data.List.Extra (nubOrd)
3335
import Data.List.NonEmpty (NonEmpty)
@@ -42,8 +44,10 @@ import qualified Data.Text.Lazy as TL
4244
import qualified Data.Text.Lazy.Encoding as TLE
4345
import Data.Time.Clock.POSIX
4446
import Distribution.Package (Dependency (..))
47+
import qualified Distribution.PackageDescription as Cabal
4548
import qualified Distribution.PackageDescription.Check as Check
4649
import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
50+
import Distribution.Text (display)
4751
import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion)
4852
import Distribution.Version.Extra
4953
import Path
@@ -91,17 +95,25 @@ getSDistTarball
9195
:: (StackM env m, HasEnvConfig env)
9296
=> Maybe PvpBounds -- ^ Override Config value
9397
-> Path Abs Dir -- ^ Path to local package
94-
-> m (FilePath, L.ByteString) -- ^ Filename and tarball contents
98+
-> m (FilePath, L.ByteString, Maybe (PackageIdentifier, L.ByteString))
99+
-- ^ Filename, tarball contents, and option cabal file revision to upload
95100
getSDistTarball mpvpBounds pkgDir = do
96101
config <- view configL
97-
let pvpBounds = fromMaybe (configPvpBounds config) mpvpBounds
102+
let PvpBounds pvpBounds asRevision = fromMaybe (configPvpBounds config) mpvpBounds
98103
tweakCabal = pvpBounds /= PvpBoundsNone
99104
pkgFp = toFilePath pkgDir
100105
lp <- readLocalPackage pkgDir
101106
$logInfo $ "Getting file list for " <> T.pack pkgFp
102107
(fileList, cabalfp) <- getSDistFileList lp
103108
$logInfo $ "Building sdist tarball for " <> T.pack pkgFp
104109
files <- normalizeTarballPaths (lines fileList)
110+
111+
-- We're going to loop below and eventually find the cabal
112+
-- file. When we do, we'll upload this reference, if the
113+
-- mpvpBounds value indicates that we should be uploading a cabal
114+
-- file revision.
115+
cabalFileRevisionRef <- liftIO (newIORef Nothing)
116+
105117
-- NOTE: Could make this use lazy I/O to only read files as needed
106118
-- for upload (both GZip.compress and Tar.write are lazy).
107119
-- However, it seems less error prone and more predictable to read
@@ -116,8 +128,16 @@ getSDistTarball mpvpBounds pkgDir = do
116128
packWith f isDir fp = liftIO $ f (pkgFp FP.</> fp) =<< tarPath isDir fp
117129
packDir = packWith Tar.packDirectoryEntry True
118130
packFile fp
131+
-- This is a cabal file, we're going to tweak it, but only
132+
-- tweak it as a revision.
133+
| tweakCabal && isCabalFp fp && asRevision = do
134+
lbsIdent <- getCabalLbs pvpBounds (Just 1) $ toFilePath cabalfp
135+
liftIO (writeIORef cabalFileRevisionRef (Just lbsIdent))
136+
packWith packFileEntry False fp
137+
-- Same, except we'll include the cabal file in the
138+
-- original tarball upload.
119139
| tweakCabal && isCabalFp fp = do
120-
lbs <- getCabalLbs pvpBounds $ toFilePath cabalfp
140+
(_ident, lbs) <- getCabalLbs pvpBounds Nothing $ toFilePath cabalfp
121141
currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch
122142
tp <- liftIO $ tarPath False fp
123143
return $ (Tar.fileEntry tp lbs) { Tar.entryTime = floor currTime }
@@ -127,11 +147,16 @@ getSDistTarball mpvpBounds pkgDir = do
127147
pkgId = packageIdentifierString (packageIdentifier (lpPackage lp))
128148
dirEntries <- mapM packDir (dirsFromFiles files)
129149
fileEntries <- mapM packFile files
130-
return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)))
150+
mcabalFileRevision <- liftIO (readIORef cabalFileRevisionRef)
151+
return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)), mcabalFileRevision)
131152

132153
-- | Get the PVP bounds-enabled version of the given cabal file
133-
getCabalLbs :: (StackM env m, HasEnvConfig env) => PvpBounds -> FilePath -> m L.ByteString
134-
getCabalLbs pvpBounds fp = do
154+
getCabalLbs :: (StackM env m, HasEnvConfig env)
155+
=> PvpBoundsType
156+
-> Maybe Int -- ^ optional revision
157+
-> FilePath
158+
-> m (PackageIdentifier, L.ByteString)
159+
getCabalLbs pvpBounds mrev fp = do
135160
bs <- liftIO $ S.readFile fp
136161
(_warnings, gpd) <- readPackageUnresolvedBS Nothing bs
137162
(_, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI
@@ -143,7 +168,24 @@ getCabalLbs pvpBounds fp = do
143168
}
144169
sourceMap
145170
let gpd' = gtraverseT (addBounds sourceMap installedMap) gpd
146-
return $ TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd'
171+
gpd'' =
172+
case mrev of
173+
Nothing -> gpd'
174+
Just rev -> gpd'
175+
{ Cabal.packageDescription
176+
= (Cabal.packageDescription gpd')
177+
{ Cabal.customFieldsPD
178+
= (("x-revision", show rev):)
179+
$ filter (\(x, _) -> map toLower x /= "x-revision")
180+
$ Cabal.customFieldsPD
181+
$ Cabal.packageDescription gpd'
182+
}
183+
}
184+
ident <- parsePackageIdentifierFromString $ display $ Cabal.package $ Cabal.packageDescription gpd''
185+
return
186+
( ident
187+
, TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd''
188+
)
147189
where
148190
addBounds :: SourceMap -> InstalledMap -> Dependency -> Dependency
149191
addBounds sourceMap installedMap dep@(Dependency cname range) =

‎src/Stack/Types/Config.hs‎

Lines changed: 23 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -101,6 +101,7 @@ module Stack.Types.Config
101101
,parseProjectAndConfigMonoid
102102
-- ** PvpBounds
103103
,PvpBounds(..)
104+
,PvpBoundsType(..)
104105
,parsePvpBounds
105106
-- ** ColorWhen
106107
,ColorWhen(..)
@@ -1632,29 +1633,44 @@ instance FromJSON (WithJSONWarnings SetupInfoLocation) where
16321633
return $ WithJSONWarnings (SetupInfoInline si) w
16331634

16341635
-- | How PVP bounds should be added to .cabal files
1635-
data PvpBounds
1636+
data PvpBoundsType
16361637
= PvpBoundsNone
16371638
| PvpBoundsUpper
16381639
| PvpBoundsLower
16391640
| PvpBoundsBoth
16401641
deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)
16411642

1642-
pvpBoundsText :: PvpBounds -> Text
1643+
data PvpBounds = PvpBounds
1644+
{ pbType :: !PvpBoundsType
1645+
, pbAsRevision :: !Bool
1646+
}
1647+
deriving (Show, Read, Eq, Typeable, Ord)
1648+
1649+
pvpBoundsText :: PvpBoundsType -> Text
16431650
pvpBoundsText PvpBoundsNone = "none"
16441651
pvpBoundsText PvpBoundsUpper = "upper"
16451652
pvpBoundsText PvpBoundsLower = "lower"
16461653
pvpBoundsText PvpBoundsBoth = "both"
16471654

16481655
parsePvpBounds :: Text -> Either String PvpBounds
1649-
parsePvpBounds t =
1650-
case Map.lookup t m of
1651-
Nothing -> Left $ "Invalid PVP bounds: " ++ T.unpack t
1652-
Just x -> Right x
1656+
parsePvpBounds t = maybe err Right $ do
1657+
(t', asRevision) <-
1658+
case T.break (== '-') t of
1659+
(x, "") -> Just (x, False)
1660+
(x, "-revision") -> Just (x, True)
1661+
_ -> Nothing
1662+
x <- Map.lookup t' m
1663+
Just PvpBounds
1664+
{ pbType = x
1665+
, pbAsRevision = asRevision
1666+
}
16531667
where
16541668
m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]
1669+
err = Left $ "Invalid PVP bounds: " ++ T.unpack t
16551670

16561671
instance ToJSON PvpBounds where
1657-
toJSON = toJSON . pvpBoundsText
1672+
toJSON (PvpBounds typ asRevision) =
1673+
toJSON (pvpBoundsText typ <> (if asRevision then "-revision" else ""))
16581674
instance FromJSON PvpBounds where
16591675
parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)
16601676

‎src/Stack/Upload.hs‎

Lines changed: 55 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Stack.Upload
99
, Uploader
1010
, upload
1111
, uploadBytes
12+
, uploadRevision
1213
, UploadSettings
1314
, defaultUploadSettings
1415
, setUploadUrl
@@ -30,7 +31,7 @@ module Stack.Upload
3031
import Control.Applicative
3132
import Control.Exception (bracket)
3233
import qualified Control.Exception as E
33-
import Control.Monad (when)
34+
import Control.Monad (when, void)
3435
import Data.Aeson (FromJSON (..),
3536
ToJSON (..),
3637
eitherDecode', encode,
@@ -46,19 +47,25 @@ import Data.Text.Encoding (encodeUtf8)
4647
import qualified Data.Text.IO as TIO
4748
import Data.Typeable (Typeable)
4849
import Network.HTTP.Client (Response,
49-
RequestBody(RequestBodyLBS))
50+
RequestBody(RequestBodyLBS),
51+
Request)
5052
import Network.HTTP.Simple (withResponse,
5153
getResponseStatusCode,
5254
getResponseBody,
5355
setRequestHeader,
54-
parseRequest)
55-
import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody)
56+
parseRequest,
57+
httpNoBody)
58+
import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody,
59+
partBS, partLBS)
5660
import Network.HTTP.Client.TLS (getGlobalManager,
5761
applyDigestAuth,
5862
displayDigestAuthException)
5963
import Path (toFilePath)
6064
import Prelude -- Fix redundant import warnings
6165
import Stack.Types.Config
66+
import Stack.Types.PackageIdentifier (PackageIdentifier, packageIdentifierString,
67+
packageIdentifierName)
68+
import Stack.Types.PackageName (packageNameString)
6269
import Stack.Types.StringError
6370
import System.Directory (createDirectoryIfMissing,
6471
removeFile)
@@ -184,8 +191,25 @@ promptPassword = do
184191

185192
nopUploader :: Config -> UploadSettings -> IO Uploader
186193
nopUploader _ _ = return (Uploader nop)
187-
where nop :: String -> L.ByteString -> IO ()
188-
nop _ _ = return ()
194+
where nop :: String -> L.ByteString -> IO HackageCreds
195+
nop _ _ = return (HackageCreds "nopUploader" "")
196+
197+
applyCreds :: HackageCreds -> Request -> IO Request
198+
applyCreds creds req0 = do
199+
manager <- getGlobalManager
200+
ereq <- applyDigestAuth
201+
(encodeUtf8 $ hcUsername creds)
202+
(encodeUtf8 $ hcPassword creds)
203+
req0
204+
manager
205+
case ereq of
206+
Left e -> do
207+
putStrLn "WARNING: No HTTP digest prompt found, this will probably fail"
208+
case E.fromException e of
209+
Just e' -> putStrLn $ displayDigestAuthException e'
210+
Nothing -> print e
211+
return req0
212+
Right req -> return req
189213

190214
-- | Turn the given settings into an @Uploader@.
191215
--
@@ -200,21 +224,7 @@ mkUploader config us = do
200224
{ upload_ = \tarName bytes -> do
201225
let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
202226
req2 <- formDataBody formData req1
203-
manager <- getGlobalManager
204-
ereq3 <- applyDigestAuth
205-
(encodeUtf8 $ hcUsername creds)
206-
(encodeUtf8 $ hcPassword creds)
207-
req2
208-
manager
209-
req3 <-
210-
case ereq3 of
211-
Left e -> do
212-
putStrLn "WARNING: No HTTP digest prompt found, this will probably fail"
213-
case E.fromException e of
214-
Just e' -> putStrLn $ displayDigestAuthException e'
215-
Nothing -> print e
216-
return req2
217-
Right req3 -> return req3
227+
req3 <- applyCreds creds req2
218228
putStr $ "Uploading " ++ tarName ++ "... "
219229
hFlush stdout
220230
withResponse req3 $ \res ->
@@ -239,6 +249,7 @@ mkUploader config us = do
239249
putStrLn $ "unhandled status code: " ++ show code
240250
printBody res
241251
throwString $ "Upload failed on " ++ tarName
252+
return creds
242253
}
243254

244255
printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()
@@ -250,22 +261,42 @@ printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout
250261
--
251262
-- Since 0.1.0.0
252263
newtype Uploader = Uploader
253-
{ upload_ :: String -> L.ByteString -> IO ()
264+
{ upload_ :: String -> L.ByteString -> IO HackageCreds
254265
}
255266

256267
-- | Upload a single tarball with the given @Uploader@.
257268
--
258269
-- Since 0.1.0.0
259-
upload :: Uploader -> FilePath -> IO ()
270+
upload :: Uploader -> FilePath -> IO HackageCreds
260271
upload uploader fp = upload_ uploader (takeFileName fp) =<< L.readFile fp
261272

262273
-- | Upload a single tarball with the given @Uploader@. Instead of
263274
-- sending a file like 'upload', this sends a lazy bytestring.
264275
--
265276
-- Since 0.1.2.1
266-
uploadBytes :: Uploader -> String -> L.ByteString -> IO ()
277+
uploadBytes :: Uploader -> String -> L.ByteString -> IO HackageCreds
267278
uploadBytes = upload_
268279

280+
uploadRevision :: HackageCreds
281+
-> PackageIdentifier
282+
-> L.ByteString
283+
-> IO ()
284+
uploadRevision creds ident cabalFile = do
285+
req0 <- parseRequest $ concat
286+
[ "https://hackage.haskell.org/package/"
287+
, packageIdentifierString ident
288+
, "/"
289+
, packageNameString $ packageIdentifierName ident
290+
, ".cabal/edit"
291+
]
292+
req1 <- formDataBody
293+
[ partLBS "cabalfile" cabalFile
294+
, partBS "publish" "on"
295+
]
296+
req0
297+
req2 <- applyCreds creds req1
298+
void $ httpNoBody req2
299+
269300
-- | Settings for creating an @Uploader@.
270301
--
271302
-- Since 0.1.0.0

‎src/main/Main.hs‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -699,7 +699,7 @@ uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do
699699
(\file ->
700700
do tarFile <- resolveFile' file
701701
liftIO
702-
(Upload.upload uploader (toFilePath tarFile))
702+
(void (Upload.upload uploader (toFilePath tarFile)))
703703
unless
704704
don'tSign
705705
(void $
@@ -709,9 +709,11 @@ uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do
709709
unless (null dirs) $
710710
forM_ dirs $ \dir -> do
711711
pkgDir <- resolveDir' dir
712-
(tarName, tarBytes) <- getSDistTarball mpvpBounds pkgDir
712+
(tarName, tarBytes, mcabalRevision) <- getSDistTarball mpvpBounds pkgDir
713713
unless ignoreCheck $ checkSDistTarball' tarName tarBytes
714-
liftIO $ Upload.uploadBytes uploader tarName tarBytes
714+
liftIO $ do
715+
creds <- Upload.uploadBytes uploader tarName tarBytes
716+
forM_ mcabalRevision $ uncurry $ Upload.uploadRevision creds
715717
tarPath <- parseRelFile tarName
716718
unless
717719
don'tSign
@@ -729,7 +731,7 @@ sdistCmd (dirs, mpvpBounds, ignoreCheck, sign, sigServerUrl) go =
729731
then liftM Map.keys getLocalPackages
730732
else mapM resolveDir' dirs
731733
forM_ dirs' $ \dir -> do
732-
(tarName, tarBytes) <- getSDistTarball mpvpBounds dir
734+
(tarName, tarBytes, _mcabalRevision) <- getSDistTarball mpvpBounds dir
733735
distDir <- distDirFromDir dir
734736
tarPath <- (distDir </>) <$> parseRelFile tarName
735737
ensureDir (parent tarPath)

0 commit comments

Comments
 (0)