Skip to content

Commit 8d9fd0c

Browse files
mgsloanmgsloan
committed
Merge pull request #2098 from commercialhaskell/863-extensible-snapshots
#863 extensible snapshots
2 parents 6a22557 + f6d352e commit 8d9fd0c

31 files changed

+729
-373
lines changed

‎ChangeLog.md

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,15 +6,25 @@ Release notes:
66

77
Major changes:
88

9+
* Extensible custom snapshots implemented. These allow you to define snapshots
10+
which extend other snapshots. See
11+
[#863](https://github.com/commercialhaskell/stack/issues/863). Local file custom
12+
snapshots can now be safely updated without changing their name. Remote custom
13+
snapshots should still be treated as immutable.
14+
915
Behavior changes:
1016

1117
Other enhancements:
1218

1319
* Grab Cabal files via Git SHA to avoid regressions from Hackage revisions
1420
[#2070](https://github.com/commercialhaskell/stack/pull/2070)
21+
* Custom snapshots now support `ghc-options`.
1522

1623
Bug fixes:
1724

25+
* Now ignore project config when doing `stack init` or `stack new`. See
26+
[#2110](https://github.com/commercialhaskell/stack/issues/2110).
27+
1828
## 1.1.0
1929

2030
Release notes:

‎src/Network/HTTP/Download.hs

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DeriveDataTypeable #-}
33
{-# LANGUAGE MultiParamTypeClasses #-}
44
{-# LANGUAGE OverloadedStrings #-}
5+
{-# LANGUAGE TemplateHaskell #-}
56
module Network.HTTP.Download
67
( verifiedDownload
78
, DownloadRequest(..)
@@ -28,6 +29,7 @@ import Control.Exception.Enclosed (handleIO)
2829
import Control.Monad (void)
2930
import Control.Monad.Catch (MonadThrow, MonadMask, throwM)
3031
import Control.Monad.IO.Class (MonadIO, liftIO)
32+
import Control.Monad.Logger (MonadLogger, logDebug)
3133
import Control.Monad.Reader (MonadReader, ReaderT, ask,
3234
runReaderT)
3335
import Data.Aeson.Extended (FromJSON, parseJSON)
@@ -40,7 +42,11 @@ import Data.Conduit.Attoparsec (sinkParser)
4042
import Data.Conduit.Binary (sinkHandle, sourceHandle)
4143
import qualified Data.Conduit.Binary as CB
4244
import Data.Foldable (forM_)
45+
import Data.Monoid ((<>))
46+
import Data.Text.Encoding.Error (lenientDecode)
47+
import Data.Text.Encoding (decodeUtf8With)
4348
import Data.Typeable (Typeable)
49+
import Network.HTTP.Client (path)
4450
import Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request,
4551
Response, checkStatus,
4652
getHttpManager, parseUrl,
@@ -64,7 +70,7 @@ import System.IO (IOMode (ReadMode),
6470
-- appropriate destination.
6571
--
6672
-- Throws an exception if things go wrong
67-
download :: (MonadReader env m, HasHttpManager env, MonadIO m)
73+
download :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
6874
=> Request
6975
-> Path Abs File -- ^ destination
7076
-> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
@@ -81,11 +87,12 @@ download req destpath = do
8187
-- | Same as 'download', but will download a file a second time if it is already present.
8288
--
8389
-- Returns 'True' if the file was downloaded, 'False' otherwise
84-
redownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
90+
redownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
8591
=> Request
8692
-> Path Abs File -- ^ destination
8793
-> m Bool
8894
redownload req0 dest = do
95+
$logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0)
8996
let destFilePath = toFilePath dest
9097
etagFilePath = destFilePath <.> "etag"
9198

‎src/Network/HTTP/Download/Verified.hs

Lines changed: 44 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
{-# LANGUAGE RankNTypes #-}
99
{-# LANGUAGE GADTs #-}
1010
{-# LANGUAGE StandaloneDeriving #-}
11+
{-# LANGUAGE TemplateHaskell #-}
1112
module Network.HTTP.Download.Verified
1213
( verifiedDownload
1314
, recoveringHttp
@@ -19,38 +20,41 @@ module Network.HTTP.Download.Verified
1920
, VerifiedDownloadException(..)
2021
) where
2122

22-
import qualified Data.List as List
23-
import qualified Data.ByteString as ByteString
24-
import qualified Data.ByteString.Base64 as B64
25-
import qualified Data.Conduit.Binary as CB
26-
import qualified Data.Conduit.List as CL
27-
import qualified Data.Text as Text
28-
import qualified Data.Text.Encoding as Text
23+
import qualified Data.List as List
24+
import qualified Data.ByteString as ByteString
25+
import qualified Data.ByteString.Base64 as B64
26+
import qualified Data.Conduit.Binary as CB
27+
import qualified Data.Conduit.List as CL
28+
import qualified Data.Text as Text
29+
import qualified Data.Text.Encoding as Text
2930

30-
import Control.Monad
31-
import Control.Monad.Catch
32-
import Control.Monad.IO.Class
33-
import Control.Monad.Reader
34-
import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
35-
import Control.Applicative
31+
import Control.Applicative
32+
import Control.Monad
33+
import Control.Monad.Catch
34+
import Control.Monad.IO.Class
35+
import Control.Monad.Logger (logDebug, MonadLogger)
36+
import Control.Monad.Reader
37+
import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
3638
import "cryptohash" Crypto.Hash
37-
import Crypto.Hash.Conduit (sinkHash)
38-
import Data.ByteString (ByteString)
39-
import Data.ByteString.Char8 (readInteger)
40-
import Data.Conduit
41-
import Data.Conduit.Binary (sourceHandle, sinkHandle)
42-
import Data.Foldable (traverse_,for_)
43-
import Data.Monoid
44-
import Data.String
45-
import Data.Typeable (Typeable)
46-
import GHC.IO.Exception (IOException(..),IOErrorType(..))
47-
import Network.HTTP.Client.Conduit
48-
import Network.HTTP.Types.Header (hContentLength, hContentMD5)
49-
import Path
50-
import Prelude -- Fix AMP warning
51-
import System.FilePath((<.>))
52-
import System.Directory
53-
import System.IO
39+
import Crypto.Hash.Conduit (sinkHash)
40+
import Data.ByteString (ByteString)
41+
import Data.ByteString.Char8 (readInteger)
42+
import Data.Conduit
43+
import Data.Conduit.Binary (sourceHandle, sinkHandle)
44+
import Data.Foldable (traverse_,for_)
45+
import Data.Monoid
46+
import Data.String
47+
import Data.Text.Encoding (decodeUtf8With)
48+
import Data.Text.Encoding.Error (lenientDecode)
49+
import Data.Typeable (Typeable)
50+
import GHC.IO.Exception (IOException(..),IOErrorType(..))
51+
import Network.HTTP.Client.Conduit
52+
import Network.HTTP.Types.Header (hContentLength, hContentMD5)
53+
import Path
54+
import Prelude -- Fix AMP warning
55+
import System.Directory
56+
import System.FilePath ((<.>))
57+
import System.IO
5458

5559
-- | A request together with some checks to perform.
5660
data DownloadRequest = DownloadRequest
@@ -215,21 +219,23 @@ recoveringHttp retryPolicy =
215219
-- Throws VerifiedDownloadException.
216220
-- Throws IOExceptions related to file system operations.
217221
-- Throws HttpException.
218-
verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
222+
verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
219223
=> DownloadRequest
220224
-> Path Abs File -- ^ destination
221225
-> (Maybe Integer -> Sink ByteString (ReaderT env IO) ()) -- ^ custom hook to observe progress
222226
-> m Bool -- ^ Whether a download was performed
223227
verifiedDownload DownloadRequest{..} destpath progressSink = do
224228
let req = drRequest
225229
env <- ask
226-
liftIO $ whenM' getShouldDownload $ do
227-
createDirectoryIfMissing True dir
228-
withBinaryFile fptmp WriteMode $ \h ->
229-
recoveringHttp drRetryPolicy $
230-
flip runReaderT env $
231-
withResponse req (go h)
232-
renameFile fptmp fp
230+
whenM' (liftIO getShouldDownload) $ do
231+
$logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req)
232+
liftIO $ do
233+
createDirectoryIfMissing True dir
234+
withBinaryFile fptmp WriteMode $ \h ->
235+
recoveringHttp drRetryPolicy $
236+
flip runReaderT env $
237+
withResponse req (go h)
238+
renameFile fptmp fp
233239
where
234240
whenM' mp m = do
235241
p <- mp

‎src/Stack/Build.hs

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -273,26 +273,27 @@ withLoadPackage :: ( MonadIO m
273273
, MonadLogger m
274274
, HasEnvConfig env)
275275
=> EnvOverride
276-
-> ((PackageName -> Version -> Map FlagName Bool -> IO Package) -> m a)
276+
-> ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a)
277277
-> m a
278278
withLoadPackage menv inner = do
279279
econfig <- asks getEnvConfig
280280
withCabalLoader menv $ \cabalLoader ->
281-
inner $ \name version flags -> do
281+
inner $ \name version flags ghcOptions -> do
282282
bs <- cabalLoader $ PackageIdentifier name version
283283

284284
-- Intentionally ignore warnings, as it's not really
285285
-- appropriate to print a bunch of warnings out while
286286
-- resolving the package index.
287-
(_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags) bs
287+
(_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags ghcOptions) bs
288288
return pkg
289289
where
290290
-- | Package config to be used for dependencies
291-
depPackageConfig :: EnvConfig -> Map FlagName Bool -> PackageConfig
292-
depPackageConfig econfig flags = PackageConfig
291+
depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig
292+
depPackageConfig econfig flags ghcOptions = PackageConfig
293293
{ packageConfigEnableTests = False
294294
, packageConfigEnableBenchmarks = False
295295
, packageConfigFlags = flags
296+
, packageConfigGhcOptions = ghcOptions
296297
, packageConfigCompilerVersion = envConfigCompilerVersion econfig
297298
, packageConfigPlatform = configPlatform (getConfig econfig)
298299
}

‎src/Stack/Build/Cache.hs

Lines changed: 13 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33
{-# LANGUAGE TemplateHaskell #-}
44
{-# LANGUAGE TupleSections #-}
55
{-# LANGUAGE ConstraintKinds #-}
6+
{-# LANGUAGE OverloadedStrings #-}
67
-- | Cache information about previous builds
78
module Stack.Build.Cache
89
( tryGetBuildCache
@@ -28,7 +29,7 @@ module Stack.Build.Cache
2829
import Control.Exception.Enclosed (handleIO)
2930
import Control.Monad.Catch (MonadThrow, MonadCatch)
3031
import Control.Monad.IO.Class
31-
import Control.Monad.Logger (MonadLogger)
32+
import Control.Monad.Logger (MonadLogger, logDebug)
3233
import Control.Monad.Reader
3334
import qualified Crypto.Hash.SHA256 as SHA256
3435
import qualified Data.Binary as Binary (encode)
@@ -37,6 +38,7 @@ import qualified Data.ByteString.Char8 as S8
3738
import qualified Data.ByteString.Base16 as B16
3839
import Data.Map (Map)
3940
import Data.Maybe (fromMaybe, mapMaybe)
41+
import Data.Monoid ((<>))
4042
import Data.Set (Set)
4143
import qualified Data.Set as Set
4244
import Data.Text (Text)
@@ -234,7 +236,7 @@ checkTestSuccess dir =
234236
-- | The file containing information on the given package/configuration
235237
-- combination. The filename contains a hash of the non-directory configure
236238
-- options for quick lookup if there's a match.
237-
precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
239+
precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)
238240
=> PackageIdentifier
239241
-> ConfigureOpts
240242
-> Set GhcPkgId -- ^ dependencies
@@ -255,14 +257,13 @@ precompiledCacheFile pkgident copts installedPackageIDs = do
255257
-- unnecessarily.
256258
--
257259
-- See issue: https://github.com/commercialhaskell/stack/issues/1103
258-
let cacheInput
259-
| envConfigCabalVersion ec >= $(mkVersion "1.22") =
260-
Binary.encode $ coNoDirs copts
261-
| otherwise =
262-
Binary.encode
263-
( coNoDirs copts
264-
, installedPackageIDs
265-
)
260+
let computeCacheSource input = do
261+
$logDebug $ "Precompiled cache input = " <> T.pack (show input)
262+
return $ Binary.encode input
263+
cacheInput <-
264+
if envConfigCabalVersion ec >= $(mkVersion "1.22")
265+
then computeCacheSource (coNoDirs copts)
266+
else computeCacheSource (coNoDirs copts, installedPackageIDs)
266267

267268
-- We only pay attention to non-directory options. We don't want to avoid a
268269
-- cache hit just because it was installed in a different directory.
@@ -279,7 +280,7 @@ precompiledCacheFile pkgident copts installedPackageIDs = do
279280
</> copts'
280281

281282
-- | Write out information about a newly built package
282-
writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
283+
writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)
283284
=> BaseConfigOpts
284285
-> PackageIdentifier
285286
-> ConfigureOpts
@@ -306,7 +307,7 @@ writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do
306307

307308
-- | Check the cache for a precompiled package matching the given
308309
-- configuration.
309-
readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
310+
readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)
310311
=> PackageIdentifier -- ^ target package
311312
-> ConfigureOpts
312313
-> Set GhcPkgId -- ^ dependencies

‎src/Stack/Build/ConstructPlan.hs

Lines changed: 10 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -102,7 +102,7 @@ type M = RWST
102102
data Ctx = Ctx
103103
{ mbp :: !MiniBuildPlan
104104
, baseConfigOpts :: !BaseConfigOpts
105-
, loadPackage :: !(PackageName -> Version -> Map FlagName Bool -> IO Package)
105+
, loadPackage :: !(PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package)
106106
, combinedMap :: !CombinedMap
107107
, toolToPackages :: !(Cabal.Dependency -> Map PackageName VersionRange)
108108
, ctxEnvConfig :: !EnvConfig
@@ -129,7 +129,7 @@ constructPlan :: forall env m.
129129
-> [LocalPackage]
130130
-> Set PackageName -- ^ additional packages that must be built
131131
-> [DumpPackage () ()] -- ^ locally registered
132-
-> (PackageName -> Version -> Map FlagName Bool -> IO Package) -- ^ load upstream package
132+
-> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package
133133
-> SourceMap
134134
-> InstalledMap
135135
-> m Plan
@@ -205,7 +205,7 @@ mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap =
205205
case M.lookup name tasks of
206206
Nothing ->
207207
case M.lookup name sourceMap of
208-
Just (PSUpstream _ Snap _ _) -> Map.singleton gid
208+
Just (PSUpstream _ Snap _ _ _) -> Map.singleton gid
209209
( ident
210210
, Just "Switching to snapshot installed package"
211211
)
@@ -234,7 +234,6 @@ addFinal lp package isAllInOne = do
234234
(getEnvConfig ctx)
235235
(baseConfigOpts ctx)
236236
allDeps
237-
True -- wanted
238237
True -- local
239238
Local
240239
package
@@ -279,14 +278,16 @@ tellExecutables :: PackageName -> PackageSource -> M ()
279278
tellExecutables _ (PSLocal lp)
280279
| lpWanted lp = tellExecutablesPackage Local $ lpPackage lp
281280
| otherwise = return ()
282-
tellExecutables name (PSUpstream version loc flags _) =
281+
-- Ignores ghcOptions because they don't matter for enumerating
282+
-- executables.
283+
tellExecutables name (PSUpstream version loc flags _ghcOptions _gitSha) =
283284
tellExecutablesUpstream name version loc flags
284285

285286
tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M ()
286287
tellExecutablesUpstream name version loc flags = do
287288
ctx <- ask
288289
when (name `Set.member` extraToBuild ctx) $ do
289-
p <- liftIO $ loadPackage ctx name version flags
290+
p <- liftIO $ loadPackage ctx name version flags []
290291
tellExecutablesPackage loc p
291292

292293
tellExecutablesPackage :: InstallLocation -> Package -> M ()
@@ -319,8 +320,8 @@ installPackage :: Bool -- ^ is this being used by a dependency?
319320
installPackage treatAsDep name ps minstalled = do
320321
ctx <- ask
321322
case ps of
322-
PSUpstream version _ flags _ -> do
323-
package <- liftIO $ loadPackage ctx name version flags
323+
PSUpstream version _ flags ghcOptions _ -> do
324+
package <- liftIO $ loadPackage ctx name version flags ghcOptions
324325
resolveDepsAndInstall False treatAsDep ps package minstalled
325326
PSLocal lp ->
326327
case lpTestBench lp of
@@ -403,7 +404,6 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL
403404
(getEnvConfig ctx)
404405
(baseConfigOpts ctx)
405406
allDeps
406-
(psWanted ps)
407407
(psLocal ps)
408408
-- An assertion to check for a recurrence of
409409
-- https://github.com/commercialhaskell/stack/issues/345
@@ -413,7 +413,7 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL
413413
, taskType =
414414
case ps of
415415
PSLocal lp -> TTLocal lp
416-
PSUpstream _ loc _ sha -> TTUpstream package (loc <> minLoc) sha
416+
PSUpstream _ loc _ _ sha -> TTUpstream package (loc <> minLoc) sha
417417
, taskAllInOne = isAllInOne
418418
}
419419

@@ -503,7 +503,6 @@ checkDirtiness ps installed package present wanted = do
503503
(getEnvConfig ctx)
504504
(baseConfigOpts ctx)
505505
present
506-
(psWanted ps)
507506
(psLocal ps)
508507
(piiLocation ps) -- should be Local always
509508
package
@@ -599,10 +598,6 @@ psDirty :: PackageSource -> Maybe (Set FilePath)
599598
psDirty (PSLocal lp) = lpDirtyFiles lp
600599
psDirty (PSUpstream {}) = Nothing -- files never change in an upstream package
601600

602-
psWanted :: PackageSource -> Bool
603-
psWanted (PSLocal lp) = lpWanted lp
604-
psWanted (PSUpstream {}) = False
605-
606601
psLocal :: PackageSource -> Bool
607602
psLocal (PSLocal _) = True
608603
psLocal (PSUpstream {}) = False

0 commit comments

Comments
 (0)