Merge pull request #2098 from commercialhaskell/863-extensible-snapshots

#863 extensible snapshots
commercialhaskell · May 7, 2016 · 8d9fd0c · 8d9fd0c
2 parents 6a22557 + f6d352e
commit 8d9fd0c
Show file tree

Hide file tree

Showing 31 changed files with 729 additions and 373 deletions.
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -6,15 +6,25 @@ Release notes:
 
 Major changes:
 
+* Extensible custom snapshots implemented. These allow you to define snapshots
+which extend other snapshots. See
+[#863](https://github.com/commercialhaskell/stack/issues/863). Local file custom
+snapshots can now be safely updated without changing their name.  Remote custom
+snapshots should still be treated as immutable.
+
 Behavior changes:
 
 Other enhancements:
 
 * Grab Cabal files via Git SHA to avoid regressions from Hackage revisions
   [#2070](https://github.com/commercialhaskell/stack/pull/2070)
+* Custom snapshots now support `ghc-options`.
 
 Bug fixes:
 
+* Now ignore project config when doing `stack init` or `stack new`. See
+  [#2110](https://github.com/commercialhaskell/stack/issues/2110).
+
 ## 1.1.0
 
 Release notes:

diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveDataTypeable    #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell  #-}
 module Network.HTTP.Download
     ( verifiedDownload
     , DownloadRequest(..)
@@ -28,6 +29,7 @@ import           Control.Exception.Enclosed  (handleIO)
 import           Control.Monad               (void)
 import           Control.Monad.Catch         (MonadThrow, MonadMask, throwM)
 import           Control.Monad.IO.Class      (MonadIO, liftIO)
+import           Control.Monad.Logger        (MonadLogger, logDebug)
 import           Control.Monad.Reader        (MonadReader, ReaderT, ask,
                                               runReaderT)
 import           Data.Aeson.Extended         (FromJSON, parseJSON)
@@ -40,7 +42,11 @@ import           Data.Conduit.Attoparsec     (sinkParser)
 import           Data.Conduit.Binary         (sinkHandle, sourceHandle)
 import qualified Data.Conduit.Binary         as CB
 import           Data.Foldable               (forM_)
+import           Data.Monoid                 ((<>))
+import           Data.Text.Encoding.Error    (lenientDecode)
+import           Data.Text.Encoding          (decodeUtf8With)
 import           Data.Typeable               (Typeable)
+import           Network.HTTP.Client         (path)
 import           Network.HTTP.Client.Conduit (HasHttpManager, Manager, Request,
                                               Response, checkStatus,
                                               getHttpManager, parseUrl,
@@ -64,7 +70,7 @@ import           System.IO                   (IOMode (ReadMode),
 -- appropriate destination.
 --
 -- Throws an exception if things go wrong
-download :: (MonadReader env m, HasHttpManager env, MonadIO m)
+download :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
          => Request
          -> Path Abs File -- ^ destination
          -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
@@ -81,11 +87,12 @@ download req destpath = do
 -- | Same as 'download', but will download a file a second time if it is already present.
 --
 -- Returns 'True' if the file was downloaded, 'False' otherwise
-redownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
+redownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
            => Request
            -> Path Abs File -- ^ destination
            -> m Bool
 redownload req0 dest = do
+    $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0)
     let destFilePath = toFilePath dest
         etagFilePath = destFilePath <.> "etag"
 

diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TemplateHaskell       #-}
 module Network.HTTP.Download.Verified
   ( verifiedDownload
   , recoveringHttp
@@ -19,38 +20,41 @@ module Network.HTTP.Download.Verified
   , VerifiedDownloadException(..)
   ) where
 
-import qualified Data.List as List
-import qualified Data.ByteString as ByteString
-import qualified Data.ByteString.Base64 as B64
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
+import qualified    Data.List as List
+import qualified    Data.ByteString as ByteString
+import qualified    Data.ByteString.Base64 as B64
+import qualified    Data.Conduit.Binary as CB
+import qualified    Data.Conduit.List as CL
+import qualified    Data.Text as Text
+import qualified    Data.Text.Encoding as Text
 
-import Control.Monad
-import Control.Monad.Catch
-import Control.Monad.IO.Class
-import Control.Monad.Reader
-import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
-import Control.Applicative
+import              Control.Applicative
+import              Control.Monad
+import              Control.Monad.Catch
+import              Control.Monad.IO.Class
+import              Control.Monad.Logger (logDebug, MonadLogger)
+import              Control.Monad.Reader
+import              Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
 import "cryptohash" Crypto.Hash
-import Crypto.Hash.Conduit (sinkHash)
-import Data.ByteString (ByteString)
-import Data.ByteString.Char8 (readInteger)
-import Data.Conduit
-import Data.Conduit.Binary (sourceHandle, sinkHandle)
-import Data.Foldable (traverse_,for_)
-import Data.Monoid
-import Data.String
-import Data.Typeable (Typeable)
-import GHC.IO.Exception (IOException(..),IOErrorType(..))
-import Network.HTTP.Client.Conduit
-import Network.HTTP.Types.Header (hContentLength, hContentMD5)
-import Path
-import Prelude -- Fix AMP warning
-import System.FilePath((<.>))
-import System.Directory
-import System.IO
+import              Crypto.Hash.Conduit (sinkHash)
+import              Data.ByteString (ByteString)
+import              Data.ByteString.Char8 (readInteger)
+import              Data.Conduit
+import              Data.Conduit.Binary (sourceHandle, sinkHandle)
+import              Data.Foldable (traverse_,for_)
+import              Data.Monoid
+import              Data.String
+import              Data.Text.Encoding (decodeUtf8With)
+import              Data.Text.Encoding.Error (lenientDecode)
+import              Data.Typeable (Typeable)
+import              GHC.IO.Exception (IOException(..),IOErrorType(..))
+import              Network.HTTP.Client.Conduit
+import              Network.HTTP.Types.Header (hContentLength, hContentMD5)
+import              Path
+import              Prelude -- Fix AMP warning
+import              System.Directory
+import              System.FilePath ((<.>))
+import              System.IO
 
 -- | A request together with some checks to perform.
 data DownloadRequest = DownloadRequest
@@ -215,21 +219,23 @@ recoveringHttp retryPolicy =
 -- Throws VerifiedDownloadException.
 -- Throws IOExceptions related to file system operations.
 -- Throws HttpException.
-verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
+verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m)
          => DownloadRequest
          -> Path Abs File -- ^ destination
          -> (Maybe Integer -> Sink ByteString (ReaderT env IO) ()) -- ^ custom hook to observe progress
          -> m Bool -- ^ Whether a download was performed
 verifiedDownload DownloadRequest{..} destpath progressSink = do
     let req = drRequest
     env <- ask
-    liftIO $ whenM' getShouldDownload $ do
-        createDirectoryIfMissing True dir
-        withBinaryFile fptmp WriteMode $ \h ->
-            recoveringHttp drRetryPolicy $
-                flip runReaderT env $
-                    withResponse req (go h)
-        renameFile fptmp fp
+    whenM' (liftIO getShouldDownload) $ do
+        $logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req)
+        liftIO $ do
+            createDirectoryIfMissing True dir
+            withBinaryFile fptmp WriteMode $ \h ->
+                recoveringHttp drRetryPolicy $
+                    flip runReaderT env $
+                        withResponse req (go h)
+            renameFile fptmp fp
   where
     whenM' mp m = do
         p <- mp

diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs
@@ -273,26 +273,27 @@ withLoadPackage :: ( MonadIO m
                    , MonadLogger m
                    , HasEnvConfig env)
                 => EnvOverride
-                -> ((PackageName -> Version -> Map FlagName Bool -> IO Package) -> m a)
+                -> ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a)
                 -> m a
 withLoadPackage menv inner = do
     econfig <- asks getEnvConfig
     withCabalLoader menv $ \cabalLoader ->
-        inner $ \name version flags -> do
+        inner $ \name version flags ghcOptions -> do
             bs <- cabalLoader $ PackageIdentifier name version
 
             -- Intentionally ignore warnings, as it's not really
             -- appropriate to print a bunch of warnings out while
             -- resolving the package index.
-            (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags) bs
+            (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags ghcOptions) bs
             return pkg
   where
     -- | Package config to be used for dependencies
-    depPackageConfig :: EnvConfig -> Map FlagName Bool -> PackageConfig
-    depPackageConfig econfig flags = PackageConfig
+    depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig
+    depPackageConfig econfig flags ghcOptions = PackageConfig
         { packageConfigEnableTests = False
         , packageConfigEnableBenchmarks = False
         , packageConfigFlags = flags
+        , packageConfigGhcOptions = ghcOptions
         , packageConfigCompilerVersion = envConfigCompilerVersion econfig
         , packageConfigPlatform = configPlatform (getConfig econfig)
         }

diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE OverloadedStrings     #-}
 -- | Cache information about previous builds
 module Stack.Build.Cache
     ( tryGetBuildCache
@@ -28,7 +29,7 @@ module Stack.Build.Cache
 import           Control.Exception.Enclosed (handleIO)
 import           Control.Monad.Catch (MonadThrow, MonadCatch)
 import           Control.Monad.IO.Class
-import           Control.Monad.Logger (MonadLogger)
+import           Control.Monad.Logger (MonadLogger, logDebug)
 import           Control.Monad.Reader
 import qualified Crypto.Hash.SHA256 as SHA256
 import qualified Data.Binary as Binary (encode)
@@ -37,6 +38,7 @@ import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Base16 as B16
 import           Data.Map (Map)
 import           Data.Maybe (fromMaybe, mapMaybe)
+import           Data.Monoid ((<>))
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
@@ -234,7 +236,7 @@ checkTestSuccess dir =
 -- | The file containing information on the given package/configuration
 -- combination. The filename contains a hash of the non-directory configure
 -- options for quick lookup if there's a match.
-precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
+precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadLogger m)
                      => PackageIdentifier
                      -> ConfigureOpts
                      -> Set GhcPkgId -- ^ dependencies
@@ -255,14 +257,13 @@ precompiledCacheFile pkgident copts installedPackageIDs = do
     -- unnecessarily.
     --
     -- See issue: https://github.com/commercialhaskell/stack/issues/1103
-    let cacheInput
-            | envConfigCabalVersion ec >= $(mkVersion "1.22") =
-                Binary.encode $ coNoDirs copts
-            | otherwise =
-                Binary.encode
-                    ( coNoDirs copts
-                    , installedPackageIDs
-                    )
+    let computeCacheSource input = do
+            $logDebug $ "Precompiled cache input = " <> T.pack (show input)
+            return $ Binary.encode input
+    cacheInput <-
+        if envConfigCabalVersion ec >= $(mkVersion "1.22")
+            then computeCacheSource (coNoDirs copts)
+            else computeCacheSource (coNoDirs copts, installedPackageIDs)
 
     -- We only pay attention to non-directory options. We don't want to avoid a
     -- cache hit just because it was installed in a different directory.
@@ -279,7 +280,7 @@ precompiledCacheFile pkgident copts installedPackageIDs = do
          </> copts'
 
 -- | Write out information about a newly built package
-writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
+writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)
                       => BaseConfigOpts
                       -> PackageIdentifier
                       -> ConfigureOpts
@@ -306,7 +307,7 @@ writePrecompiledCache baseConfigOpts pkgident copts depIDs mghcPkgId exes = do
 
 -- | Check the cache for a precompiled package matching the given
 -- configuration.
-readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
+readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m, MonadLogger m)
                      => PackageIdentifier -- ^ target package
                      -> ConfigureOpts
                      -> Set GhcPkgId -- ^ dependencies

diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs
@@ -102,7 +102,7 @@ type M = RWST
 data Ctx = Ctx
     { mbp            :: !MiniBuildPlan
     , baseConfigOpts :: !BaseConfigOpts
-    , loadPackage    :: !(PackageName -> Version -> Map FlagName Bool -> IO Package)
+    , loadPackage    :: !(PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package)
     , combinedMap    :: !CombinedMap
     , toolToPackages :: !(Cabal.Dependency -> Map PackageName VersionRange)
     , ctxEnvConfig   :: !EnvConfig
@@ -129,7 +129,7 @@ constructPlan :: forall env m.
               -> [LocalPackage]
               -> Set PackageName -- ^ additional packages that must be built
               -> [DumpPackage () ()] -- ^ locally registered
-              -> (PackageName -> Version -> Map FlagName Bool -> IO Package) -- ^ load upstream package
+              -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package
               -> SourceMap
               -> InstalledMap
               -> m Plan
@@ -205,7 +205,7 @@ mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap =
         case M.lookup name tasks of
             Nothing ->
                 case M.lookup name sourceMap of
-                    Just (PSUpstream _ Snap _ _) -> Map.singleton gid
+                    Just (PSUpstream _ Snap _ _ _) -> Map.singleton gid
                         ( ident
                         , Just "Switching to snapshot installed package"
                         )
@@ -234,7 +234,6 @@ addFinal lp package isAllInOne = do
                             (getEnvConfig ctx)
                             (baseConfigOpts ctx)
                             allDeps
-                            True -- wanted
                             True -- local
                             Local
                             package
@@ -279,14 +278,16 @@ tellExecutables :: PackageName -> PackageSource -> M ()
 tellExecutables _ (PSLocal lp)
     | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp
     | otherwise = return ()
-tellExecutables name (PSUpstream version loc flags _) =
+-- Ignores ghcOptions because they don't matter for enumerating
+-- executables.
+tellExecutables name (PSUpstream version loc flags _ghcOptions _gitSha) =
     tellExecutablesUpstream name version loc flags
 
 tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M ()
 tellExecutablesUpstream name version loc flags = do
     ctx <- ask
     when (name `Set.member` extraToBuild ctx) $ do
-        p <- liftIO $ loadPackage ctx name version flags
+        p <- liftIO $ loadPackage ctx name version flags []
         tellExecutablesPackage loc p
 
 tellExecutablesPackage :: InstallLocation -> Package -> M ()
@@ -319,8 +320,8 @@ installPackage :: Bool -- ^ is this being used by a dependency?
 installPackage treatAsDep name ps minstalled = do
     ctx <- ask
     case ps of
-        PSUpstream version _ flags _ -> do
-            package <- liftIO $ loadPackage ctx name version flags
+        PSUpstream version _ flags ghcOptions _ -> do
+            package <- liftIO $ loadPackage ctx name version flags ghcOptions
             resolveDepsAndInstall False treatAsDep ps package minstalled
         PSLocal lp ->
             case lpTestBench lp of
@@ -403,7 +404,6 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL
                         (getEnvConfig ctx)
                         (baseConfigOpts ctx)
                         allDeps
-                        (psWanted ps)
                         (psLocal ps)
                         -- An assertion to check for a recurrence of
                         -- https://github.com/commercialhaskell/stack/issues/345
@@ -413,7 +413,7 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL
             , taskType =
                 case ps of
                     PSLocal lp -> TTLocal lp
-                    PSUpstream _ loc _ sha -> TTUpstream package (loc <> minLoc) sha
+                    PSUpstream _ loc _ _ sha -> TTUpstream package (loc <> minLoc) sha
             , taskAllInOne = isAllInOne
             }
 
@@ -503,7 +503,6 @@ checkDirtiness ps installed package present wanted = do
             (getEnvConfig ctx)
             (baseConfigOpts ctx)
             present
-            (psWanted ps)
             (psLocal ps)
             (piiLocation ps) -- should be Local always
             package
@@ -599,10 +598,6 @@ psDirty :: PackageSource -> Maybe (Set FilePath)
 psDirty (PSLocal lp) = lpDirtyFiles lp
 psDirty (PSUpstream {}) = Nothing -- files never change in an upstream package
 
-psWanted :: PackageSource -> Bool
-psWanted (PSLocal lp) = lpWanted lp
-psWanted (PSUpstream {}) = False
-
 psLocal :: PackageSource -> Bool
 psLocal (PSLocal _) = True
 psLocal (PSUpstream {}) = False