Skip to content

Commit 0a9711c

Browse files
snoybergsnoyberg
authored
Merge pull request commercialhaskell#4811 from commercialhaskell/4795-lock-file-behavior
Add new --lock-file flag commercialhaskell#4795
2 parents 9e6fd9f + 4665712 commit 0a9711c

3 files changed

Lines changed: 77 additions & 12 deletions

File tree

‎src/Stack/Lock.hs‎

Lines changed: 28 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,6 @@ import qualified Data.Yaml as Yaml
1818
import Pantry
1919
import Path (addFileExtension, parent)
2020
import Path.IO (doesFileExist)
21-
import RIO.Process
2221
import Stack.Prelude
2322
import Stack.SourceMap
2423
import Stack.Types.Config
@@ -86,7 +85,7 @@ loadYamlThrow parser path = do
8685
return res
8786

8887
lockCachedWanted ::
89-
(HasPantryConfig env, HasProcessContext env, HasLogFunc env)
88+
(HasPantryConfig env, HasRunner env)
9089
=> Path Abs File
9190
-> RawSnapshotLocation
9291
-> (Map RawPackageLocationImmutable PackageLocationImmutable
@@ -96,16 +95,23 @@ lockCachedWanted ::
9695
-> RIO env SMWanted
9796
lockCachedWanted stackFile resolver fillWanted = do
9897
lockFile <- liftIO $ addFileExtension "lock" stackFile
99-
lockExists <- doesFileExist lockFile
98+
let getLockExists = doesFileExist lockFile
99+
lfb <- view lockFileBehaviorL
100+
readLockFile <-
101+
case lfb of
102+
LFBIgnore -> pure False
103+
LFBReadWrite -> getLockExists
104+
LFBReadOnly -> getLockExists
105+
LFBErrorOnWrite -> getLockExists
100106
locked <-
101-
if not lockExists
107+
if readLockFile
102108
then do
103-
logDebug "Lock file doesn't exist"
104-
pure $ Locked [] []
105-
else do
106109
logDebug "Using package location completions from a lock file"
107110
unresolvedLocked <- loadYamlThrow parseJSON lockFile
108111
resolvePaths (Just $ parent stackFile) unresolvedLocked
112+
else do
113+
logDebug "Not reading lock file"
114+
pure $ Locked [] []
109115
let toMap :: Ord a => [LockedLocation a b] -> Map a b
110116
toMap = Map.fromList . map (\ll -> (llOriginal ll, llCompleted ll))
111117
slocCache = toMap $ lckSnapshotLocations locked
@@ -121,10 +127,21 @@ lockCachedWanted stackFile resolver fillWanted = do
121127
, lckPkgImmutableLocations =
122128
lockLocations $ pliCompleted <> prjCompleted
123129
}
124-
when (newLocked /= locked) $
125-
writeFileBinary (toFilePath lockFile) $
126-
header <>
127-
Yaml.encode newLocked
130+
when (newLocked /= locked) $ do
131+
case lfb of
132+
LFBReadWrite ->
133+
writeFileBinary (toFilePath lockFile) $
134+
header <>
135+
Yaml.encode newLocked
136+
LFBErrorOnWrite -> do
137+
logError "You indicated that Stack should error out on writing a lock file"
138+
logError $
139+
"I just tried to write the following lock file contents to " <>
140+
fromString (toFilePath lockFile)
141+
logError $ display $ decodeUtf8With lenientDecode $ Yaml.encode newLocked
142+
exitFailure
143+
LFBIgnore -> pure ()
144+
LFBReadOnly -> pure ()
128145
pure wanted
129146
where
130147
header =

‎src/Stack/Options/GlobalParser.hs‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -60,7 +60,11 @@ globalOptsParser currentDir kind defLogLevel =
6060
completer (fileExtCompleter [".yaml"]) <>
6161
help ("Override project stack.yaml file " <>
6262
"(overrides any STACK_YAML environment variable)") <>
63-
hide))
63+
hide)) <*>
64+
optionalFirst (option readLockFileBehavior
65+
(long "lock-file" <>
66+
help "Specify how to interact with lock files. Default: read/write. If resolver is overridden: read-only" <>
67+
hide))
6468
where
6569
hide = hideMods hide0
6670
hide0 = kind /= OuterGlobalOpts
@@ -90,6 +94,12 @@ globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = do
9094
, globalStylesUpdate = globalMonoidStyles
9195
, globalTermWidth = getFirst globalMonoidTermWidth
9296
, globalStackYaml = stackYaml
97+
, globalLockFileBehavior =
98+
let defLFB =
99+
case getFirst globalMonoidResolver of
100+
Nothing -> LFBReadWrite
101+
_ -> LFBReadOnly
102+
in fromFirst defLFB globalMonoidLockFileBehavior
93103
}
94104

