From 56ad46254ad3260a57c87a497504a1b2bdb0c7be Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 16 Apr 2019 10:29:12 +0300 Subject: [PATCH 01/12] Fix lock files logic description --- doc/lock_files.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/lock_files.md b/doc/lock_files.md index fc6260158b..ff559ffc88 100644 --- a/doc/lock_files.md +++ b/doc/lock_files.md @@ -211,7 +211,7 @@ If the lock file does not exist, it will be created by: If the `stack.yaml.lock` file exists, its last modification time is compared against the last modification time of the `stack.yaml` file and any local snapshot files. If any of those files is more recent -than the `stack.yaml` file, and the file hashes in the lock file +than the `stack.yaml.lock` file, and the file hashes in the lock file do not match the files on the filesystem, then the update procedure is triggered. Otherwise, the `stack.yaml.lock` file can be used as the definition of the snapshot. From a21ce5661b7f102318c820b5b5f7c97ff9dc187f Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 16 Apr 2019 15:12:52 +0300 Subject: [PATCH 02/12] Implement stack.yaml lock files --- package.yaml | 2 + src/Stack/Config.hs | 98 ++++---- src/Stack/Lock.hs | 334 +++++++++++++++++++++++++++ src/Stack/SourceMap.hs | 2 +- src/Stack/Types/SourceMap.hs | 2 +- src/test/Stack/LockSpec.hs | 258 +++++++++++++++++++++ subs/pantry/package.yaml | 1 + subs/pantry/src/Pantry.hs | 93 +++++--- subs/pantry/src/Pantry/Internal.hs | 1 + subs/pantry/src/Pantry/Types.hs | 121 +++++++++- subs/pantry/test/Pantry/TypesSpec.hs | 104 ++++++++- 11 files changed, 930 insertions(+), 86 deletions(-) create mode 100644 src/Stack/Lock.hs create mode 100644 src/test/Stack/LockSpec.hs diff --git a/package.yaml b/package.yaml index ddf427abe0..8e7c8a419c 100644 --- a/package.yaml +++ b/package.yaml @@ -183,6 +183,7 @@ library: - Stack.IDE - Stack.Init - Stack.Ls + - Stack.Lock - Stack.New - Stack.Nix - Stack.Options.BenchParser @@ -302,6 +303,7 @@ tests: dependencies: - QuickCheck - hspec + - raw-strings-qq - stack - smallcheck flags: diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 1b69107aec..700e0b8a09 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -62,6 +62,7 @@ import Stack.Config.Docker import Stack.Config.Nix import Stack.Constants import Stack.Build.Haddock (shouldHaddockDeps) +import Stack.Lock (lockCachedWanted) import Stack.Storage (initStorage) import Stack.SourceMap import Stack.Types.Build @@ -76,6 +77,7 @@ import System.Console.ANSI (hSupportsANSIWithoutEmulation) import System.Environment import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) +import RIO.List (unzip) import RIO.PrettyPrint (stylesUpdateL, useColorL) import RIO.Process @@ -501,12 +503,51 @@ loadBuildConfig = do { projectCompiler = mcompiler <|> projectCompiler project' , projectResolver = fromMaybe (projectResolver project') mresolver } + extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) - resolver <- completeSnapshotLocation $ projectResolver project - (snapshot, _completed) <- loadAndCompleteSnapshot resolver + wanted <- lockCachedWanted stackYamlFP (projectResolver project) $ + fillProjectWanted stackYamlFP config project - extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) + return BuildConfig + { bcConfig = config + , bcSMWanted = wanted + , bcExtraPackageDBs = extraPackageDBs + , bcStackYaml = stackYamlFP + , bcCurator = projectCurator project + } + where + getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project + getEmptyProject mresolver extraDeps = do + r <- case mresolver of + Just resolver -> do + logInfo ("Using resolver: " <> display resolver <> " specified on command line") + return resolver + Nothing -> do + r'' <- getLatestResolver + logInfo ("Using latest snapshot resolver: " <> display r'') + return r'' + return Project + { projectUserMsg = Nothing + , projectPackages = [] + , projectDependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps + , projectFlags = mempty + , projectResolver = r + , projectCompiler = Nothing + , projectExtraPackageDBs = [] + , projectCurator = Nothing + , projectDropPackages = mempty + } +fillProjectWanted :: + (HasProcessContext env, HasLogFunc env, HasPantryConfig env) + => Path Abs t + -> Config + -> Project + -> Map RawPackageLocationImmutable PackageLocationImmutable + -> WantedCompiler + -> Map PackageName (Bool -> RIO env DepPackage) + -> RIO env (SMWanted, [CompletedPLI]) +fillProjectWanted stackYamlFP config project locCache snapCompiler snapPackages = do let bopts = configBuild config packages0 <- for (projectPackages project) $ \fp@(RelFilePath t) -> do @@ -515,25 +556,27 @@ loadBuildConfig = 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 + (deps0, mcompleted) <- fmap unzip . forM (projectDependencies project) $ \rpl -> do + (pl, mCompleted) <- case rpl of + RPLImmutable rpli -> do + compl <- maybe (completePackageLocation rpli) pure (Map.lookup rpli locCache) + pure (PLImmutable compl, Just (rpli, compl)) + RPLMutable p -> + pure (PLMutable p, Nothing) dp <- additionalDepPackage (shouldHaddockDeps bopts) pl - pure (cpName $ dpCommon dp, dp) + pure ((cpName $ dpCommon dp, dp), mCompleted) checkDuplicateNames $ map (second (PLMutable . ppResolvedDir)) packages0 ++ map (second dpLocation) deps0 let packages1 = Map.fromList packages0 - snPackages = snapshotPackages snapshot + snPackages = snapPackages `Map.difference` packages1 `Map.difference` Map.fromList deps0 `Map.withoutKeys` projectDropPackages project - snDeps <- Map.traverseWithKey (snapToDepPackage (shouldHaddockDeps bopts)) snPackages + snDeps <- for snPackages $ \getDep -> getDep (shouldHaddockDeps bopts) let deps1 = Map.fromList deps0 `Map.union` snDeps @@ -559,41 +602,14 @@ loadBuildConfig = do throwM $ InvalidGhcOptionsSpecification (Map.keys unusedPkgGhcOptions) let wanted = SMWanted - { smwCompiler = fromMaybe (snapshotCompiler snapshot) (projectCompiler project) + { smwCompiler = fromMaybe snapCompiler (projectCompiler project) , smwProject = packages , smwDeps = deps , smwSnapshotLocation = projectResolver project } - return BuildConfig - { bcConfig = config - , bcSMWanted = wanted - , bcExtraPackageDBs = extraPackageDBs - , bcStackYaml = stackYamlFP - , bcCurator = projectCurator project - } - where - getEmptyProject :: Maybe RawSnapshotLocation -> [PackageIdentifierRevision] -> RIO Config Project - getEmptyProject mresolver extraDeps = do - r <- case mresolver of - Just resolver -> do - logInfo ("Using resolver: " <> display resolver <> " specified on command line") - return resolver - Nothing -> do - r'' <- getLatestResolver - logInfo ("Using latest snapshot resolver: " <> display r'') - return r'' - return Project - { projectUserMsg = Nothing - , projectPackages = [] - , projectDependencies = map (RPLImmutable . flip RPLIHackage Nothing) extraDeps - , projectFlags = mempty - , projectResolver = r - , projectCompiler = Nothing - , projectExtraPackageDBs = [] - , projectCurator = Nothing - , projectDropPackages = mempty - } + pure (wanted, catMaybes mcompleted) + -- | Check if there are any duplicate package names and, if so, throw an -- exception. diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs new file mode 100644 index 0000000000..e37f527357 --- /dev/null +++ b/src/Stack/Lock.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Stack.Lock + ( lockCachedWanted + , LockedLocation(..) + , LockedPackage(..) + , Locked(..) + ) where + +import Data.Aeson.Extended +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Yaml as Yaml +import Pantry +import Pantry.Internal (Unresolved(..)) +import qualified Pantry.SHA256 as SHA256 +import Path (addFileExtension, parent) +import Path.IO (doesFileExist, getModificationTime, resolveFile) +import qualified RIO.ByteString as B +import RIO.Process +import qualified RIO.Text as T +import RIO.Time (UTCTime) +import Stack.Prelude +import Stack.SourceMap +import Stack.Types.Config +import Stack.Types.SourceMap + +data CompletedSnapshotLocation + = CSLFilePath !(ResolvedPath File) + !SHA256 + !FileSize + | CSLCompiler !WantedCompiler + | CSLUrl !Text !BlobKey + deriving (Show, Eq) + +instance ToJSON CompletedSnapshotLocation where + toJSON (CSLFilePath fp sha size) = + object [ "file" .= resolvedRelative fp + , "sha" .= sha + , "size" .= size + ] + toJSON (CSLCompiler c) = + object ["compiler" .= toJSON c] + toJSON (CSLUrl url (BlobKey sha size)) = + object [ "url" .= url + , "sha" .= sha + , "size" .= size + ] + +instance FromJSON (WithJSONWarnings (Unresolved CompletedSnapshotLocation)) where + parseJSON v = file v <|> url v <|> compiler v + where + file = withObjectWarnings "CSLFilepath" $ \o -> do + ufp <- o ..: "file" + sha <- o ..: "sha" + size <- o ..: "size" + pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ CSLFilePath fp sha size + url = withObjectWarnings "CSLUrl" $ \o -> do + url' <- o ..: "url" + sha <- o ..: "sha" + size <- o ..: "size" + pure $ Unresolved $ \_ -> pure $ CSLUrl url' (BlobKey sha size) + compiler = withObjectWarnings "CSLCompiler" $ \o -> do + c <- o ..: "compiler" + pure $ Unresolved $ \_ -> pure $ CSLCompiler c + +data LockedLocation a b = LockedLocation + { llOriginal :: a + , llCompleted :: b + } deriving (Show, Eq) + +instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where + toJSON LockedLocation{..} = + object [ "original" .= llOriginal, "completed" .= llCompleted ] + +instance ( FromJSON (WithJSONWarnings (Unresolved a)) + , FromJSON (WithJSONWarnings (Unresolved b))) => + FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where + parseJSON = + withObjectWarnings "LockedLocation" $ \o -> do + llOriginal <- jsonSubWarnings $ o ..: "original" + llCompleted <- jsonSubWarnings $ o ..: "completed" + pure $ LockedLocation <$> llOriginal <*> llCompleted + +data LockedPackage = LockedPackage + { lpLocation :: !(LockedLocation RawPackageLocationImmutable PackageLocationImmutable) + , lpFlags :: !(Map FlagName Bool) + , lpHidden :: !Bool + , lpGhcOptions :: ![Text] + , lpFromSnapshot :: !FromSnapshot + } deriving (Show, Eq) + +instance ToJSON LockedPackage where + toJSON LockedPackage {..} = + let toBoolean FromSnapshot = True + toBoolean NotFromSnapshot = False + in object $ concat + [ ["location" .= lpLocation] + , if Map.null lpFlags then [] else ["flags" .= toCabalStringMap lpFlags] + , if lpFromSnapshot == FromSnapshot then [] else ["from-snapshot" .= toBoolean lpFromSnapshot] + , if not lpHidden then [] else ["hidden" .= lpHidden] + , if null lpGhcOptions then [] else ["ghc-options" .= lpGhcOptions] + ] + +-- 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 { unSingleRPLI :: RawPackageLocationImmutable} + +instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where + parseJSON v = + do + WithJSONWarnings unresolvedRPLIs ws <- parseJSON v + let withWarnings x = WithJSONWarnings x ws + pure $ withWarnings $ Unresolved $ \mdir -> do + rpli <- NE.head <$> resolvePaths mdir unresolvedRPLIs + pure $ SingleRPLI rpli + +instance FromJSON (WithJSONWarnings (Unresolved LockedPackage)) where + parseJSON = withObjectWarnings "LockedPackage" $ \o -> do + let unwrap (LockedLocation single c) = LockedLocation (unSingleRPLI single) c + location <- jsonSubWarnings $ o ..: "location" + lpFlags <- fmap unCabalStringMap $ o ..:? "flags" ..!= Map.empty + lpHidden <- o ..:? "hidden" ..!= False + lpGhcOptions <- o ..:? "ghc-options" ..!= [] + let fromBoolean True = FromSnapshot + fromBoolean False = NotFromSnapshot + lpFromSnapshot <- fmap fromBoolean $ o ..:? "from-snapshot" ..!= True + pure $ (\lpLocation -> LockedPackage {..}) <$> fmap unwrap location + +data Locked = Locked + { lckStackSha :: !SHA256 + , lckStackSize :: !FileSize + , lckCompiler :: WantedCompiler + , lckSnapshots :: NE.NonEmpty (LockedLocation RawSnapshotLocation CompletedSnapshotLocation) + , lckPackages :: Map PackageName LockedPackage + } + deriving (Show, Eq) + +instance FromJSON (WithJSONWarnings (Unresolved Locked)) where + parseJSON = withObjectWarnings "Locked" $ \o -> do + stackYaml <- o ..: "stack-yaml" + lckStackSha <- stackYaml ..: "sha256" + lckStackSize <- stackYaml ..: "size" + lckCompiler <- o ..: "compiler" + snapshots <- jsonSubWarningsT $ o ..: "snapshots" + packages <- fmap unCabalStringMap $ jsonSubWarningsT $ o ..: "packages" + pure $ (\lckSnapshots lckPackages -> Locked {..}) <$> sequenceA snapshots <*> sequenceA packages + +instance ToJSON Locked where + toJSON Locked {..} = + object + [ "stack-yaml" .= object ["sha256" .= lckStackSha, "size" .= lckStackSize] + , "compiler" .= lckCompiler + , "snapshots" .= lckSnapshots + , "packages" .= toCabalStringMap lckPackages + ] + +loadYamlThrow + :: HasLogFunc env + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a +loadYamlThrow parser path = do + val <- liftIO $ Yaml.decodeFileThrow (toFilePath path) + case Yaml.parseEither parser val of + Left err -> throwIO $ Yaml.AesonException err + Right (WithJSONWarnings res warnings) -> do + logJSONWarnings (toFilePath path) warnings + return res + +lockCachedWanted :: + (HasPantryConfig env, HasProcessContext env, HasLogFunc env) + => Path Abs File + -> RawSnapshotLocation + -> (Map RawPackageLocationImmutable PackageLocationImmutable + -> WantedCompiler + -> Map PackageName (Bool -> RIO env DepPackage) + -> RIO env ( SMWanted, [CompletedPLI])) + -> RIO env SMWanted +lockCachedWanted stackFile resolver fillWanted = do + lockFile <- liftIO $ addFileExtension "lock" stackFile + lockExists <- doesFileExist lockFile + if not lockExists + then do + (snap, slocs, completed) <- + loadAndCompleteSnapshotRaw resolver Map.empty + let compiler = snapshotCompiler snap + snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) + (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs + (stackSha, stackSize) <- shaSize stackFile + let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) + (completed <> prjCompleted) + snapshots <- for slocs $ \(orig, sloc) -> do + compl <- case sloc of + SLFilePath fp -> do + (sha, size) <- shaSize (resolvedAbsolute fp) + pure $ CSLFilePath fp sha size + SLCompiler c -> + pure $ CSLCompiler c + SLUrl url blobKey -> + pure $ CSLUrl url blobKey + pure $ LockedLocation orig compl + liftIO $ Yaml.encodeFile (toFilePath lockFile) $ + Locked { lckStackSha = stackSha + , lckStackSize = stackSize + , lckCompiler = smwCompiler wanted + , lckSnapshots = snapshots + , lckPackages = Map.fromList pkgs + } + pure wanted + else do + lmt <- liftIO $ getModificationTime lockFile + unresolvedLocked <- loadYamlThrow parseJSON lockFile + locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked + let pkgLocCache = Map.fromList + [ (llOriginal ll, llCompleted ll) + | ll <- map lpLocation $ Map.elems (lckPackages locked0) ] + sha0 = lckStackSha locked0 + size0 = lckStackSize locked0 + result <- liftIO $ checkOutdated stackFile lmt size0 sha0 + let (syOutdated, sySha, sySize) = + case result of + Right () -> (False, sha0, size0) + Left (sha, sz) -> (True, sha, sz) + let lockedSnapshots = Map.fromList + [ (orig, compl) + | LockedLocation orig compl <- NE.toList (lckSnapshots locked0) + ] + layers <- readSnapshotLayers resolver + (outdated, valid) <- + fmap partitionEithers . forM (NE.toList layers) $ \(rsloc, sloc) -> liftIO $ + let outdatedLoc = Left . LockedLocation rsloc + validLoc = Right . LockedLocation rsloc + in case Map.lookup rsloc lockedSnapshots of + Nothing -> + case sloc of + SLFilePath fp -> do + (sha, size) <- shaSize $ resolvedAbsolute fp + pure $ outdatedLoc (CSLFilePath fp sha size) + SLCompiler c -> + pure $ outdatedLoc (CSLCompiler c) + SLUrl u bk -> + pure $ outdatedLoc (CSLUrl u bk) + Just loc@(CSLFilePath fp sha size) -> do + result' <- checkOutdated (resolvedAbsolute fp) lmt size sha + case result' of + Right () -> pure $ validLoc loc + Left (sha', size') -> + pure $ outdatedLoc (CSLFilePath fp sha' size') + Just immutable -> + pure $ validLoc immutable + let lockIsUpToDate = not syOutdated && null outdated + if lockIsUpToDate + then do + let compiler = lckCompiler locked0 + pkgs = flip Map.mapWithKey (lckPackages locked0) $ \nm lp haddocks -> do + run <- askRunInIO + let location = llCompleted (lpLocation lp) + common = CommonPackage + { cpName = nm + , cpGPD = run $ loadCabalFileImmutable location + , cpFlags = lpFlags lp + , cpGhcOptions = lpGhcOptions lp + , cpHaddocks = haddocks + } + pure $ DepPackage{ dpLocation = PLImmutable location + , dpCommon = common + , dpHidden = lpHidden lp + , dpFromSnapshot = lpFromSnapshot lp + } + (wanted, _prjCompleted) <- fillWanted pkgLocCache compiler pkgs + pure wanted + else do + (snap, _slocs, completed) <- + loadAndCompleteSnapshotRaw resolver pkgLocCache + let compiler = snapshotCompiler snap + snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) + (wanted, prjCompleted) <- fillWanted pkgLocCache compiler snPkgs + let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) + (completed <> prjCompleted) + liftIO $ Yaml.encodeFile (toFilePath lockFile) $ + Locked { lckStackSha = sySha + , lckStackSize = sySize + , lckCompiler = smwCompiler wanted + , lckSnapshots = NE.fromList $ outdated ++ valid + , lckPackages = Map.fromList pkgs + } + pure wanted + where + maybeWantedLockedPackage wanted rpli pli = do + let name = pkgName (packageLocationIdent pli) + dp <- Map.lookup name (smwDeps wanted) + let common = dpCommon dp + pure ( name + , LockedPackage { lpFlags = cpFlags common + , lpFromSnapshot = dpFromSnapshot dp + , lpGhcOptions = cpGhcOptions common + , lpHidden = dpHidden dp + , lpLocation = LockedLocation rpli pli + } + ) + shaSize fp = do + bs <- B.readFile $ toFilePath fp + let size = FileSize . fromIntegral $ B.length bs + sha = SHA256.hashBytes bs + return (sha, size) + +checkOutdated :: + Path Abs File + -> UTCTime + -> FileSize + -> SHA256 + -> IO (Either (SHA256, FileSize) ()) +checkOutdated fp dt size sha = do + mt <- getModificationTime fp + if mt < dt + then pure $ Right () + else do + bs <- B.readFile $ toFilePath fp + let newSize = FileSize . fromIntegral $ B.length bs + newSha = SHA256.hashBytes bs + if newSize /= size || sha /= newSha + then pure $ Left (newSha, newSize) + else pure $ Right () diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index f6c1c67500..e16467c59f 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -260,7 +260,7 @@ loadProjectSnapshotCandidate :: -> Bool -> RIO env (SnapshotCandidate env) loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do - snapshot <- fmap fst . loadAndCompleteSnapshot =<< completeSnapshotLocation loc + (snapshot, _, _) <- loadAndCompleteSnapshotRaw loc Map.empty deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot) let wc = snapshotCompiler snapshot globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs index 56b712ff61..4af5ed4731 100644 --- a/src/Stack/Types/SourceMap.hs +++ b/src/Stack/Types/SourceMap.hs @@ -46,7 +46,7 @@ data CommonPackage = CommonPackage data FromSnapshot = FromSnapshot | NotFromSnapshot - deriving (Show) + deriving (Show, Eq) -- | A view of a dependency package, specified in stack.yaml data DepPackage = DepPackage diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs new file mode 100644 index 0000000000..1b35852261 --- /dev/null +++ b/src/test/Stack/LockSpec.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.LockSpec where + +import Data.Aeson.Extended (WithJSONWarnings(..)) +import Data.ByteString (ByteString) +import qualified Data.Map as Map +import qualified Data.Yaml as Yaml +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) +import Pantry +import qualified Pantry.SHA256 as SHA256 +import RIO +import Stack.Lock +import Stack.Types.SourceMap (FromSnapshot(..)) +import Test.Hspec +import Text.RawString.QQ + +toBlobKey :: ByteString -> Word -> BlobKey +toBlobKey string size = BlobKey (decodeSHA string) (FileSize size) + +decodeSHA :: ByteString -> SHA256 +decodeSHA string = + case SHA256.fromHexBytes string of + Right csha -> csha + Left err -> error $ "Failed decoding. Error: " <> show err + +decodeLocked :: ByteString -> IO Locked +decodeLocked bs = do + val <- Yaml.decodeThrow bs + case Yaml.parseEither Yaml.parseJSON val of + Left err -> throwIO $ Yaml.AesonException err + Right (WithJSONWarnings res warnings) -> do + unless (null warnings) $ + throwIO $ Yaml.AesonException $ "Unexpected warnings: " ++ show warnings + -- we just assume no file references + resolvePaths Nothing res + +spec :: Spec +spec = do + it "parses lock file (empty with GHC resolver)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +packages: {} +snapshots: +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +stack-yaml: + size: 90 + sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 +compiler: ghc-8.2.2 +|] + pkgImm <- lckPackages <$> decodeLocked lockFile + Map.toList pkgImm `shouldBe` [] + it "parses lock file (empty with LTS)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +packages: {} +snapshots: +- completed: + sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +stack-yaml: + size: 90 + sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 +compiler: ghc-8.2.2 +|] + pkgImm <- lckPackages <$> decodeLocked lockFile + Map.toList pkgImm `shouldBe` [] + it "parses lock file (non empty)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +packages: + wai: + location: + original: + subdir: wai + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + completed: + subdir: wai + cabal-file: + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 + name: wai + version: 3.2.1.2 + git: https://github.com/yesodweb/wai.git + pantry-tree: + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + warp: + location: + original: + subdir: warp + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + completed: + subdir: warp + cabal-file: + size: 10725 + sha256: cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758 + name: warp + version: 3.2.25 + git: https://github.com/yesodweb/wai.git + pantry-tree: + size: 5103 + sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 +snapshots: +- completed: + sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +stack-yaml: + size: 90 + sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 +compiler: ghc-8.2.2 +|] + pkgImm <- Map.toList . lckPackages <$> decodeLocked lockFile + let waiSubdirRepo subdir = + Repo { repoType = RepoGit + , repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = subdir + } + emptyRPM = RawPackageMetadata { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + , rpmCabal = Nothing + } + pkgImm `shouldBe` + [ ( "wai" + , lockedPackageWithLocations + (RPLIRepo (waiSubdirRepo "wai") emptyRPM) + (PLIRepo (waiSubdirRepo "wai") + (PackageMetadata { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 2, 1, 2] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") + (FileSize 714)) + , pmCabal = + toBlobKey + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + 1765 + })) + ) + , ( "warp" + , lockedPackageWithLocations + (RPLIRepo (waiSubdirRepo "warp") emptyRPM) + (PLIRepo (waiSubdirRepo "warp") + (PackageMetadata { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "warp" + , pkgVersion = mkVersion [3, 2, 25] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") + (FileSize 5103)) + , pmCabal = + toBlobKey + "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" + 10725 + })) + ) + ] + it "parses snapshot lock file (non empty)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +packages: + string-quote: + location: + original: + hackage: string-quote-0.0.1 + completed: + hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 + pantry-tree: + size: 273 + sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f +snapshots: +- completed: + sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +stack-yaml: + size: 90 + sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 +compiler: ghc-8.2.2 +|] + pkgImm <- Map.toList . lckPackages <$> decodeLocked lockFile + pkgImm `shouldBe` + [("string-quote" + , lockedPackageWithLocations + ( RPLIHackage + (PackageIdentifierRevision + (mkPackageName "string-quote") + (mkVersion [0, 0, 1]) + CFILatest) + Nothing) + ( PLIHackage + (PackageIdentifier + { pkgName = mkPackageName "string-quote" + , pkgVersion = mkVersion [0, 0, 1] + }) + (toBlobKey + "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" + 758) + (TreeKey + (BlobKey + (decodeSHA + "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") + (FileSize 273)))) + ) + ] + + +lockedPackageWithLocations :: RawPackageLocationImmutable -> PackageLocationImmutable -> LockedPackage +lockedPackageWithLocations rpli pli = + LockedPackage{ lpLocation = LockedLocation rpli pli + , lpFlags = mempty + , lpGhcOptions = mempty + , lpFromSnapshot = FromSnapshot + , lpHidden = False + } diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index bbbd842967..6a7f440fc2 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -118,3 +118,4 @@ tests: - exceptions - hedgehog - QuickCheck + - raw-strings-qq diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 167ba1ced5..43ead38f6e 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -92,7 +92,10 @@ module Pantry , loadRawSnapshotLayer , loadSnapshotLayer , loadSnapshot + , readSnapshotLayers , loadAndCompleteSnapshot + , loadAndCompleteSnapshotRaw + , CompletedPLI , addPackagesToSnapshot , AddPackagesConfig (..) @@ -105,6 +108,7 @@ module Pantry , parseWantedCompiler , parseRawSnapshotLocation , parsePackageIdentifierRevision + , parseHackageText -- ** Cabal values , parsePackageIdentifier @@ -199,6 +203,7 @@ import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP import Data.Char (isHexDigit) +import Data.List.NonEmpty (NonEmpty((:|)), (<|)) -- | Create a new 'PantryConfig' with the given settings. -- @@ -392,7 +397,7 @@ loadCabalFileImmutable loadCabalFileImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadCabalFileBytes loc - let foundCabalKey = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + let foundCabalKey = bsToBlobKey bs (_warnings, gpd) <- rawParseGPD (Left $ toRawPLI loc) bs let pm = case loc of @@ -438,7 +443,7 @@ loadCabalFileRawImmutable loadCabalFileRawImmutable loc = withCache $ do logDebug $ "Parsing cabal file for " <> display loc bs <- loadRawCabalFileBytes loc - let foundCabalKey = BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) + let foundCabalKey = bsToBlobKey bs (_warnings, gpd) <- rawParseGPD (Left loc) bs let rpm = case loc of @@ -791,8 +796,7 @@ completeSnapshotLocation (RSLFilePath f) = pure $ SLFilePath f completeSnapshotLocation (RSLUrl url (Just blobKey)) = pure $ SLUrl url blobKey completeSnapshotLocation (RSLUrl url Nothing) = do bs <- loadFromURL url Nothing - let blobKey = BlobKey (SHA256.hashBytes bs) (FileSize $ fromIntegral $ B.length bs) - pure $ SLUrl url blobKey + pure $ SLUrl url (bsToBlobKey bs) -- | Fill in optional fields in a 'SnapshotLayer' for more reproducible builds. -- @@ -957,6 +961,22 @@ loadSnapshot loc = do } type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) +type CompletedSL = (RawSnapshotLocation, SnapshotLocation) + +-- | Get completed locations of all snapshot layers from a 'RawSnapshotLocation' +-- +-- @since 0.1.0.0 +readSnapshotLayers :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawSnapshotLocation + -> RIO env (NonEmpty CompletedSL) +readSnapshotLayers loc = do + eres <- loadRawSnapshotLayer loc + case eres of + Left wc -> + pure $ (RSLCompiler wc, SLCompiler wc) :| [] + Right (rsl, sloc) -> + (sloc <|) <$> readSnapshotLayers (rslParent rsl) -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations @@ -965,9 +985,10 @@ type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation - -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshot loc = - loadAndCompleteSnapshotRaw (toRawSL loc) + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file + -> RIO env (Snapshot, NonEmpty CompletedSL, [CompletedPLI]) +loadAndCompleteSnapshot loc cachedPL = + loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations @@ -976,8 +997,9 @@ loadAndCompleteSnapshot loc = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation - -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshotRaw loc = do + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file + -> RIO env (Snapshot, NonEmpty CompletedSL, [CompletedPLI]) +loadAndCompleteSnapshotRaw loc cachePL = do eres <- loadRawSnapshotLayer loc case eres of Left wc -> @@ -986,12 +1008,13 @@ loadAndCompleteSnapshotRaw loc = do , snapshotPackages = mempty , snapshotDrop = mempty } - in pure (snapshot, []) - Right (rsl, _sha) -> do - (snap0, completed0) <- loadAndCompleteSnapshotRaw $ rslParent rsl + in pure (snapshot, (RSLCompiler wc, SLCompiler wc) :| [], []) + Right (rsl, sloc) -> do + (snap0, slocs0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL (packages, completed, unused) <- addAndCompletePackagesToSnapshot - (display loc) + loc + cachePL (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl @@ -1006,7 +1029,7 @@ loadAndCompleteSnapshotRaw loc = do , snapshotPackages = packages , snapshotDrop = apcDrop unused } - return (snapshot, completed ++ completed0) + return (snapshot, sloc <| slocs0, completed ++ completed0) data SingleOrNot a = Single !a @@ -1120,6 +1143,16 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens pure (allPackages, unused) +cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Map RawPackageLocationImmutable PackageLocationImmutable + -> RawPackageLocationImmutable + -> RIO env PackageLocationImmutable +cachedSnapshotCompletePackageLocation cachePackages rpli = do + let xs = Map.lookup rpli cachePackages + case xs of + Nothing -> completePackageLocation rpli + Just x -> pure x + -- | Add more packages to a snapshot completing their locations if needed -- -- Note that any settings on a parent flag which is being replaced will be @@ -1127,31 +1160,36 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens -- set, and @foo@ also appears in new packages, then @bar@ will no longer be -- set. -- --- Returns any of the 'AddPackagesConfig' values not used. +-- Returns any of the 'AddPackagesConfig' values not used and also all +-- package location completions. -- -- @since 0.1.0.0 addAndCompletePackagesToSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => Utf8Builder + => RawSnapshotLocation -- ^ Text description of where these new packages are coming from, for error -- messages only + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig -> Map PackageName SnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) -addAndCompletePackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens options) old = do - let addPackage (ps, completed) loc = do - name <- getPackageLocationName loc - loc' <- completePackageLocation loc +addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig drops flags hiddens options) old = do + let source = display loc + addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ([(PackageName, SnapshotPackage)],[CompletedPLI]) + -> RawPackageLocationImmutable + -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) + addPackage (ps, completed) rawLoc = do + name <- getPackageLocationName rawLoc + complLoc <- cachedSnapshotCompletePackageLocation cachedPL rawLoc let p = (name, SnapshotPackage - { spLocation = loc' + { spLocation = complLoc , spFlags = Map.findWithDefault mempty name flags , spHidden = Map.findWithDefault False name hiddens , spGhcOptions = Map.findWithDefault [] name options }) - if toRawPLI loc' == loc - then pure (p:ps, completed) - else pure (p:ps, (loc, loc'):completed) + pure (p:ps, (rawLoc, complLoc):completed) (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers @@ -1188,20 +1226,19 @@ addAndCompletePackagesToSnapshot source newPackages (AddPackagesConfig drops fla loadRawSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayer, SHA256)) -- FIXME remove SHA? Be smart? + -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler loadRawSnapshotLayer sl@(RSLUrl url blob) = handleAny (throwIO . InvalidSnapshot sl) $ do bs <- loadFromURL url blob value <- Yaml.decodeThrow bs snapshot <- warningsParserHelperRaw sl value Nothing - pure $ Right (snapshot, SHA256.hashBytes bs) + pure $ Right (snapshot, (sl, SLUrl url (bsToBlobKey bs))) loadRawSnapshotLayer sl@(RSLFilePath fp) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - sha <- SHA256.hashFile $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelperRaw sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, sha) + pure $ Right (snapshot, (sl, SLFilePath fp)) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index be603a94f9..1423dee364 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -9,6 +9,7 @@ module Pantry.Internal , pcHpackExecutable , normalizeParents , makeTarRelative + , Unresolved (..) ) where import Control.Exception (assert) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 44a6318d41..0b2148e050 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -44,7 +44,7 @@ module Pantry.Types , renderTree , parseTree , SHA256 - , Unresolved + , Unresolved (..) , resolvePaths , Package (..) , PackageCabal (..) @@ -91,6 +91,7 @@ module Pantry.Types , RawSnapshotLocation (..) , SnapshotLocation (..) , toRawSL + , parseHackageText , parseRawSnapshotLocation , RawSnapshotLayer (..) , SnapshotLayer (..) @@ -105,6 +106,7 @@ module Pantry.Types , toRawPM , cabalFileName , SnapshotCacheHash (..) + , bsToBlobKey ) where import RIO @@ -292,7 +294,7 @@ instance NFData (ResolvedPath t) data RawPackageLocation = RPLImmutable !RawPackageLocationImmutable | RPLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) + deriving (Show, Eq, Ord, Generic) instance NFData RawPackageLocation -- | Location to load a package from. Can either be immutable (see @@ -303,13 +305,17 @@ instance NFData RawPackageLocation data PackageLocation = PLImmutable !PackageLocationImmutable | PLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Generic) + deriving (Show, Eq, Ord, Generic) instance NFData PackageLocation instance Display PackageLocation where display (PLImmutable loc) = display loc display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp +instance ToJSON PackageLocation where + toJSON (PLImmutable pli) = toJSON pli + toJSON (PLMutable resolved) = toJSON (resolvedRelative resolved) + -- | Convert `PackageLocation` to its "raw" equivalent -- -- @since 0.1.0.0 @@ -503,6 +509,16 @@ instance Display Repo where (if T.null subdir then mempty else " in subdirectory " <> display subdir) +instance FromJSON Repo where + parseJSON = + withObject "Repo" $ \o -> do + repoSubdir <- o .: "subdir" + repoCommit <- o .: "commit" + (repoType, repoUrl) <- + (o .: "git" >>= \url -> pure (RepoGit, url)) <|> + (o .: "hg" >>= \url -> pure (RepoHg, url)) + pure Repo {..} + -- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains -- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". @@ -683,6 +699,32 @@ instance FromJSON PackageIdentifierRevision where Left e -> fail $ show e Right pir -> pure pir +-- | Parse a hackage text. +parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) +parseHackageText t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do + let (identT, cfiT) = T.break (== '@') t + PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT + (csha, csize) <- + case splitColon cfiT of + Just ("@sha256", shaSizeT) -> do + let (shaT, sizeT) = T.break (== ',') shaSizeT + sha <- either (const Nothing) Just $ SHA256.fromHexText shaT + msize <- + case T.stripPrefix "," sizeT of + Nothing -> Nothing + Just sizeT' -> + case decimal sizeT' of + Right (size', "") -> Just $ (sha, FileSize size') + _ -> Nothing + pure msize + _ -> Nothing + pure $ (PackageIdentifier name version, BlobKey csha csize) + +splitColon :: Text -> Maybe (Text, Text) +splitColon t' = + let (x, y) = T.break (== ':') t' + in (x, ) <$> T.stripPrefix ":" y + -- | Parse a 'PackageIdentifierRevision' -- -- @since 0.1.0.0 @@ -710,10 +752,6 @@ parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseF Nothing -> pure CFILatest _ -> Nothing pure $ PackageIdentifierRevision name version cfi - where - splitColon t' = - let (x, y) = T.break (== ':') t' - in (x, ) <$> T.stripPrefix ":" y data Mismatch a = Mismatch { mismatchExpected :: !a @@ -1350,6 +1388,18 @@ instance Display PackageMetadata where , "cabal file == " <> display (pmCabal pm) ] +instance FromJSON PackageMetadata where + parseJSON = + withObject "PackageMetadata" $ \o -> do + pmCabal :: BlobKey <- o .: "cabal-file" + pantryTree :: BlobKey <- o .: "pantry-tree" + CabalString pkgName <- o .: "name" + CabalString pkgVersion <- o .: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} + + -- | Conver package metadata to its "raw" equivalent. -- -- @since 0.1.0.0 @@ -1462,6 +1512,54 @@ rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] +instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where + parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + where + repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) + repoObject value = do + pm <- parseJSON value + repo <- parseJSON value + pure $ noJSONWarnings $ pure $ PLIRepo repo pm + + archiveObject value = do + pm <- parseJSON value + withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do + Unresolved mkArchiveLocation <- parseArchiveLocationObject o + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..:? "subdir" ..!= "" + pure $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + pure $ PLIArchive Archive {..} pm + ) value + + hackageObject value = + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do + treeKey <- o ..: "pantry-tree" + htxt <- o ..: "hackage" + case parseHackageText htxt of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> + pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)) value + + github value = do + pm <- parseJSON value + withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do + GitHubRepo ghRepo <- o ..: "github" + commit <- o ..: "commit" + let archiveLocation = ALUrl $ T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + archiveHash <- o ..: "sha256" + archiveSize <- o ..: "size" + archiveSubdir <- o ..: "subdir" + pure $ pure $ PLIArchive Archive {..} pm) value + instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where parseJSON v = http v @@ -1470,7 +1568,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu <|> repo v <|> archiveObject v <|> github v - <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) where http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) http = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> @@ -2102,3 +2200,10 @@ toRawSnapshotLayer sl = RawSnapshotLayer newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} deriving (Show) + +-- | Creates BlobKey for an input ByteString +-- +-- @sinc 0.1.0.0 +bsToBlobKey :: ByteString -> BlobKey +bsToBlobKey bs = + BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index c45898ed26..010049df5e 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -1,22 +1,43 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} -module Pantry.TypesSpec (spec) where +{-# LANGUAGE FlexibleInstances #-} -import Test.Hspec +module Pantry.TypesSpec + ( spec + ) where + +import Data.Aeson.Extended +import qualified Data.ByteString.Char8 as S8 +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty hiding (map) +import Data.Semigroup +import qualified Data.Vector as Vector +import qualified Data.Yaml as Yaml +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Pantry +import Pantry.Internal + ( Tree(..) + , TreeEntry(..) + , mkSafeFilePath + , parseTree + , renderTree + ) import qualified Pantry.SHA256 as SHA256 -import Pantry.Internal (parseTree, renderTree, Tree (..), TreeEntry (..), mkSafeFilePath) +import qualified Path as Path import RIO -import Distribution.Types.Version (mkVersion) +import qualified RIO.HashMap as HM import qualified RIO.Text as T -import qualified Data.Yaml as Yaml -import Data.Aeson.Extended (WithJSONWarnings (..)) -import qualified Data.ByteString.Char8 as S8 +import Test.Hspec +import Text.RawString.QQ import RIO.Time (Day (..)) hh :: HasCallStack => String -> Property -> Spec @@ -30,6 +51,22 @@ genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 1 genSha256 :: Gen SHA256 genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) +samplePLIRepo :: ByteString +samplePLIRepo = + [r| +subdir: wai +cabal-file: + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 +name: wai +version: 3.2.1.2 +git: https://github.com/yesodweb/wai.git +pantry-tree: + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 +commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 +|] + spec :: Spec spec = do describe "WantedCompiler" $ do @@ -110,3 +147,56 @@ spec = do liftIO $ Yaml.toJSON (nightlySnapshotLocation day) `shouldBe` Yaml.String (T.pack $ "nightly-" ++ show day) + it "FromJSON instance for Repo" $ do + repValue <- + case Yaml.decodeThrow samplePLIRepo of + Just x -> pure x + Nothing -> fail "Can't parse Repo" + let repoValue = + Repo + { repoSubdir = "wai" + , repoType = RepoGit + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoUrl = "https://github.com/yesodweb/wai.git" + } + repValue `shouldBe` repoValue + it "FromJSON instance for PackageMetadata" $ do + pkgMeta <- + case Yaml.decodeThrow samplePLIRepo of + Just x -> pure x + Nothing -> fail "Can't parse Repo" + let cabalSha = + SHA256.fromHexBytes + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + pantrySha = + SHA256.fromHexBytes + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2" + (csha, psha) <- case (cabalSha, pantrySha) of + (Right csha, Right psha) -> pure (csha, psha) + _ -> fail "Failed decoding sha256" + let pkgValue = + PackageMetadata + { pmIdent = + PackageIdentifier + (mkPackageName "wai") + (mkVersion [3, 2, 1, 2]) + , pmTreeKey = TreeKey (BlobKey psha (FileSize 714)) + , pmCabal = BlobKey csha (FileSize 1765) + } + pkgMeta `shouldBe` pkgValue + it "parseHackageText parses" $ do + let txt = + "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" + hsha = + SHA256.fromHexBytes + "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" + sha <- case hsha of + Right sha' -> pure sha' + _ -> fail "parseHackagetext: failed decoding the sha256" + let Right (pkgIdentifier, blobKey) = parseHackageText txt + blobKey `shouldBe` (BlobKey sha (FileSize 5058)) + pkgIdentifier `shouldBe` + PackageIdentifier + (mkPackageName "persistent") + (mkVersion [2, 8, 2]) From d33805c6dc0ef086ea230200c811f76c02dea961 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 16 Apr 2019 15:18:59 +0300 Subject: [PATCH 03/12] Changelog entry --- ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog.md b/ChangeLog.md index 79a7aee506..9c61299dd5 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -60,6 +60,7 @@ Major changes: is uniquely identified by a commit id and an Hadrian "flavour" (Hadrian is the newer GHC build system), hence `compiler` can be set to use a GHC built from source with `ghc-git-COMMIT-FLAVOUR` +* Support for lock files for pinning exact project dependency versions Behavior changes: * `stack.yaml` now supports `snapshot`: a synonym for `resolver`. See [#4256](https://github.com/commercialhaskell/stack/issues/4256) From 182daadfa71b29a990fac007b0eeedc4fc25651c Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 22 Apr 2019 15:44:14 +0300 Subject: [PATCH 04/12] Read snapshot locations without content, optimize exact locs --- src/Stack/Lock.hs | 86 +++++++++++++++++++++++++-------------- subs/pantry/src/Pantry.hs | 64 ++++++++++++++++++++++++++--- 2 files changed, 114 insertions(+), 36 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index e37f527357..4e4556a197 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -75,23 +75,31 @@ instance FromJSON (WithJSONWarnings (Unresolved CompletedSnapshotLocation)) wher c <- o ..: "compiler" pure $ Unresolved $ \_ -> pure $ CSLCompiler c -data LockedLocation a b = LockedLocation - { llOriginal :: a - , llCompleted :: b - } deriving (Show, Eq) +data LockedLocation a b + = LockedExact b + | LockedCompleted a + b + deriving (Show, Eq) instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where - toJSON LockedLocation{..} = - object [ "original" .= llOriginal, "completed" .= llCompleted ] + toJSON (LockedExact o) = + object ["exact" .= o] + toJSON (LockedCompleted o c) = + object [ "original" .= o, "completed" .= c ] instance ( FromJSON (WithJSONWarnings (Unresolved a)) - , FromJSON (WithJSONWarnings (Unresolved b))) => + , FromJSON (WithJSONWarnings (Unresolved b)) + ) => FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where - parseJSON = - withObjectWarnings "LockedLocation" $ \o -> do - llOriginal <- jsonSubWarnings $ o ..: "original" - llCompleted <- jsonSubWarnings $ o ..: "completed" - pure $ LockedLocation <$> llOriginal <*> llCompleted + parseJSON v = withObjectWarnings "LockedLocation" (\o -> lockedExact o <|> lockedCompleted o) v + where + lockedExact o = do + exact <- jsonSubWarnings $ o ..: "exact" + pure $ LockedExact <$> exact + lockedCompleted o = do + original <- jsonSubWarnings $ o ..: "original" + completed <- jsonSubWarnings $ o ..: "completed" + pure $ LockedCompleted <$> original <*> completed data LockedPackage = LockedPackage { lpLocation :: !(LockedLocation RawPackageLocationImmutable PackageLocationImmutable) @@ -129,7 +137,8 @@ instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where instance FromJSON (WithJSONWarnings (Unresolved LockedPackage)) where parseJSON = withObjectWarnings "LockedPackage" $ \o -> do - let unwrap (LockedLocation single c) = LockedLocation (unSingleRPLI single) c + let unwrap (LockedExact c) = LockedExact c + unwrap (LockedCompleted single c) = LockedCompleted (unSingleRPLI single) c location <- jsonSubWarnings $ o ..: "location" lpFlags <- fmap unCabalStringMap $ o ..:? "flags" ..!= Map.empty lpHidden <- o ..:? "hidden" ..!= False @@ -192,6 +201,7 @@ lockCachedWanted stackFile resolver fillWanted = do lockExists <- doesFileExist lockFile if not lockExists then do + logDebug "Lock file doesn't exist" (snap, slocs, completed) <- loadAndCompleteSnapshotRaw resolver Map.empty let compiler = snapshotCompiler snap @@ -201,15 +211,17 @@ lockCachedWanted stackFile resolver fillWanted = do let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) (completed <> prjCompleted) snapshots <- for slocs $ \(orig, sloc) -> do - compl <- case sloc of + case sloc of SLFilePath fp -> do (sha, size) <- shaSize (resolvedAbsolute fp) - pure $ CSLFilePath fp sha size + pure $ LockedCompleted orig (CSLFilePath fp sha size) SLCompiler c -> - pure $ CSLCompiler c - SLUrl url blobKey -> - pure $ CSLUrl url blobKey - pure $ LockedLocation orig compl + pure $ LockedExact (CSLCompiler c) + sl@(SLUrl url blobKey) -> + let csurl = CSLUrl url blobKey + in if toRawSL sl == orig + then pure $ LockedExact csurl + else pure $ LockedCompleted orig csurl liftIO $ Yaml.encodeFile (toFilePath lockFile) $ Locked { lckStackSha = stackSha , lckStackSize = stackSize @@ -222,9 +234,10 @@ lockCachedWanted stackFile resolver fillWanted = do lmt <- liftIO $ getModificationTime lockFile unresolvedLocked <- loadYamlThrow parseJSON lockFile locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked - let pkgLocCache = Map.fromList - [ (llOriginal ll, llCompleted ll) - | ll <- map lpLocation $ Map.elems (lckPackages locked0) ] + let pkgLocCache = Map.fromList $ + map (lockPair . lpLocation) $ Map.elems (lckPackages locked0) + lockPair (LockedExact compl) = (toRawPLI compl, compl) + lockPair (LockedCompleted orig compl) = (orig, compl) sha0 = lckStackSha locked0 size0 = lckStackSize locked0 result <- liftIO $ checkOutdated stackFile lmt size0 sha0 @@ -232,15 +245,21 @@ lockCachedWanted stackFile resolver fillWanted = do case result of Right () -> (False, sha0, size0) Left (sha, sz) -> (True, sha, sz) - let lockedSnapshots = Map.fromList - [ (orig, compl) - | LockedLocation orig compl <- NE.toList (lckSnapshots locked0) - ] + let lockedSnapshots = Map.fromList $ map toPair $ NE.toList (lckSnapshots locked0) + toPair (LockedExact compl) = (toRawSL' compl, compl) + toPair (LockedCompleted orig compl) = (orig, compl) + toRawSL' (CSLCompiler c) = RSLCompiler c + toRawSL' (CSLUrl url blobKey) = toRawSL (SLUrl url blobKey) + toRawSL' (CSLFilePath fp _ _) = toRawSL (SLFilePath fp) layers <- readSnapshotLayers resolver (outdated, valid) <- fmap partitionEithers . forM (NE.toList layers) $ \(rsloc, sloc) -> liftIO $ - let outdatedLoc = Left . LockedLocation rsloc - validLoc = Right . LockedLocation rsloc + let toLockedSL _orig compl@(CSLCompiler _) = LockedExact compl + toLockedSL orig compl@(CSLUrl url bk) + | toRawSL (SLUrl url bk) == orig = LockedExact compl + toLockedSL orig compl = LockedCompleted orig compl + outdatedLoc = Left . toLockedSL rsloc + validLoc = Right . toLockedSL rsloc in case Map.lookup rsloc lockedSnapshots of Nothing -> case sloc of @@ -262,10 +281,13 @@ lockCachedWanted stackFile resolver fillWanted = do let lockIsUpToDate = not syOutdated && null outdated if lockIsUpToDate then do + logDebug "Lock file exist and is up-to-date" let compiler = lckCompiler locked0 pkgs = flip Map.mapWithKey (lckPackages locked0) $ \nm lp haddocks -> do run <- askRunInIO - let location = llCompleted (lpLocation lp) + let location = case lpLocation lp of + LockedExact c -> c + LockedCompleted _ c -> c common = CommonPackage { cpName = nm , cpGPD = run $ loadCabalFileImmutable location @@ -281,6 +303,7 @@ lockCachedWanted stackFile resolver fillWanted = do (wanted, _prjCompleted) <- fillWanted pkgLocCache compiler pkgs pure wanted else do + logDebug "Lock file exist but is not up-to-date" (snap, _slocs, completed) <- loadAndCompleteSnapshotRaw resolver pkgLocCache let compiler = snapshotCompiler snap @@ -306,7 +329,10 @@ lockCachedWanted stackFile resolver fillWanted = do , lpFromSnapshot = dpFromSnapshot dp , lpGhcOptions = cpGhcOptions common , lpHidden = dpHidden dp - , lpLocation = LockedLocation rpli pli + , lpLocation = + if toRawPLI pli == rpli + then LockedExact pli + else LockedCompleted rpli pli } ) shaSize fp = do diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 43ead38f6e..e3ee6eaf94 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -69,6 +70,7 @@ module Pantry , RawPackageLocation (..) , PackageLocation (..) , toRawPL + , toRawPLI , RawPackageLocationImmutable (..) , PackageLocationImmutable (..) @@ -198,7 +200,7 @@ import RIO.PrettyPrint import RIO.Process import RIO.Directory (getAppUserDataDirectory) import qualified Data.Yaml as Yaml -import Data.Aeson.Extended (WithJSONWarnings (..), Value) +import Data.Aeson.Extended (unWarningParser, (...:?), WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP @@ -963,7 +965,9 @@ loadSnapshot loc = do type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) type CompletedSL = (RawSnapshotLocation, SnapshotLocation) --- | Get completed locations of all snapshot layers from a 'RawSnapshotLocation' +-- | Get completed locations of all snapshot layers from a 'RawSnapshotLocation'. +-- Uses only fields 'compiler', 'parent' and 'solver' without parsing other +-- snapshot fields -- -- @since 0.1.0.0 readSnapshotLayers :: @@ -971,12 +975,12 @@ readSnapshotLayers :: => RawSnapshotLocation -> RIO env (NonEmpty CompletedSL) readSnapshotLayers loc = do - eres <- loadRawSnapshotLayer loc + eres <- loadRawSnapshotLayerParent loc case eres of Left wc -> pure $ (RSLCompiler wc, SLCompiler wc) :| [] - Right (rsl, sloc) -> - (sloc <|) <$> readSnapshotLayers (rslParent rsl) + Right (RawSnapshotLayerParent p, sloc) -> + (sloc <|) <$> readSnapshotLayers p -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations @@ -1029,7 +1033,7 @@ loadAndCompleteSnapshotRaw loc cachePL = do , snapshotPackages = packages , snapshotDrop = apcDrop unused } - return (snapshot, sloc <| slocs0, completed ++ completed0) + return (snapshot, sloc <| slocs0, completed0 ++ completed) data SingleOrNot a = Single !a @@ -1216,6 +1220,54 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro pure (allPackages, reverse revCompleted, unused) +-- helper data type for reading only parent snapshot locaitons +newtype RawSnapshotLayerParent = RawSnapshotLayerParent RawSnapshotLocation + +instance Yaml.FromJSON (Unresolved RawSnapshotLayerParent) where + parseJSON = Yaml.withObject "Snapshot" $ \o -> do + mcompiler <- o Yaml..:? "compiler" + mresolver <- unWarningParser $ o ...:? ["snapshot", "resolver"] + unresolvedSnapshotParent <- + case (mcompiler, mresolver) of + (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" + (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler) + (_, Just (WithJSONWarnings (Unresolved usl) _)) -> pure $ Unresolved $ \mdir -> do + sl <- usl mdir + case (sl, mcompiler) of + (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 + _ -> pure sl + + pure $ RawSnapshotLayerParent <$> unresolvedSnapshotParent + +loadRawSnapshotLayerParent + :: (HasPantryConfig env, HasLogFunc env) + => RawSnapshotLocation + -> RIO env (Either WantedCompiler (RawSnapshotLayerParent, CompletedSL)) +loadRawSnapshotLayerParent (RSLCompiler compiler) = pure $ Left compiler +loadRawSnapshotLayerParent sl@(RSLUrl url blob) = + handleAny (throwIO . InvalidSnapshot sl) $ do + bs <- loadFromURL url blob + value <- Yaml.decodeThrow bs + lparent <- parserHelperLayerParent sl value Nothing + pure $ Right (lparent, (sl, SLUrl url (bsToBlobKey bs))) +loadRawSnapshotLayerParent sl@(RSLFilePath fp) = + handleAny (throwIO . InvalidSnapshot sl) $ do + value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp + lparent <- parserHelperLayerParent sl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right (lparent, (sl, SLFilePath fp)) + +parserHelperLayerParent + :: HasLogFunc env + => RawSnapshotLocation + -> Value + -> Maybe (Path Abs Dir) + -> RIO env RawSnapshotLayerParent +parserHelperLayerParent rsl val mdir = + case parseEither Yaml.parseJSON val of + Left e -> throwIO $ Couldn'tParseSnapshot rsl e + Right x -> do + resolvePaths mdir x + -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- -- Returns a 'Left' value if provided an 'SLCompiler' From a3f71ab1a7d7c46c4d5c5c7cc0275fd77e535cd3 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 23 Apr 2019 11:14:58 +0300 Subject: [PATCH 05/12] Simplify locks: use them only as completion cache --- src/Stack/Lock.hs | 338 ++++------------------------- src/Stack/SourceMap.hs | 2 +- src/Stack/Types/SourceMap.hs | 2 +- src/test/Stack/LockSpec.hs | 210 ++++++------------ subs/pantry/src/Pantry.hs | 99 ++------- subs/pantry/src/Pantry/Internal.hs | 1 - subs/pantry/src/Pantry/Types.hs | 10 +- 7 files changed, 127 insertions(+), 535 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 4e4556a197..91cc5bc319 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -2,12 +2,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Stack.Lock ( lockCachedWanted , LockedLocation(..) - , LockedPackage(..) , Locked(..) ) where @@ -17,109 +15,29 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Yaml as Yaml import Pantry -import Pantry.Internal (Unresolved(..)) -import qualified Pantry.SHA256 as SHA256 import Path (addFileExtension, parent) -import Path.IO (doesFileExist, getModificationTime, resolveFile) -import qualified RIO.ByteString as B +import Path.IO (doesFileExist) import RIO.Process -import qualified RIO.Text as T -import RIO.Time (UTCTime) import Stack.Prelude import Stack.SourceMap import Stack.Types.Config import Stack.Types.SourceMap -data CompletedSnapshotLocation - = CSLFilePath !(ResolvedPath File) - !SHA256 - !FileSize - | CSLCompiler !WantedCompiler - | CSLUrl !Text !BlobKey +data LockedLocation = + LockedLocation RawPackageLocationImmutable + PackageLocationImmutable deriving (Show, Eq) -instance ToJSON CompletedSnapshotLocation where - toJSON (CSLFilePath fp sha size) = - object [ "file" .= resolvedRelative fp - , "sha" .= sha - , "size" .= size - ] - toJSON (CSLCompiler c) = - object ["compiler" .= toJSON c] - toJSON (CSLUrl url (BlobKey sha size)) = - object [ "url" .= url - , "sha" .= sha - , "size" .= size - ] - -instance FromJSON (WithJSONWarnings (Unresolved CompletedSnapshotLocation)) where - parseJSON v = file v <|> url v <|> compiler v - where - file = withObjectWarnings "CSLFilepath" $ \o -> do - ufp <- o ..: "file" - sha <- o ..: "sha" - size <- o ..: "size" - pure $ Unresolved $ \mdir -> - case mdir of - Nothing -> throwIO $ InvalidFilePathSnapshot ufp - Just dir -> do - absolute <- resolveFile dir (T.unpack ufp) - let fp = ResolvedPath (RelFilePath ufp) absolute - pure $ CSLFilePath fp sha size - url = withObjectWarnings "CSLUrl" $ \o -> do - url' <- o ..: "url" - sha <- o ..: "sha" - size <- o ..: "size" - pure $ Unresolved $ \_ -> pure $ CSLUrl url' (BlobKey sha size) - compiler = withObjectWarnings "CSLCompiler" $ \o -> do - c <- o ..: "compiler" - pure $ Unresolved $ \_ -> pure $ CSLCompiler c - -data LockedLocation a b - = LockedExact b - | LockedCompleted a - b - deriving (Show, Eq) - -instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where - toJSON (LockedExact o) = - object ["exact" .= o] - toJSON (LockedCompleted o c) = +instance ToJSON LockedLocation where + toJSON (LockedLocation o c) = object [ "original" .= o, "completed" .= c ] -instance ( FromJSON (WithJSONWarnings (Unresolved a)) - , FromJSON (WithJSONWarnings (Unresolved b)) - ) => - FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where - parseJSON v = withObjectWarnings "LockedLocation" (\o -> lockedExact o <|> lockedCompleted o) v - where - lockedExact o = do - exact <- jsonSubWarnings $ o ..: "exact" - pure $ LockedExact <$> exact - lockedCompleted o = do - original <- jsonSubWarnings $ o ..: "original" - completed <- jsonSubWarnings $ o ..: "completed" - pure $ LockedCompleted <$> original <*> completed - -data LockedPackage = LockedPackage - { lpLocation :: !(LockedLocation RawPackageLocationImmutable PackageLocationImmutable) - , lpFlags :: !(Map FlagName Bool) - , lpHidden :: !Bool - , lpGhcOptions :: ![Text] - , lpFromSnapshot :: !FromSnapshot - } deriving (Show, Eq) - -instance ToJSON LockedPackage where - toJSON LockedPackage {..} = - let toBoolean FromSnapshot = True - toBoolean NotFromSnapshot = False - in object $ concat - [ ["location" .= lpLocation] - , if Map.null lpFlags then [] else ["flags" .= toCabalStringMap lpFlags] - , if lpFromSnapshot == FromSnapshot then [] else ["from-snapshot" .= toBoolean lpFromSnapshot] - , if not lpHidden then [] else ["hidden" .= lpHidden] - , if null lpGhcOptions then [] else ["ghc-options" .= lpGhcOptions] - ] +instance FromJSON (WithJSONWarnings (Unresolved LockedLocation)) where + parseJSON = + withObjectWarnings "LockedLocation" $ \o -> do + original <- jsonSubWarnings $ o ..: "original" + completed <- jsonSubWarnings $ o ..: "completed" + pure $ (\single c -> LockedLocation (unSingleRPLI single) c) <$> original <*> completed -- Special wrapper extracting only 1 RawPackageLocationImmutable -- serialization should not produce locations with multiple subdirs @@ -131,61 +49,23 @@ instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where do WithJSONWarnings unresolvedRPLIs ws <- parseJSON v let withWarnings x = WithJSONWarnings x ws - pure $ withWarnings $ Unresolved $ \mdir -> do - rpli <- NE.head <$> resolvePaths mdir unresolvedRPLIs - pure $ SingleRPLI rpli - -instance FromJSON (WithJSONWarnings (Unresolved LockedPackage)) where - parseJSON = withObjectWarnings "LockedPackage" $ \o -> do - let unwrap (LockedExact c) = LockedExact c - unwrap (LockedCompleted single c) = LockedCompleted (unSingleRPLI single) c - location <- jsonSubWarnings $ o ..: "location" - lpFlags <- fmap unCabalStringMap $ o ..:? "flags" ..!= Map.empty - lpHidden <- o ..:? "hidden" ..!= False - lpGhcOptions <- o ..:? "ghc-options" ..!= [] - let fromBoolean True = FromSnapshot - fromBoolean False = NotFromSnapshot - lpFromSnapshot <- fmap fromBoolean $ o ..:? "from-snapshot" ..!= True - pure $ (\lpLocation -> LockedPackage {..}) <$> fmap unwrap location + pure $ withWarnings $ SingleRPLI . NE.head <$> unresolvedRPLIs -data Locked = Locked - { lckStackSha :: !SHA256 - , lckStackSize :: !FileSize - , lckCompiler :: WantedCompiler - , lckSnapshots :: NE.NonEmpty (LockedLocation RawSnapshotLocation CompletedSnapshotLocation) - , lckPackages :: Map PackageName LockedPackage - } - deriving (Show, Eq) +newtype Locked = Locked [LockedLocation] -instance FromJSON (WithJSONWarnings (Unresolved Locked)) where - parseJSON = withObjectWarnings "Locked" $ \o -> do - stackYaml <- o ..: "stack-yaml" - lckStackSha <- stackYaml ..: "sha256" - lckStackSize <- stackYaml ..: "size" - lckCompiler <- o ..: "compiler" - snapshots <- jsonSubWarningsT $ o ..: "snapshots" - packages <- fmap unCabalStringMap $ jsonSubWarningsT $ o ..: "packages" - pure $ (\lckSnapshots lckPackages -> Locked {..}) <$> sequenceA snapshots <*> sequenceA packages - -instance ToJSON Locked where - toJSON Locked {..} = - object - [ "stack-yaml" .= object ["sha256" .= lckStackSha, "size" .= lckStackSize] - , "compiler" .= lckCompiler - , "snapshots" .= lckSnapshots - , "packages" .= toCabalStringMap lckPackages - ] +instance FromJSON (Unresolved Locked) where + parseJSON v = do + locs <- unWarningParser $ jsonSubWarningsT (lift $ parseJSON v) + pure $ Locked <$> sequenceA locs loadYamlThrow :: HasLogFunc env - => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a + => (Value -> Yaml.Parser a) -> Path Abs File -> RIO env a loadYamlThrow parser path = do val <- liftIO $ Yaml.decodeFileThrow (toFilePath path) case Yaml.parseEither parser val of Left err -> throwIO $ Yaml.AesonException err - Right (WithJSONWarnings res warnings) -> do - logJSONWarnings (toFilePath path) warnings - return res + Right res -> return res lockCachedWanted :: (HasPantryConfig env, HasProcessContext env, HasLogFunc env) @@ -199,162 +79,22 @@ lockCachedWanted :: lockCachedWanted stackFile resolver fillWanted = do lockFile <- liftIO $ addFileExtension "lock" stackFile lockExists <- doesFileExist lockFile - if not lockExists - then do - logDebug "Lock file doesn't exist" - (snap, slocs, completed) <- - loadAndCompleteSnapshotRaw resolver Map.empty - let compiler = snapshotCompiler snap - snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) - (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs - (stackSha, stackSize) <- shaSize stackFile - let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) - (completed <> prjCompleted) - snapshots <- for slocs $ \(orig, sloc) -> do - case sloc of - SLFilePath fp -> do - (sha, size) <- shaSize (resolvedAbsolute fp) - pure $ LockedCompleted orig (CSLFilePath fp sha size) - SLCompiler c -> - pure $ LockedExact (CSLCompiler c) - sl@(SLUrl url blobKey) -> - let csurl = CSLUrl url blobKey - in if toRawSL sl == orig - then pure $ LockedExact csurl - else pure $ LockedCompleted orig csurl - liftIO $ Yaml.encodeFile (toFilePath lockFile) $ - Locked { lckStackSha = stackSha - , lckStackSize = stackSize - , lckCompiler = smwCompiler wanted - , lckSnapshots = snapshots - , lckPackages = Map.fromList pkgs - } - pure wanted - else do - lmt <- liftIO $ getModificationTime lockFile - unresolvedLocked <- loadYamlThrow parseJSON lockFile - locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked - let pkgLocCache = Map.fromList $ - map (lockPair . lpLocation) $ Map.elems (lckPackages locked0) - lockPair (LockedExact compl) = (toRawPLI compl, compl) - lockPair (LockedCompleted orig compl) = (orig, compl) - sha0 = lckStackSha locked0 - size0 = lckStackSize locked0 - result <- liftIO $ checkOutdated stackFile lmt size0 sha0 - let (syOutdated, sySha, sySize) = - case result of - Right () -> (False, sha0, size0) - Left (sha, sz) -> (True, sha, sz) - let lockedSnapshots = Map.fromList $ map toPair $ NE.toList (lckSnapshots locked0) - toPair (LockedExact compl) = (toRawSL' compl, compl) - toPair (LockedCompleted orig compl) = (orig, compl) - toRawSL' (CSLCompiler c) = RSLCompiler c - toRawSL' (CSLUrl url blobKey) = toRawSL (SLUrl url blobKey) - toRawSL' (CSLFilePath fp _ _) = toRawSL (SLFilePath fp) - layers <- readSnapshotLayers resolver - (outdated, valid) <- - fmap partitionEithers . forM (NE.toList layers) $ \(rsloc, sloc) -> liftIO $ - let toLockedSL _orig compl@(CSLCompiler _) = LockedExact compl - toLockedSL orig compl@(CSLUrl url bk) - | toRawSL (SLUrl url bk) == orig = LockedExact compl - toLockedSL orig compl = LockedCompleted orig compl - outdatedLoc = Left . toLockedSL rsloc - validLoc = Right . toLockedSL rsloc - in case Map.lookup rsloc lockedSnapshots of - Nothing -> - case sloc of - SLFilePath fp -> do - (sha, size) <- shaSize $ resolvedAbsolute fp - pure $ outdatedLoc (CSLFilePath fp sha size) - SLCompiler c -> - pure $ outdatedLoc (CSLCompiler c) - SLUrl u bk -> - pure $ outdatedLoc (CSLUrl u bk) - Just loc@(CSLFilePath fp sha size) -> do - result' <- checkOutdated (resolvedAbsolute fp) lmt size sha - case result' of - Right () -> pure $ validLoc loc - Left (sha', size') -> - pure $ outdatedLoc (CSLFilePath fp sha' size') - Just immutable -> - pure $ validLoc immutable - let lockIsUpToDate = not syOutdated && null outdated - if lockIsUpToDate - then do - logDebug "Lock file exist and is up-to-date" - let compiler = lckCompiler locked0 - pkgs = flip Map.mapWithKey (lckPackages locked0) $ \nm lp haddocks -> do - run <- askRunInIO - let location = case lpLocation lp of - LockedExact c -> c - LockedCompleted _ c -> c - common = CommonPackage - { cpName = nm - , cpGPD = run $ loadCabalFileImmutable location - , cpFlags = lpFlags lp - , cpGhcOptions = lpGhcOptions lp - , cpHaddocks = haddocks - } - pure $ DepPackage{ dpLocation = PLImmutable location - , dpCommon = common - , dpHidden = lpHidden lp - , dpFromSnapshot = lpFromSnapshot lp - } - (wanted, _prjCompleted) <- fillWanted pkgLocCache compiler pkgs - pure wanted - else do - logDebug "Lock file exist but is not up-to-date" - (snap, _slocs, completed) <- - loadAndCompleteSnapshotRaw resolver pkgLocCache - let compiler = snapshotCompiler snap - snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) - (wanted, prjCompleted) <- fillWanted pkgLocCache compiler snPkgs - let pkgs = mapMaybe (uncurry $ maybeWantedLockedPackage wanted) - (completed <> prjCompleted) - liftIO $ Yaml.encodeFile (toFilePath lockFile) $ - Locked { lckStackSha = sySha - , lckStackSize = sySize - , lckCompiler = smwCompiler wanted - , lckSnapshots = NE.fromList $ outdated ++ valid - , lckPackages = Map.fromList pkgs - } - pure wanted - where - maybeWantedLockedPackage wanted rpli pli = do - let name = pkgName (packageLocationIdent pli) - dp <- Map.lookup name (smwDeps wanted) - let common = dpCommon dp - pure ( name - , LockedPackage { lpFlags = cpFlags common - , lpFromSnapshot = dpFromSnapshot dp - , lpGhcOptions = cpGhcOptions common - , lpHidden = dpHidden dp - , lpLocation = - if toRawPLI pli == rpli - then LockedExact pli - else LockedCompleted rpli pli - } - ) - shaSize fp = do - bs <- B.readFile $ toFilePath fp - let size = FileSize . fromIntegral $ B.length bs - sha = SHA256.hashBytes bs - return (sha, size) - -checkOutdated :: - Path Abs File - -> UTCTime - -> FileSize - -> SHA256 - -> IO (Either (SHA256, FileSize) ()) -checkOutdated fp dt size sha = do - mt <- getModificationTime fp - if mt < dt - then pure $ Right () - else do - bs <- B.readFile $ toFilePath fp - let newSize = FileSize . fromIntegral $ B.length bs - newSha = SHA256.hashBytes bs - if newSize /= size || sha /= newSha - then pure $ Left (newSha, newSize) - else pure $ Right () + pkgLocCache <- if not lockExists + then do + logDebug "Lock file doesn't exist" + pure Map.empty + else do + logDebug "Using package location completions from a lock file" + unresolvedLocked <- loadYamlThrow parseJSON lockFile + Locked locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked + pure $ Map.fromList [(orig, compl) | LockedLocation orig compl <- locked0] + + (snap, completed) <- + loadAndCompleteSnapshotRaw resolver pkgLocCache + let compiler = snapshotCompiler snap + snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) + (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs + liftIO $ Yaml.encodeFile (toFilePath lockFile) $ + map (uncurry LockedLocation) $ + prjCompleted <> completed + pure wanted diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index e16467c59f..40970b48dd 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -260,7 +260,7 @@ loadProjectSnapshotCandidate :: -> Bool -> RIO env (SnapshotCandidate env) loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do - (snapshot, _, _) <- loadAndCompleteSnapshotRaw loc Map.empty + (snapshot, _) <- loadAndCompleteSnapshotRaw loc Map.empty deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot) let wc = snapshotCompiler snapshot globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc diff --git a/src/Stack/Types/SourceMap.hs b/src/Stack/Types/SourceMap.hs index 4af5ed4731..56b712ff61 100644 --- a/src/Stack/Types/SourceMap.hs +++ b/src/Stack/Types/SourceMap.hs @@ -46,7 +46,7 @@ data CommonPackage = CommonPackage data FromSnapshot = FromSnapshot | NotFromSnapshot - deriving (Show, Eq) + deriving (Show) -- | A view of a dependency package, specified in stack.yaml data DepPackage = DepPackage diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index 1b35852261..aa67d58dcf 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -4,9 +4,7 @@ module Stack.LockSpec where -import Data.Aeson.Extended (WithJSONWarnings(..)) import Data.ByteString (ByteString) -import qualified Data.Map as Map import qualified Data.Yaml as Yaml import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) @@ -14,7 +12,6 @@ import Pantry import qualified Pantry.SHA256 as SHA256 import RIO import Stack.Lock -import Stack.Types.SourceMap (FromSnapshot(..)) import Test.Hspec import Text.RawString.QQ @@ -32,110 +29,58 @@ decodeLocked bs = do val <- Yaml.decodeThrow bs case Yaml.parseEither Yaml.parseJSON val of Left err -> throwIO $ Yaml.AesonException err - Right (WithJSONWarnings res warnings) -> do - unless (null warnings) $ - throwIO $ Yaml.AesonException $ "Unexpected warnings: " ++ show warnings + Right res -> do -- we just assume no file references resolvePaths Nothing res spec :: Spec spec = do - it "parses lock file (empty with GHC resolver)" $ do + it "parses lock file (empty)" $ do let lockFile :: ByteString lockFile = [r|#some -packages: {} -snapshots: -- completed: - compiler: ghc-8.2.2 - original: - compiler: ghc-8.2.2 -stack-yaml: - size: 90 - sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 -compiler: ghc-8.2.2 +[] |] - pkgImm <- lckPackages <$> decodeLocked lockFile - Map.toList pkgImm `shouldBe` [] - it "parses lock file (empty with LTS)" $ do + Locked pkgImm <- decodeLocked lockFile + pkgImm `shouldBe` [] + it "parses lock file (wai + warp)" $ do let lockFile :: ByteString lockFile = [r|#some -packages: {} -snapshots: -- completed: - sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a - size: 527801 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml - original: lts-11.22 -- completed: - compiler: ghc-8.2.2 - original: - compiler: ghc-8.2.2 -stack-yaml: - size: 90 - sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 -compiler: ghc-8.2.2 +- original: + subdir: wai + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + completed: + subdir: wai + cabal-file: + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 + name: wai + version: 3.2.1.2 + git: https://github.com/yesodweb/wai.git + pantry-tree: + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 +- original: + subdir: warp + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + completed: + subdir: warp + cabal-file: + size: 10725 + sha256: cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758 + name: warp + version: 3.2.25 + git: https://github.com/yesodweb/wai.git + pantry-tree: + size: 5103 + sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 |] - pkgImm <- lckPackages <$> decodeLocked lockFile - Map.toList pkgImm `shouldBe` [] - it "parses lock file (non empty)" $ do - let lockFile :: ByteString - lockFile = - [r|#some -packages: - wai: - location: - original: - subdir: wai - git: https://github.com/yesodweb/wai.git - commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 - completed: - subdir: wai - cabal-file: - size: 1765 - sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 - name: wai - version: 3.2.1.2 - git: https://github.com/yesodweb/wai.git - pantry-tree: - size: 714 - sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 - commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 - warp: - location: - original: - subdir: warp - git: https://github.com/yesodweb/wai.git - commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 - completed: - subdir: warp - cabal-file: - size: 10725 - sha256: cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758 - name: warp - version: 3.2.25 - git: https://github.com/yesodweb/wai.git - pantry-tree: - size: 5103 - sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a - commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 -snapshots: -- completed: - sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a - size: 527801 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml - original: lts-11.22 -- completed: - compiler: ghc-8.2.2 - original: - compiler: ghc-8.2.2 -stack-yaml: - size: 90 - sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 -compiler: ghc-8.2.2 -|] - pkgImm <- Map.toList . lckPackages <$> decodeLocked lockFile + Locked pkgImm <- decodeLocked lockFile let waiSubdirRepo subdir = Repo { repoType = RepoGit , repoUrl = "https://github.com/yesodweb/wai.git" @@ -149,10 +94,9 @@ compiler: ghc-8.2.2 , rpmCabal = Nothing } pkgImm `shouldBe` - [ ( "wai" - , lockedPackageWithLocations - (RPLIRepo (waiSubdirRepo "wai") emptyRPM) - (PLIRepo (waiSubdirRepo "wai") + [ LockedLocation + (RPLIRepo (waiSubdirRepo "wai") emptyRPM) + (PLIRepo (waiSubdirRepo "wai") (PackageMetadata { pmIdent = PackageIdentifier { pkgName = mkPackageName "wai" @@ -169,11 +113,9 @@ compiler: ghc-8.2.2 "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" 1765 })) - ) - , ( "warp" - , lockedPackageWithLocations - (RPLIRepo (waiSubdirRepo "warp") emptyRPM) - (PLIRepo (waiSubdirRepo "warp") + , LockedLocation + (RPLIRepo (waiSubdirRepo "warp") emptyRPM) + (PLIRepo (waiSubdirRepo "warp") (PackageMetadata { pmIdent = PackageIdentifier { pkgName = mkPackageName "warp" @@ -190,48 +132,29 @@ compiler: ghc-8.2.2 "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" 10725 })) - ) ] it "parses snapshot lock file (non empty)" $ do let lockFile :: ByteString lockFile = [r|#some -packages: - string-quote: - location: - original: - hackage: string-quote-0.0.1 - completed: - hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 - pantry-tree: - size: 273 - sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f -snapshots: -- completed: - sha: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a - size: 527801 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml - original: lts-11.22 -- completed: - compiler: ghc-8.2.2 - original: - compiler: ghc-8.2.2 -stack-yaml: - size: 90 - sha256: a76edd6dce723eb10cde23535eb1ed6e9c9206603cb219d0af73f74020202390 -compiler: ghc-8.2.2 +- original: + hackage: string-quote-0.0.1 + completed: + hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 + pantry-tree: + size: 273 + sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f |] - pkgImm <- Map.toList . lckPackages <$> decodeLocked lockFile + Locked pkgImm <- decodeLocked lockFile pkgImm `shouldBe` - [("string-quote" - , lockedPackageWithLocations - ( RPLIHackage + [ LockedLocation + (RPLIHackage (PackageIdentifierRevision (mkPackageName "string-quote") (mkVersion [0, 0, 1]) CFILatest) Nothing) - ( PLIHackage + (PLIHackage (PackageIdentifier { pkgName = mkPackageName "string-quote" , pkgVersion = mkVersion [0, 0, 1] @@ -243,16 +166,17 @@ compiler: ghc-8.2.2 (BlobKey (decodeSHA "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") - (FileSize 273)))) + (FileSize 273))) ) ] - -lockedPackageWithLocations :: RawPackageLocationImmutable -> PackageLocationImmutable -> LockedPackage -lockedPackageWithLocations rpli pli = - LockedPackage{ lpLocation = LockedLocation rpli pli - , lpFlags = mempty - , lpGhcOptions = mempty - , lpFromSnapshot = FromSnapshot - , lpHidden = False - } +-- +--lockedPackageWithLocations :: RawPackageLocationImmutable -> PackageLocationImmutable -> LockedPackage +--lockedPackageWithLocations rpli pli = +-- LockedPackage{ lpLocation = LockedLocation rpli pli +-- , lpFlags = mempty +-- , lpGhcOptions = mempty +-- , lpFromSnapshot = FromSnapshot +-- , lpHidden = False +-- } +-- diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index e3ee6eaf94..1c724accd7 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -70,7 +69,6 @@ module Pantry , RawPackageLocation (..) , PackageLocation (..) , toRawPL - , toRawPLI , RawPackageLocationImmutable (..) , PackageLocationImmutable (..) @@ -94,7 +92,6 @@ module Pantry , loadRawSnapshotLayer , loadSnapshotLayer , loadSnapshot - , readSnapshotLayers , loadAndCompleteSnapshot , loadAndCompleteSnapshotRaw , CompletedPLI @@ -200,12 +197,11 @@ import RIO.PrettyPrint import RIO.Process import RIO.Directory (getAppUserDataDirectory) import qualified Data.Yaml as Yaml -import Data.Aeson.Extended (unWarningParser, (...:?), WithJSONWarnings (..), Value) +import Data.Aeson.Extended (WithJSONWarnings (..), Value) import Data.Aeson.Types (parseEither) import Data.Monoid (Endo (..)) import Pantry.HTTP import Data.Char (isHexDigit) -import Data.List.NonEmpty (NonEmpty((:|)), (<|)) -- | Create a new 'PantryConfig' with the given settings. -- @@ -906,7 +902,7 @@ loadSnapshotRaw loc = do , rsPackages = mempty , rsDrop = mempty } - Right (rsl, _sha) -> do + Right rsl -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot @@ -963,24 +959,6 @@ loadSnapshot loc = do } type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) -type CompletedSL = (RawSnapshotLocation, SnapshotLocation) - --- | Get completed locations of all snapshot layers from a 'RawSnapshotLocation'. --- Uses only fields 'compiler', 'parent' and 'solver' without parsing other --- snapshot fields --- --- @since 0.1.0.0 -readSnapshotLayers :: - (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawSnapshotLocation - -> RIO env (NonEmpty CompletedSL) -readSnapshotLayers loc = do - eres <- loadRawSnapshotLayerParent loc - case eres of - Left wc -> - pure $ (RSLCompiler wc, SLCompiler wc) :| [] - Right (RawSnapshotLayerParent p, sloc) -> - (sloc <|) <$> readSnapshotLayers p -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations @@ -990,7 +968,7 @@ loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> RIO env (Snapshot, NonEmpty CompletedSL, [CompletedPLI]) + -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshot loc cachedPL = loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL @@ -1002,7 +980,7 @@ loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> RIO env (Snapshot, NonEmpty CompletedSL, [CompletedPLI]) + -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshotRaw loc cachePL = do eres <- loadRawSnapshotLayer loc case eres of @@ -1012,9 +990,9 @@ loadAndCompleteSnapshotRaw loc cachePL = do , snapshotPackages = mempty , snapshotDrop = mempty } - in pure (snapshot, (RSLCompiler wc, SLCompiler wc) :| [], []) - Right (rsl, sloc) -> do - (snap0, slocs0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL + in pure (snapshot, []) + Right rsl -> do + (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL (packages, completed, unused) <- addAndCompletePackagesToSnapshot loc @@ -1033,7 +1011,7 @@ loadAndCompleteSnapshotRaw loc cachePL = do , snapshotPackages = packages , snapshotDrop = apcDrop unused } - return (snapshot, sloc <| slocs0, completed0 ++ completed) + return (snapshot, completed0 ++ completed) data SingleOrNot a = Single !a @@ -1165,7 +1143,7 @@ cachedSnapshotCompletePackageLocation cachePackages rpli = do -- set. -- -- Returns any of the 'AddPackagesConfig' values not used and also all --- package location completions. +-- non-trivial package location completions. -- -- @since 0.1.0.0 addAndCompletePackagesToSnapshot @@ -1193,7 +1171,10 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro , spHidden = Map.findWithDefault False name hiddens , spGhcOptions = Map.findWithDefault [] name options }) - pure (p:ps, (rawLoc, complLoc):completed) + completed' = if toRawPLI complLoc == rawLoc + then completed + else (rawLoc, complLoc):completed + pure (p:ps, completed') (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers @@ -1220,54 +1201,6 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro pure (allPackages, reverse revCompleted, unused) --- helper data type for reading only parent snapshot locaitons -newtype RawSnapshotLayerParent = RawSnapshotLayerParent RawSnapshotLocation - -instance Yaml.FromJSON (Unresolved RawSnapshotLayerParent) where - parseJSON = Yaml.withObject "Snapshot" $ \o -> do - mcompiler <- o Yaml..:? "compiler" - mresolver <- unWarningParser $ o ...:? ["snapshot", "resolver"] - unresolvedSnapshotParent <- - case (mcompiler, mresolver) of - (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" - (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler) - (_, Just (WithJSONWarnings (Unresolved usl) _)) -> pure $ Unresolved $ \mdir -> do - sl <- usl mdir - case (sl, mcompiler) of - (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 - _ -> pure sl - - pure $ RawSnapshotLayerParent <$> unresolvedSnapshotParent - -loadRawSnapshotLayerParent - :: (HasPantryConfig env, HasLogFunc env) - => RawSnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayerParent, CompletedSL)) -loadRawSnapshotLayerParent (RSLCompiler compiler) = pure $ Left compiler -loadRawSnapshotLayerParent sl@(RSLUrl url blob) = - handleAny (throwIO . InvalidSnapshot sl) $ do - bs <- loadFromURL url blob - value <- Yaml.decodeThrow bs - lparent <- parserHelperLayerParent sl value Nothing - pure $ Right (lparent, (sl, SLUrl url (bsToBlobKey bs))) -loadRawSnapshotLayerParent sl@(RSLFilePath fp) = - handleAny (throwIO . InvalidSnapshot sl) $ do - value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - lparent <- parserHelperLayerParent sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (lparent, (sl, SLFilePath fp)) - -parserHelperLayerParent - :: HasLogFunc env - => RawSnapshotLocation - -> Value - -> Maybe (Path Abs Dir) - -> RIO env RawSnapshotLayerParent -parserHelperLayerParent rsl val mdir = - case parseEither Yaml.parseJSON val of - Left e -> throwIO $ Couldn'tParseSnapshot rsl e - Right x -> do - resolvePaths mdir x - -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- -- Returns a 'Left' value if provided an 'SLCompiler' @@ -1278,19 +1211,19 @@ parserHelperLayerParent rsl val mdir = loadRawSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) + -> RIO env (Either WantedCompiler RawSnapshotLayer) loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler loadRawSnapshotLayer sl@(RSLUrl url blob) = handleAny (throwIO . InvalidSnapshot sl) $ do bs <- loadFromURL url blob value <- Yaml.decodeThrow bs snapshot <- warningsParserHelperRaw sl value Nothing - pure $ Right (snapshot, (sl, SLUrl url (bsToBlobKey bs))) + pure $ Right snapshot loadRawSnapshotLayer sl@(RSLFilePath fp) = handleAny (throwIO . InvalidSnapshot sl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelperRaw sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, (sl, SLFilePath fp)) + pure $ Right snapshot -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- diff --git a/subs/pantry/src/Pantry/Internal.hs b/subs/pantry/src/Pantry/Internal.hs index 1423dee364..be603a94f9 100644 --- a/subs/pantry/src/Pantry/Internal.hs +++ b/subs/pantry/src/Pantry/Internal.hs @@ -9,7 +9,6 @@ module Pantry.Internal , pcHpackExecutable , normalizeParents , makeTarRelative - , Unresolved (..) ) where import Control.Exception (assert) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 0b2148e050..c2c548e0dc 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -44,7 +44,7 @@ module Pantry.Types , renderTree , parseTree , SHA256 - , Unresolved (..) + , Unresolved , resolvePaths , Package (..) , PackageCabal (..) @@ -294,7 +294,7 @@ instance NFData (ResolvedPath t) data RawPackageLocation = RPLImmutable !RawPackageLocationImmutable | RPLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Generic) instance NFData RawPackageLocation -- | Location to load a package from. Can either be immutable (see @@ -305,17 +305,13 @@ instance NFData RawPackageLocation data PackageLocation = PLImmutable !PackageLocationImmutable | PLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Generic) instance NFData PackageLocation instance Display PackageLocation where display (PLImmutable loc) = display loc display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp -instance ToJSON PackageLocation where - toJSON (PLImmutable pli) = toJSON pli - toJSON (PLMutable resolved) = toJSON (resolvedRelative resolved) - -- | Convert `PackageLocation` to its "raw" equivalent -- -- @since 0.1.0.0 From 90dc3c55431c2c609d369a238749102c307abe0b Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 11:36:47 +0300 Subject: [PATCH 06/12] Fix freeze test (publish-date field was added to snapshots) --- test/integration/tests/4220-freeze-command/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/integration/tests/4220-freeze-command/Main.hs b/test/integration/tests/4220-freeze-command/Main.hs index 15c79d0ab6..cac220e80a 100644 --- a/test/integration/tests/4220-freeze-command/Main.hs +++ b/test/integration/tests/4220-freeze-command/Main.hs @@ -9,9 +9,9 @@ main = do stackCheckStdout ["freeze"] $ \stdOut -> do let contents = fromList [ "resolver:", - "size: 527165", + "size: 527200", "url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/19.yaml", - "sha256: 0116ad1779b20ad2c9d6620f172531f13b12bb69867e78f4277157e28865dfd4", + "sha256: 16758b43c10c731bc142fdc5c005795db8338d7b4a28cd0af6730d739af2b306", "extra-deps:", "pantry-tree:", "hackage: a50-0.5@sha256:b8dfcc13dcbb12e444128bb0e17527a2a7a9bd74ca9450d6f6862c4b394ac054,1491", From 4f28d663d4f81098f4d41082e015fc3d7d746812 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 13:03:18 +0300 Subject: [PATCH 07/12] Don't symlink stack.yaml so lock files won't pollute src dir --- test/integration/IntegrationSpec.hs | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/test/integration/IntegrationSpec.hs b/test/integration/IntegrationSpec.hs index 786a3af8bf..c1ac7ed934 100644 --- a/test/integration/IntegrationSpec.hs +++ b/test/integration/IntegrationSpec.hs @@ -238,8 +238,15 @@ copyTree src dst = Just suffix <- return $ stripPrefix src srcfp let dstfp = dst stripHeadSeparator suffix createDirectoryIfMissing True $ takeDirectory dstfp - createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) -> - copyFile srcfp dstfp -- for Windows + -- copying yaml files so lock files won't get created in + -- the source directory + if takeFileName srcfp /= "package.yaml" && + (takeExtensions srcfp == ".yaml" || takeExtensions srcfp == ".yml") + then + copyFile srcfp dstfp + else + createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) -> + copyFile srcfp dstfp -- for Windows stripHeadSeparator :: FilePath -> FilePath stripHeadSeparator [] = [] From 9b5a2d3e5237552049ee1517945b7b423259d05a Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 15:22:37 +0300 Subject: [PATCH 08/12] Add not only package but also snapshot location cache in lock files --- src/Stack/Freeze.hs | 2 +- src/Stack/Lock.hs | 87 +++++++++++++++++++----------- src/Stack/SourceMap.hs | 2 +- src/test/Stack/LockSpec.hs | 96 +++++++++++++++------------------ subs/curator/app/Main.hs | 5 +- subs/pantry/src/Pantry.hs | 63 ++++++++++++---------- subs/pantry/src/Pantry/Types.hs | 21 ++++++++ 7 files changed, 159 insertions(+), 117 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index c751b3145d..77fa033a0c 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -69,7 +69,7 @@ doFreeze p FreezeSnapshot = do case result of Left _wc -> logInfo "No freezing is required for compiler resolver" - Right (snap, _) -> do + Right snap -> do snap' <- completeSnapshotLayer snap let rawCompleted = toRawSnapshotLayer snap' if rawCompleted == snap diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 91cc5bc319..bb9709a82d 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Stack.Lock ( lockCachedWanted @@ -23,21 +24,24 @@ import Stack.SourceMap import Stack.Types.Config import Stack.Types.SourceMap -data LockedLocation = - LockedLocation RawPackageLocationImmutable - PackageLocationImmutable - deriving (Show, Eq) +data LockedLocation a b = LockedLocation + { llOriginal :: a + , llCompleted :: b + } deriving (Eq, Show) -instance ToJSON LockedLocation where - toJSON (LockedLocation o c) = - object [ "original" .= o, "completed" .= c ] +instance (ToJSON a, ToJSON b) => ToJSON (LockedLocation a b) where + toJSON ll = + object [ "original" .= llOriginal ll, "completed" .= llCompleted ll ] -instance FromJSON (WithJSONWarnings (Unresolved LockedLocation)) where +instance ( FromJSON (WithJSONWarnings (Unresolved a)) + , FromJSON (WithJSONWarnings (Unresolved b)) + ) => + FromJSON (WithJSONWarnings (Unresolved (LockedLocation a b))) where parseJSON = withObjectWarnings "LockedLocation" $ \o -> do original <- jsonSubWarnings $ o ..: "original" completed <- jsonSubWarnings $ o ..: "completed" - pure $ (\single c -> LockedLocation (unSingleRPLI single) c) <$> original <*> completed + pure $ LockedLocation <$> original <*> completed -- Special wrapper extracting only 1 RawPackageLocationImmutable -- serialization should not produce locations with multiple subdirs @@ -51,21 +55,35 @@ instance FromJSON (WithJSONWarnings (Unresolved SingleRPLI)) where let withWarnings x = WithJSONWarnings x ws pure $ withWarnings $ SingleRPLI . NE.head <$> unresolvedRPLIs -newtype Locked = Locked [LockedLocation] +data Locked = Locked + { lckSnapshotLocaitons :: [LockedLocation RawSnapshotLocation SnapshotLocation] + , lckPkgImmutableLocations :: [LockedLocation RawPackageLocationImmutable PackageLocationImmutable] + } deriving (Eq, Show) -instance FromJSON (Unresolved Locked) where - parseJSON v = do - locs <- unWarningParser $ jsonSubWarningsT (lift $ parseJSON v) - pure $ Locked <$> sequenceA locs +instance ToJSON Locked where + toJSON Locked {..} = + object + [ "snapshots" .= lckSnapshotLocaitons + , "packages" .= lckPkgImmutableLocations + ] + +instance FromJSON (WithJSONWarnings (Unresolved Locked)) where + parseJSON = withObjectWarnings "Locked" $ \o -> do + snapshots <- jsonSubWarningsT $ o ..: "snapshots" + packages <- jsonSubWarningsT $ o ..: "packages" + let unwrap ll = ll { llOriginal = unSingleRPLI (llOriginal ll) } + pure $ Locked <$> sequenceA snapshots <*> (map unwrap <$> sequenceA packages) loadYamlThrow :: HasLogFunc env - => (Value -> Yaml.Parser a) -> Path Abs File -> RIO env a + => (Value -> Yaml.Parser (WithJSONWarnings a)) -> Path Abs File -> RIO env a loadYamlThrow parser path = do val <- liftIO $ Yaml.decodeFileThrow (toFilePath path) case Yaml.parseEither parser val of Left err -> throwIO $ Yaml.AesonException err - Right res -> return res + Right (WithJSONWarnings res warnings) -> do + logJSONWarnings (toFilePath path) warnings + return res lockCachedWanted :: (HasPantryConfig env, HasProcessContext env, HasLogFunc env) @@ -79,22 +97,29 @@ lockCachedWanted :: lockCachedWanted stackFile resolver fillWanted = do lockFile <- liftIO $ addFileExtension "lock" stackFile lockExists <- doesFileExist lockFile - pkgLocCache <- if not lockExists - then do - logDebug "Lock file doesn't exist" - pure Map.empty - else do - logDebug "Using package location completions from a lock file" - unresolvedLocked <- loadYamlThrow parseJSON lockFile - Locked locked0 <- resolvePaths (Just $ parent stackFile) unresolvedLocked - pure $ Map.fromList [(orig, compl) | LockedLocation orig compl <- locked0] - - (snap, completed) <- - loadAndCompleteSnapshotRaw resolver pkgLocCache + locked <- + if not lockExists + 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 + let toMap :: Ord a => [LockedLocation a b] -> Map a b + toMap = Map.fromList . map (\ll -> (llOriginal ll, llCompleted ll)) + slocCache = toMap $ lckSnapshotLocaitons locked + pkgLocCache = toMap $ lckPkgImmutableLocations locked + (snap, slocCompleted, pliCompleted) <- + loadAndCompleteSnapshotRaw resolver slocCache pkgLocCache let compiler = snapshotCompiler snap snPkgs = Map.mapWithKey (\n p h -> snapToDepPackage h n p) (snapshotPackages snap) (wanted, prjCompleted) <- fillWanted Map.empty compiler snPkgs - liftIO $ Yaml.encodeFile (toFilePath lockFile) $ - map (uncurry LockedLocation) $ - prjCompleted <> completed + let lockLocations = map (uncurry LockedLocation) + newLocked = Locked { lckSnapshotLocaitons = lockLocations slocCompleted + , lckPkgImmutableLocations = + lockLocations $ pliCompleted <> prjCompleted + } + when (newLocked /= locked) $ + liftIO $ Yaml.encodeFile (toFilePath lockFile) newLocked pure wanted diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index 54f1107b71..6e8070e219 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -262,7 +262,7 @@ loadProjectSnapshotCandidate :: -> Bool -> RIO env (SnapshotCandidate env) loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do - (snapshot, _) <- loadAndCompleteSnapshotRaw loc Map.empty + (snapshot, _, _) <- loadAndCompleteSnapshotRaw loc Map.empty Map.empty deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot) let wc = snapshotCompiler snapshot globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index aa67d58dcf..3d15829987 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -4,6 +4,7 @@ module Stack.LockSpec where +import Data.Aeson.Extended (WithJSONWarnings(..)) import Data.ByteString (ByteString) import qualified Data.Yaml as Yaml import Distribution.Types.PackageName (mkPackageName) @@ -29,24 +30,60 @@ decodeLocked bs = do val <- Yaml.decodeThrow bs case Yaml.parseEither Yaml.parseJSON val of Left err -> throwIO $ Yaml.AesonException err - Right res -> do + Right (WithJSONWarnings res warnings) -> do + unless (null warnings) $ + throwIO $ Yaml.AesonException $ "Unexpected warnings: " ++ show warnings -- we just assume no file references resolvePaths Nothing res spec :: Spec spec = do - it "parses lock file (empty)" $ do + it "parses lock file (empty with GHC resolver)" $ do let lockFile :: ByteString lockFile = [r|#some -[] +snapshots: +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +packages: [] |] - Locked pkgImm <- decodeLocked lockFile + pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile pkgImm `shouldBe` [] - it "parses lock file (wai + warp)" $ do + it "parses lock file (empty with LTS resolver)" $ do let lockFile :: ByteString lockFile = [r|#some +snapshots: +- completed: + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +packages: [] +|] + pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile + pkgImm `shouldBe` [] + it "parses lock file (LTS, wai + warp)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +snapshots: +- completed: + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + original: lts-11.22 +- completed: + compiler: ghc-8.2.2 + original: + compiler: ghc-8.2.2 +packages: - original: subdir: wai git: https://github.com/yesodweb/wai.git @@ -80,7 +117,7 @@ spec = do sha256: f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 |] - Locked pkgImm <- decodeLocked lockFile + pkgImm <- lckPkgImmutableLocations <$> decodeLocked lockFile let waiSubdirRepo subdir = Repo { repoType = RepoGit , repoUrl = "https://github.com/yesodweb/wai.git" @@ -133,50 +170,3 @@ spec = do 10725 })) ] - it "parses snapshot lock file (non empty)" $ do - let lockFile :: ByteString - lockFile = - [r|#some -- original: - hackage: string-quote-0.0.1 - completed: - hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 - pantry-tree: - size: 273 - sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f -|] - Locked pkgImm <- decodeLocked lockFile - pkgImm `shouldBe` - [ LockedLocation - (RPLIHackage - (PackageIdentifierRevision - (mkPackageName "string-quote") - (mkVersion [0, 0, 1]) - CFILatest) - Nothing) - (PLIHackage - (PackageIdentifier - { pkgName = mkPackageName "string-quote" - , pkgVersion = mkVersion [0, 0, 1] - }) - (toBlobKey - "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" - 758) - (TreeKey - (BlobKey - (decodeSHA - "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") - (FileSize 273))) - ) - ] - --- ---lockedPackageWithLocations :: RawPackageLocationImmutable -> PackageLocationImmutable -> LockedPackage ---lockedPackageWithLocations rpli pli = --- LockedPackage{ lpLocation = LockedLocation rpli pli --- , lpFlags = mempty --- , lpGhcOptions = mempty --- , lpFromSnapshot = FromSnapshot --- , lpHidden = False --- } --- diff --git a/subs/curator/app/Main.hs b/subs/curator/app/Main.hs index ebf473fb28..9db9561e1f 100644 --- a/subs/curator/app/Main.hs +++ b/subs/curator/app/Main.hs @@ -158,7 +158,8 @@ loadSnapshotYaml = do abs' <- resolveFile' snapshotFilename let sloc = SLFilePath $ ResolvedPath (RelFilePath (fromString snapshotFilename)) abs' - fmap fst $ loadAndCompleteSnapshot sloc Map.empty + (snap, _, _) <- loadAndCompleteSnapshot sloc Map.empty Map.empty + pure snap checkSnapshot :: RIO PantryApp () checkSnapshot = do @@ -220,4 +221,4 @@ loadPantrySnapshotLayerFile fp = do eres <- loadSnapshotLayer $ SLFilePath (ResolvedPath (RelFilePath (fromString fp)) abs') case eres of Left x -> error $ "should not happen: " ++ show (fp, x) - Right (x, _) -> pure x + Right x -> pure x diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 116f22a2ec..94087594c5 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -171,6 +171,7 @@ module Pantry import RIO import Conduit +import Control.Arrow (right) import Control.Monad.State.Strict (State, execState, get, modify') import qualified RIO.Map as Map import qualified RIO.Set as Set @@ -908,7 +909,7 @@ loadSnapshotRaw loc = do , rsPackages = mempty , rsDrop = mempty } - Right rsl -> do + Right (rsl, _) -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot @@ -944,7 +945,7 @@ loadSnapshot loc = do , rsPackages = mempty , rsDrop = mempty } - Right (rsl, _sha) -> do + Right rsl -> do snap0 <- loadSnapshotRaw $ rslParent rsl (packages, unused) <- addPackagesToSnapshot @@ -965,6 +966,7 @@ loadSnapshot loc = do } type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) +type CompletedSL = (RawSnapshotLocation, SnapshotLocation) -- | Parse a 'Snapshot' (all layers) from a 'SnapshotLocation' noting -- any incomplete package locations @@ -973,10 +975,11 @@ type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshot loc cachedPL = - loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshot loc cachedSL cachedPL = + loadAndCompleteSnapshotRaw (toRawSL loc) cachedSL cachedPL -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations @@ -985,10 +988,13 @@ loadAndCompleteSnapshot loc cachedPL = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation - -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshotRaw loc cachePL = do - eres <- loadRawSnapshotLayer loc + -> Map RawSnapshotLocation SnapshotLocation -- ^ Cached snapshot locations from lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached locations from lock file + -> RIO env (Snapshot, [CompletedSL], [CompletedPLI]) +loadAndCompleteSnapshotRaw rawLoc cacheSL cachePL = do + eres <- case Map.lookup rawLoc cacheSL of + Just loc -> right (\rsl -> (rsl, (rawLoc, loc))) <$> loadSnapshotLayer loc + Nothing -> loadRawSnapshotLayer rawLoc case eres of Left wc -> let snapshot = Snapshot @@ -996,12 +1002,12 @@ loadAndCompleteSnapshotRaw loc cachePL = do , snapshotPackages = mempty , snapshotDrop = mempty } - in pure (snapshot, []) - Right rsl -> do - (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL + in pure (snapshot, [(RSLCompiler wc, SLCompiler wc)], []) + Right (rsl, sloc) -> do + (snap0, slocs, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cacheSL cachePL (packages, completed, unused) <- addAndCompletePackagesToSnapshot - loc + rawLoc cachePL (rslLocations rsl) AddPackagesConfig @@ -1011,13 +1017,13 @@ loadAndCompleteSnapshotRaw loc cachePL = do , apcGhcOptions = rslGhcOptions rsl } (snapshotPackages snap0) - warnUnusedAddPackagesConfig (display loc) unused + warnUnusedAddPackagesConfig (display rawLoc) unused let snapshot = Snapshot { snapshotCompiler = fromMaybe (snapshotCompiler snap0) (rslCompiler rsl) , snapshotPackages = packages , snapshotDrop = apcDrop unused } - return (snapshot, completed0 ++ completed) + return (snapshot, sloc : slocs,completed0 ++ completed) data SingleOrNot a = Single !a @@ -1217,19 +1223,19 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro loadRawSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => RawSnapshotLocation - -> RIO env (Either WantedCompiler RawSnapshotLayer) + -> RIO env (Either WantedCompiler (RawSnapshotLayer, CompletedSL)) loadRawSnapshotLayer (RSLCompiler compiler) = pure $ Left compiler -loadRawSnapshotLayer sl@(RSLUrl url blob) = - handleAny (throwIO . InvalidSnapshot sl) $ do +loadRawSnapshotLayer rsl@(RSLUrl url blob) = + handleAny (throwIO . InvalidSnapshot rsl) $ do bs <- loadFromURL url blob value <- Yaml.decodeThrow bs - snapshot <- warningsParserHelperRaw sl value Nothing - pure $ Right snapshot -loadRawSnapshotLayer sl@(RSLFilePath fp) = - handleAny (throwIO . InvalidSnapshot sl) $ do + snapshot <- warningsParserHelperRaw rsl value Nothing + pure $ Right (snapshot, (rsl, SLUrl url (bsToBlobKey bs))) +loadRawSnapshotLayer rsl@(RSLFilePath fp) = + handleAny (throwIO . InvalidSnapshot rsl) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - snapshot <- warningsParserHelperRaw sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right snapshot + snapshot <- warningsParserHelperRaw rsl value $ Just $ parent $ resolvedAbsolute fp + pure $ Right (snapshot, (rsl, SLFilePath fp)) -- | Parse a 'SnapshotLayer' value from a 'SnapshotLocation'. -- @@ -1241,20 +1247,19 @@ loadRawSnapshotLayer sl@(RSLFilePath fp) = loadSnapshotLayer :: (HasPantryConfig env, HasLogFunc env) => SnapshotLocation - -> RIO env (Either WantedCompiler (RawSnapshotLayer, SHA256)) -- FIXME remove SHA? Be smart? + -> RIO env (Either WantedCompiler RawSnapshotLayer) loadSnapshotLayer (SLCompiler compiler) = pure $ Left compiler loadSnapshotLayer sl@(SLUrl url blob) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do bs <- loadFromURL url (Just blob) value <- Yaml.decodeThrow bs snapshot <- warningsParserHelper sl value Nothing - pure $ Right (snapshot, SHA256.hashBytes bs) + pure $ Right snapshot loadSnapshotLayer sl@(SLFilePath fp) = handleAny (throwIO . InvalidSnapshot (toRawSL sl)) $ do value <- Yaml.decodeFileThrow $ toFilePath $ resolvedAbsolute fp - sha <- SHA256.hashFile $ toFilePath $ resolvedAbsolute fp snapshot <- warningsParserHelper sl value $ Just $ parent $ resolvedAbsolute fp - pure $ Right (snapshot, sha) + pure $ Right snapshot loadFromURL :: (HasPantryConfig env, HasLogFunc env) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index dce0f40c5c..5c7f1b5e5e 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -2004,6 +2004,27 @@ instance NFData SnapshotLocation instance ToJSON SnapshotLocation where toJSON sl = toJSON (toRawSL sl) +instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where + parseJSON v = file v <|> url v <|> compiler v + where + file = withObjectWarnings "SLFilepath" $ \o -> do + ufp <- o ..: "filepath" + pure $ Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot ufp + Just dir -> do + absolute <- resolveFile dir (T.unpack ufp) + let fp = ResolvedPath (RelFilePath ufp) absolute + pure $ SLFilePath fp + url = withObjectWarnings "SLUrl" $ \o -> do + url' <- o ..: "url" + sha <- o ..: "sha256" + size <- o ..: "size" + pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) + compiler = withObjectWarnings "SLCompiler" $ \o -> do + c <- o ..: "compiler" + pure $ Unresolved $ \_ -> pure $ SLCompiler c + -- | Convert snapshot location to its "raw" equivalent. -- -- @since 0.1.0.0 From f20c46707afead28fcfd0a9dc83e6d23aea0da97 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 15:23:57 +0300 Subject: [PATCH 09/12] Update docs to new lock files design --- doc/lock_files.md | 99 ++++++++++------------------------------------- 1 file changed, 21 insertions(+), 78 deletions(-) diff --git a/doc/lock_files.md b/doc/lock_files.md index ff559ffc88..173c387aec 100644 --- a/doc/lock_files.md +++ b/doc/lock_files.md @@ -18,11 +18,12 @@ set of input files. There are a few problems with making this work: To address this, we follow the (fairly standard) approach of having a _lock file_. The goal of the lock file is to cache completed -information about all packages and snapshot files so that: +locations of project, snapshot packages and snapshots themselves so that: * These files can be stored in source control * Users on other machines can reuse these lock files and get identical - build plans + build plans given that the used local packages and local snapshots are + the same on those machines * Rerunning `stack build` in the future is deterministic in the build plan, not depending on mutable state in the world like Hackage revisions @@ -31,8 +32,6 @@ information about all packages and snapshot files so that: to perform the build. However, by deterministic, we mean it either performs the same build or fails, never accidentally doing something different. -* Stack can quickly determine the build plan in the common case of no - changes to `stack.yaml` or snapshot files This document explains the contents of a lock file, how they are used, and how they are created and updated. @@ -42,11 +41,7 @@ and how they are created and updated. Relevant to this discussion, the `stack.yaml` file specifies: * Resolver (the parent snapshot) -* Compiler override * `extra-deps` -* Flags -* GHC options -* Hidden packages The resolver can either specify a compiler version or another snapshot file. This snapshot file can contain the same information referenced @@ -55,12 +50,7 @@ above for a `stack.yaml`, with the following differences: * The `extra-deps` are called `packages` * Drop packages can be included -Some of this information is, by its nature, complete. For example, the -"flags" field cannot be influenced by anything outside of the file -itself. - -On the other hand, some information in these files can be -incomplete. Consider: +Some information in these files can be incomplete. Consider: ```yaml resolver: lts-13.9 @@ -128,24 +118,16 @@ parsing of the additional files in the common case of no changes. The lock file contains the following information: -* The full snapshot definition information, including completed - package locations for both `extra-deps` and packages in +* Completed package locations for both `extra-deps` and packages in snapshot files * **NOTE** This only applies to _immutable_ packages. Mutable packages are not included in the lock file. * Completed information for the snapshot locations -* A hash of the `stack.yaml` file -* The snapshot hash, to bypass the need to recalculate this on each - run of Stack It looks like the following: ```yaml # Lock file, some message about the file being auto-generated -stack-yaml: - sha256: XXXX - size: XXXX # in bytes - snapshots: # Starts with the snapshot specified in stack.yaml, # then continues with the snapshot specified in each @@ -163,33 +145,22 @@ snapshots: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/9.yaml sha256: 83de9017d911cf7795f19353dba4d04bd24cd40622b7567ff61fc3f7223aa3ea -compiler: ghc-X.Y.Z - packages: - acme-missiles: - location: - # QUESTION: any reason we need to specify which snapshot file it came from? I don't think so... - original: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz - completed: - size: 1442 - url: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz - cabal-file: - size: 613 - sha256: 2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 - name: acme-missiles - version: '0.3' - sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b - pantry-tree: - size: 226 - sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033 - flags: ... - hidden: true/false - ghc-options: [...] +- original: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz + completed: + size: 1442 + url: https://hackage.haskell.org/package/acme-missiles-0.3.tar.gz + cabal-file: + size: 613 + sha256: 2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 + name: acme-missiles + version: '0.3' + sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b + pantry-tree: + size: 226 + sha256: 614bc0cca76937507ea0a5ccc17a504c997ce458d7f2f9e43b15a10c8eaeb033 ``` -**NOTE** The `original` fields may seem superfluous at first. See the -update procedure below for an explanation. - ## Creation Whenever a `stack.yaml` file is loaded, Stack checks for a lock file @@ -206,36 +177,8 @@ If the lock file does not exist, it will be created by: * Completing all missing information * Writing out the new `stack.yaml.lock` file -## Dirtiness checking - -If the `stack.yaml.lock` file exists, its last modification time is -compared against the last modification time of the `stack.yaml` file -and any local snapshot files. If any of those files is more recent -than the `stack.yaml.lock` file, and the file hashes in the lock file -do not match the files on the filesystem, then the update procedure is -triggered. Otherwise, the `stack.yaml.lock` file can be used as the -definition of the snapshot. - ## Update procedure -The simplest possible implementation is: ignore the lock file entirely -and create a new one followign the creation steps above. There's a -significant downside to this, however: it may cause a larger delta in -the lock file than intended, by causing more packages to be -updates. For example, many packages from Hackage may have their -Hackage revision information updated unnecessarily. - -The more complicated update procedure is described below. **QUESTION** -Do we want to go the easy way at first and later implement the more -complicated update procedure? - -1. Create a map from original package location to completed package - location in the lock file -2. Load up each snapshot file -3. For each incomplete package location: - * Lookup the value in the map created in (1) - * If present: use that completed information - * Otherwise: complete the information using the same completion - procedure from Pantry as in "creation" - -This should minimize the number of changes to packages incurred. +When loading a Stack project all completed package or snapshot locations +(even when they were completed using information from a lock file) get +collected to form a new lock file. From 47cf7da7a7f6dd89db9acbb07068d98314fbd3b2 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Mon, 29 Apr 2019 15:24:23 +0300 Subject: [PATCH 10/12] Lock files test --- test/integration/tests/lock-files/Main.hs | 17 +++++++++++++++++ test/integration/tests/lock-files/files/Lib.hs | 2 ++ .../tests/lock-files/files/package.yaml | 4 ++++ .../tests/lock-files/files/stack-1-extra | 3 +++ .../tests/lock-files/files/stack-2-extras | 4 ++++ 5 files changed, 30 insertions(+) create mode 100644 test/integration/tests/lock-files/Main.hs create mode 100644 test/integration/tests/lock-files/files/Lib.hs create mode 100644 test/integration/tests/lock-files/files/package.yaml create mode 100644 test/integration/tests/lock-files/files/stack-1-extra create mode 100644 test/integration/tests/lock-files/files/stack-2-extras diff --git a/test/integration/tests/lock-files/Main.hs b/test/integration/tests/lock-files/Main.hs new file mode 100644 index 0000000000..8f7c89700f --- /dev/null +++ b/test/integration/tests/lock-files/Main.hs @@ -0,0 +1,17 @@ +import Control.Monad (unless, when) +import Data.List (isInfixOf) +import StackTest +import System.Directory + +main :: IO () +main = do + copyFile "stack-2-extras" "stack.yaml" + stack ["build"] + lock1 <- readFile "stack.yaml.lock" + unless ("acme-dont" `isInfixOf` lock1) $ + error "Package acme-dont wasn't found in Stack lock file" + copyFile "stack-1-extra" "stack.yaml" + stack ["build"] + lock2 <- readFile "stack.yaml.lock" + when ("acme-dont" `isInfixOf` lock2) $ + error "Package acme-dont shouldn't be in Stack lock file anymore" diff --git a/test/integration/tests/lock-files/files/Lib.hs b/test/integration/tests/lock-files/files/Lib.hs new file mode 100644 index 0000000000..a3b82e6e83 --- /dev/null +++ b/test/integration/tests/lock-files/files/Lib.hs @@ -0,0 +1,2 @@ +foo :: Int +foo = 42 diff --git a/test/integration/tests/lock-files/files/package.yaml b/test/integration/tests/lock-files/files/package.yaml new file mode 100644 index 0000000000..36e02ec5e7 --- /dev/null +++ b/test/integration/tests/lock-files/files/package.yaml @@ -0,0 +1,4 @@ +name: example +library: + dependencies: + - base diff --git a/test/integration/tests/lock-files/files/stack-1-extra b/test/integration/tests/lock-files/files/stack-1-extra new file mode 100644 index 0000000000..94527115ec --- /dev/null +++ b/test/integration/tests/lock-files/files/stack-1-extra @@ -0,0 +1,3 @@ +resolver: lts-11.22 +extra-deps: +- acme-cuteboy-0.1.0.0 diff --git a/test/integration/tests/lock-files/files/stack-2-extras b/test/integration/tests/lock-files/files/stack-2-extras new file mode 100644 index 0000000000..5415f52ee4 --- /dev/null +++ b/test/integration/tests/lock-files/files/stack-2-extras @@ -0,0 +1,4 @@ +resolver: lts-11.22 +extra-deps: +- acme-cuteboy-0.1.0.0 +- acme-dont-1.1 From 7dc60018b02314a77d86b59491af4107e048d8b7 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 30 Apr 2019 09:28:43 +0300 Subject: [PATCH 11/12] Remove some unused imports --- subs/pantry/test/Pantry/TypesSpec.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 010049df5e..2de9e75ee0 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -12,11 +12,6 @@ module Pantry.TypesSpec import Data.Aeson.Extended import qualified Data.ByteString.Char8 as S8 -import qualified Data.List as List -import qualified Data.List.NonEmpty as NonEmpty -import Data.List.NonEmpty hiding (map) -import Data.Semigroup -import qualified Data.Vector as Vector import qualified Data.Yaml as Yaml import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) @@ -32,9 +27,7 @@ import Pantry.Internal , renderTree ) import qualified Pantry.SHA256 as SHA256 -import qualified Path as Path import RIO -import qualified RIO.HashMap as HM import qualified RIO.Text as T import Test.Hspec import Text.RawString.QQ From 43425d89c2a4e9956920ba99691f2596fa36eccc Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Tue, 30 Apr 2019 12:35:27 +0300 Subject: [PATCH 12/12] Minor doc fix --- doc/lock_files.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/lock_files.md b/doc/lock_files.md index 173c387aec..fee779ccd5 100644 --- a/doc/lock_files.md +++ b/doc/lock_files.md @@ -181,4 +181,5 @@ If the lock file does not exist, it will be created by: When loading a Stack project all completed package or snapshot locations (even when they were completed using information from a lock file) get -collected to form a new lock file. +collected to form a new lock file in memory and compare against the one +on disk, writing if there are any differences.