[WIP] Lock files

package.yaml

@@ -185,6 +185,7 @@ library:
   - Stack.Image
   - Stack.Init
   - Stack.Ls
+  - Stack.Lock
   - Stack.New
   - Stack.Nix
   - Stack.Options.BenchParser
@@ -301,6 +302,7 @@ tests:
     - hspec
     - stack
     - smallcheck
+    - raw-strings-qq
   stack-integration-test:
     main: IntegrationSpec.hs
     source-dirs:

src/Stack/Build.hs

@@ -92,7 +92,6 @@ build msetLocalFiles mbuildLk = do
     boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI
     baseConfigOpts <- mkBaseConfigOpts boptsCli
     plan <- constructPlan baseConfigOpts localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli)
-
     allowLocals <- view $ configL.to configAllowLocals
     unless allowLocals $ case justLocals plan of
       [] -> return ()
@@ -107,14 +106,11 @@ build msetLocalFiles mbuildLk = do
       (Just lk,True) -> do logDebug "All installs are local; releasing snapshot lock early."
                            liftIO $ unlockFile lk
       _ -> return ()
-
     checkCabalVersion
     warnAboutSplitObjs bopts
     warnIfExecutablesWithSameNameCouldBeOverwritten locals plan
-
     when (boptsPreFetch bopts) $
         preFetch plan
-
     if boptsCLIDryrun boptsCli
         then printPlan plan
         else executePlan boptsCli baseConfigOpts locals

src/Stack/Build/ConstructPlan.hs

@@ -1016,6 +1016,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDe
          , line
          ]
 
+    extras :: Map PackageName (Version, BlobKey)
     extras = Map.unions $ map getExtras exceptions'
     getExtras DependencyCycleDetected{} = Map.empty
     getExtras UnknownPackage{} = Map.empty
@@ -1028,9 +1029,8 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDe
        go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) =
            Map.singleton name (version, cabalHash)
        go _ = Map.empty
-    pprintExtra (name, (version, BlobKey cabalHash cabalSize)) =
-      let cfInfo = CFIHash cabalHash (Just cabalSize)
-          packageIdRev = PackageIdentifierRevision name version cfInfo
+    pprintExtra (name, (version, BlobKey _ _)) =
+      let packageIdRev = PackageIdentifierRevision name version CFILatest
        in fromString $ T.unpack $ utf8BuilderToText $ RIO.display packageIdRev
 
     allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions'

src/Stack/Config.hs

@@ -87,6 +87,14 @@ import           System.PosixCompat.Files (fileOwner, getFileStatus)
 import           System.PosixCompat.User (getEffectiveUserID)
 import           RIO.PrettyPrint
 import           RIO.Process
+import Stack.Lock
+    ( LockFile(..)
+    , generatePackageLockFile
+    , generateSnapshotLayerLockFile
+    , isLockFileOutdated
+    , loadPackageLockFile
+    , loadSnapshotLayerLockFile
+    )
 
 -- | If deprecated path exists, use it and print a warning.
 -- Otherwise, return the new path.
@@ -513,6 +521,18 @@ loadConfig :: HasRunner env
 loadConfig configArgs mresolver mstackYaml inner =
     loadProjectConfig mstackYaml >>= \x -> loadConfigMaybeProject configArgs mresolver x inner
 
+cachedCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)   => Map RawPackageLocation PackageLocation
+  -> RawPackageLocation
+  -> RIO env PackageLocation
+cachedCompletePackageLocation cachePackages rp@(RPLImmutable rpli) = do
+  let item = Map.lookup rp cachePackages
+  case item of
+    Nothing -> do
+              pl <- completePackageLocation rpli
+              pure $ PLImmutable pl
+    Just pl -> pure pl
+cachedCompletePackageLocation _ (RPLMutable rplm) = pure $ PLMutable rplm
+
 -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.
 -- values.
 loadBuildConfig :: LocalConfigStatus (Project, Path Abs File, ConfigMonoid)
