{-# 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

-- Special wrapper extracting only 1 RawPackageLocationImmutable

-- serialization should not produce locations with multiple subdirs

-- so we should be OK using just a head element

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"