diff --git a/package.yaml b/package.yaml index 2d26fa2771..2b5b76b5ca 100644 --- a/package.yaml +++ b/package.yaml @@ -185,6 +185,7 @@ library: - Stack.Image - Stack.Init - Stack.Ls + - Stack.Lock - Stack.New - Stack.Nix - Stack.Options.BenchParser @@ -301,6 +302,7 @@ tests: - hspec - stack - smallcheck + - raw-strings-qq stack-integration-test: main: IntegrationSpec.hs source-dirs: diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 40133b50d6..87922e1356 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -92,7 +92,6 @@ build msetLocalFiles mbuildLk = do boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI baseConfigOpts <- mkBaseConfigOpts boptsCli plan <- constructPlan baseConfigOpts localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) - allowLocals <- view $ configL.to configAllowLocals unless allowLocals $ case justLocals plan of [] -> return () @@ -107,14 +106,11 @@ build msetLocalFiles mbuildLk = do (Just lk,True) -> do logDebug "All installs are local; releasing snapshot lock early." liftIO $ unlockFile lk _ -> return () - checkCabalVersion warnAboutSplitObjs bopts warnIfExecutablesWithSameNameCouldBeOverwritten locals plan - when (boptsPreFetch bopts) $ preFetch plan - if boptsCLIDryrun boptsCli then printPlan plan else executePlan boptsCli baseConfigOpts locals diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 9cc512ba94..6d4d55c7b1 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1016,6 +1016,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDe , line ] + extras :: Map PackageName (Version, BlobKey) extras = Map.unions $ map getExtras exceptions' getExtras DependencyCycleDetected{} = Map.empty getExtras UnknownPackage{} = Map.empty @@ -1028,9 +1029,8 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDe go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) = Map.singleton name (version, cabalHash) go _ = Map.empty - pprintExtra (name, (version, BlobKey cabalHash cabalSize)) = - let cfInfo = CFIHash cabalHash (Just cabalSize) - packageIdRev = PackageIdentifierRevision name version cfInfo + pprintExtra (name, (version, BlobKey _ _)) = + let packageIdRev = PackageIdentifierRevision name version CFILatest in fromString $ T.unpack $ utf8BuilderToText $ RIO.display packageIdRev allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 9bd6699130..4a9f841d68 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -87,6 +87,14 @@ import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) import RIO.PrettyPrint import RIO.Process +import Stack.Lock + ( LockFile(..) + , generatePackageLockFile + , generateSnapshotLayerLockFile + , isLockFileOutdated + , loadPackageLockFile + , loadSnapshotLayerLockFile + ) -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. @@ -513,6 +521,18 @@ loadConfig :: HasRunner env loadConfig configArgs mresolver mstackYaml inner = loadProjectConfig mstackYaml >>= \x -> loadConfigMaybeProject configArgs mresolver x inner +cachedCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => Map RawPackageLocation PackageLocation + -> RawPackageLocation + -> RIO env PackageLocation +cachedCompletePackageLocation cachePackages rp@(RPLImmutable rpli) = do + let item = Map.lookup rp cachePackages + case item of + Nothing -> do + pl <- completePackageLocation rpli + pure $ PLImmutable pl + Just pl -> pure pl +cachedCompletePackageLocation _ (RPLMutable rplm) = pure $ PLMutable rplm + -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. loadBuildConfig :: LocalConfigStatus (Project, Path Abs File, ConfigMonoid) @@ -587,8 +607,37 @@ loadBuildConfig mproject maresolver mcompiler = do { projectResolver = fromMaybe (projectResolver project') mresolver } - resolver <- completeSnapshotLocation $ projectResolver project - (snapshot, _completed) <- loadAndCompleteSnapshot resolver + lockFileOutdated <- isLockFileOutdated stackYamlFP + if lockFileOutdated + then do + logDebug "Lock file is outdated or isn't present" + generatePackageLockFile stackYamlFP + else logDebug "Lock file is upto date" + + lockFile <- liftIO $ addFileExtension "lock" stackYamlFP + (cachedPackageLock, origResolver, compResolver) <- liftIO $ do + lf <- loadPackageLockFile lockFile + return (lfPackageLocations lf, lfoResolver lf, lfcResolver lf) + + + resolver <- if projectResolver project == origResolver + then pure compResolver + else completeSnapshotLocation $ projectResolver project + + case resolver of + SLFilePath path -> do + outdated <- isLockFileOutdated (resolvedAbsolute path) + when outdated (generateSnapshotLayerLockFile resolver stackYamlFP) + _ -> return () + + cachedSnapshotLock <- case resolver of + SLFilePath path -> do + let sf = resolvedAbsolute path + slf <- liftIO $ addFileExtension "lock" sf + liftIO $ loadSnapshotLayerLockFile slf (parent stackYamlFP) + _ -> pure Map.empty + + (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedSnapshotLock extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) @@ -600,11 +649,8 @@ loadBuildConfig mproject maresolver mcompiler = 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 + pl <- cachedCompletePackageLocation cachedPackageLock rpl dp <- additionalDepPackage (shouldHaddockDeps bopts) pl pure (cpName $ dpCommon dp, dp) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 66c89df14c..c9b46069a9 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -1,20 +1,23 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Stack.Freeze ( freeze - , FreezeOpts (..) - , FreezeMode (..) + , FreezeOpts(..) + , FreezeMode(..) ) where -import Data.Aeson ((.=), object) +import Data.Aeson ((.=), object) import qualified Data.Yaml as Yaml -import RIO.Process import qualified RIO.ByteString as B -import Stack.Prelude -import Stack.Types.Config +import RIO.Process +import Stack.Prelude +import Stack.Types.Config -data FreezeMode = FreezeProject | FreezeSnapshot +data FreezeMode + = FreezeProject + | FreezeSnapshot newtype FreezeOpts = FreezeOpts { freezeMode :: FreezeMode @@ -22,56 +25,60 @@ newtype FreezeOpts = FreezeOpts freeze :: HasEnvConfig env => FreezeOpts -> RIO env () freeze (FreezeOpts mode) = do - mproject <- view $ configL.to configMaybeProject - case mproject of - Just (p, _) -> doFreeze p mode - Nothing -> logWarn "No project was found: nothing to freeze" + mproject <- view $ configL . to configMaybeProject + case mproject of + Just (p, _) -> doFreeze p mode + Nothing -> logWarn "No project was found: nothing to freeze" + +completeFullPackageLocation :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocation + -> RIO env PackageLocation +completeFullPackageLocation (RPLImmutable rpli) = do + pl <- completePackageLocation rpli + pure $ PLImmutable pl +completeFullPackageLocation (RPLMutable rplm) = pure $ PLMutable rplm doFreeze :: - (HasProcessContext env, HasLogFunc env, HasPantryConfig env) + ( HasProcessContext env + , HasLogFunc env + , HasPantryConfig env + , HasEnvConfig env + ) => Project -> FreezeMode -> RIO env () doFreeze p FreezeProject = do - let deps = projectDependencies p - resolver = projectResolver p - completePackageLocation' pl = - case pl of - RPLImmutable pli -> PLImmutable <$> completePackageLocation pli - RPLMutable m -> pure $ PLMutable m - resolver' <- completeSnapshotLocation resolver - deps' <- mapM completePackageLocation' deps - let rawCompleted = map toRawPL deps' - rawResolver = toRawSL resolver' - if rawCompleted == deps && rawResolver == resolver - then - logInfo "No freezing is required for this project" - else do - logInfo "# Fields not mentioned below do not need to be updated" - - if rawResolver == resolver - then logInfo "# No update to resolver is needed" - else do - logInfo "# Frozen version of resolver" - B.putStr $ Yaml.encode $ object ["resolver" .= rawResolver] - - if rawCompleted == deps - then logInfo "# No update to extra-deps is needed" - else do - logInfo "# Frozen version of extra-deps" - B.putStr $ Yaml.encode $ object ["extra-deps" .= rawCompleted] - + let deps :: [RawPackageLocation] = projectDependencies p + resolver :: RawSnapshotLocation = projectResolver p + resolver' :: SnapshotLocation <- completeSnapshotLocation resolver + deps' :: [PackageLocation] <- mapM completeFullPackageLocation deps + let rawCompleted = map toRawPL deps' + rawResolver = toRawSL resolver' + if rawCompleted == deps && rawResolver == resolver + then logInfo "No freezing is required for this project" + else do + logInfo "# Fields not mentioned below do not need to be updated" + if rawResolver == resolver + then logInfo "# No update to resolver is needed" + else do + logInfo "# Frozen version of resolver" + B.putStr $ Yaml.encode $ object ["resolver" .= rawResolver] + if rawCompleted == deps + then logInfo "# No update to extra-deps is needed" + else do + logInfo "# Frozen version of extra-deps" + B.putStr $ + Yaml.encode $ object ["extra-deps" .= rawCompleted] doFreeze p FreezeSnapshot = do - resolver <- completeSnapshotLocation $ projectResolver p - result <- loadSnapshotLayer resolver - case result of - Left _wc -> - logInfo "No freezing is required for compiler resolver" - Right (snap, _) -> do - snap' <- completeSnapshotLayer snap - let rawCompleted = toRawSnapshotLayer snap' - if rawCompleted == snap - then - logInfo "No freezing is required for the snapshot of this project" - else - liftIO $ B.putStr $ Yaml.encode snap' + resolver <- completeSnapshotLocation $ projectResolver p + result <- loadSnapshotLayer resolver + case result of + Left _wc -> logInfo "No freezing is required for compiler resolver" + Right (snap, _) -> do + snap' <- completeSnapshotLayer snap + let rawCompleted = toRawSnapshotLayer snap' + if rawCompleted == snap + then logInfo + "No freezing is required for the snapshot of this project" + else liftIO $ B.putStr $ Yaml.encode snap' diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs new file mode 100644 index 0000000000..64ec365bd0 --- /dev/null +++ b/src/Stack/Lock.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Stack.Lock where + +import Data.Aeson.Extended (unWarningParser) +import Data.List ((\\), intersect) +import qualified Data.List.NonEmpty as NE +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Vector as Vector +import qualified Data.Yaml as Yaml +import Data.Yaml +import Pantry + ( GitHubRepo(..) + , OptionalSubdirs(..) + , Unresolved(..) + , completePackageLocation + , osToRpms + , parseArchiveLocationObject + , parseArchiveLocationText + , parsePackageIdentifierRevision + , parseRawSnapshotLocation + , parseRawSnapshotLocationPath + , parseWantedCompiler + , rpmEmpty + ) +import Path (addFileExtension, fromAbsFile, parent) +import Path.IO (doesFileExist, getModificationTime, resolveDir, resolveFile) +import qualified RIO.ByteString as B +import qualified RIO.HashMap as HM +import RIO.Process +import qualified RIO.Text as T +import Stack.Prelude +import Stack.Types.Config + +data LockException + = LockNoProject + | LockCannotGenerate SnapshotLocation + deriving (Typeable) + +instance Exception LockException + +instance Show LockException where + show LockNoProject = "No project found for locking." + show (LockCannotGenerate e) = + "Lock file cannot be generated for snapshot: " <> show e + +-- You need to keep track of the following things +-- Has resolver changed. +-- * If yes, then to what value it has changed. Both from and to has to be printed. +-- Has extra-deps changed +-- * Can be (added/changed/removed). You need to indicate them. +-- * Keep track of lockfile package and current stack.yaml [RawPackageLocation] +data Change = Change + { chAdded :: ![RawPackageLocation] + , chRemoved :: ![RawPackageLocation] + , chUnchanged :: ![(RawPackageLocation, PackageLocation)] + } + +completeFullPackageLocation :: + (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocation + -> RIO env PackageLocation +completeFullPackageLocation (RPLImmutable rpli) = do + pl <- completePackageLocation rpli + pure $ PLImmutable pl +completeFullPackageLocation (RPLMutable rplm) = pure $ PLMutable rplm + +findChange :: + [(RawPackageLocation, PackageLocation)] -- ^ Lock file + -> [RawPackageLocation] -- ^ stack.yaml file + -> Change +findChange lrpl srpl = + let lr = map fst lrpl + unchangedOnes = intersect lr srpl + -- unchangedOnes contains the ones present in both the lock + -- file as well as stack.yaml file + unchangedFull :: [(RawPackageLocation, PackageLocation)] + unchangedFull = filter (\(rpl, _) -> rpl `elem` srpl) lrpl + -- unchangedFull is same as unchangedOnes + in Change + { chAdded = srpl \\ unchangedOnes + , chRemoved = lr \\ unchangedOnes + , chUnchanged = unchangedFull + } + +generatePackageLockFile :: Path Abs File -> RIO Config () +generatePackageLockFile stackFile = do + logDebug "Generating lock file" + mproject <- view $ configL . to configMaybeProject + p <- + case mproject of + Just (p, _) -> return p + Nothing -> throwM LockNoProject + let deps :: [RawPackageLocation] = projectDependencies p + resolver :: RawSnapshotLocation = projectResolver p + packageLockFile <- liftIO $ addFileExtension "lock" stackFile + packageLockFileExists <- liftIO $ doesFileExist packageLockFile + lockInfo :: Maybe LockFile <- + if packageLockFileExists + then liftIO $ do + lfio <- loadPackageLockFile packageLockFile + pure $ Just lfio + else pure Nothing + (deps', resolver') <- + case lockInfo of + Just lockData -> do + let change = + findChange + (Map.toList $ lfPackageLocations lockData) + deps + unchangedRes = map snd (chUnchanged change) + addedStr :: [Utf8Builder] = + map + (\x -> "Lock file package added: " <> display x) + (chAdded change) + deletedStr :: [Utf8Builder] = + map + (\x -> "Lock file package removed: " <> display x) + (chRemoved change) + mapM_ logDebug addedStr + mapM_ logDebug deletedStr + cdeps <- mapM completeFullPackageLocation (chAdded change) + let allDeps = unchangedRes <> cdeps + res <- + if lfoResolver lockData == resolver + then pure (lfcResolver lockData) + else completeSnapshotLocation resolver + pure (allDeps, res) + Nothing -> do + resolver' :: SnapshotLocation <- + completeSnapshotLocation resolver + deps' :: [PackageLocation] <- + mapM completeFullPackageLocation deps + pure (deps', resolver') + let deps'' = zip deps deps' + let depsObject = + Yaml.object + [ ( "resolver" + , object + [ ("original", Yaml.toJSON resolver) + , ("complete", Yaml.toJSON resolver') + ]) + , ( "dependencies" + , Yaml.array + (map (\(raw, comp) -> + object + [ ("original", Yaml.toJSON raw) + , ("complete", Yaml.toJSON comp) + ]) + deps'')) + ] + B.writeFile (fromAbsFile packageLockFile) (Yaml.encode depsObject) + +loadSnapshotFile :: + Path Abs File + -> Path Abs Dir + -> IO ([RawPackageLocationImmutable], RawSnapshotLocation) +loadSnapshotFile path rootDir = do + val <- Yaml.decodeFileThrow (toFilePath path) + case Yaml.parseEither (resolveSnapshotFile rootDir) val of + Left str -> fail $ "Cannot parse snapshot file: Got error " <> str + Right rplio -> rplio + +createSnapshotLayerLockFile :: + Path Abs File -- ^ Snapshot file + -> [RawPackageLocationImmutable] + -> RawSnapshotLocation + -> RIO Config () +createSnapshotLayerLockFile path rpli rpl = do + let rpli' :: [RawPackageLocation] = map RPLImmutable rpli + deps :: [PackageLocation] <- mapM completeFullPackageLocation rpli' + rpl' :: SnapshotLocation <- completeSnapshotLocation rpl + snapshotLockFile <- liftIO $ addFileExtension "lock" path + let depPairs :: [(PackageLocation, RawPackageLocation)] = zip deps rpli' + depsObject = + Yaml.object + [ ( "dependencies" + , Yaml.array + (map (\(comp, raw) -> + object + [ ("original", Yaml.toJSON raw) + , ("complete", Yaml.toJSON comp) + ]) + depPairs)) + , ( "resolver" + , object + [ ("original", Yaml.toJSON rpl) + , ("complete", Yaml.toJSON rpl') + ]) + ] + B.writeFile (fromAbsFile snapshotLockFile) (Yaml.encode depsObject) + +generateSnapshotLayerLockFile :: + SnapshotLocation -> Path Abs File -> RIO Config () +generateSnapshotLayerLockFile (SLFilePath path) stackFile = do + logInfo "Generating Lock file for custom snapshot" + let snapshotPath = resolvedAbsolute path + (rpli, rpl) <- liftIO $ loadSnapshotFile snapshotPath (parent stackFile) + createSnapshotLayerLockFile snapshotPath rpli rpl +generateSnapshotLayerLockFile xs _ = throwM (LockCannotGenerate xs) + +isLockFileOutdated :: Path Abs File -> RIO Config Bool +isLockFileOutdated stackFile = do + lockFile <- liftIO $ addFileExtension "lock" stackFile + smt <- liftIO $ getModificationTime stackFile + liftIO $ do + exists <- doesFileExist lockFile + if exists + then do + mt <- getModificationTime lockFile + pure $ smt > mt + else pure True + +parsePackageLockFile :: Path Abs Dir -> Value -> Parser (IO LockFile) +parsePackageLockFile rootDir value = + withObject + "LockFile" + (\obj -> do + vals :: Value <- obj .: "dependencies" + xs :: Vector (Unresolved (RawPackageLocation, PackageLocation)) <- + withArray + "LockFileArray" + (\vec -> sequence $ Vector.map parseSingleObject vec) + vals + resolver <- obj .: "resolver" + roriginal <- resolver .: "original" + rcomplete <- resolver .: "complete" + ro <- parseRSL roriginal + rc <- parseSL rcomplete + let rpaths = resolvePaths (Just rootDir) + pure $ do + lfpls <- rpaths $ sequence $ Vector.toList xs + lfor <- rpaths ro + lfcr <- rpaths rc + pure $ + LockFile + { lfPackageLocations = Map.fromList lfpls + , lfoResolver = lfor + , lfcResolver = lfcr + }) + value + +loadPackageLockFile :: Path Abs File -> IO LockFile +loadPackageLockFile lockFile = do + val <- Yaml.decodeFileThrow (toFilePath lockFile) + case Yaml.parseEither (parsePackageLockFile (parent lockFile)) val of + Left str -> fail $ "Cannot parse package lock file: Got error " <> str + Right lockFileIO -> lockFileIO + +data LockFile = LockFile + { lfPackageLocations :: !(Map RawPackageLocation PackageLocation) + , lfoResolver :: !RawSnapshotLocation + , lfcResolver :: !SnapshotLocation + } + +combineUnresolved :: Unresolved a -> Unresolved b -> Unresolved (a, b) +combineUnresolved a b = do + ua <- a + ub <- b + pure (ua, ub) + +parseRPLImmutable :: Value -> Parser (Unresolved RawPackageLocation) +parseRPLImmutable v = do + xs :: Unresolved RawPackageLocationImmutable <- parseRPLI v + pure $ RPLImmutable <$> xs + +parseResolvedPath :: Value -> Parser (Unresolved RawPackageLocation) +parseResolvedPath value = mkMutable <$> parseJSON value + where + mkMutable :: Text -> Unresolved RawPackageLocation + mkMutable t = + Unresolved $ \mdir -> do + case mdir of + Nothing -> throwIO $ MutablePackageLocationFromUrl t + Just dir -> do + abs' <- resolveDir dir $ T.unpack t + pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' + +parseRPL :: Value -> Parser (Unresolved RawPackageLocation) +parseRPL v = parseRPLImmutable v <|> parseResolvedPath v + +parsePImmutable :: Value -> Parser (Unresolved PackageLocation) +parsePImmutable v = do + xs :: Unresolved PackageLocationImmutable <- parseJSON v + pure $ PLImmutable <$> xs + +parseSingleObject :: + Value -> Parser (Unresolved (RawPackageLocation, PackageLocation)) +parseSingleObject value = + withObject + "LockFile" + (\obj -> do + original <- obj .: "original" + complete <- obj .: "complete" + orig <- parseRPL original + comp <- parsePImmutable complete + pure $ combineUnresolved orig comp) + value + +parseSnapshotLocationPath :: Text -> Unresolved SnapshotLocation +parseSnapshotLocationPath t = + Unresolved $ \mdir -> + case mdir of + Nothing -> throwIO $ InvalidFilePathSnapshot t + Just dir -> do + abs' <- + resolveFile dir (T.unpack t) `catchAny` \_ -> + throwIO (InvalidSnapshotLocation dir t) + pure $ SLFilePath $ ResolvedPath (RelFilePath t) abs' + +parseSLObject :: Value -> Parser (Unresolved SnapshotLocation) +parseSLObject = + withObject "UnresolvedSnapshotLocation (Object)" $ \o -> + (pure . SLCompiler <$> o .: "compiler") <|> + ((\x y -> pure $ SLUrl x y) <$> o .: "url" <*> parseJSON (Object o)) <|> + (parseSnapshotLocationPath <$> o .: "filepath") + +parseSnapshotLocation :: Value -> Parser (Unresolved SnapshotLocation) +parseSnapshotLocation = + withObject + "UnresolvedSnapshotLocation" + (\o -> do + url <- o .: "url" + bkey <- parseJSON (Object o) + pure $ pure $ SLUrl url bkey) + +parseSL :: Value -> Parser (Unresolved SnapshotLocation) +parseSL v = txtParser v <|> parseSLObject v + where + txt :: Text -> Maybe (Unresolved SnapshotLocation) + txt t = + either + (const Nothing) + (Just . pure . SLCompiler) + (parseWantedCompiler t) + txtParser = + withText + "UnresolvedSnapshotLocation (Text)" + (\t -> pure $ fromMaybe (parseSnapshotLocationPath t) (txt t)) + +parseBlobKey :: Object -> Parser (Maybe BlobKey) +parseBlobKey o = do + msha <- o .:? "sha256" + msize <- o .:? "size" + case (msha, msize) of + (Nothing, Nothing) -> pure Nothing + (Just sha, Just size') -> pure $ Just $ BlobKey sha size' + (Just _sha, Nothing) -> fail "You must also specify the file size" + (Nothing, Just _) -> fail "You must also specify the file's SHA256" + +parseRSLObject :: Value -> Parser (Unresolved RawSnapshotLocation) +parseRSLObject = + withObject "UnresolvedRawSnapshotLocation (Object)" $ \o -> + (pure . RSLCompiler <$> o .: "compiler") <|> + ((\x y -> pure $ RSLUrl x y) <$> o .: "url" <*> parseBlobKey o) <|> + (parseRawSnapshotLocationPath <$> o .: "filepath") + +parseRSL :: Value -> Parser (Unresolved RawSnapshotLocation) +parseRSL v = txtParser v <|> parseRSLObject v + where + txtParser = + withText + "UnresolvedSnapshotLocation (Text)" + (pure . parseRawSnapshotLocation) + +parseSnapshotFile :: + Value + -> Parser (Unresolved ([RawPackageLocationImmutable], RawSnapshotLocation)) +parseSnapshotFile (Object obj) = do + packages <- obj .: "packages" + resolver <- obj .: "resolver" + xs <- + withArray + "SnapshotFileArray" + (\vec -> sequence $ Vector.map parseRPLI vec) + packages + resolver' <- parseRSL resolver + pure $ combineUnresolved (sequence $ Vector.toList xs) resolver' +parseSnapshotFile val = fail $ "Expected Object, but got: " <> show val + +resolveSnapshotFile :: + Path Abs Dir + -> Value + -> Parser (IO ([RawPackageLocationImmutable], RawSnapshotLocation)) +resolveSnapshotFile rootDir val = do + unrpl <- parseSnapshotFile val + let pkgLoc = resolvePaths (Just rootDir) unrpl + pure pkgLoc + +parseRPLHttpText :: Value -> Parser (Unresolved RawPackageLocationImmutable) +parseRPLHttpText = + withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> + case parseArchiveLocationText t of + Nothing -> fail $ "Invalid archive location: " ++ T.unpack t + Just (Unresolved mkArchiveLocation) -> + pure $ + Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + let raHash = Nothing + raSize = Nothing + raSubdir = T.empty + pure $ RPLIArchive RawArchive {..} rpmEmpty + +parseRPLHackageText :: Value -> Parser (Unresolved RawPackageLocationImmutable) +parseRPLHackageText = + withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> + case parsePackageIdentifierRevision t of + Left e -> fail $ show e + Right pir -> pure $ pure $ RPLIHackage pir Nothing + +parseRPLHackageObject :: + Value -> Parser (Unresolved RawPackageLocationImmutable) +parseRPLHackageObject = + withObject "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> + pure <$> (RPLIHackage <$> o .: "hackage" <*> o .:? "pantry-tree") + +optionalSubdirs' :: Object -> Parser OptionalSubdirs +optionalSubdirs' o = + case HM.lookup "subdirs" o -- if subdirs exists, it needs to be valid + of + Just v' -> do + subdirs <- parseJSON v' + case NE.nonEmpty subdirs of + Nothing -> fail "Invalid empty subdirs" + Just x -> pure $ OSSubdirs x + Nothing -> + OSPackageMetadata <$> o .:? "subdir" .!= T.empty <*> + (RawPackageMetadata <$> (fmap unCabalString <$> (o .:? "name")) <*> + (fmap unCabalString <$> (o .:? "version")) <*> + o .:? "pantry-tree" <*> + o .:? "cabal-file") + +parseRPLRepo :: Value -> Parser (Unresolved RawPackageLocationImmutable) +parseRPLRepo = + withObject "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do + (repoType, repoUrl) <- + ((RepoGit, ) <$> o .: "git") <|> ((RepoHg, ) <$> o .: "hg") + repoCommit <- o .: "commit" + os <- optionalSubdirs' o + pure $ + pure $ + NE.head $ + NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) + +parseArchiveRPLObject :: + Value -> Parser (Unresolved RawPackageLocationImmutable) +parseArchiveRPLObject = + withObject "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do + Unresolved mkArchiveLocation <- + unWarningParser $ parseArchiveLocationObject o + raHash <- o .:? "sha256" + raSize <- o .:? "size" + os <- optionalSubdirs' o + pure $ + Unresolved $ \mdir -> do + raLocation <- mkArchiveLocation mdir + pure $ + NE.head $ + NE.map + (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) + (osToRpms os) + +parseGithubRPLObject :: Value -> Parser (Unresolved RawPackageLocationImmutable) +parseGithubRPLObject = + withObject "PLArchive:github" $ \o -> do + GitHubRepo ghRepo <- o .: "github" + commit <- o .: "commit" + let raLocation = + ALUrl $ + T.concat + [ "https://github.com/" + , ghRepo + , "/archive/" + , commit + , ".tar.gz" + ] + raSize <- o .:? "size" + raHash <- o .:? "sha256" + os <- optionalSubdirs' o + pure $ + pure $ + NE.head $ + NE.map + (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) + (osToRpms os) + +parseRPLI :: Value -> Parser (Unresolved RawPackageLocationImmutable) +parseRPLI v = + parseRPLHttpText v <|> parseRPLHackageText v <|> parseRPLHackageObject v <|> + parseRPLRepo v <|> + parseArchiveRPLObject v <|> + parseGithubRPLObject v + +parsePLI :: Value -> Parser (Unresolved PackageLocationImmutable) +parsePLI v = parseJSON v + +parseImmutableObject :: + Value + -> Parser (Unresolved ( RawPackageLocationImmutable + , PackageLocationImmutable)) +parseImmutableObject value = + withObject + "LockFile" + (\obj -> do + original <- obj .: "original" + complete <- obj .: "complete" + orig <- parseRPLI original + comp <- parsePLI complete + pure $ combineUnresolved orig comp) + value + +parseSnapshotLayerLockFile :: + Value + -> Parser (Unresolved [( RawPackageLocationImmutable + , PackageLocationImmutable)]) +parseSnapshotLayerLockFile = + withObject + "SnapshotLayerLockFile" + (\obj -> do + vals <- obj .: "dependencies" + xs <- + withArray + "SnapshotLayerLockArray" + (\vec -> sequence $ Vector.map parseImmutableObject vec) + vals + pure $ sequence $ Vector.toList xs) + +resolveSnapshotLayerLockFile :: + Path Abs Dir + -> Value + -> Parser (IO (Map RawPackageLocationImmutable PackageLocationImmutable)) +resolveSnapshotLayerLockFile rootDir val = do + pkgs <- parseSnapshotLayerLockFile val + let pkgsLoc = resolvePaths (Just rootDir) pkgs + pure $ Map.fromList <$> pkgsLoc + +loadSnapshotLayerLockFile :: + Path Abs File + -> Path Abs Dir + -> IO (Map RawPackageLocationImmutable PackageLocationImmutable) +loadSnapshotLayerLockFile lockFile rootDir = do + val <- Yaml.decodeFileThrow (toFilePath lockFile) + case Yaml.parseEither (resolveSnapshotLayerLockFile rootDir) val of + Left str -> + fail $ + "Cannot parse snapshot lock file: Got error " <> str <> show val + Right lockFileIO -> lockFileIO diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index fb4da044d6..183dfdd517 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -224,7 +224,6 @@ import Stack.Types.Version import qualified System.FilePath as FilePath import System.PosixCompat.Types (UserID, GroupID, FileMode) import RIO.Process (ProcessContext, HasProcessContext (..), findExecutable) - -- Re-exports import Stack.Types.Config.Build as X @@ -1434,8 +1433,8 @@ data ProjectAndConfigMonoid parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)) parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do - packages <- o ..:? "packages" ..!= [RelFilePath "."] - deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] + (packages :: [RelFilePath]) <- o ..:? "packages" ..!= [RelFilePath "."] + (deps :: [Unresolved (NonEmpty RawPackageLocation)]) <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] flags' <- o ..:? "flags" ..!= mempty let flags = unCabalStringMap <$> unCabalStringMap (flags' :: Map (CabalString PackageName) (Map (CabalString FlagName) Bool)) diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs new file mode 100644 index 0000000000..2cdae5ec12 --- /dev/null +++ b/src/test/Stack/LockSpec.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.LockSpec where + +import Data.ByteString (ByteString) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import qualified Data.Yaml as Yaml +import Data.Yaml (Value) +import Distribution.Types.PackageName (mkPackageName) +import Distribution.Types.Version (mkVersion) +import Pantry +import qualified Pantry.SHA256 as SHA256 +import qualified Path.IO as Path +import Stack.Lock +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 + +spec :: Spec +spec = do + it "parses lock file (empty)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +dependencies: [] +resolver: + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/20.yaml + complete: + size: 508369 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/20.yaml + sha256: 7373bd6e5bb08955cb30bc98afe38a06eadc44706d20aff896fd0376ec0de619 +|] + rootDir <- Path.getHomeDir + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither (parsePackageLockFile rootDir) pkgIm of + Left str -> + fail $ + "Can't parse PackageLocationImmutable - 1" <> str <> + show pkgIm + Right iopl -> lfPackageLocations <$> iopl + Nothing -> fail "Can't parse PackageLocationImmutable" + Map.toList pkgImm `shouldBe` [] + it "parses lock file (non empty)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +dependencies: +- original: + subdir: wai + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + complete: + 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 + complete: + 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 +resolver: + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + complete: + size: 527801 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml + sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a +|] + rootDir <- Path.getHomeDir + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither (parsePackageLockFile rootDir) pkgIm of + Left str -> + fail $ + "Can't parse PackageLocationImmutable - 1" <> str <> + show pkgIm + Right iopl -> lfPackageLocations <$> iopl + Nothing -> fail "Can't parse PackageLocationImmutable" + let pkgImm' = map (\(a, b) -> (b, a)) (Map.toList pkgImm) + pkgImm' `shouldBe` + [ ( PLImmutable + (PLIRepo + (Repo + { repoType = RepoGit + , repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "wai" + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 2, 1, 2] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") + (FileSize 714)) + , pmCabal = + toBlobKey + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + 1765 + })) + , RPLImmutable + (RPLIRepo + (Repo + { repoType = RepoGit + , repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "wai" + }) + (RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + , rpmCabal = Nothing + }))) + , ( PLImmutable + (PLIRepo + (Repo + { repoType = RepoGit + , repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "warp" + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "warp" + , pkgVersion = mkVersion [3, 2, 25] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") + (FileSize 5103)) + , pmCabal = + toBlobKey + "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" + 10725 + })) + , RPLImmutable + (RPLIRepo + (Repo + { repoType = RepoGit + , repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = + "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "warp" + }) + (RawPackageMetadata + { rpmName = Nothing + , rpmVersion = Nothing + , rpmTreeKey = Nothing + , rpmCabal = Nothing + }))) + ] + it "parses snapshot lock file (non empty)" $ do + let lockFile :: ByteString + lockFile = + [r|#some +dependencies: +- original: + hackage: string-quote-0.0.1 + complete: + hackage: string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3,758 + pantry-tree: + size: 273 + sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f +|] + rootDir <- Path.getHomeDir + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither + (resolveSnapshotLayerLockFile rootDir) + pkgIm of + Left str -> + fail $ + "Can't parse PackageLocationImmutable - 1" <> str <> + show pkgIm + Right iopl -> iopl + Nothing -> fail "Can't parse PackageLocationImmutable" + let pkgImm' = map (\(a, b) -> (b, a)) (Map.toList pkgImm) + pkgImm' `shouldBe` + [ ( PLIHackage + (PackageIdentifier + { pkgName = mkPackageName "string-quote" + , pkgVersion = mkVersion [0, 0, 1] + }) + (toBlobKey + "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" + 758) + (TreeKey + (BlobKey + (decodeSHA + "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") + (FileSize 273))) + , RPLIHackage + (PackageIdentifierRevision + (mkPackageName "string-quote") + (mkVersion [0, 0, 1]) + CFILatest) + Nothing) + ] diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index a526245211..a48ac8d65c 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -120,3 +120,4 @@ tests: - exceptions - hedgehog - QuickCheck + - raw-strings-qq diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index d6d08fcf7d..496ff3f436 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -37,7 +37,7 @@ module Pantry , FileSize (..) , RelFilePath (..) , ResolvedPath (..) - , Unresolved + , Unresolved (..) -- ** Cryptography , SHA256 @@ -46,6 +46,7 @@ module Pantry -- ** Packages , RawPackageMetadata (..) + , rpmEmpty , PackageMetadata (..) , Package (..) @@ -59,10 +60,13 @@ module Pantry , RawArchive (..) , Archive (..) , ArchiveLocation (..) + , OptionalSubdirs (..) + , osToRpms -- ** Repos , Repo (..) , RepoType (..) + , GitHubRepo (..) -- ** Package location , RawPackageLocation (..) @@ -104,6 +108,11 @@ module Pantry , parseWantedCompiler , parseRawSnapshotLocation , parsePackageIdentifierRevision + , parseHackageText + , parseArchiveLocationText + , parseArchiveLocationObject + , parseRawSnapshotLocationPath + , parseAndResolvePackageLocation -- ** Cabal values , parsePackageIdentifier @@ -971,9 +980,10 @@ 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 = - loadAndCompleteSnapshotRaw (toRawSL loc) +loadAndCompleteSnapshot loc cachedPL = + loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations @@ -982,8 +992,9 @@ loadAndCompleteSnapshot loc = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshotRaw loc = do +loadAndCompleteSnapshotRaw loc cachePL = do eres <- loadRawSnapshotLayer loc case eres of Left wc -> @@ -995,10 +1006,11 @@ loadAndCompleteSnapshotRaw loc = do } in pure (snapshot, []) Right (rsl, _sha) -> do - (snap0, completed0) <- loadAndCompleteSnapshotRaw $ rslParent rsl + (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL (packages, completed, unused) <- addAndCompletePackagesToSnapshot - (display loc) + loc + cachePL (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl @@ -1128,6 +1140,17 @@ 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 @@ -1140,26 +1163,32 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens -- @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) locs = do + name <- getPackageLocationName locs + loc' <- cachedSnapshotCompletePackageLocation cachedPL locs let p = (name, SnapshotPackage { spLocation = loc' , spFlags = Map.findWithDefault mempty name flags , spHidden = Map.findWithDefault False name hiddens , spGhcOptions = Map.findWithDefault [] name options }) - if toRawPLI loc' == loc + if toRawPLI loc' == locs then pure (p:ps, completed) - else pure (p:ps, (loc, loc'):completed) + else pure (p:ps, (locs, loc'):completed) (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 49da897ac7..4946a205aa 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -41,7 +41,7 @@ module Pantry.Types , renderTree , parseTree , SHA256 - , Unresolved + , Unresolved (..) , resolvePaths , Package (..) , PackageCabal (..) @@ -58,6 +58,7 @@ module Pantry.Types , toRawArchive , Repo (..) , RepoType (..) + , GitHubRepo (..) , parsePackageIdentifier , parsePackageName , parsePackageNameThrowing @@ -66,16 +67,20 @@ module Pantry.Types , parseVersionThrowing , packageIdentifierString , packageNameString + , parseAndResolvePackageLocation + , parseRawSnapshotLocationPath , flagNameString , versionString , moduleNameString , OptionalSubdirs (..) + , osToRpms , ArchiveLocation (..) , RelFilePath (..) , CabalString (..) , toCabalStringMap , unCabalStringMap , parsePackageIdentifierRevision + , parseHackageText , Mismatch (..) , PantryException (..) , FuzzyResults (..) @@ -89,6 +94,8 @@ module Pantry.Types , SnapshotLocation (..) , toRawSL , parseRawSnapshotLocation + , parseArchiveLocationText + , parseArchiveLocationObject , RawSnapshotLayer (..) , SnapshotLayer (..) , toRawSnapshotLayer @@ -98,6 +105,7 @@ module Pantry.Types , SnapshotPackage (..) , parseWantedCompiler , RawPackageMetadata (..) + , rpmEmpty , PackageMetadata (..) , toRawPM , cabalFileName @@ -247,6 +255,12 @@ newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) instance Applicative Unresolved where pure = Unresolved . const . pure Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir +instance Monad Unresolved where + return = pure + (Unresolved f) >>= f1 = Unresolved $ \mdir -> do + y <- (f mdir) + let (Unresolved f2) = f1 y + f2 mdir -- | Resolve all of the file paths in an 'Unresolved' relative to the -- given directory. @@ -283,10 +297,14 @@ instance Store (ResolvedPath File) data RawPackageLocation = RPLImmutable !RawPackageLocationImmutable | RPLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Data, Generic) + deriving (Show, Eq, Ord, Data, Generic) instance NFData RawPackageLocation instance Store RawPackageLocation +instance Display RawPackageLocation where + display (RPLImmutable loc) = display loc + display (RPLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp + -- | Location to load a package from. Can either be immutable (see -- 'PackageLocationImmutable') or a local directory which is expected -- to change over time. @@ -295,7 +313,7 @@ instance Store RawPackageLocation data PackageLocation = PLImmutable !PackageLocationImmutable | PLMutable !(ResolvedPath Dir) - deriving (Show, Eq, Data, Generic) + deriving (Show, Eq, Ord, Data, Generic) instance NFData PackageLocation instance Store PackageLocation @@ -303,6 +321,10 @@ 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 @@ -502,6 +524,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". @@ -670,6 +702,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 @@ -697,10 +755,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 @@ -1333,6 +1387,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 @@ -1395,6 +1461,26 @@ validateFilePath t = pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' else fail $ "Does not have an archive file extension: " ++ T.unpack t +parsePackageLocation :: Value -> Parser (Unresolved (NonEmpty PackageLocation)) +parsePackageLocation v = parsePLImmutable v <|> parsePLMutable v + +parsePLImmutable :: Value -> Parser (Unresolved (NonEmpty PackageLocation)) +parsePLImmutable v = do + xs :: NonEmpty (Unresolved PackageLocation) <- (fmap.fmap.fmap) PLImmutable (parseJSON v) + let ys :: Unresolved (NonEmpty PackageLocation) = sequence xs + pure ys + +parsePLMutable :: Value -> Parser (Unresolved (NonEmpty PackageLocation)) +parsePLMutable v = (mkMutable <$> parseJSON v) + where + mkMutable :: Text -> Unresolved (NonEmpty PackageLocation) + mkMutable t = Unresolved $ \mdir -> do + case mdir of + Nothing -> throwIO $ MutablePackageLocationFromUrl t + Just dir -> do + abs' <- resolveDir dir $ T.unpack t + pure $ pure $ PLMutable $ ResolvedPath (RelFilePath t) abs' + instance ToJSON RawPackageLocation where toJSON (RPLImmutable rpli) = toJSON rpli toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) @@ -1446,6 +1532,62 @@ rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] +parseAndResolvePackageLocation :: Path Abs Dir -> Value -> Parser (IO (NonEmpty PackageLocation)) +parseAndResolvePackageLocation rootDir v = do + (Unresolved unresolvedPL) <- parsePackageLocation v + pure $ unresolvedPL (Just rootDir) + +instance FromJSON (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 (Unresolved PackageLocationImmutable) + repoObject value = do + repo <- parseJSON value + pm <- parseJSON value + pure $ pure $ PLIRepo repo pm + + archiveObject :: Value -> Parser (Unresolved PackageLocationImmutable) + archiveObject value = do + pm <- parseJSON value + pli <- withObject "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do + Unresolved mkArchiveLocation <- unWarningParser $ parseArchiveLocationObject o + archiveHash <- o .: "sha256" + archiveSize <- o .: "size" + archiveSubdir <- o .: "subdir" + pure $ Unresolved $ \mdir -> do + archiveLocation <- mkArchiveLocation mdir + pure $ PLIArchive Archive {..} pm + ) value + pure $ pli + + hackageObject :: Value -> Parser (Unresolved PackageLocationImmutable) + hackageObject value = + withObject "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do + treeKey <- o .: "pantry-tree" + htxt :: Text <- o .: "hackage" + case parseHackageText htxt of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)) value + + github :: Value -> Parser (Unresolved PackageLocationImmutable) + github value = do + pm <- parseJSON value + withObject "PLArchive: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 @@ -1454,7 +1596,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 -> @@ -1468,11 +1610,14 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu raSubdir = T.empty pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty + hackageText :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> case parsePackageIdentifierRevision t of Left e -> fail $ show e Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing + + hackageObject :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (RPLIHackage <$> o ..: "hackage" <*> o ..:? "pantry-tree") @@ -1495,6 +1640,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu <*> o ..:? "pantry-tree" <*> o ..:? "cabal-file") + repo :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do (repoType, repoUrl) <- ((RepoGit, ) <$> o ..: "git") <|> @@ -1503,6 +1649,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu os <- optionalSubdirs o pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) + archiveObject :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIArchive" $ \o -> do Unresolved mkArchiveLocation <- parseArchiveLocationObject o raHash <- o ..:? "sha256" @@ -1512,6 +1659,7 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu raLocation <- mkArchiveLocation mdir pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + github :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) github = withObjectWarnings "PLArchive:github" $ \o -> do GitHubRepo ghRepo <- o ..: "github" commit <- o ..: "commit" @@ -1739,6 +1887,8 @@ defUser = "commercialhaskell" defRepo :: Text defRepo = "stackage-snapshots" + + -- | Location of an LTS snapshot -- -- @since 0.1.0.0 diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index c1a46344f1..d20807ba84 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -1,96 +1,193 @@ {-# 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 hh :: HasCallStack => String -> Property -> Spec -hh name p = it name $ do - result <- check p - unless result $ throwString "Hedgehog property failed" :: IO () +hh name p = + it name $ do + result <- check p + unless result $ throwString "Hedgehog property failed" :: IO () genBlobKey :: Gen BlobKey -genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) +genBlobKey = + BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) 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 - hh "parse/render works" $ property $ do - wc <- forAll $ - let ghc = WCGhc <$> genVersion - ghcjs = WCGhcjs <$> genVersion <*> genVersion - genVersion = mkVersion <$> Gen.list (Range.linear 1 5) (Gen.int (Range.linear 0 100)) - in Gen.choice [ghc, ghcjs] - let text = utf8BuilderToText $ display wc - case parseWantedCompiler text of - Left e -> throwIO e - Right actual -> liftIO $ actual `shouldBe` wc - - describe "Tree" $ do - hh "parse/render works" $ property $ do - tree <- forAll $ - let sfp = do - pieces <- Gen.list (Range.linear 1 10) sfpComponent - let combined = T.intercalate "/" pieces - case mkSafeFilePath combined of - Nothing -> error $ "Incorrect SafeFilePath in test suite: " ++ show pieces - Just sfp' -> pure sfp' - sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum - entry = TreeEntry - <$> genBlobKey - <*> Gen.choice (map pure [minBound..maxBound]) - in TreeMap <$> Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) - let bs = renderTree tree - liftIO $ parseTree bs `shouldBe` Just tree - - describe "(Raw)SnapshotLayer" $ do - let parseSl :: String -> IO RawSnapshotLayer - parseSl str = case Yaml.decodeThrow . S8.pack $ str of - (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x - Nothing -> fail "Can't parse RawSnapshotLayer" - - it "parses snapshot using 'resolver'" $ do - RawSnapshotLayer{..} <- parseSl $ - "name: 'test'\n" ++ - "resolver: lts-2.10\n" - rslParent `shouldBe` ltsSnapshotLocation 2 10 - - it "parses snapshot using 'snapshot'" $ do - RawSnapshotLayer{..} <- parseSl $ - "name: 'test'\n" ++ - "snapshot: lts-2.10\n" - rslParent `shouldBe` ltsSnapshotLocation 2 10 - - it "throws if both 'resolver' and 'snapshot' are present" $ do - let go = parseSl $ - "name: 'test'\n" ++ - "resolver: lts-2.10\n" ++ - "snapshot: lts-2.10\n" - go `shouldThrow` anyException - - it "throws if both 'snapshot' and 'compiler' are not present" $ do - let go = parseSl "name: 'test'\n" - go `shouldThrow` anyException - - it "works if no 'snapshot' specified" $ do - RawSnapshotLayer{..} <- parseSl $ - "name: 'test'\n" ++ - "compiler: ghc-8.0.1\n" - rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1])) + describe "WantedCompiler" $ do + hh "parse/render works" $ + property $ do + wc <- + forAll $ + let ghc = WCGhc <$> genVersion + ghcjs = WCGhcjs <$> genVersion <*> genVersion + genVersion = + mkVersion <$> + Gen.list + (Range.linear 1 5) + (Gen.int (Range.linear 0 100)) + in Gen.choice [ghc, ghcjs] + let text = utf8BuilderToText $ display wc + case parseWantedCompiler text of + Left e -> throwIO e + Right actual -> liftIO $ actual `shouldBe` wc + describe "Tree" $ do + hh "parse/render works" $ + property $ do + tree <- + forAll $ + let sfp = do + pieces <- Gen.list (Range.linear 1 10) sfpComponent + let combined = T.intercalate "/" pieces + case mkSafeFilePath combined of + Nothing -> + error $ + "Incorrect SafeFilePath in test suite: " ++ + show pieces + Just sfp' -> pure sfp' + sfpComponent = Gen.text (Range.linear 1 15) Gen.alphaNum + entry = + TreeEntry <$> genBlobKey <*> + Gen.choice (map pure [minBound .. maxBound]) + in TreeMap <$> + Gen.map (Range.linear 1 20) ((,) <$> sfp <*> entry) + let bs = renderTree tree + liftIO $ parseTree bs `shouldBe` Just tree + describe "(Raw)SnapshotLayer" $ do + let parseSl :: String -> IO RawSnapshotLayer + parseSl str = + case Yaml.decodeThrow . S8.pack $ str of + (Just (WithJSONWarnings x _)) -> resolvePaths Nothing x + Nothing -> fail "Can't parse RawSnapshotLayer" + it "parses snapshot using 'resolver'" $ do + RawSnapshotLayer {..} <- + parseSl $ "name: 'test'\n" ++ "resolver: lts-2.10\n" + rslParent `shouldBe` ltsSnapshotLocation 2 10 + it "parses snapshot using 'snapshot'" $ do + RawSnapshotLayer {..} <- + parseSl $ "name: 'test'\n" ++ "snapshot: lts-2.10\n" + rslParent `shouldBe` ltsSnapshotLocation 2 10 + it "throws if both 'resolver' and 'snapshot' are present" $ do + let go = + parseSl $ + "name: 'test'\n" ++ + "resolver: lts-2.10\n" ++ "snapshot: lts-2.10\n" + go `shouldThrow` anyException + it "throws if both 'snapshot' and 'compiler' are not present" $ do + let go = parseSl "name: 'test'\n" + go `shouldThrow` anyException + it "works if no 'snapshot' specified" $ do + RawSnapshotLayer {..} <- + parseSl $ "name: 'test'\n" ++ "compiler: ghc-8.0.1\n" + rslParent `shouldBe` RSLCompiler (WCGhc (mkVersion [8, 0, 1])) + 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])