@@ -587,8 +607,37 @@ loadBuildConfig mproject maresolver mcompiler = do
             { projectResolver = fromMaybe (projectResolver project') mresolver
             }
 
-    resolver <- completeSnapshotLocation $ projectResolver project
-    (snapshot, _completed) <- loadAndCompleteSnapshot resolver
+    lockFileOutdated <- isLockFileOutdated stackYamlFP
+    if lockFileOutdated
+    then do
+      logDebug "Lock file is outdated or isn't present"
+      generatePackageLockFile stackYamlFP
+    else logDebug "Lock file is upto date"
+
+    lockFile <- liftIO $ addFileExtension "lock" stackYamlFP
+    (cachedPackageLock, origResolver, compResolver) <- liftIO $ do
+                                                  lf <- loadPackageLockFile lockFile
+                                                  return (lfPackageLocations lf, lfoResolver lf, lfcResolver lf)
+
+
+    resolver <- if projectResolver project == origResolver
+                then pure compResolver
+                else completeSnapshotLocation $ projectResolver project
+
+    case resolver of
+      SLFilePath path -> do
+                    outdated <- isLockFileOutdated (resolvedAbsolute path)
+                    when outdated (generateSnapshotLayerLockFile resolver stackYamlFP)
+      _ -> return ()
+
+    cachedSnapshotLock <- case resolver of
+                  SLFilePath path -> do
+                           let sf = resolvedAbsolute path
+                           slf <- liftIO $ addFileExtension "lock" sf
+                           liftIO $ loadSnapshotLayerLockFile slf (parent stackYamlFP)
+                  _ -> pure Map.empty
+
+    (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedSnapshotLock
 
     extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)
 
@@ -600,11 +649,8 @@ loadBuildConfig mproject maresolver mcompiler = do
       pp <- mkProjectPackage YesPrintWarnings resolved (boptsHaddock bopts)
       pure (cpName $ ppCommon pp, pp)
 
-    let completeLocation (RPLMutable m) = pure $ PLMutable m
-        completeLocation (RPLImmutable im) = PLImmutable <$> completePackageLocation im
-
     deps0 <- forM (projectDependencies project) $ \rpl -> do
-      pl <- completeLocation rpl
+      pl <- cachedCompletePackageLocation cachedPackageLock rpl
       dp <- additionalDepPackage (shouldHaddockDeps bopts) pl
       pure (cpName $ dpCommon dp, dp)
 

src/Stack/Freeze.hs

@@ -1,77 +1,84 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Stack.Freeze
     ( freeze
-    , FreezeOpts (..)
-    , FreezeMode (..)
+    , FreezeOpts(..)
+    , FreezeMode(..)
     ) where
 
-import           Data.Aeson ((.=), object)
+import Data.Aeson ((.=), object)
 import qualified Data.Yaml as Yaml
-import           RIO.Process
 import qualified RIO.ByteString as B
-import           Stack.Prelude
-import           Stack.Types.Config
+import RIO.Process
+import Stack.Prelude
+import Stack.Types.Config
 
-data FreezeMode = FreezeProject | FreezeSnapshot
+data FreezeMode
+    = FreezeProject
+    | FreezeSnapshot
 
 newtype FreezeOpts = FreezeOpts
     { freezeMode :: FreezeMode
     }
 
 freeze :: HasEnvConfig env => FreezeOpts -> RIO env ()
 freeze (FreezeOpts mode) = do
-  mproject <- view $ configL.to configMaybeProject
-  case mproject of
-    Just (p, _) -> doFreeze p mode
-    Nothing -> logWarn "No project was found: nothing to freeze"
+    mproject <- view $ configL . to configMaybeProject
+    case mproject of
+        Just (p, _) -> doFreeze p mode
+        Nothing -> logWarn "No project was found: nothing to freeze"
+
+completeFullPackageLocation ::
+       (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+    => RawPackageLocation
+    -> RIO env PackageLocation
+completeFullPackageLocation (RPLImmutable rpli) = do
+    pl <- completePackageLocation rpli
+    pure $ PLImmutable pl
+completeFullPackageLocation (RPLMutable rplm) = pure $ PLMutable rplm
 
 doFreeze ::
-       (HasProcessContext env, HasLogFunc env, HasPantryConfig env)
+       ( HasProcessContext env
+       , HasLogFunc env
+       , HasPantryConfig env
+       , HasEnvConfig env
+       )
     => Project
     -> FreezeMode
     -> RIO env ()
 doFreeze p FreezeProject = do
-  let deps = projectDependencies p
-      resolver = projectResolver p
-      completePackageLocation' pl =
-        case pl of
-          RPLImmutable pli -> PLImmutable <$> completePackageLocation pli
-          RPLMutable m -> pure $ PLMutable m
-  resolver' <- completeSnapshotLocation resolver
-  deps' <- mapM completePackageLocation' deps
-  let rawCompleted = map toRawPL deps'
-      rawResolver = toRawSL resolver'
-  if rawCompleted == deps && rawResolver == resolver
-  then
-    logInfo "No freezing is required for this project"
-  else do
-    logInfo "# Fields not mentioned below do not need to be updated"
-
-    if rawResolver == resolver
-      then logInfo "# No update to resolver is needed"
-      else do
-        logInfo "# Frozen version of resolver"
-        B.putStr $ Yaml.encode $ object ["resolver" .= rawResolver]
-
-    if rawCompleted == deps
-      then logInfo "# No update to extra-deps is needed"
-      else do
-        logInfo "# Frozen version of extra-deps"
-        B.putStr $ Yaml.encode $ object ["extra-deps" .= rawCompleted]
-
+    let deps :: [RawPackageLocation] = projectDependencies p
+        resolver :: RawSnapshotLocation = projectResolver p
+    resolver' :: SnapshotLocation <- completeSnapshotLocation resolver
+    deps' :: [PackageLocation] <- mapM completeFullPackageLocation deps
+    let rawCompleted = map toRawPL deps'
+        rawResolver = toRawSL resolver'
+    if rawCompleted == deps && rawResolver == resolver
+        then logInfo "No freezing is required for this project"
+        else do
+            logInfo "# Fields not mentioned below do not need to be updated"
+            if rawResolver == resolver
+                then logInfo "# No update to resolver is needed"
+                else do
+                    logInfo "# Frozen version of resolver"
+                    B.putStr $ Yaml.encode $ object ["resolver" .= rawResolver]
+            if rawCompleted == deps
+                then logInfo "# No update to extra-deps is needed"
+                else do
+                    logInfo "# Frozen version of extra-deps"
+                    B.putStr $
+                        Yaml.encode $ object ["extra-deps" .= rawCompleted]
 doFreeze p FreezeSnapshot = do
-  resolver <- completeSnapshotLocation $ projectResolver p
-  result <- loadSnapshotLayer resolver
-  case result of
-    Left _wc ->
-      logInfo "No freezing is required for compiler resolver"
-    Right (snap, _) -> do
-      snap' <- completeSnapshotLayer snap
-      let rawCompleted = toRawSnapshotLayer snap'
-      if rawCompleted == snap
-        then
-        logInfo "No freezing is required for the snapshot of this project"
-        else
-        liftIO $ B.putStr $ Yaml.encode snap'
+    resolver <- completeSnapshotLocation $ projectResolver p
+    result <- loadSnapshotLayer resolver
+    case result of
+        Left _wc -> logInfo "No freezing is required for compiler resolver"
+        Right (snap, _) -> do
+            snap' <- completeSnapshotLayer snap
+            let rawCompleted = toRawSnapshotLayer snap'
+            if rawCompleted == snap
+                then logInfo
+                         "No freezing is required for the snapshot of this project"
+                else liftIO $ B.putStr $ Yaml.encode snap'