Merge pull request #884 from commercialhaskell/878-shared-database

Share binary package buils between snapshots #878

ChangeLog.md

@@ -4,6 +4,7 @@ Major changes:
 
 * You now have more control over how GHC versions are matched, e.g. "use exactly this version," "use the specified minor version, but allow patches," or "use the given minor version or any later minor in the given major release." The default has switched from allowing newer later minor versions to a specific minor version allowing patches. For more information, see [#736](https://github.com/commercialhaskell/stack/issues/736) and [#784](https://github.com/commercialhaskell/stack/pull/784).
 * Support added for compiling with GHCJS
+* stack can now reuse prebuilt binaries between snapshots. That means that, if you build package foo in LTS-3.1, that binary version can be reused in LTS-3.2, assuming it uses the same dependencies and flags. [#878](https://github.com/commercialhaskell/stack/issues/878)
 
 Other enhancements:
 

src/Stack/Build/Cache.hs

@@ -26,16 +26,26 @@ module Stack.Build.Cache
     , setBenchBuilt
     , unsetBenchBuilt
     , checkBenchBuilt
+    , writePrecompiledCache
+    , readPrecompiledCache
     ) where
 
 import           Control.Exception.Enclosed (handleIO)
 import           Control.Monad.Catch (MonadThrow)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger (MonadLogger)
 import           Control.Monad.Reader
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Data.Binary as Binary
 import           Data.Binary.VersionTagged
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Base64 as B64
 import           Data.Map (Map)
 import           Data.Maybe (fromMaybe, mapMaybe)
+import           Data.Set (Set)
+import qualified Data.Set as Set
+import           Data.Text (Text)
+import qualified Data.Text as T
 import           GHC.Generics (Generic)
 import           Path
 import           Path.IO
@@ -271,3 +281,71 @@ checkBenchBuilt dir =
     liftM
         (fromMaybe False)
         (tryGetCache benchBuiltFile dir)
+
+--------------------------------------
+-- Precompiled Cache
+--
+-- Idea is simple: cache information about packages built in other snapshots,
+-- and then for identical matches (same flags, config options, dependencies)
+-- just copy over the executables and reregister the libraries.
+--------------------------------------
+
+-- | 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)
+                     => PackageIdentifier
+                     -> ConfigureOpts
+                     -> m (Path Abs File)
+precompiledCacheFile pkgident copts = do
+    ec <- asks getEnvConfig
+
+    compiler <- parseRelDir $ T.unpack $ compilerVersionName $ envConfigCompilerVersion ec
+    cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec
+    pkg <- parseRelDir $ packageIdentifierString pkgident
+
+    -- 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.
+    copts' <- parseRelFile $ S8.unpack $ B64.encode $ SHA256.hashlazy $ Binary.encode $ coNoDirs copts
+
+    return $ getStackRoot ec
+         </> $(mkRelDir "precompiled")
+         </> compiler
+         </> cabal
+         </> pkg
+         </> copts'
+
+-- | Write out information about a newly built package
+writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
+                      => BaseConfigOpts
+                      -> PackageIdentifier
+                      -> ConfigureOpts
+                      -> Maybe GhcPkgId -- ^ library
+                      -> Set Text -- ^ executables
+                      -> m ()
+writePrecompiledCache baseConfigOpts pkgident copts mghcPkgId exes = do
+    file <- precompiledCacheFile pkgident copts
+    createTree $ parent file
+    mlibpath <-
+        case mghcPkgId of
+            Nothing -> return Nothing
+            Just ipid -> liftM Just $ do
+                ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf"
+                return $ toFilePath $ bcoSnapDB baseConfigOpts </> ipid'
+    exes' <- forM (Set.toList exes) $ \exe -> do
+        name <- parseRelFile $ T.unpack exe
+        return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
+    liftIO $ encodeFile (toFilePath file) PrecompiledCache
+        { pcLibrary = mlibpath
+        , pcExes = exes'
+        }
+
+-- | Check the cache for a precompiled package matching the given
+-- configuration.
+readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m)
+                     => PackageIdentifier -- ^ target package
+                     -> ConfigureOpts
+                     -> m (Maybe PrecompiledCache)
+readPrecompiledCache pkgident copts = do
+    file <- precompiledCacheFile pkgident copts
+    decodeFileOrFailDeep $ toFilePath file

src/Stack/Build/ConstructPlan.hs

@@ -28,7 +28,7 @@ import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
 import qualified Data.Text as T
-import           Data.Text.Encoding (encodeUtf8, decodeUtf8With)
+import           Data.Text.Encoding (decodeUtf8With)
 import           Data.Text.Encoding.Error (lenientDecode)
 import           Distribution.Package (Dependency (..))
 import           Distribution.Version         (anyVersion)
@@ -423,7 +423,7 @@ checkDirtiness ps installed package present wanted = do
             package
         buildOpts = bcoBuildOpts (baseConfigOpts ctx)
         wantConfigCache = ConfigCache
-            { configCacheOpts = map encodeUtf8 configOpts
+            { configCacheOpts = configOpts
             , configCacheDeps = present
             , configCacheComponents =
                 case ps of
@@ -474,7 +474,8 @@ describeConfigDiff old new
         ]
 
     userOpts = filter (not . isStackOpt)
-             . map (decodeUtf8With lenientDecode)
+             . map T.pack
+             . (\(ConfigureOpts x y) -> x ++ y)
              . configCacheOpts
 
     (oldOpts, newOpts) = removeMatching (userOpts old) (userOpts new)