Merge pull request #4811 from commercialhaskell/4795-lock-file-behavior

Add new --lock-file flag #4795

src/Stack/Lock.hs

@@ -18,7 +18,6 @@ import qualified Data.Yaml as Yaml
 import Pantry
 import Path (addFileExtension, parent)
 import Path.IO (doesFileExist)
-import RIO.Process
 import Stack.Prelude
 import Stack.SourceMap
 import Stack.Types.Config
@@ -86,7 +85,7 @@ loadYamlThrow parser path = do
             return res
 
 lockCachedWanted ::
-       (HasPantryConfig env, HasProcessContext env, HasLogFunc env)
+       (HasPantryConfig env, HasRunner env)
     => Path Abs File
     -> RawSnapshotLocation
     -> (Map RawPackageLocationImmutable PackageLocationImmutable
@@ -96,16 +95,23 @@ lockCachedWanted ::
     -> RIO env SMWanted
 lockCachedWanted stackFile resolver fillWanted = do
     lockFile <- liftIO $ addFileExtension "lock" stackFile
-    lockExists <- doesFileExist lockFile
+    let getLockExists = doesFileExist lockFile
+    lfb <- view lockFileBehaviorL
+    readLockFile <-
+      case lfb of
+        LFBIgnore -> pure False
+        LFBReadWrite -> getLockExists
+        LFBReadOnly -> getLockExists
+        LFBErrorOnWrite -> getLockExists
     locked <-
-        if not lockExists
+        if readLockFile
         then do
-            logDebug "Lock file doesn't exist"
-            pure $ Locked [] []
-        else do
             logDebug "Using package location completions from a lock file"
             unresolvedLocked <- loadYamlThrow parseJSON lockFile
             resolvePaths (Just $ parent stackFile) unresolvedLocked
+        else do
+            logDebug "Not reading lock file"
+            pure $ Locked [] []
     let toMap :: Ord a => [LockedLocation a b] -> Map a b
         toMap =  Map.fromList . map (\ll -> (llOriginal ll, llCompleted ll))
         slocCache = toMap $ lckSnapshotLocations locked
@@ -121,10 +127,21 @@ lockCachedWanted stackFile resolver fillWanted = do
                            , lckPkgImmutableLocations =
                              lockLocations $ pliCompleted <> prjCompleted
                            }
-    when (newLocked /= locked) $
-      writeFileBinary (toFilePath lockFile) $
-        header <>
-        Yaml.encode newLocked
+    when (newLocked /= locked) $ do
+      case lfb of
+        LFBReadWrite ->
+          writeFileBinary (toFilePath lockFile) $
+            header <>
+            Yaml.encode newLocked
+        LFBErrorOnWrite -> do
+          logError "You indicated that Stack should error out on writing a lock file"
+          logError $
+            "I just tried to write the following lock file contents to " <>
+            fromString (toFilePath lockFile)
+          logError $ display $ decodeUtf8With lenientDecode $ Yaml.encode newLocked
+          exitFailure
+        LFBIgnore -> pure ()
+        LFBReadOnly -> pure ()
     pure wanted
   where
     header =

src/Stack/Options/GlobalParser.hs

@@ -60,7 +60,11 @@ globalOptsParser currentDir kind defLogLevel =
              completer (fileExtCompleter [".yaml"]) <>
              help ("Override project stack.yaml file " <>
                    "(overrides any STACK_YAML environment variable)") <>
-             hide))
+             hide)) <*>
+    optionalFirst (option readLockFileBehavior
+        (long "lock-file" <>
+         help "Specify how to interact with lock files. Default: read/write. If resolver is overridden: read-only" <>
+         hide))
   where
     hide = hideMods hide0
     hide0 = kind /= OuterGlobalOpts
@@ -90,6 +94,12 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = do
     , globalStylesUpdate = globalMonoidStyles
     , globalTermWidth = getFirst globalMonoidTermWidth
     , globalStackYaml = stackYaml
