{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Stack.Lock
( lockCachedWanted
, LockedLocation(..)
, Locked(..)
) where
import Pantry.Internal.AesonExtended
import Data.ByteString.Builder (byteString)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Yaml as Yaml
import Path (parent)
import Path.Extended (addExtension)
import Path.IO (doesFileExist)
import Stack.Prelude
import Stack.SourceMap
import Stack.Types.Config
import Stack.Types.SourceMap
data LockedLocation a b = LockedLocation
{ forall a b. LockedLocation a b -> a
llOriginal :: a
, forall a b. LockedLocation a b -> b
llCompleted :: b
} deriving (LockedLocation a b -> LockedLocation a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
LockedLocation a b -> LockedLocation a b -> Bool
/= :: LockedLocation a b -> LockedLocation a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
LockedLocation a b -> LockedLocation a b -> Bool
== :: LockedLocation a b -> LockedLocation a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
LockedLocation a b -> LockedLocation a b -> Bool
Eq, Int -> LockedLocation a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> LockedLocation a b -> ShowS
forall a b. (Show a, Show b) => [LockedLocation a b] -> ShowS
forall a b. (Show a, Show b) => LockedLocation a b -> String
showList :: [LockedLocation a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [LockedLocation a b] -> ShowS
show :: LockedLocation a b -> String
$cshow :: forall a b. (Show a, Show b) => LockedLocation a b -> String
showsPrec :: Int -> LockedLocation a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> LockedLocation a b -> ShowS
Show)
instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where
toJSON :: LockedLocation a b -> Value
toJSON LockedLocation a b
ll =
[Pair] -> Value
object [ Key
"original" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. LockedLocation a b -> a
llOriginal LockedLocation a b
ll, Key
"completed" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. LockedLocation a b -> b
llCompleted LockedLocation a b
ll ]
instance ( FromJSON (WithJSONWarnings (Unresolved a))
, FromJSON (WithJSONWarnings (Unresolved b))
) =>
FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where
parseJSON :: Value
-> Parser (WithJSONWarnings (Unresolved (LockedLocation a b)))
parseJSON =
forall a.
String
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings String
"LockedLocation" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
Unresolved a
original <- forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings forall a b. (a -> b) -> a -> b
$ Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"original"
Unresolved b
completed <- forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings forall a b. (a -> b) -> a -> b
$ Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"completed"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> LockedLocation a b
LockedLocation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unresolved a
original forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Unresolved b
completed
newtype SingleRPLI = SingleRPLI { SingleRPLI -> RawPackageLocationImmutable
unSingleRPLI :: RawPackageLocationImmutable}
instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where
parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved SingleRPLI))
parseJSON Value
v =
do
WithJSONWarnings Unresolved (NonEmpty RawPackageLocationImmutable)
unresolvedRPLIs [JSONWarning]
ws <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
let withWarnings :: a -> WithJSONWarnings a
withWarnings a
x = forall a. a -> [JSONWarning] -> WithJSONWarnings a
WithJSONWarnings a
x [JSONWarning]
ws
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {a}. a -> WithJSONWarnings a
withWarnings forall a b. (a -> b) -> a -> b
$ RawPackageLocationImmutable -> SingleRPLI
SingleRPLI forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unresolved (NonEmpty RawPackageLocationImmutable)
unresolvedRPLIs
data Locked = Locked
{ Locked -> [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]
, Locked
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckPkgImmutableLocations :: [LockedLocation RawPackageLocationImmutable PackageLocationImmutable]
} deriving (Locked -> Locked -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Locked -> Locked -> Bool
$c/= :: Locked -> Locked -> Bool
== :: Locked -> Locked -> Bool
$c== :: Locked -> Locked -> Bool
Eq, Int -> Locked -> ShowS
[Locked] -> ShowS
Locked -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Locked] -> ShowS
$cshowList :: [Locked] -> ShowS
show :: Locked -> String
$cshow :: Locked -> String
showsPrec :: Int -> Locked -> ShowS
$cshowsPrec :: Int -> Locked -> ShowS
Show)
instance ToJSON Locked where
toJSON :: Locked -> Value
toJSON Locked {[LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
[LockedLocation RawSnapshotLocation SnapshotLocation]
lckPkgImmutableLocations :: [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]
lckPkgImmutableLocations :: Locked
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckSnapshotLocations :: Locked -> [LockedLocation RawSnapshotLocation SnapshotLocation]
..} =
[Pair] -> Value
object
[ Key
"snapshots" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations
, Key
"packages" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckPkgImmutableLocations
]
instance FromJSON (WithJSONWarnings (Unresolved Locked)) where
parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved Locked))
parseJSON = forall a.
String
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings String
"Locked" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
[Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)]
snapshots <- forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT forall a b. (a -> b) -> a -> b
$ Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"snapshots"
[Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)]
packages <- forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT forall a b. (a -> b) -> a -> b
$ Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"packages"
let unwrap :: LockedLocation SingleRPLI b
-> LockedLocation RawPackageLocationImmutable b
unwrap LockedLocation SingleRPLI b
ll = LockedLocation SingleRPLI b
ll { llOriginal :: RawPackageLocationImmutable
llOriginal = SingleRPLI -> RawPackageLocationImmutable
unSingleRPLI (forall a b. LockedLocation a b -> a
llOriginal LockedLocation SingleRPLI b
ll) }
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [LockedLocation RawSnapshotLocation SnapshotLocation]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Locked
Locked forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Unresolved (LockedLocation RawSnapshotLocation SnapshotLocation)]
snapshots forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a b. (a -> b) -> [a] -> [b]
map forall {b}.
LockedLocation SingleRPLI b
-> LockedLocation RawPackageLocationImmutable b
unwrap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Unresolved (LockedLocation SingleRPLI PackageLocationImmutable)]
packages)
loadYamlThrow
:: HasLogFunc env
=> (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a
loadYamlThrow :: forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadYamlThrow Value -> Parser (WithJSONWarnings a)
parser Path Abs File
path = do
Either ParseException Value
eVal <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither (forall b t. Path b t -> String
toFilePath Path Abs File
path)
case Either ParseException Value
eVal of
Left ParseException
parseException -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$
Path Abs File -> ParseException -> ConfigException
ParseConfigFileException Path Abs File
path ParseException
parseException
Right Value
val -> case forall a b. (a -> Parser b) -> a -> Either String b
Yaml.parseEither Value -> Parser (WithJSONWarnings a)
parser Value
val of
Left String
err -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ParseException
Yaml.AesonException String
err
Right (WithJSONWarnings a
res [JSONWarning]
warnings) -> do
forall env (m :: * -> *).
(MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m) =>
String -> [JSONWarning] -> m ()
logJSONWarnings (forall b t. Path b t -> String
toFilePath Path Abs File
path) [JSONWarning]
warnings
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
lockCachedWanted ::
(HasPantryConfig env, HasRunner env)
=> Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env ( SMWanted, [CompletedPLI]))
-> RIO env SMWanted
lockCachedWanted :: forall env.
(HasPantryConfig env, HasRunner env) =>
Path Abs File
-> RawSnapshotLocation
-> (Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI]))
-> RIO env SMWanted
lockCachedWanted Path Abs File
stackFile RawSnapshotLocation
resolver Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillWanted = do
Path Abs File
lockFile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadThrow m =>
String -> Path b File -> m (Path b File)
addExtension String
".lock" Path Abs File
stackFile
let getLockExists :: RIO env Bool
getLockExists = forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
lockFile
LockFileBehavior
lfb <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => SimpleGetter env LockFileBehavior
lockFileBehaviorL
Bool
readLockFile <-
case LockFileBehavior
lfb of
LockFileBehavior
LFBIgnore -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
LockFileBehavior
LFBReadWrite -> RIO env Bool
getLockExists
LockFileBehavior
LFBReadOnly -> RIO env Bool
getLockExists
LockFileBehavior
LFBErrorOnWrite -> RIO env Bool
getLockExists
Locked
locked <-
if Bool
readLockFile
then do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Using package location completions from a lock file"
Unresolved Locked
unresolvedLocked <- forall env a.
HasLogFunc env =>
(Value -> Parser (WithJSONWarnings a))
-> Path Abs File -> RIO env a
loadYamlThrow forall a. FromJSON a => Value -> Parser a
parseJSON Path Abs File
lockFile
forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> Path b Dir
parent Path Abs File
stackFile) Unresolved Locked
unresolvedLocked
else do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Not reading lock file"
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [LockedLocation RawSnapshotLocation SnapshotLocation]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
-> Locked
Locked [] []
let toMap :: Ord a => [LockedLocation a b] -> Map a b
toMap :: forall a b. Ord a => [LockedLocation a b] -> Map a b
toMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\LockedLocation a b
ll -> (forall a b. LockedLocation a b -> a
llOriginal LockedLocation a b
ll, forall a b. LockedLocation a b -> b
llCompleted LockedLocation a b
ll))
slocCache :: Map RawSnapshotLocation SnapshotLocation
slocCache = forall a b. Ord a => [LockedLocation a b] -> Map a b
toMap forall a b. (a -> b) -> a -> b
$ Locked -> [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations Locked
locked
pkgLocCache :: Map RawPackageLocationImmutable PackageLocationImmutable
pkgLocCache = forall a b. Ord a => [LockedLocation a b] -> Map a b
toMap forall a b. (a -> b) -> a -> b
$ Locked
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckPkgImmutableLocations Locked
locked
Bool
debugRSL <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasRunner env => SimpleGetter env Bool
rslInLogL
(Snapshot
snap, [CompletedSL]
slocCompleted, [CompletedPLI]
pliCompleted) <-
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool
-> RawSnapshotLocation
-> Map RawSnapshotLocation SnapshotLocation
-> Map RawPackageLocationImmutable PackageLocationImmutable
-> RIO env (Snapshot, [CompletedSL], [CompletedPLI])
loadAndCompleteSnapshotRaw' Bool
debugRSL RawSnapshotLocation
resolver Map RawSnapshotLocation SnapshotLocation
slocCache Map RawPackageLocationImmutable PackageLocationImmutable
pkgLocCache
let compiler :: WantedCompiler
compiler = Snapshot -> WantedCompiler
snapshotCompiler Snapshot
snap
snPkgs :: Map PackageName (Bool -> RIO env DepPackage)
snPkgs = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\PackageName
n SnapshotPackage
p Bool
h -> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageName -> SnapshotPackage -> RIO env DepPackage
snapToDepPackage Bool
h PackageName
n SnapshotPackage
p) (Snapshot -> Map PackageName SnapshotPackage
snapshotPackages Snapshot
snap)
(SMWanted
wanted, [CompletedPLI]
prjCompleted) <- Map RawPackageLocationImmutable PackageLocationImmutable
-> WantedCompiler
-> Map PackageName (Bool -> RIO env DepPackage)
-> RIO env (SMWanted, [CompletedPLI])
fillWanted Map RawPackageLocationImmutable PackageLocationImmutable
pkgLocCache WantedCompiler
compiler Map PackageName (Bool -> RIO env DepPackage)
snPkgs
let lockLocations :: [CompletedPLI]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lockLocations = forall a b. (a -> b) -> [a] -> [b]
map (\(CompletedPLI RawPackageLocationImmutable
r PackageLocationImmutable
c) -> forall a b. a -> b -> LockedLocation a b
LockedLocation RawPackageLocationImmutable
r PackageLocationImmutable
c)
differentSnapLocs :: CompletedSL
-> Maybe (LockedLocation RawSnapshotLocation SnapshotLocation)
differentSnapLocs (CompletedSL RawSnapshotLocation
raw SnapshotLocation
complete)
| RawSnapshotLocation
raw forall a. Eq a => a -> a -> Bool
== SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
complete = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> LockedLocation a b
LockedLocation RawSnapshotLocation
raw SnapshotLocation
complete
newLocked :: Locked
newLocked = Locked { lckSnapshotLocations :: [LockedLocation RawSnapshotLocation SnapshotLocation]
lckSnapshotLocations = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CompletedSL
-> Maybe (LockedLocation RawSnapshotLocation SnapshotLocation)
differentSnapLocs [CompletedSL]
slocCompleted
, lckPkgImmutableLocations :: [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lckPkgImmutableLocations =
[CompletedPLI]
-> [LockedLocation
RawPackageLocationImmutable PackageLocationImmutable]
lockLocations forall a b. (a -> b) -> a -> b
$ [CompletedPLI]
pliCompleted forall a. Semigroup a => a -> a -> a
<> [CompletedPLI]
prjCompleted
}
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Locked
newLocked forall a. Eq a => a -> a -> Bool
/= Locked
locked) forall a b. (a -> b) -> a -> b
$ do
case LockFileBehavior
lfb of
LockFileBehavior
LFBReadWrite ->
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
lockFile forall a b. (a -> b) -> a -> b
$
Builder
header forall a. Semigroup a => a -> a -> a
<>
ByteString -> Builder
byteString (forall a. ToJSON a => a -> ByteString
Yaml.encode Locked
newLocked)
LockFileBehavior
LFBErrorOnWrite -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError Utf8Builder
"You indicated that Stack should error out on writing a lock file"
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
Utf8Builder
"I just tried to write the following lock file contents to " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
lockFile)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Yaml.encode Locked
newLocked
forall (m :: * -> *) a. MonadIO m => m a
exitFailure
LockFileBehavior
LFBIgnore -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
LockFileBehavior
LFBReadOnly -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMWanted
wanted
where
header :: Builder
header =
Builder
"# This file was autogenerated by Stack.\n\
\# You should not edit this file by hand.\n\
\# For more information, please see the documentation at:\n\
\# https://docs.haskellstack.org/en/stable/lock_files\n\n"