95105
initOptsParser :: Parser InitOpts

‎src/Stack/Types/Config.hs‎

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -83,6 +83,9 @@ module Stack.Types.Config
8383
,GlobalOptsMonoid(..)
8484
,StackYamlLoc(..)
8585
,stackYamlLocL
86+
,LockFileBehavior(..)
87+
,readLockFileBehavior
88+
,lockFileBehaviorL
8689
,defaultLogLevel
8790
-- ** Project & ProjectAndConfigMonoid
8891
,Project(..)
@@ -210,6 +213,7 @@ import qualified Options.Applicative.Types as OA
210213
import Pantry.SQLite (Storage)
211214
import Path
212215
import qualified Paths_stack as Meta
216+
import qualified RIO.List as List
213217
import RIO.PrettyPrint (HasTerm (..))
214218
import RIO.PrettyPrint.StylesUpdate (StylesUpdate,
215219
parseStylesUpdateFromString, HasStylesUpdate (..))
@@ -487,6 +491,7 @@ data GlobalOpts = GlobalOpts
487491
, globalStylesUpdate :: !StylesUpdate -- ^ SGR (Ansi) codes for styles
488492
, globalTermWidth :: !(Maybe Int) -- ^ Terminal width override
489493
, globalStackYaml :: !StackYamlLoc -- ^ Override project stack.yaml
494+
, globalLockFileBehavior :: !LockFileBehavior
490495
} deriving (Show)
491496

492497
-- | Location for the project's stack.yaml file.
@@ -505,6 +510,38 @@ data StackYamlLoc
505510
stackYamlLocL :: HasRunner env => Lens' env StackYamlLoc
506511
stackYamlLocL = globalOptsL.lens globalStackYaml (\x y -> x { globalStackYaml = y })
507512

513+
-- | How to interact with lock files
514+
data LockFileBehavior
515+
= LFBReadWrite
516+
-- ^ Read and write lock files
517+
| LFBReadOnly
518+
-- ^ Read lock files, but do not write them
519+
| LFBIgnore
520+
-- ^ Entirely ignore lock files
521+
| LFBErrorOnWrite
522+
-- ^ Error out on trying to write a lock file. This can be used to
523+
-- ensure that lock files in a repository already ensure
524+
-- reproducible builds.
525+
deriving (Show, Enum, Bounded)
526+
527+
lockFileBehaviorL :: HasRunner env => SimpleGetter env LockFileBehavior
528+
lockFileBehaviorL = globalOptsL.to globalLockFileBehavior
529+
530+
-- | Parser for 'LockFileBehavior'
531+
readLockFileBehavior :: ReadM LockFileBehavior
532+
readLockFileBehavior = do
533+
s <- OA.readerAsk
534+
case Map.lookup s m of
535+
Just x -> pure x
536+
Nothing -> OA.readerError $ "Invalid lock file behavior, valid options: " ++
537+
List.intercalate ", " (Map.keys m)
538+
where
539+
m = Map.fromList $ map (\x -> (render x, x)) [minBound..maxBound]
540+
render LFBReadWrite = "read-write"
541+
render LFBReadOnly = "read-only"
542+
render LFBIgnore = "ignore"
543+
render LFBErrorOnWrite = "error-on-write"
544+
508545
-- | Project configuration information. Not every run of Stack has a
509546
-- true local project; see constructors below.
510547
data ProjectConfig a
@@ -532,6 +569,7 @@ data GlobalOptsMonoid = GlobalOptsMonoid
532569
, globalMonoidStyles :: !StylesUpdate -- ^ Stack's output styles
533570
, globalMonoidTermWidth :: !(First Int) -- ^ Terminal width override
534571
, globalMonoidStackYaml :: !(First FilePath) -- ^ Override project stack.yaml
572+
, globalMonoidLockFileBehavior :: !(First LockFileBehavior) -- ^ See 'globalLockFileBehavior'
535573
} deriving Generic
536574

537575
instance Semigroup GlobalOptsMonoid where

0 commit comments

Comments
 (0)