+    , globalLockFileBehavior =
+        let defLFB =
+              case getFirst globalMonoidResolver of
+                Nothing -> LFBReadWrite
+                _ -> LFBReadOnly
+         in fromFirst defLFB globalMonoidLockFileBehavior
     }
 
 initOptsParser :: Parser InitOpts

src/Stack/Types/Config.hs

@@ -83,6 +83,9 @@ module Stack.Types.Config
   ,GlobalOptsMonoid(..)
   ,StackYamlLoc(..)
   ,stackYamlLocL
+  ,LockFileBehavior(..)
+  ,readLockFileBehavior
+  ,lockFileBehaviorL
   ,defaultLogLevel
   -- ** Project & ProjectAndConfigMonoid
   ,Project(..)
@@ -210,6 +213,7 @@ import qualified Options.Applicative.Types as OA
 import           Pantry.SQLite (Storage)
 import           Path
 import qualified Paths_stack as Meta
+import qualified RIO.List as List
 import           RIO.PrettyPrint (HasTerm (..))
 import           RIO.PrettyPrint.StylesUpdate (StylesUpdate,
                      parseStylesUpdateFromString, HasStylesUpdate (..))
@@ -487,6 +491,7 @@ data GlobalOpts = GlobalOpts
     , globalStylesUpdate :: !StylesUpdate -- ^ SGR (Ansi) codes for styles
     , globalTermWidth    :: !(Maybe Int) -- ^ Terminal width override
     , globalStackYaml    :: !StackYamlLoc -- ^ Override project stack.yaml
+    , globalLockFileBehavior :: !LockFileBehavior
     } deriving (Show)
 
 -- | Location for the project's stack.yaml file.
@@ -505,6 +510,38 @@ data StackYamlLoc
 stackYamlLocL :: HasRunner env => Lens' env StackYamlLoc
 stackYamlLocL = globalOptsL.lens globalStackYaml (\x y -> x { globalStackYaml = y })
 
+-- | How to interact with lock files
+data LockFileBehavior
+  = LFBReadWrite
+  -- ^ Read and write lock files
+  | LFBReadOnly
+  -- ^ Read lock files, but do not write them
+  | LFBIgnore
+  -- ^ Entirely ignore lock files
+  | LFBErrorOnWrite
+  -- ^ Error out on trying to write a lock file. This can be used to
+  -- ensure that lock files in a repository already ensure
+  -- reproducible builds.
+  deriving (Show, Enum, Bounded)
+
+lockFileBehaviorL :: HasRunner env => SimpleGetter env LockFileBehavior
+lockFileBehaviorL = globalOptsL.to globalLockFileBehavior
+
+-- | Parser for 'LockFileBehavior'
+readLockFileBehavior :: ReadM LockFileBehavior
+readLockFileBehavior = do
+  s <- OA.readerAsk
+  case Map.lookup s m of
+    Just x -> pure x
+    Nothing -> OA.readerError $ "Invalid lock file behavior, valid options: " ++
+                                List.intercalate ", " (Map.keys m)
+  where
+    m = Map.fromList $ map (\x -> (render x, x)) [minBound..maxBound]
+    render LFBReadWrite = "read-write"
+    render LFBReadOnly = "read-only"
+    render LFBIgnore = "ignore"
+    render LFBErrorOnWrite = "error-on-write"
+
 -- | Project configuration information. Not every run of Stack has a
 -- true local project; see constructors below.
 data ProjectConfig a
@@ -532,6 +569,7 @@ data GlobalOptsMonoid = GlobalOptsMonoid
     , globalMonoidStyles       :: !StylesUpdate -- ^ Stack's output styles
     , globalMonoidTermWidth    :: !(First Int) -- ^ Terminal width override
     , globalMonoidStackYaml    :: !(First FilePath) -- ^ Override project stack.yaml
+    , globalMonoidLockFileBehavior :: !(First LockFileBehavior) -- ^ See 'globalLockFileBehavior'
     } deriving Generic
 
 instance Semigroup GlobalOptsMonoid where