From 3be0c5ae57a0f34dbc5c34fb479f2ef04ea1a9cb Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 8 Jan 2019 17:37:29 +0530 Subject: [PATCH 01/76] Add FromJSON instance for Repo --- subs/pantry/src/Pantry/Types.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index cff33e7825..28024a825c 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -484,6 +484,12 @@ instance Display Repo where (if T.null subdir then mempty else " in subdirectory " <> display subdir) +instance FromJSON (WithJSONWarnings Repo) where + parseJSON = withObjectWarnings "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". From 889059cf5839bc396d0170335a8f4b044d920b36 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 8 Jan 2019 17:37:56 +0530 Subject: [PATCH 02/76] Add corresponding test for fromJSON instance --- subs/pantry/test/Pantry/TypesSpec.hs | 31 ++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index c1a46344f1..f5662a41ca 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes#-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} module Pantry.TypesSpec (spec) where @@ -17,6 +19,7 @@ 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 Data.String.Quote hh :: HasCallStack => String -> Property -> Spec hh name p = it name $ do @@ -29,6 +32,21 @@ 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 = [s| +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 @@ -94,3 +112,16 @@ spec = do "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 (WithJSONWarnings 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 From 7abafb5f27b9812e4eeb60f245cde3cdcf17acb8 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 8 Jan 2019 20:06:04 +0530 Subject: [PATCH 03/76] Add FromJSON for PackageMetadata --- subs/pantry/src/Pantry/Types.hs | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 28024a825c..6de05114c0 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -485,11 +485,15 @@ instance Display Repo where then mempty else " in subdirectory " <> display subdir) instance FromJSON (WithJSONWarnings Repo) where - parseJSON = withObjectWarnings "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 {..} + parseJSON = + withObjectWarnings "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". @@ -1297,6 +1301,18 @@ instance Display PackageMetadata where , "cabal file == " <> display (pmCabal pm) ] +instance FromJSON (WithJSONWarnings PackageMetadata) where + parseJSON = + withObjectWarnings "PackageMetadata" $ \o -> do + pmCabal :: BlobKey <- o ..: "cabal-file" + pantryTree :: BlobKey <- o ..: "pantry-tree" + CabalString pkgName <- o ..: "name" -- come here + CabalString pkgVersion <- o ..: "version" + let pmTreeKey = TreeKey pantryTree + pmIdent = PackageIdentifier {..} + pure PackageMetadata {..} + + -- | Conver package metadata to its "raw" equivalent. -- -- @since 0.1.0.0 From d10af00524c73c2f70350091eaf1fb526d167f94 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 8 Jan 2019 20:06:20 +0530 Subject: [PATCH 04/76] Add relevant test --- subs/pantry/test/Pantry/TypesSpec.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index f5662a41ca..3c797c93d5 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -18,6 +18,7 @@ import Distribution.Types.Version (mkVersion) import qualified RIO.Text as T import qualified Data.Yaml as Yaml import Data.Aeson.Extended (WithJSONWarnings (..)) +import Distribution.Types.PackageName (mkPackageName) import qualified Data.ByteString.Char8 as S8 import Data.String.Quote @@ -125,3 +126,20 @@ spec = do } repValue `shouldBe` repoValue + + it "FromJSON instance for PackageMetadata" $ do + pkgMeta <- case Yaml.decodeThrow samplePLIRepo of + Just (WithJSONWarnings 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 From d1d91383335063d496a0875b58c3fedae157909f Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 10 Jan 2019 23:13:10 +0530 Subject: [PATCH 05/76] Commit typechecking code --- subs/pantry/test/Pantry/TypesSpec.hs | 114 ++++++++++++++++++++++++++- 1 file changed, 113 insertions(+), 1 deletion(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 3c797c93d5..31fe3166ea 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -10,6 +10,7 @@ import Test.Hspec import Hedgehog import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range +import qualified RIO.HashMap as HM import Pantry import qualified Pantry.SHA256 as SHA256 import Pantry.Internal (parseTree, renderTree, Tree (..), TreeEntry (..), mkSafeFilePath) @@ -17,10 +18,13 @@ import RIO import Distribution.Types.Version (mkVersion) import qualified RIO.Text as T import qualified Data.Yaml as Yaml -import Data.Aeson.Extended (WithJSONWarnings (..)) +import Data.Aeson.Extended import Distribution.Types.PackageName (mkPackageName) import qualified Data.ByteString.Char8 as S8 +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) import Data.String.Quote +import qualified Data.Vector as Vector hh :: HasCallStack => String -> Property -> Spec hh name p = it name $ do @@ -143,3 +147,111 @@ spec = do } 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]) + + it "parses PackageLocationImmutable" $ do + let lockFile :: ByteString + lockFile = [s|#some +dependencies: +- complete: + - size: 285152 + subdir: wai + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 710 + sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +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 +|] + + let x = 3 +-- parseLockFile :: Value -> Yaml.Parser (WithJSONWarnings (IO [PackageLocationImmutable])) +-- parseLockFile value = withObjectWarnings "PackageLocationimmutable" (\obj -> do +-- (deps :: Value) <- obj ..: "dependencies" +-- val :: [Unresolved (NonEmpty PackageLocationImmutable)] <- undefined +-- undefined) value +-- -- return $ do +-- -- val' :: [NonEmpty PackageLocationImmutable] <- mapM (resolvePaths Nothing) val +-- -- pure $ (concatMap toList val')) value + + -- parseLockFile :: + -- Value -> Yaml.Parser [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] + -- parseLockFile value = do + -- (WithJSONWarnings val _) <- withObjectWarnings + -- "PackageLocationimmutable" + -- (\obj -> do + -- deps@(Array depe) <- obj ..: "dependencies" + -- let origAndComplete :: [Value] = Vector.toList depe + -- origAndComplete' :: Yaml.Parser [Maybe Value]= sequence $ map (withObject "complete" (\obj -> obj .:? "complete")) origAndComplete + -- lift $ withArray "PackageLocationimmutable.complete (Array)" (\array -> do + -- let array' :: [Value] = Vector.toList array + -- array'' :: [ Yaml.Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))] = map (parseJSON) array' + -- sequence array'') deps + -- ) value + -- let val' :: [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] = map (\(WithJSONWarnings item warn) -> WithJSONWarnings (resolvePaths Nothing item) warn) val + -- pure val' + + -- Object (fromList [("dependencies",Array [Object (fromList [("complete",Array [Object (fromList [("size",Number 285152.0),("subdir",String "wai"),("url",String "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip"),("cabal-file",Object (fromList [("size",Number 1717.0),("sha256",String "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056")])),("name",String "wai"),("version",String "3.0.2.3"),("sha256",String "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba"),("pantry-tree",Object (fromList [("size",Number 710.0),("sha256",String "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc")]))])])])]),("sha256",String "7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a"),("resolver",Array [Object (fromList [("original",Object (fromList [("url",String "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml")]))]),Object (fromList [("complete",Object (fromList [("size",Number 527801.0),("url",String "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml")]))])])]))) + + + + + getCompleteObject :: Value -> Value + getCompleteObject (Array deps) = Array $ Vector.filter isCompleteObject deps + getCompleteObject arr = error $ "Expected Array but received " <> show arr + + isCompleteObject :: Value -> Bool + isCompleteObject obj@(Object xs) = HM.member "complete" xs + isCompleteObject _ = False + + parseLockFile :: + Value -> Yaml.Parser [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] + parseLockFile value = do + (WithJSONWarnings val _) <- withObjectWarnings + "PackageLocationimmutable" + (\obj -> do + deps@(Array depe) <- obj ..: "dependencies" + let origAndComplete :: [Value] = Vector.toList depe + origAndComplete' :: Yaml.Parser [Maybe Value] = sequence $ map (withObject "complete" (\obj -> obj .: "complete")) origAndComplete + pure origAndComplete' + ) value + v :: [Maybe Value] <- val + let v1 :: [Value] = catMaybes v + v2 :: [ Yaml.Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))] = map parseJSON v1 + v3 <- sequence v2 + let v4 :: [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] = map (\(WithJSONWarnings item warn) -> WithJSONWarnings (resolvePaths Nothing item) warn) v3 + pure v4 + + + pkgImm <- case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseMaybe parseLockFile pkgIm of + Nothing -> fail $ "Can't parse PackageLocationImmutable - 1" <> (show pkgIm) + Just xs -> do + let xs' :: [IO (NonEmpty PackageLocationImmutable)] = map (\(WithJSONWarnings item _) -> item )xs + xs'' :: IO [NonEmpty PackageLocationImmutable] = sequence xs' + xs''' :: [NonEmpty PackageLocationImmutable] <- xs'' + let xs'''' = concat $ map NonEmpty.toList xs''' + pure xs'''' + Nothing -> fail "Can't parse PackageLocationImmutable - 2" + pkgImm `shouldBe` ([] :: [PackageLocationImmutable]) From 1ec1a64097d11fac6d72d267a231cf52180e11f1 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 11 Jan 2019 19:58:22 +0530 Subject: [PATCH 06/76] Modify types and parsing logic --- subs/pantry/src/Pantry/Types.hs | 123 ++++++++++++++++++++++++++++---- 1 file changed, 110 insertions(+), 13 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 6de05114c0..839cdeed91 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -71,6 +71,7 @@ module Pantry.Types , toCabalStringMap , unCabalStringMap , parsePackageIdentifierRevision + , parseHackageText , Mismatch (..) , PantryException (..) , FuzzyResults (..) @@ -99,7 +100,9 @@ module Pantry.Types ) where import RIO +import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Conduit.Tar as Tar +import qualified Data.Vector as Vector import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL @@ -484,14 +487,14 @@ instance Display Repo where (if T.null subdir then mempty else " in subdirectory " <> display subdir) -instance FromJSON (WithJSONWarnings Repo) where +instance FromJSON Repo where parseJSON = - withObjectWarnings "Repo" $ \o -> do - repoSubdir <- o ..: "subdir" - repoCommit <- o ..: "commit" + withObject "Repo" $ \o -> do + repoSubdir <- o .: "subdir" + repoCommit <- o .: "commit" (repoType, repoUrl) <- - (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> - (o ..: "hg" >>= \url -> pure (RepoHg, url)) + (o .: "git" >>= \url -> pure (RepoGit, url)) <|> + (o .: "hg" >>= \url -> pure (RepoHg, url)) pure Repo {..} @@ -662,6 +665,31 @@ 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) + where + splitColon t' = + let (x, y) = T.break (== ':') t' + in (x, ) <$> T.stripPrefix ":" y + -- | Parse a 'PackageIdentifierRevision' -- -- @since 0.1.0.0 @@ -1301,13 +1329,13 @@ instance Display PackageMetadata where , "cabal file == " <> display (pmCabal pm) ] -instance FromJSON (WithJSONWarnings PackageMetadata) where +instance FromJSON PackageMetadata where parseJSON = - withObjectWarnings "PackageMetadata" $ \o -> do - pmCabal :: BlobKey <- o ..: "cabal-file" - pantryTree :: BlobKey <- o ..: "pantry-tree" - CabalString pkgName <- o ..: "name" -- come here - CabalString pkgVersion <- o ..: "version" + 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 {..} @@ -1426,6 +1454,71 @@ rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] +instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) where + parseJSON v = repo v + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + where + hackageText :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + hackageText value = do + tkey <- withObject "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do + treeKey <- o .: "pantry-tree" + pure treeKey) value + withText "UnresolvedPackageLocationImmutable.PLIHackage (Text)" (\t -> do + case parseHackageText t of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> pure $ noJSONWarnings $ pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey tkey)) value + + repo :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + repo value@(Array objs) = do + pli :: NonEmpty PackageLocationImmutable <- repos value + pure $ noJSONWarnings $ pure $ pli + + repos :: Value -> Parser (NonEmpty PackageLocationImmutable) + repos value@(Array arr) = do + let xs :: [Parser PackageLocationImmutable] = Vector.toList $ Vector.map repoObject arr + xs' :: Parser [PackageLocationImmutable] = sequence xs + pli <- xs' + pure $ NonEmpty.fromList pli + + repoObject :: Value -> Parser PackageLocationImmutable + repoObject value@(Object _) = do + repo <- parseJSON value + pm <- parseJSON value + pure $ PLIRepo repo pm + + + + -- archiveObject :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + -- archiveObject value = do + -- (WithJSONWarnings 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 $ pure $ PLIArchive Archive {..} pm + -- ) value + + -- github :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + -- github value = do + -- (WithJSONWarnings pm _) <- parseJSON value + -- withObjectWarnings "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 $ pure $ PLIArchive Archive {..} pm) value + instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where parseJSON v = http v @@ -1434,7 +1527,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 -> @@ -1448,6 +1541,7 @@ 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 @@ -1475,6 +1569,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") <|> @@ -1483,6 +1578,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" @@ -1492,6 +1588,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" From d20749b08e817fe85918650fded1f02fef5af4b3 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 11 Jan 2019 19:58:36 +0530 Subject: [PATCH 07/76] The parsing logic works now --- subs/pantry/test/Pantry/TypesSpec.hs | 146 +++++++++++++++------------ 1 file changed, 83 insertions(+), 63 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 31fe3166ea..a3bbc1d962 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -4,6 +4,7 @@ {-# LANGUAGE QuasiQuotes#-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} module Pantry.TypesSpec (spec) where import Test.Hspec @@ -22,9 +23,11 @@ import Data.Aeson.Extended import Distribution.Types.PackageName (mkPackageName) import qualified Data.ByteString.Char8 as S8 import qualified Data.List.NonEmpty as NonEmpty -import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List as List +import Data.List.NonEmpty hiding (map) import Data.String.Quote import qualified Data.Vector as Vector +import Data.Semigroup hh :: HasCallStack => String -> Property -> Spec hh name p = it name $ do @@ -118,35 +121,35 @@ spec = do "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 (WithJSONWarnings 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" - } + -- it "FromJSON instance for Repo" $ do + -- repValue <- case Yaml.decodeThrow samplePLIRepo of + -- Just (WithJSONWarnings 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 + -- repValue `shouldBe` repoValue - it "FromJSON instance for PackageMetadata" $ do - pkgMeta <- case Yaml.decodeThrow samplePLIRepo of - Just (WithJSONWarnings 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) - } + -- it "FromJSON instance for PackageMetadata" $ do + -- pkgMeta <- case Yaml.decodeThrow samplePLIRepo of + -- Just (WithJSONWarnings 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 + -- pkgMeta `shouldBe` pkgValue it "parseHackageText parses" $ do let txt = "persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058" @@ -163,18 +166,17 @@ spec = do lockFile = [s|#some dependencies: - complete: - - size: 285152 - subdir: wai - url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + - subdir: wai cabal-file: - size: 1717 - sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 name: wai - version: 3.0.2.3 - sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + version: 3.2.1.2 + git: https://github.com/yesodweb/wai.git pantry-tree: - size: 710 - sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc + size: 714 + sha256: ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2 + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 resolver: - original: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml @@ -214,44 +216,62 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a -- Object (fromList [("dependencies",Array [Object (fromList [("complete",Array [Object (fromList [("size",Number 285152.0),("subdir",String "wai"),("url",String "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip"),("cabal-file",Object (fromList [("size",Number 1717.0),("sha256",String "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056")])),("name",String "wai"),("version",String "3.0.2.3"),("sha256",String "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba"),("pantry-tree",Object (fromList [("size",Number 710.0),("sha256",String "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc")]))])])])]),("sha256",String "7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a"),("resolver",Array [Object (fromList [("original",Object (fromList [("url",String "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml")]))]),Object (fromList [("complete",Object (fromList [("size",Number 527801.0),("url",String "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml")]))])])]))) - - - getCompleteObject :: Value -> Value - getCompleteObject (Array deps) = Array $ Vector.filter isCompleteObject deps - getCompleteObject arr = error $ "Expected Array but received " <> show arr - isCompleteObject :: Value -> Bool isCompleteObject obj@(Object xs) = HM.member "complete" xs isCompleteObject _ = False + appendPLI :: WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -> WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -> WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) + appendPLI (WithJSONWarnings item1 warn1) (WithJSONWarnings item2 warn2) = WithJSONWarnings (item1 <> item2) (warn1 <> warn2) + parseLockFile :: - Value -> Yaml.Parser [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] + Value + -> Yaml.Parser (WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))) parseLockFile value = do - (WithJSONWarnings val _) <- withObjectWarnings + (WithJSONWarnings val _) <- + withObjectWarnings "PackageLocationimmutable" (\obj -> do - deps@(Array depe) <- obj ..: "dependencies" - let origAndComplete :: [Value] = Vector.toList depe - origAndComplete' :: Yaml.Parser [Maybe Value] = sequence $ map (withObject "complete" (\obj -> obj .: "complete")) origAndComplete - pure origAndComplete' - ) value - v :: [Maybe Value] <- val - let v1 :: [Value] = catMaybes v - v2 :: [ Yaml.Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))] = map parseJSON v1 - v3 <- sequence v2 - let v4 :: [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] = map (\(WithJSONWarnings item warn) -> WithJSONWarnings (resolvePaths Nothing item) warn) v3 - pure v4 + deps <- obj ..: "dependencies" + lift $ + withArray + "Dependencies (Array)" + (\vector -> do + let vector' :: Array = + Vector.filter isCompleteObject vector + let pli :: Vector (Yaml.Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))) = + Vector.map + (\(Object o) -> do + complete <- o .: "complete" + pl :: (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) <- + parseJSON complete + pure pl) + vector' + pliSeq = sequence pli + pli' <- pliSeq + pure pli') + deps) + value + let pli :: Vector (WithJSONWarnings (Unresolved (NonEmpty (PackageLocationImmutable)))) = + val + pliResolve :: Vector (WithJSONWarnings (IO (NonEmpty (PackageLocationImmutable)))) = + Vector.map + (\(WithJSONWarnings item warn) -> + (WithJSONWarnings (resolvePaths Nothing item) warn)) + pli + pure $ Vector.foldr1 appendPLI pliResolve pkgImm <- case Yaml.decodeThrow lockFile of Just (pkgIm :: Value) -> do - case Yaml.parseMaybe parseLockFile pkgIm of - Nothing -> fail $ "Can't parse PackageLocationImmutable - 1" <> (show pkgIm) - Just xs -> do - let xs' :: [IO (NonEmpty PackageLocationImmutable)] = map (\(WithJSONWarnings item _) -> item )xs - xs'' :: IO [NonEmpty PackageLocationImmutable] = sequence xs' - xs''' :: [NonEmpty PackageLocationImmutable] <- xs'' - let xs'''' = concat $ map NonEmpty.toList xs''' - pure xs'''' + case Yaml.parseEither parseLockFile pkgIm of + Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + let (WithJSONWarnings iopli _) = xs + pli <- iopli + pure $ NonEmpty.toList pli +-- xs'' :: IO [NonEmpty PackageLocationImmutable] = sequence xs' +-- xs''' :: [NonEmpty PackageLocationImmutable] <- xs'' +-- let xs'''' = concat $ map NonEmpty.toList xs''' +-- pure xs'''' Nothing -> fail "Can't parse PackageLocationImmutable - 2" pkgImm `shouldBe` ([] :: [PackageLocationImmutable]) From e0ee3baa009d43943ecdca0e0874be54f8b90337 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 11 Jan 2019 21:32:41 +0530 Subject: [PATCH 08/76] Move function to the Types module and simplify tests --- subs/pantry/src/Pantry.hs | 2 + subs/pantry/src/Pantry/Types.hs | 113 ++++++++++++++------- subs/pantry/test/Pantry/TypesSpec.hs | 145 +++++++-------------------- 3 files changed, 117 insertions(+), 143 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 7e987d0c03..61a0c6ac27 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -103,6 +103,8 @@ module Pantry , parseWantedCompiler , parseRawSnapshotLocation , parsePackageIdentifierRevision + , parseHackageText + , parseLockFile -- ** Cabal values , parsePackageIdentifier diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 839cdeed91..c7f7e2a436 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -61,6 +61,7 @@ module Pantry.Types , parseVersionThrowing , packageIdentifierString , packageNameString + , parseLockFile , flagNameString , versionString , moduleNameString @@ -1454,41 +1455,85 @@ rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] +appendPLI :: WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -> WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -> WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) +appendPLI (WithJSONWarnings item1 warn1) (WithJSONWarnings item2 warn2) = WithJSONWarnings (item1 <> item2) (warn1 <> warn2) + +isCompleteObject :: Value -> Bool +isCompleteObject obj@(Object xs) = HM.member "complete" xs +isCompleteObject _ = False + +parseLockFile :: + Value -> Parser (WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))) +parseLockFile value = do + (WithJSONWarnings val _) <- + withObjectWarnings + "PackageLocationimmutable" + (\obj -> do + deps <- obj ..: "dependencies" + lift $ + withArray + "Dependencies (Array)" + (\vector -> do + let vector' :: Array = + Vector.filter isCompleteObject vector + let pli :: Vector (Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))) = + Vector.map + (\(Object o) -> do + complete <- o .: "complete" + pl :: (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) <- + parseJSON complete + pure pl) + vector' + pliSeq = sequence pli + pli' <- pliSeq + pure pli') + deps) + value + let pli :: Vector (WithJSONWarnings (Unresolved (NonEmpty (PackageLocationImmutable)))) = + val + pliResolve :: Vector (WithJSONWarnings (IO (NonEmpty (PackageLocationImmutable)))) = + Vector.map + (\(WithJSONWarnings item warn) -> + (WithJSONWarnings (resolvePaths Nothing item) warn)) + pli + pure $ Vector.foldr1 appendPLI pliResolve + + instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) where - parseJSON v = repo v - <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) - where - hackageText :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - hackageText value = do - tkey <- withObject "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do - treeKey <- o .: "pantry-tree" - pure treeKey) value - withText "UnresolvedPackageLocationImmutable.PLIHackage (Text)" (\t -> do - case parseHackageText t of - Left e -> fail $ show e - Right (pkgIdentifier, blobKey) -> pure $ noJSONWarnings $ pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey tkey)) value - - repo :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - repo value@(Array objs) = do - pli :: NonEmpty PackageLocationImmutable <- repos value - pure $ noJSONWarnings $ pure $ pli - - repos :: Value -> Parser (NonEmpty PackageLocationImmutable) - repos value@(Array arr) = do - let xs :: [Parser PackageLocationImmutable] = Vector.toList $ Vector.map repoObject arr - xs' :: Parser [PackageLocationImmutable] = sequence xs - pli <- xs' - pure $ NonEmpty.fromList pli - - repoObject :: Value -> Parser PackageLocationImmutable - repoObject value@(Object _) = do - repo <- parseJSON value - pm <- parseJSON value - pure $ PLIRepo repo pm - - - - -- archiveObject :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + parseJSON v = repo v + <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) + where + hackageText :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + hackageText value = do + tkey <- withObject "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do + treeKey <- o .: "pantry-tree" + pure treeKey) value + withText "UnresolvedPackageLocationImmutable.PLIHackage (Text)" (\t -> do + case parseHackageText t of + Left e -> fail $ show e + Right (pkgIdentifier, blobKey) -> pure $ noJSONWarnings $ pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey tkey)) value + + repo :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + repo value@(Array objs) = do + pli :: NonEmpty PackageLocationImmutable <- repos value + pure $ noJSONWarnings $ pure $ pli + + repos :: Value -> Parser (NonEmpty PackageLocationImmutable) + repos value@(Array arr) = do + let xs :: [Parser PackageLocationImmutable] = Vector.toList $ Vector.map repoObject arr + xs' :: Parser [PackageLocationImmutable] = sequence xs + pli <- xs' + pure $ NonEmpty.fromList pli + + repoObject :: Value -> Parser PackageLocationImmutable + repoObject value@(Object _) = do + repo <- parseJSON value + pm <- parseJSON value + pure $ PLIRepo repo pm + + + + -- archiveObject :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) -- archiveObject value = do -- (WithJSONWarnings pm _) <- parseJSON value -- withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index a3bbc1d962..94fa719e10 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -34,6 +34,14 @@ hh name p = it name $ do result <- check p unless result $ throwString "Hedgehog property failed" :: IO () +decodeSHA :: ByteString -> SHA256 +decodeSHA string = case SHA256.fromHexBytes string of + Right csha -> csha + Left err -> error $ "Failed decoding. Error: " <> show err + +toBlobKey :: ByteString -> Word -> BlobKey +toBlobKey string size = BlobKey (decodeSHA string) (FileSize size) + genBlobKey :: Gen BlobKey genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) @@ -121,35 +129,33 @@ spec = do "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 (WithJSONWarnings 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 (WithJSONWarnings 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 "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" @@ -186,81 +192,6 @@ resolver: sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a |] - let x = 3 --- parseLockFile :: Value -> Yaml.Parser (WithJSONWarnings (IO [PackageLocationImmutable])) --- parseLockFile value = withObjectWarnings "PackageLocationimmutable" (\obj -> do --- (deps :: Value) <- obj ..: "dependencies" --- val :: [Unresolved (NonEmpty PackageLocationImmutable)] <- undefined --- undefined) value --- -- return $ do --- -- val' :: [NonEmpty PackageLocationImmutable] <- mapM (resolvePaths Nothing) val --- -- pure $ (concatMap toList val')) value - - -- parseLockFile :: - -- Value -> Yaml.Parser [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] - -- parseLockFile value = do - -- (WithJSONWarnings val _) <- withObjectWarnings - -- "PackageLocationimmutable" - -- (\obj -> do - -- deps@(Array depe) <- obj ..: "dependencies" - -- let origAndComplete :: [Value] = Vector.toList depe - -- origAndComplete' :: Yaml.Parser [Maybe Value]= sequence $ map (withObject "complete" (\obj -> obj .:? "complete")) origAndComplete - -- lift $ withArray "PackageLocationimmutable.complete (Array)" (\array -> do - -- let array' :: [Value] = Vector.toList array - -- array'' :: [ Yaml.Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))] = map (parseJSON) array' - -- sequence array'') deps - -- ) value - -- let val' :: [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] = map (\(WithJSONWarnings item warn) -> WithJSONWarnings (resolvePaths Nothing item) warn) val - -- pure val' - - -- Object (fromList [("dependencies",Array [Object (fromList [("complete",Array [Object (fromList [("size",Number 285152.0),("subdir",String "wai"),("url",String "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip"),("cabal-file",Object (fromList [("size",Number 1717.0),("sha256",String "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056")])),("name",String "wai"),("version",String "3.0.2.3"),("sha256",String "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba"),("pantry-tree",Object (fromList [("size",Number 710.0),("sha256",String "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc")]))])])])]),("sha256",String "7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a"),("resolver",Array [Object (fromList [("original",Object (fromList [("url",String "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml")]))]),Object (fromList [("complete",Object (fromList [("size",Number 527801.0),("url",String "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml")]))])])]))) - - - isCompleteObject :: Value -> Bool - isCompleteObject obj@(Object xs) = HM.member "complete" xs - isCompleteObject _ = False - - appendPLI :: WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -> WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -> WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) - appendPLI (WithJSONWarnings item1 warn1) (WithJSONWarnings item2 warn2) = WithJSONWarnings (item1 <> item2) (warn1 <> warn2) - - parseLockFile :: - Value - -> Yaml.Parser (WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))) - parseLockFile value = do - (WithJSONWarnings val _) <- - withObjectWarnings - "PackageLocationimmutable" - (\obj -> do - deps <- obj ..: "dependencies" - lift $ - withArray - "Dependencies (Array)" - (\vector -> do - let vector' :: Array = - Vector.filter isCompleteObject vector - let pli :: Vector (Yaml.Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))) = - Vector.map - (\(Object o) -> do - complete <- o .: "complete" - pl :: (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) <- - parseJSON complete - pure pl) - vector' - pliSeq = sequence pli - pli' <- pliSeq - pure pli') - deps) - value - let pli :: Vector (WithJSONWarnings (Unresolved (NonEmpty (PackageLocationImmutable)))) = - val - pliResolve :: Vector (WithJSONWarnings (IO (NonEmpty (PackageLocationImmutable)))) = - Vector.map - (\(WithJSONWarnings item warn) -> - (WithJSONWarnings (resolvePaths Nothing item) warn)) - pli - pure $ Vector.foldr1 appendPLI pliResolve - - pkgImm <- case Yaml.decodeThrow lockFile of Just (pkgIm :: Value) -> do case Yaml.parseEither parseLockFile pkgIm of @@ -269,9 +200,5 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a let (WithJSONWarnings iopli _) = xs pli <- iopli pure $ NonEmpty.toList pli --- xs'' :: IO [NonEmpty PackageLocationImmutable] = sequence xs' --- xs''' :: [NonEmpty PackageLocationImmutable] <- xs'' --- let xs'''' = concat $ map NonEmpty.toList xs''' --- pure xs'''' Nothing -> fail "Can't parse PackageLocationImmutable - 2" - pkgImm `shouldBe` ([] :: [PackageLocationImmutable]) + pkgImm `shouldBe` [PLIRepo (Repo {repoUrl = "https://github.com/yesodweb/wai.git", repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0", repoSubdir = "wai", repoType = RepoGit}) (PackageMetadata {pmIdent = PackageIdentifier {pkgName = mkPackageName "wai", pkgVersion = mkVersion [3,2,1,2]}, pmTreeKey = TreeKey (BlobKey (decodeSHA "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") (FileSize 714)), pmCabal = toBlobKey "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" 1765})] From 3bbc3d18ca1976f9d0ac1671123579789cbfc836 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 11 Jan 2019 21:41:47 +0530 Subject: [PATCH 09/76] Add multiple repo parsing --- subs/pantry/test/Pantry/TypesSpec.hs | 125 ++++++++++++++++++++++++++- 1 file changed, 123 insertions(+), 2 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 94fa719e10..fc005d4691 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -167,7 +167,7 @@ spec = do blobKey `shouldBe` (BlobKey sha (FileSize 5058)) pkgIdentifier `shouldBe` PackageIdentifier (mkPackageName "persistent") (mkVersion [2,8,2]) - it "parses PackageLocationImmutable" $ do + it "parses PackageLocationImmutable (Repo)" $ do let lockFile :: ByteString lockFile = [s|#some dependencies: @@ -201,4 +201,125 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a pli <- iopli pure $ NonEmpty.toList pli Nothing -> fail "Can't parse PackageLocationImmutable - 2" - pkgImm `shouldBe` [PLIRepo (Repo {repoUrl = "https://github.com/yesodweb/wai.git", repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0", repoSubdir = "wai", repoType = RepoGit}) (PackageMetadata {pmIdent = PackageIdentifier {pkgName = mkPackageName "wai", pkgVersion = mkVersion [3,2,1,2]}, pmTreeKey = TreeKey (BlobKey (decodeSHA "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") (FileSize 714)), pmCabal = toBlobKey "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" 1765})] + pkgImm `shouldBe` + [ PLIRepo + (Repo + { repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "wai" + , repoType = RepoGit + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 2, 1, 2] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") + (FileSize 714)) + , pmCabal = + toBlobKey + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + 1765 + }) + ] + + it "parses PackageLocationImmutable (Multiple Repos)" $ do + let lockFile :: ByteString + lockFile = [s|#some +dependencies: +- 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 + - 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 +|] + + pkgImm <- case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither parseLockFile pkgIm of + Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + let (WithJSONWarnings iopli _) = xs + pli <- iopli + pure $ NonEmpty.toList pli + Nothing -> fail "Can't parse PackageLocationImmutable - 2" + pkgImm `shouldBe` + [ PLIRepo + (Repo + { repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "wai" + , repoType = RepoGit + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 2, 1, 2] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") + (FileSize 714)) + , pmCabal = + toBlobKey + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + 1765 + }), + PLIRepo + (Repo + { repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "warp" + , repoType = RepoGit + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "warp" + , pkgVersion = mkVersion [3, 2, 25] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") + (FileSize 5103)) + , pmCabal = + toBlobKey + "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" + 10725 + }) + ] From 71668fc5105450da51a7a7fb0f407df493b727ac Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 11 Jan 2019 22:32:17 +0530 Subject: [PATCH 10/76] Add Monad instance for Unrseolved type --- subs/pantry/src/Pantry/Types.hs | 41 +++++++++++++++++++++------------ 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index c7f7e2a436..9bcaf252fc 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -233,6 +233,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. @@ -1531,21 +1537,26 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutab pm <- parseJSON value pure $ PLIRepo repo pm - - - -- archiveObject :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - -- archiveObject value = do - -- (WithJSONWarnings 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 $ pure $ PLIArchive Archive {..} pm - -- ) value - + archiveObject :: Value -> Parser (Unresolved PackageLocationImmutable) + archiveObject value@(Object _) = do + pm <- parseJSON value + (WithJSONWarnings pli _) <- 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 + pure pli + + archiveArray :: Value -> Parser (Unresolved (NonEmpty PackageLocationImmutable)) + archiveArray value@(Array arr) = do + let xs :: [Parser (Unresolved PackageLocationImmutable)] = Vector.toList $ Vector.map archiveObject arr + xs' = sequence xs + pli :: [Unresolved PackageLocationImmutable] <- xs' + pure (sequence $ NonEmpty.fromList pli) -- github :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) -- github value = do -- (WithJSONWarnings pm _) <- parseJSON value From b8e56cf502cc55467b588b8d4a5bbeed20e91488 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 17 Jan 2019 23:23:33 +0530 Subject: [PATCH 11/76] Commit work --- src/Stack/Build.hs | 12 +++-- src/Stack/Build/ConstructPlan.hs | 1 + src/Stack/Freeze.hs | 78 ++++++++++++++++++++++++++++---- src/Stack/Types/Config.hs | 51 +++++++++++++++++++-- 4 files changed, 125 insertions(+), 17 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 40133b50d6..6c8bf62480 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -59,6 +59,7 @@ build :: HasEnvConfig env -> Maybe FileLock -> RIO env () build msetLocalFiles mbuildLk = do + logDebug $ "build: 0" mcp <- view $ configL.to configModifyCodePage ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion fixCodePage mcp ghcVersion $ do @@ -73,6 +74,8 @@ build msetLocalFiles mbuildLk = do -- Set local files, necessary for file watching stackYaml <- view stackYamlL + logDebug $ "build: 1" + logDebug $ displayShow $ toFilePath stackYaml for_ msetLocalFiles $ \setLocalFiles -> do files <- sequence [lpFiles lp | lp <- allLocals] @@ -92,8 +95,9 @@ build msetLocalFiles mbuildLk = do boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI baseConfigOpts <- mkBaseConfigOpts boptsCli plan <- constructPlan baseConfigOpts localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) - + logDebug $ "build: 2" allowLocals <- view $ configL.to configAllowLocals + logDebug $ "build: 3" unless allowLocals $ case justLocals plan of [] -> return () localsIdents -> throwM $ LocalPackagesPresent localsIdents @@ -107,14 +111,14 @@ build msetLocalFiles mbuildLk = do (Just lk,True) -> do logDebug "All installs are local; releasing snapshot lock early." liftIO $ unlockFile lk _ -> return () - + logDebug $ "build: 4" checkCabalVersion warnAboutSplitObjs bopts warnIfExecutablesWithSameNameCouldBeOverwritten locals plan - + logDebug $ "build: 5" when (boptsPreFetch bopts) $ preFetch plan - + logDebug $ "build: 6" 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 a43092b1f9..fc9bebc526 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -200,6 +200,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap BSAll -> id BSOnlySnapshot -> stripLocals BSOnlyDependencies -> stripNonDeps deps + logDebug "constructPlan: 1" return $ takeSubset Plan { planTasks = tasks , planFinals = M.fromList finals diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 66c89df14c..796857a2db 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -1,18 +1,25 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Stack.Freeze ( freeze , FreezeOpts (..) , FreezeMode (..) + , hasLockFile + , isLockFileOutdated ) where +import qualified Prelude as Prelude 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 Stack.Config (loadConfigYaml) +import Path (addFileExtension, parent, fromAbsFile) +import Path.IO (doesFileExist) data FreezeMode = FreezeProject | FreezeSnapshot @@ -27,20 +34,25 @@ freeze (FreezeOpts mode) = do Just (p, _) -> doFreeze p mode Nothing -> logWarn "No project was found: nothing to freeze" +completePackageLocation' :: (HasProcessContext env, HasLogFunc env, HasPantryConfig env, HasEnvConfig env) => RawPackageLocation -> RIO env PackageLocation +completePackageLocation' pl = + case pl of + RPLImmutable pli -> PLImmutable <$> completePackageLocation pli + RPLMutable m -> pure $ PLMutable m + 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 + envConfig <- view envConfigL + let bconfig = envConfigBuildConfig envConfig + generateLockFile bconfig + let deps :: [RawPackageLocation] = projectDependencies p + resolver :: RawSnapshotLocation = projectResolver p + resolver' :: SnapshotLocation <- completeSnapshotLocation resolver + deps' :: [PackageLocation] <- mapM completePackageLocation' deps let rawCompleted = map toRawPL deps' rawResolver = toRawSL resolver' if rawCompleted == deps && rawResolver == resolver @@ -75,3 +87,51 @@ doFreeze p FreezeSnapshot = do logInfo "No freezing is required for the snapshot of this project" else liftIO $ B.putStr $ Yaml.encode snap' + +-- BuildConfig is in Types/Config.hs +generateLockFile :: HasEnvConfig env => BuildConfig -> RIO env () +generateLockFile bconfig = do + let stackFile = bcStackYaml bconfig + lockFile <- liftIO $ addFileExtension "lock" stackFile + iosc <- loadConfigYaml (parseStackYamlConfig (parent stackFile)) stackFile + StackYamlConfig deps resolver <- liftIO iosc + resolver' :: SnapshotLocation <- completeSnapshotLocation resolver + deps' :: [PackageLocation] <- mapM completePackageLocation' deps + liftIO $ Prelude.print deps' + let deps'' = map toRawPL deps' + let depsObject = Yaml.object [ + ("resolver", + Yaml.array + [ + object [("original", Yaml.toJSON resolver)], + object [("complete", Yaml.toJSON resolver')] + ] + ), + ("dependencies", + Yaml.array + [ + object [("original", Yaml.toJSON deps)], + object [("complete", Yaml.toJSON deps'')] + ] + )] + B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) + + +hasLockFile :: HasEnvConfig env => BuildConfig -> RIO env Bool +hasLockFile bconfig = do + let stackFile = bcStackYaml bconfig + lockFile <- liftIO $ addFileExtension "lock" stackFile + liftIO $ doesFileExist lockFile + +isLockFileOutdated :: HasEnvConfig env => BuildConfig -> RIO env Bool +isLockFileOutdated bconfig = do + let stackFile = bcStackYaml bconfig + lockFile <- liftIO $ addFileExtension "lock" stackFile + iosc <- loadConfigYaml (parseStackYamlConfig (parent stackFile)) stackFile + StackYamlConfig deps resolver <- liftIO iosc + resolver' :: SnapshotLocation <- completeSnapshotLocation resolver + deps' :: [PackageLocation] <- mapM completePackageLocation' deps + let deps'' = map toRawPL deps' + rawResolver = toRawSL resolver' + isUpdated = (deps'' == deps) && (resolver == rawResolver) + pure $ not isUpdated diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index f978089129..6973d0526f 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -91,6 +91,8 @@ module Stack.Types.Config ,Curator(..) ,ProjectAndConfigMonoid(..) ,parseProjectAndConfigMonoid + ,StackYamlConfig(..) + ,parseStackYamlConfig -- ** PvpBounds ,PvpBounds(..) ,PvpBoundsType(..) @@ -169,10 +171,12 @@ module Stack.Types.Config import Control.Monad.Writer (tell) import Crypto.Hash (hashWith, SHA1(..)) import Stack.Prelude +import qualified Data.Aeson.Types as Aeson +import qualified Data.Vector as Vector import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object, (.=), (..:), (...:), (..:?), (..!=), Value(Bool), - withObjectWarnings, WarningParser, Object, jsonSubWarnings, + withObjectWarnings, WarningParser, Object, jsonSubWarnings, unWarningParser, jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings, FromJSONKeyFunction (FromJSONKeyTextParser)) import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) @@ -223,7 +227,7 @@ import Stack.Types.Version import qualified System.FilePath as FilePath import System.PosixCompat.Types (UserID, GroupID, FileMode) import RIO.Process (ProcessContext, HasProcessContext (..), findExecutable) - +import Data.Aeson (withArray, (.:)) -- Re-exports import Stack.Types.Config.Build as X @@ -1430,11 +1434,50 @@ getCompilerPath wc = do data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid +data StackYamlConfig = StackYamlConfig { + sycDeps :: [RawPackageLocation], + sycResolver :: RawSnapshotLocation +} + +data StackLockConfig = StackLockConfig { + slcDeps :: [PackageLocation], + slcResolver :: SnapshotLocation +} + +-- tr :: Aeson.Parser a -> WarningParser a + + +-- myParser :: Value -> Yaml.Parser (WithJSONWarnings [PackageLocationImmutable]) +parseLockFile :: + Value -> Yaml.Parser [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] +parseLockFile value = do + (WithJSONWarnings val _) <- withObjectWarnings + "PackageLocationimmutable" + (\obj -> do + (deps :: Value) <- obj ..: "dependencies" + lift $ withArray "PackageLocationimmutable.complete (Array)" (\array -> do + let array' :: [Value] = Vector.toList array + array'' :: [ Yaml.Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))] = map (parseJSON) array' + sequence array'') deps + ) value + let val' :: [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] = map (\(WithJSONWarnings item warn) -> WithJSONWarnings (resolvePaths Nothing item) warn) val + pure val' + + +parseStackYamlConfig :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO StackYamlConfig)) +parseStackYamlConfig rootDir = withObjectWarnings "StackYamlConfig" $ \o -> do + deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] + resolver <- jsonSubWarnings $ o ...: ["snapshot", "resolver"] + return $ do + (deps' :: [NonEmpty RawPackageLocation]) <- mapM (resolvePaths (Just rootDir)) deps + resolver' <- resolvePaths (Just rootDir) resolver + pure $ StackYamlConfig { sycResolver = resolver', sycDeps = concatMap toList deps' } + 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)) From bad14438d3d88b114c1147f773e5d1d60bd1fd18 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 17 Jan 2019 23:23:52 +0530 Subject: [PATCH 12/76] Commit work --- snapshot.yaml | 1 + subs/pantry/package.yaml | 1 + subs/pantry/pantry.cabal | 5 ++-- subs/pantry/test/Pantry/TypesSpec.hs | 36 ++++++++++++++++++++++++++++ 4 files changed, 41 insertions(+), 2 deletions(-) diff --git a/snapshot.yaml b/snapshot.yaml index eda3def578..59b52c9c0f 100644 --- a/snapshot.yaml +++ b/snapshot.yaml @@ -17,6 +17,7 @@ packages: - cabal-doctest-1.0.6@rev:2 - unliftio-0.2.8.0@sha256:5a47f12ffcee837215c67b05abf35dffb792096564a6f81652d75a54668224cd,2250 - happy-1.19.9@sha256:f8c774230735a390c287b2980cfcd2703d24d8dde85a01ea721b7b4b4c82944f,4667 +- string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3 flags: cabal-install: diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index d4e2e7992c..646aa808fc 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -116,3 +116,4 @@ tests: - exceptions - hedgehog - QuickCheck + - string-quote diff --git a/subs/pantry/pantry.cabal b/subs/pantry/pantry.cabal index 5d6ea4acc4..2dc5b844ee 100644 --- a/subs/pantry/pantry.cabal +++ b/subs/pantry/pantry.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.30.0. +-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- --- hash: bfc4bfcec8fa396290c6a92012ae46cae07ca2bd329e9ae0ca7aaec18202474f +-- hash: c31488cb66292515d13ca79288eefcbb015bcc109ed18812cac158abde6a0685 name: pantry version: 0.1.0.0 @@ -191,6 +191,7 @@ test-suite spec , rio-orphans , safe , store-core + , string-quote , syb , tar-conduit >=0.3.0 , template-haskell diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index fc005d4691..c9773ebd2d 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -323,3 +323,39 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a 10725 }) ] + it "parses PackageLocationImmutable (RPLIArchive)" $ do + let lockFile :: ByteString + lockFile = [s|#some +dependencies: +- complete: + - size: 285152 + subdir: wai + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 710 + sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +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 +|] + + pkgImm <- case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither parseLockFile pkgIm of + Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + let (WithJSONWarnings iopli _) = xs + pli <- iopli + pure $ NonEmpty.toList pli + Nothing -> fail "Can't parse PackageLocationImmutable" + pkgImm `shouldBe` [] From a9a82684084a7f6c34e49625878cd97eb9868bd9 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 30 Jan 2019 14:28:33 +0530 Subject: [PATCH 13/76] Add test case for RPLIArchive --- subs/pantry/test/Pantry/TypesSpec.hs | 56 +++++++++++++++++++++------- 1 file changed, 43 insertions(+), 13 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index c9773ebd2d..c76430f5c8 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -324,8 +324,8 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a }) ] it "parses PackageLocationImmutable (RPLIArchive)" $ do - let lockFile :: ByteString - lockFile = [s|#some + let lockFile :: ByteString + lockFile = [s|#some dependencies: - complete: - size: 285152 @@ -348,14 +348,44 @@ resolver: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a |] - - pkgImm <- case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of - Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - let (WithJSONWarnings iopli _) = xs - pli <- iopli - pure $ NonEmpty.toList pli - Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` [] + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither parseLockFile pkgIm of + Left str -> + fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + let (WithJSONWarnings iopli _) = xs + pli <- iopli + pure $ NonEmpty.toList pli + Nothing -> fail "Can't parse PackageLocationImmutable" + pkgImm `shouldBe` + [ PLIArchive + (Archive + { archiveLocation = + ALUrl + "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" + , archiveHash = + decodeSHA + "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" + , archiveSize = FileSize 285152 + , archiveSubdir = "wai" + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 0, 2, 3] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") + (FileSize 710)) + , pmCabal = + toBlobKey + "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" + 1717 + }) + ] From da478981d0dcefab07c3edb25412346c0f7d46e9 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 30 Jan 2019 14:28:53 +0530 Subject: [PATCH 14/76] Add parsing logic for archive --- subs/pantry/src/Pantry/Types.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 954f1ca4be..913beb6aa2 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1542,13 +1542,13 @@ parseLockFile value = do pliResolve :: Vector (WithJSONWarnings (IO (NonEmpty (PackageLocationImmutable)))) = Vector.map (\(WithJSONWarnings item warn) -> - (WithJSONWarnings (resolvePaths Nothing item) warn)) + (WithJSONWarnings (resolvePaths Nothing item) warn)) -- todo: Fix Root path pli pure $ Vector.foldr1 appendPLI pliResolve instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) where - parseJSON v = repo v + parseJSON v = repo v <|> archiveArray v <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where hackageText :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) @@ -1591,14 +1591,14 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutab archiveLocation <- mkArchiveLocation mdir pure $ PLIArchive Archive {..} pm ) value - pure pli + pure $ pli - archiveArray :: Value -> Parser (Unresolved (NonEmpty PackageLocationImmutable)) + archiveArray :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) archiveArray value@(Array arr) = do let xs :: [Parser (Unresolved PackageLocationImmutable)] = Vector.toList $ Vector.map archiveObject arr xs' = sequence xs pli :: [Unresolved PackageLocationImmutable] <- xs' - pure (sequence $ NonEmpty.fromList pli) + pure $ noJSONWarnings (sequence $ NonEmpty.fromList pli) -- github :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) -- github value = do -- (WithJSONWarnings pm _) <- parseJSON value From fb3446c089f6d80cd69cbde146c8bdfaa1baabeb Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 30 Jan 2019 14:33:16 +0530 Subject: [PATCH 15/76] Add test for multiple RPLIArchive --- subs/pantry/test/Pantry/TypesSpec.hs | 106 +++++++++++++++++++++++++++ 1 file changed, 106 insertions(+) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index c76430f5c8..7b2d1be4f0 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -389,3 +389,109 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a 1717 }) ] + it "parses PackageLocationImmutable (multiple RPLIArchive)" $ do + let lockFile :: ByteString + lockFile = [s|#some +dependencies: +- complete: + - size: 285152 + subdir: wai + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 710 + sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc + - size: 285152 + subdir: wai + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 710 + sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +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 +|] + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither parseLockFile pkgIm of + Left str -> + fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + let (WithJSONWarnings iopli _) = xs + pli <- iopli + pure $ NonEmpty.toList pli + Nothing -> fail "Can't parse PackageLocationImmutable" + pkgImm `shouldBe` + [ PLIArchive + (Archive + { archiveLocation = + ALUrl + "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" + , archiveHash = + decodeSHA + "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" + , archiveSize = FileSize 285152 + , archiveSubdir = "wai" + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 0, 2, 3] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") + (FileSize 710)) + , pmCabal = + toBlobKey + "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" + 1717 + }), + PLIArchive + (Archive + { archiveLocation = + ALUrl + "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" + , archiveHash = + decodeSHA + "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" + , archiveSize = FileSize 285152 + , archiveSubdir = "wai" + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 0, 2, 3] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") + (FileSize 710)) + , pmCabal = + toBlobKey + "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" + 1717 + }) + ] From c868f6a4ef085292c47441f7d9e8ffea78c885af Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 30 Jan 2019 22:14:15 +0530 Subject: [PATCH 16/76] Change the parsing logic for individual objects --- subs/pantry/src/Pantry/Types.hs | 87 +++-- subs/pantry/test/Pantry/TypesSpec.hs | 522 ++++++++++++++++----------- 2 files changed, 363 insertions(+), 246 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 913beb6aa2..18aa652044 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1503,15 +1503,15 @@ rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] -appendPLI :: WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -> WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -> WithJSONWarnings (IO (NonEmpty PackageLocationImmutable)) -appendPLI (WithJSONWarnings item1 warn1) (WithJSONWarnings item2 warn2) = WithJSONWarnings (item1 <> item2) (warn1 <> warn2) +appendPLI :: NonEmpty (IO PackageLocationImmutable) -> NonEmpty (IO PackageLocationImmutable) -> NonEmpty (IO PackageLocationImmutable) +appendPLI xs ys = xs <> ys isCompleteObject :: Value -> Bool isCompleteObject obj@(Object xs) = HM.member "complete" xs isCompleteObject _ = False parseLockFile :: - Value -> Parser (WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))) + Value -> Parser (NonEmpty (IO PackageLocationImmutable)) parseLockFile value = do (WithJSONWarnings val _) <- withObjectWarnings @@ -1524,11 +1524,11 @@ parseLockFile value = do (\vector -> do let vector' :: Array = Vector.filter isCompleteObject vector - let pli :: Vector (Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))) = + let pli :: Vector (Parser (NonEmpty (Unresolved PackageLocationImmutable))) = Vector.map (\(Object o) -> do complete <- o .: "complete" - pl :: (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) <- + pl :: (NonEmpty (Unresolved PackageLocationImmutable)) <- parseJSON complete pure pl) vector' @@ -1537,47 +1537,41 @@ parseLockFile value = do pure pli') deps) value - let pli :: Vector (WithJSONWarnings (Unresolved (NonEmpty (PackageLocationImmutable)))) = + let pli :: Vector (NonEmpty (Unresolved (PackageLocationImmutable))) = val - pliResolve :: Vector (WithJSONWarnings (IO (NonEmpty (PackageLocationImmutable)))) = - Vector.map - (\(WithJSONWarnings item warn) -> - (WithJSONWarnings (resolvePaths Nothing item) warn)) -- todo: Fix Root path - pli + pliResolve :: Vector (NonEmpty (IO PackageLocationImmutable)) = + Vector.map (\item -> NE.map (resolvePaths Nothing) item) pli -- todo: Fix Root path pure $ Vector.foldr1 appendPLI pliResolve - -instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) where - parseJSON v = repo v <|> archiveArray v +instance FromJSON (Unresolved PackageLocationImmutable) where + parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where - hackageText :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - hackageText value = do - tkey <- withObject "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do - treeKey <- o .: "pantry-tree" - pure treeKey) value - withText "UnresolvedPackageLocationImmutable.PLIHackage (Text)" (\t -> do - case parseHackageText t of - Left e -> fail $ show e - Right (pkgIdentifier, blobKey) -> pure $ noJSONWarnings $ pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey tkey)) value - - repo :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - repo value@(Array objs) = do - pli :: NonEmpty PackageLocationImmutable <- repos value - pure $ noJSONWarnings $ pure $ pli - - repos :: Value -> Parser (NonEmpty PackageLocationImmutable) - repos value@(Array arr) = do - let xs :: [Parser PackageLocationImmutable] = Vector.toList $ Vector.map repoObject arr - xs' :: Parser [PackageLocationImmutable] = sequence xs - pli <- xs' - pure $ NonEmpty.fromList pli - - repoObject :: Value -> Parser PackageLocationImmutable + -- repo :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + -- repo value@(Array objs) = do + -- pli :: NonEmpty PackageLocationImmutable <- repos value + -- pure $ noJSONWarnings $ pure $ pli + + -- repos :: Value -> Parser (NonEmpty PackageLocationImmutable) + -- repos value@(Array arr) = do + -- let xs :: [Parser PackageLocationImmutable] = Vector.toList $ Vector.map repoObject arr + -- xs' :: Parser [PackageLocationImmutable] = sequence xs + -- pli <- xs' + -- pure $ NonEmpty.fromList pli + + repoObject :: Value -> Parser (Unresolved PackageLocationImmutable) repoObject value@(Object _) = do repo <- parseJSON value pm <- parseJSON value - pure $ PLIRepo repo pm + pure $ pure $ PLIRepo repo pm + + -- hackageObject :: Value -> Parser (Unresolved PackageLocationImmutable) + -- hackageObject value@(Object _) = do + -- (WithJSONWarnings pli _) <- withObjectWarnings "UnresolvedPackageLocationImmutable.PLIHackage" (\o -> do + -- hackageText <- o ..: "hackage" + -- case parseHackageText t of + -- Left e -> fail $ show e + -- Right (pkgIdentifier, blobKey) -> pure $ noJSONWarnings $ pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey tkey)) value archiveObject :: Value -> Parser (Unresolved PackageLocationImmutable) archiveObject value@(Object _) = do @@ -1599,6 +1593,23 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutab xs' = sequence xs pli :: [Unresolved PackageLocationImmutable] <- xs' pure $ noJSONWarnings (sequence $ NonEmpty.fromList pli) + + hackageArray :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) + hackageArray value@(Array arr) = do + let xs :: [Parser (Unresolved PackageLocationImmutable)] = Vector.toList $ Vector.map hackageObject arr + xs' = sequence xs + pli :: [Unresolved PackageLocationImmutable] <- xs' + pure $ noJSONWarnings (sequence $ NonEmpty.fromList 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 (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) -- github value = do -- (WithJSONWarnings pm _) <- parseJSON value diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 7b2d1be4f0..165d265185 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -197,9 +197,8 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a case Yaml.parseEither parseLockFile pkgIm of Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str Right xs -> do - let (WithJSONWarnings iopli _) = xs - pli <- iopli - pure $ NonEmpty.toList pli + xs' <- sequence xs + pure $ NonEmpty.toList xs' Nothing -> fail "Can't parse PackageLocationImmutable - 2" pkgImm `shouldBe` [ PLIRepo @@ -228,184 +227,316 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a }) ] - it "parses PackageLocationImmutable (Multiple Repos)" $ do - let lockFile :: ByteString - lockFile = [s|#some -dependencies: -- 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 - - 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 -|] +-- it "parses PackageLocationImmutable (Multiple Repos)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - 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 +-- - 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 +-- |] - pkgImm <- case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of - Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - let (WithJSONWarnings iopli _) = xs - pli <- iopli - pure $ NonEmpty.toList pli - Nothing -> fail "Can't parse PackageLocationImmutable - 2" - pkgImm `shouldBe` - [ PLIRepo - (Repo - { repoUrl = "https://github.com/yesodweb/wai.git" - , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" - , repoSubdir = "wai" - , repoType = RepoGit - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 2, 1, 2] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") - (FileSize 714)) - , pmCabal = - toBlobKey - "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" - 1765 - }), - PLIRepo - (Repo - { repoUrl = "https://github.com/yesodweb/wai.git" - , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" - , repoSubdir = "warp" - , repoType = RepoGit - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "warp" - , pkgVersion = mkVersion [3, 2, 25] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") - (FileSize 5103)) - , pmCabal = - toBlobKey - "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" - 10725 - }) - ] - it "parses PackageLocationImmutable (RPLIArchive)" $ do +-- pkgImm <- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither parseLockFile pkgIm of +-- Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right xs -> do +-- let (WithJSONWarnings iopli _) = xs +-- pli <- iopli +-- pure $ NonEmpty.toList pli +-- Nothing -> fail "Can't parse PackageLocationImmutable - 2" +-- pkgImm `shouldBe` +-- [ PLIRepo +-- (Repo +-- { repoUrl = "https://github.com/yesodweb/wai.git" +-- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" +-- , repoSubdir = "wai" +-- , repoType = RepoGit +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 2, 1, 2] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") +-- (FileSize 714)) +-- , pmCabal = +-- toBlobKey +-- "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" +-- 1765 +-- }), +-- PLIRepo +-- (Repo +-- { repoUrl = "https://github.com/yesodweb/wai.git" +-- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" +-- , repoSubdir = "warp" +-- , repoType = RepoGit +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "warp" +-- , pkgVersion = mkVersion [3, 2, 25] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") +-- (FileSize 5103)) +-- , pmCabal = +-- toBlobKey +-- "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" +-- 10725 +-- }) +-- ] +-- it "parses PackageLocationImmutable (RPLIArchive)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - complete: +-- - size: 285152 +-- subdir: wai +-- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip +-- cabal-file: +-- size: 1717 +-- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 +-- name: wai +-- version: 3.0.2.3 +-- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba +-- pantry-tree: +-- size: 710 +-- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +-- 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 +-- |] +-- pkgImm <- +-- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither parseLockFile pkgIm of +-- Left str -> +-- fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right xs -> do +-- let (WithJSONWarnings iopli _) = xs +-- pli <- iopli +-- pure $ NonEmpty.toList pli +-- Nothing -> fail "Can't parse PackageLocationImmutable" +-- pkgImm `shouldBe` +-- [ PLIArchive +-- (Archive +-- { archiveLocation = +-- ALUrl +-- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" +-- , archiveHash = +-- decodeSHA +-- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" +-- , archiveSize = FileSize 285152 +-- , archiveSubdir = "wai" +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 0, 2, 3] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") +-- (FileSize 710)) +-- , pmCabal = +-- toBlobKey +-- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" +-- 1717 +-- }) +-- ] +-- it "parses PackageLocationImmutable (multiple RPLIArchive)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - complete: +-- - size: 285152 +-- subdir: wai +-- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip +-- cabal-file: +-- size: 1717 +-- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 +-- name: wai +-- version: 3.0.2.3 +-- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba +-- pantry-tree: +-- size: 710 +-- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +-- - size: 285152 +-- subdir: wai +-- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip +-- cabal-file: +-- size: 1717 +-- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 +-- name: wai +-- version: 3.0.2.3 +-- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba +-- pantry-tree: +-- size: 710 +-- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +-- 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 +-- |] +-- pkgImm <- +-- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither parseLockFile pkgIm of +-- Left str -> +-- fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right xs -> do +-- let (WithJSONWarnings iopli _) = xs +-- pli <- iopli +-- pure $ NonEmpty.toList pli +-- Nothing -> fail "Can't parse PackageLocationImmutable" +-- pkgImm `shouldBe` +-- [ PLIArchive +-- (Archive +-- { archiveLocation = +-- ALUrl +-- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" +-- , archiveHash = +-- decodeSHA +-- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" +-- , archiveSize = FileSize 285152 +-- , archiveSubdir = "wai" +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 0, 2, 3] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") +-- (FileSize 710)) +-- , pmCabal = +-- toBlobKey +-- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" +-- 1717 +-- }), +-- PLIArchive +-- (Archive +-- { archiveLocation = +-- ALUrl +-- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" +-- , archiveHash = +-- decodeSHA +-- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" +-- , archiveSize = FileSize 285152 +-- , archiveSubdir = "wai" +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 0, 2, 3] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") +-- (FileSize 710)) +-- , pmCabal = +-- toBlobKey +-- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" +-- 1717 +-- }) +-- ] +-- it "parses PackageLocationImmutable (PLIHackage)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - complete: +-- - hackage: persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058 +-- pantry-tree: +-- size: 2165 +-- sha256: 3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce +-- 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 +-- |] +-- pkgImm <- +-- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither parseLockFile pkgIm of +-- Left str -> +-- fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right xs -> do +-- let (WithJSONWarnings iopli _) = xs +-- pli <- iopli +-- pure $ NonEmpty.toList pli +-- Nothing -> fail "Can't parse PackageLocationImmutable" +-- pkgImm `shouldBe` [PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey +-- "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey +-- (BlobKey +-- (decodeSHA +-- "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") +-- (FileSize 2165)))] + it "parses PackageLocationImmutable (PLIHackage & PLIArchive)" $ do let lockFile :: ByteString lockFile = [s|#some dependencies: - complete: - - size: 285152 - subdir: wai - url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip - cabal-file: - size: 1717 - sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 - name: wai - version: 3.0.2.3 - sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + - hackage: persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058 pantry-tree: - size: 710 - sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc -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 -|] - pkgImm <- - case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of - Left str -> - fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - let (WithJSONWarnings iopli _) = xs - pli <- iopli - pure $ NonEmpty.toList pli - Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` - [ PLIArchive - (Archive - { archiveLocation = - ALUrl - "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" - , archiveHash = - decodeSHA - "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" - , archiveSize = FileSize 285152 - , archiveSubdir = "wai" - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 0, 2, 3] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") - (FileSize 710)) - , pmCabal = - toBlobKey - "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" - 1717 - }) - ] - it "parses PackageLocationImmutable (multiple RPLIArchive)" $ do - let lockFile :: ByteString - lockFile = [s|#some -dependencies: -- complete: - - size: 285152 - subdir: wai - url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip - cabal-file: - size: 1717 - sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 - name: wai - version: 3.0.2.3 - sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba - pantry-tree: - size: 710 - sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc + size: 2165 + sha256: 3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce - size: 285152 subdir: wai url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip @@ -433,40 +564,16 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str Right xs -> do - let (WithJSONWarnings iopli _) = xs - pli <- iopli - pure $ NonEmpty.toList pli + xs' <- sequence xs + pure $ NonEmpty.toList xs' Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` - [ PLIArchive - (Archive - { archiveLocation = - ALUrl - "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" - , archiveHash = - decodeSHA - "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" - , archiveSize = FileSize 285152 - , archiveSubdir = "wai" - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 0, 2, 3] - } - , pmTreeKey = - TreeKey + pkgImm `shouldBe` [PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey + "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey (BlobKey (decodeSHA - "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") - (FileSize 710)) - , pmCabal = - toBlobKey - "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" - 1717 - }), - PLIArchive + "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") + (FileSize 2165))), + PLIArchive (Archive { archiveLocation = ALUrl @@ -493,5 +600,4 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a toBlobKey "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" 1717 - }) - ] + })] From 446b147f7265056a488c7d020fae3ffc8b3a9467 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 31 Jan 2019 13:24:24 +0530 Subject: [PATCH 17/76] Fix compile errors --- subs/pantry/test/Pantry/TypesSpec.hs | 597 +++++++++++++-------------- 1 file changed, 296 insertions(+), 301 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 165d265185..f41b91e97e 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -227,307 +227,302 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a }) ] --- it "parses PackageLocationImmutable (Multiple Repos)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - 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 --- - 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 --- |] - --- pkgImm <- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither parseLockFile pkgIm of --- Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right xs -> do --- let (WithJSONWarnings iopli _) = xs --- pli <- iopli --- pure $ NonEmpty.toList pli --- Nothing -> fail "Can't parse PackageLocationImmutable - 2" --- pkgImm `shouldBe` --- [ PLIRepo --- (Repo --- { repoUrl = "https://github.com/yesodweb/wai.git" --- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" --- , repoSubdir = "wai" --- , repoType = RepoGit --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 2, 1, 2] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") --- (FileSize 714)) --- , pmCabal = --- toBlobKey --- "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" --- 1765 --- }), --- PLIRepo --- (Repo --- { repoUrl = "https://github.com/yesodweb/wai.git" --- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" --- , repoSubdir = "warp" --- , repoType = RepoGit --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "warp" --- , pkgVersion = mkVersion [3, 2, 25] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") --- (FileSize 5103)) --- , pmCabal = --- toBlobKey --- "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" --- 10725 --- }) --- ] --- it "parses PackageLocationImmutable (RPLIArchive)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - complete: --- - size: 285152 --- subdir: wai --- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip --- cabal-file: --- size: 1717 --- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 --- name: wai --- version: 3.0.2.3 --- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba --- pantry-tree: --- size: 710 --- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc --- 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 --- |] --- pkgImm <- --- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither parseLockFile pkgIm of --- Left str -> --- fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right xs -> do --- let (WithJSONWarnings iopli _) = xs --- pli <- iopli --- pure $ NonEmpty.toList pli --- Nothing -> fail "Can't parse PackageLocationImmutable" --- pkgImm `shouldBe` --- [ PLIArchive --- (Archive --- { archiveLocation = --- ALUrl --- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" --- , archiveHash = --- decodeSHA --- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" --- , archiveSize = FileSize 285152 --- , archiveSubdir = "wai" --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 0, 2, 3] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") --- (FileSize 710)) --- , pmCabal = --- toBlobKey --- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" --- 1717 --- }) --- ] --- it "parses PackageLocationImmutable (multiple RPLIArchive)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - complete: --- - size: 285152 --- subdir: wai --- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip --- cabal-file: --- size: 1717 --- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 --- name: wai --- version: 3.0.2.3 --- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba --- pantry-tree: --- size: 710 --- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc --- - size: 285152 --- subdir: wai --- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip --- cabal-file: --- size: 1717 --- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 --- name: wai --- version: 3.0.2.3 --- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba --- pantry-tree: --- size: 710 --- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc --- 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 --- |] --- pkgImm <- --- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither parseLockFile pkgIm of --- Left str -> --- fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right xs -> do --- let (WithJSONWarnings iopli _) = xs --- pli <- iopli --- pure $ NonEmpty.toList pli --- Nothing -> fail "Can't parse PackageLocationImmutable" --- pkgImm `shouldBe` --- [ PLIArchive --- (Archive --- { archiveLocation = --- ALUrl --- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" --- , archiveHash = --- decodeSHA --- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" --- , archiveSize = FileSize 285152 --- , archiveSubdir = "wai" --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 0, 2, 3] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") --- (FileSize 710)) --- , pmCabal = --- toBlobKey --- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" --- 1717 --- }), --- PLIArchive --- (Archive --- { archiveLocation = --- ALUrl --- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" --- , archiveHash = --- decodeSHA --- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" --- , archiveSize = FileSize 285152 --- , archiveSubdir = "wai" --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 0, 2, 3] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") --- (FileSize 710)) --- , pmCabal = --- toBlobKey --- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" --- 1717 --- }) --- ] --- it "parses PackageLocationImmutable (PLIHackage)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - complete: --- - hackage: persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058 --- pantry-tree: --- size: 2165 --- sha256: 3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce --- 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 --- |] --- pkgImm <- --- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither parseLockFile pkgIm of --- Left str -> --- fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right xs -> do --- let (WithJSONWarnings iopli _) = xs --- pli <- iopli --- pure $ NonEmpty.toList pli --- Nothing -> fail "Can't parse PackageLocationImmutable" --- pkgImm `shouldBe` [PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey --- "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey --- (BlobKey --- (decodeSHA --- "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") --- (FileSize 2165)))] + it "parses PackageLocationImmutable (Multiple Repos)" $ do + let lockFile :: ByteString + lockFile = [s|#some +dependencies: +- 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 + - 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 +|] + pkgImm <- case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither parseLockFile pkgIm of + Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + xs' <- sequence xs + pure $ NonEmpty.toList xs' + Nothing -> fail "Can't parse PackageLocationImmutable - 2" + pkgImm `shouldBe` + [ PLIRepo + (Repo + { repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "wai" + , repoType = RepoGit + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 2, 1, 2] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") + (FileSize 714)) + , pmCabal = + toBlobKey + "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" + 1765 + }), + PLIRepo + (Repo + { repoUrl = "https://github.com/yesodweb/wai.git" + , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" + , repoSubdir = "warp" + , repoType = RepoGit + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "warp" + , pkgVersion = mkVersion [3, 2, 25] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") + (FileSize 5103)) + , pmCabal = + toBlobKey + "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" + 10725 + }) + ] + it "parses PackageLocationImmutable (RPLIArchive)" $ do + let lockFile :: ByteString + lockFile = [s|#some +dependencies: +- complete: + - size: 285152 + subdir: wai + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 710 + sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +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 +|] + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither parseLockFile pkgIm of + Left str -> + fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + xs' <- sequence xs + pure $ NonEmpty.toList xs' + Nothing -> fail "Can't parse PackageLocationImmutable" + pkgImm `shouldBe` + [ PLIArchive + (Archive + { archiveLocation = + ALUrl + "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" + , archiveHash = + decodeSHA + "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" + , archiveSize = FileSize 285152 + , archiveSubdir = "wai" + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 0, 2, 3] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") + (FileSize 710)) + , pmCabal = + toBlobKey + "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" + 1717 + }) + ] + it "parses PackageLocationImmutable (multiple RPLIArchive)" $ do + let lockFile :: ByteString + lockFile = [s|#some +dependencies: +- complete: + - size: 285152 + subdir: wai + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 710 + sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc + - size: 285152 + subdir: wai + url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip + cabal-file: + size: 1717 + sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + name: wai + version: 3.0.2.3 + sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + pantry-tree: + size: 710 + sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +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 +|] + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither parseLockFile pkgIm of + Left str -> + fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + xs' <- sequence xs + pure $ NonEmpty.toList xs' + Nothing -> fail "Can't parse PackageLocationImmutable" + pkgImm `shouldBe` + [ PLIArchive + (Archive + { archiveLocation = + ALUrl + "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" + , archiveHash = + decodeSHA + "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" + , archiveSize = FileSize 285152 + , archiveSubdir = "wai" + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 0, 2, 3] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") + (FileSize 710)) + , pmCabal = + toBlobKey + "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" + 1717 + }), + PLIArchive + (Archive + { archiveLocation = + ALUrl + "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" + , archiveHash = + decodeSHA + "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" + , archiveSize = FileSize 285152 + , archiveSubdir = "wai" + }) + (PackageMetadata + { pmIdent = + PackageIdentifier + { pkgName = mkPackageName "wai" + , pkgVersion = mkVersion [3, 0, 2, 3] + } + , pmTreeKey = + TreeKey + (BlobKey + (decodeSHA + "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") + (FileSize 710)) + , pmCabal = + toBlobKey + "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" + 1717 + }) + ] + it "parses PackageLocationImmutable (PLIHackage)" $ do + let lockFile :: ByteString + lockFile = [s|#some +dependencies: +- complete: + - hackage: persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058 + pantry-tree: + size: 2165 + sha256: 3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce +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 +|] + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither parseLockFile pkgIm of + Left str -> + fail $ "Can't parse PackageLocationImmutable - 1" <> str + Right xs -> do + xs' <- sequence xs + pure $ NonEmpty.toList xs' + Nothing -> fail "Can't parse PackageLocationImmutable" + pkgImm `shouldBe` [PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey + "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey + (BlobKey + (decodeSHA + "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") + (FileSize 2165)))] it "parses PackageLocationImmutable (PLIHackage & PLIArchive)" $ do let lockFile :: ByteString lockFile = [s|#some From c76b1f644bb0a48b840cb51fdebf3a6c71a8f012 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Sun, 3 Feb 2019 17:37:41 +0530 Subject: [PATCH 18/76] Commit work --- src/Stack/Freeze.hs | 24 +- src/Stack/Types/Config.hs | 20 - subs/pantry/src/Pantry.hs | 1 + subs/pantry/src/Pantry/Types.hs | 84 ++-- subs/pantry/test/Pantry/TypesSpec.hs | 629 ++++++++++++++------------- 5 files changed, 378 insertions(+), 380 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 796857a2db..3218b5bf2a 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -18,8 +18,9 @@ import qualified RIO.ByteString as B import Stack.Prelude import Stack.Types.Config import Stack.Config (loadConfigYaml) -import Path (addFileExtension, parent, fromAbsFile) +import Path (addFileExtension, parent, fromAbsFile, toFilePath) import Path.IO (doesFileExist) +import qualified Data.List.NonEmpty as NE data FreezeMode = FreezeProject | FreezeSnapshot @@ -49,6 +50,7 @@ doFreeze p FreezeProject = do envConfig <- view envConfigL let bconfig = envConfigBuildConfig envConfig generateLockFile bconfig + isLockFileOutdated bconfig -- todo: remove this in future (just for testing) let deps :: [RawPackageLocation] = projectDependencies p resolver :: RawSnapshotLocation = projectResolver p resolver' :: SnapshotLocation <- completeSnapshotLocation resolver @@ -97,7 +99,6 @@ generateLockFile bconfig = do StackYamlConfig deps resolver <- liftIO iosc resolver' :: SnapshotLocation <- completeSnapshotLocation resolver deps' :: [PackageLocation] <- mapM completePackageLocation' deps - liftIO $ Prelude.print deps' let deps'' = map toRawPL deps' let depsObject = Yaml.object [ ("resolver", @@ -123,9 +124,21 @@ hasLockFile bconfig = do lockFile <- liftIO $ addFileExtension "lock" stackFile liftIO $ doesFileExist lockFile +parsePLI :: HasEnvConfig env => BuildConfig -> RIO env [PackageLocation] +parsePLI bconfig = do + let stackFile = bcStackYaml bconfig + rootDir = parent stackFile + lockFile <- liftIO $ addFileExtension "lock" stackFile + (pli :: Yaml.Value) <- Yaml.decodeFileThrow (toFilePath lockFile) + plis <- Yaml.parseMonad (parseLockFile rootDir) pli + plis' <- liftIO $ plis + pure $ NE.toList plis' + +-- Parse the orignial stack file and then parse the lock file and then compare it with the original file content isLockFileOutdated :: HasEnvConfig env => BuildConfig -> RIO env Bool isLockFileOutdated bconfig = do let stackFile = bcStackYaml bconfig + plis <- parsePLI bconfig lockFile <- liftIO $ addFileExtension "lock" stackFile iosc <- loadConfigYaml (parseStackYamlConfig (parent stackFile)) stackFile StackYamlConfig deps resolver <- liftIO iosc @@ -134,4 +147,11 @@ isLockFileOutdated bconfig = do let deps'' = map toRawPL deps' rawResolver = toRawSL resolver' isUpdated = (deps'' == deps) && (resolver == rawResolver) + liftIO $ Prelude.print "raw PLI" + liftIO $ Prelude.print deps + liftIO $ Prelude.print "raw PLI from complete" + liftIO $ Prelude.print plis pure $ not isUpdated + + +-- Use loadProjectConfig and parseLockfile to see if lock file has been outdated diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 3c7499eb62..d2f10bfca7 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1445,26 +1445,6 @@ data StackLockConfig = StackLockConfig { slcResolver :: SnapshotLocation } --- tr :: Aeson.Parser a -> WarningParser a - - --- myParser :: Value -> Yaml.Parser (WithJSONWarnings [PackageLocationImmutable]) -parseLockFile :: - Value -> Yaml.Parser [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] -parseLockFile value = do - (WithJSONWarnings val _) <- withObjectWarnings - "PackageLocationimmutable" - (\obj -> do - (deps :: Value) <- obj ..: "dependencies" - lift $ withArray "PackageLocationimmutable.complete (Array)" (\array -> do - let array' :: [Value] = Vector.toList array - array'' :: [ Yaml.Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable)))] = map (parseJSON) array' - sequence array'') deps - ) value - let val' :: [WithJSONWarnings (IO (NonEmpty PackageLocationImmutable))] = map (\(WithJSONWarnings item warn) -> WithJSONWarnings (resolvePaths Nothing item) warn) val - pure val' - - parseStackYamlConfig :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO StackYamlConfig)) parseStackYamlConfig rootDir = withObjectWarnings "StackYamlConfig" $ \o -> do deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index bbb616657b..cc8276933a 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -106,6 +106,7 @@ module Pantry , parsePackageIdentifierRevision , parseHackageText , parseLockFile + , parseAndResolvePackageLocation -- ** Cabal values , parsePackageIdentifier diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 18aa652044..7310818d35 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -67,6 +67,7 @@ module Pantry.Types , packageIdentifierString , packageNameString , parseLockFile + , parseAndResolvePackageLocation , flagNameString , versionString , moduleNameString @@ -1452,6 +1453,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) @@ -1503,16 +1524,24 @@ rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] -appendPLI :: NonEmpty (IO PackageLocationImmutable) -> NonEmpty (IO PackageLocationImmutable) -> NonEmpty (IO PackageLocationImmutable) +appendPLI :: NonEmpty (IO PackageLocation) -> NonEmpty (IO PackageLocation) -> NonEmpty (IO PackageLocation) appendPLI xs ys = xs <> ys +appendPLI' :: IO (NonEmpty PackageLocation) -> IO (NonEmpty PackageLocation) -> IO (NonEmpty PackageLocation) +appendPLI' xs ys = xs <> ys + isCompleteObject :: Value -> Bool isCompleteObject obj@(Object xs) = HM.member "complete" xs isCompleteObject _ = False +parseAndResolvePackageLocation :: Path Abs Dir -> Value -> Parser (IO (NonEmpty PackageLocation)) +parseAndResolvePackageLocation rootDir v = do + (Unresolved unresolvedPL) <- parsePackageLocation v + pure $ unresolvedPL (Just rootDir) + parseLockFile :: - Value -> Parser (NonEmpty (IO PackageLocationImmutable)) -parseLockFile value = do + Path Abs Dir -> Value -> Parser (IO (NonEmpty PackageLocation)) +parseLockFile rootDir value = do (WithJSONWarnings val _) <- withObjectWarnings "PackageLocationimmutable" @@ -1524,55 +1553,32 @@ parseLockFile value = do (\vector -> do let vector' :: Array = Vector.filter isCompleteObject vector - let pli :: Vector (Parser (NonEmpty (Unresolved PackageLocationImmutable))) = + let pli :: Vector (Parser (IO (NonEmpty PackageLocation))) = Vector.map (\(Object o) -> do complete <- o .: "complete" - pl :: (NonEmpty (Unresolved PackageLocationImmutable)) <- - parseJSON complete + pl :: (IO (NonEmpty PackageLocation)) <- + parseAndResolvePackageLocation rootDir complete pure pl) vector' pliSeq = sequence pli - pli' <- pliSeq + pli' :: Vector (IO (NonEmpty PackageLocation)) <- pliSeq pure pli') deps) value - let pli :: Vector (NonEmpty (Unresolved (PackageLocationImmutable))) = - val - pliResolve :: Vector (NonEmpty (IO PackageLocationImmutable)) = - Vector.map (\item -> NE.map (resolvePaths Nothing) item) pli -- todo: Fix Root path - pure $ Vector.foldr1 appendPLI pliResolve + let pli :: Vector (IO (NonEmpty (PackageLocation))) = val + pure $ Vector.foldr1 appendPLI' pli instance FromJSON (Unresolved PackageLocationImmutable) where parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where - -- repo :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - -- repo value@(Array objs) = do - -- pli :: NonEmpty PackageLocationImmutable <- repos value - -- pure $ noJSONWarnings $ pure $ pli - - -- repos :: Value -> Parser (NonEmpty PackageLocationImmutable) - -- repos value@(Array arr) = do - -- let xs :: [Parser PackageLocationImmutable] = Vector.toList $ Vector.map repoObject arr - -- xs' :: Parser [PackageLocationImmutable] = sequence xs - -- pli <- xs' - -- pure $ NonEmpty.fromList pli - repoObject :: Value -> Parser (Unresolved PackageLocationImmutable) repoObject value@(Object _) = do repo <- parseJSON value pm <- parseJSON value pure $ pure $ PLIRepo repo pm - -- hackageObject :: Value -> Parser (Unresolved PackageLocationImmutable) - -- hackageObject value@(Object _) = do - -- (WithJSONWarnings pli _) <- withObjectWarnings "UnresolvedPackageLocationImmutable.PLIHackage" (\o -> do - -- hackageText <- o ..: "hackage" - -- case parseHackageText t of - -- Left e -> fail $ show e - -- Right (pkgIdentifier, blobKey) -> pure $ noJSONWarnings $ pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey tkey)) value - archiveObject :: Value -> Parser (Unresolved PackageLocationImmutable) archiveObject value@(Object _) = do pm <- parseJSON value @@ -1587,20 +1593,6 @@ instance FromJSON (Unresolved PackageLocationImmutable) where ) value pure $ pli - archiveArray :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - archiveArray value@(Array arr) = do - let xs :: [Parser (Unresolved PackageLocationImmutable)] = Vector.toList $ Vector.map archiveObject arr - xs' = sequence xs - pli :: [Unresolved PackageLocationImmutable] <- xs' - pure $ noJSONWarnings (sequence $ NonEmpty.fromList pli) - - hackageArray :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - hackageArray value@(Array arr) = do - let xs :: [Parser (Unresolved PackageLocationImmutable)] = Vector.toList $ Vector.map hackageObject arr - xs' = sequence xs - pli :: [Unresolved PackageLocationImmutable] <- xs' - pure $ noJSONWarnings (sequence $ NonEmpty.fromList pli) - hackageObject :: Value -> Parser (Unresolved PackageLocationImmutable) hackageObject value = withObject "UnresolvedPackagelocationimmutable.PLIHackage (Object)" (\o -> do diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index f41b91e97e..daf81a2f00 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -27,6 +27,7 @@ import qualified Data.List as List import Data.List.NonEmpty hiding (map) import Data.String.Quote import qualified Data.Vector as Vector +import qualified Path as Path import Data.Semigroup hh :: HasCallStack => String -> Property -> Spec @@ -191,17 +192,17 @@ resolver: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a |] - + rootDir <- Path.parseAbsDir "/home/sibi" pkgImm <- case Yaml.decodeThrow lockFile of Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of + case Yaml.parseEither (parseLockFile rootDir) pkgIm of Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - xs' <- sequence xs - pure $ NonEmpty.toList xs' + Right iopl -> do + pl <- iopl + pure $ NonEmpty.toList pl Nothing -> fail "Can't parse PackageLocationImmutable - 2" pkgImm `shouldBe` - [ PLIRepo + [ PLImmutable (PLIRepo (Repo { repoUrl = "https://github.com/yesodweb/wai.git" , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" @@ -224,305 +225,308 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a toBlobKey "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" 1765 - }) - ] + }))] - it "parses PackageLocationImmutable (Multiple Repos)" $ do - let lockFile :: ByteString - lockFile = [s|#some -dependencies: -- 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 - - 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 -|] - pkgImm <- case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of - Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - xs' <- sequence xs - pure $ NonEmpty.toList xs' - Nothing -> fail "Can't parse PackageLocationImmutable - 2" - pkgImm `shouldBe` - [ PLIRepo - (Repo - { repoUrl = "https://github.com/yesodweb/wai.git" - , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" - , repoSubdir = "wai" - , repoType = RepoGit - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 2, 1, 2] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") - (FileSize 714)) - , pmCabal = - toBlobKey - "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" - 1765 - }), - PLIRepo - (Repo - { repoUrl = "https://github.com/yesodweb/wai.git" - , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" - , repoSubdir = "warp" - , repoType = RepoGit - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "warp" - , pkgVersion = mkVersion [3, 2, 25] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") - (FileSize 5103)) - , pmCabal = - toBlobKey - "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" - 10725 - }) - ] - it "parses PackageLocationImmutable (RPLIArchive)" $ do - let lockFile :: ByteString - lockFile = [s|#some -dependencies: -- complete: - - size: 285152 - subdir: wai - url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip - cabal-file: - size: 1717 - sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 - name: wai - version: 3.0.2.3 - sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba - pantry-tree: - size: 710 - sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc -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 -|] - pkgImm <- - case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of - Left str -> - fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - xs' <- sequence xs - pure $ NonEmpty.toList xs' - Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` - [ PLIArchive - (Archive - { archiveLocation = - ALUrl - "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" - , archiveHash = - decodeSHA - "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" - , archiveSize = FileSize 285152 - , archiveSubdir = "wai" - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 0, 2, 3] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") - (FileSize 710)) - , pmCabal = - toBlobKey - "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" - 1717 - }) - ] - it "parses PackageLocationImmutable (multiple RPLIArchive)" $ do - let lockFile :: ByteString - lockFile = [s|#some -dependencies: -- complete: - - size: 285152 - subdir: wai - url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip - cabal-file: - size: 1717 - sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 - name: wai - version: 3.0.2.3 - sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba - pantry-tree: - size: 710 - sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc - - size: 285152 - subdir: wai - url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip - cabal-file: - size: 1717 - sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 - name: wai - version: 3.0.2.3 - sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba - pantry-tree: - size: 710 - sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc -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 -|] - pkgImm <- - case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of - Left str -> - fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - xs' <- sequence xs - pure $ NonEmpty.toList xs' - Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` - [ PLIArchive - (Archive - { archiveLocation = - ALUrl - "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" - , archiveHash = - decodeSHA - "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" - , archiveSize = FileSize 285152 - , archiveSubdir = "wai" - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 0, 2, 3] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") - (FileSize 710)) - , pmCabal = - toBlobKey - "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" - 1717 - }), - PLIArchive - (Archive - { archiveLocation = - ALUrl - "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" - , archiveHash = - decodeSHA - "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" - , archiveSize = FileSize 285152 - , archiveSubdir = "wai" - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 0, 2, 3] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") - (FileSize 710)) - , pmCabal = - toBlobKey - "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" - 1717 - }) - ] - it "parses PackageLocationImmutable (PLIHackage)" $ do - let lockFile :: ByteString - lockFile = [s|#some -dependencies: -- complete: - - hackage: persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058 - pantry-tree: - size: 2165 - sha256: 3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce -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 -|] - pkgImm <- - case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of - Left str -> - fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - xs' <- sequence xs - pure $ NonEmpty.toList xs' - Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` [PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey - "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey - (BlobKey - (decodeSHA - "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") - (FileSize 2165)))] +-- it "parses PackageLocationImmutable (Multiple Repos)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - 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 +-- - 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.parseAbsDir "/home/sibi" +-- pkgImm <- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither (parseLockFile rootDir) pkgIm of +-- Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right xs -> do +-- xs' <- sequence xs +-- pure $ NonEmpty.toList xs' +-- Nothing -> fail "Can't parse PackageLocationImmutable - 2" +-- pkgImm `shouldBe` +-- [ PLIRepo +-- (Repo +-- { repoUrl = "https://github.com/yesodweb/wai.git" +-- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" +-- , repoSubdir = "wai" +-- , repoType = RepoGit +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 2, 1, 2] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") +-- (FileSize 714)) +-- , pmCabal = +-- toBlobKey +-- "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" +-- 1765 +-- }), +-- PLIRepo +-- (Repo +-- { repoUrl = "https://github.com/yesodweb/wai.git" +-- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" +-- , repoSubdir = "warp" +-- , repoType = RepoGit +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "warp" +-- , pkgVersion = mkVersion [3, 2, 25] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") +-- (FileSize 5103)) +-- , pmCabal = +-- toBlobKey +-- "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" +-- 10725 +-- }) +-- ] +-- it "parses PackageLocationImmutable (RPLIArchive)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - complete: +-- - size: 285152 +-- subdir: wai +-- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip +-- cabal-file: +-- size: 1717 +-- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 +-- name: wai +-- version: 3.0.2.3 +-- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba +-- pantry-tree: +-- size: 710 +-- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +-- 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.parseAbsDir "/home/sibi" +-- pkgImm <- +-- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither (parseLockFile rootDir) pkgIm of +-- Left str -> +-- fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right xs -> do +-- xs' <- sequence xs +-- pure $ NonEmpty.toList xs' +-- Nothing -> fail "Can't parse PackageLocationImmutable" +-- pkgImm `shouldBe` +-- [ PLIArchive +-- (Archive +-- { archiveLocation = +-- ALUrl +-- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" +-- , archiveHash = +-- decodeSHA +-- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" +-- , archiveSize = FileSize 285152 +-- , archiveSubdir = "wai" +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 0, 2, 3] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") +-- (FileSize 710)) +-- , pmCabal = +-- toBlobKey +-- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" +-- 1717 +-- }) +-- ] +-- it "parses PackageLocationImmutable (multiple RPLIArchive)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - complete: +-- - size: 285152 +-- subdir: wai +-- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip +-- cabal-file: +-- size: 1717 +-- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 +-- name: wai +-- version: 3.0.2.3 +-- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba +-- pantry-tree: +-- size: 710 +-- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +-- - size: 285152 +-- subdir: wai +-- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip +-- cabal-file: +-- size: 1717 +-- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 +-- name: wai +-- version: 3.0.2.3 +-- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba +-- pantry-tree: +-- size: 710 +-- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc +-- 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.parseAbsDir "/home/sibi" +-- pkgImm <- +-- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither (parseLockFile rootDir) pkgIm of +-- Left str -> +-- fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right xs -> do +-- xs' <- sequence xs +-- pure $ NonEmpty.toList xs' +-- Nothing -> fail "Can't parse PackageLocationImmutable" +-- pkgImm `shouldBe` +-- [ PLIArchive +-- (Archive +-- { archiveLocation = +-- ALUrl +-- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" +-- , archiveHash = +-- decodeSHA +-- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" +-- , archiveSize = FileSize 285152 +-- , archiveSubdir = "wai" +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 0, 2, 3] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") +-- (FileSize 710)) +-- , pmCabal = +-- toBlobKey +-- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" +-- 1717 +-- }), +-- PLIArchive +-- (Archive +-- { archiveLocation = +-- ALUrl +-- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" +-- , archiveHash = +-- decodeSHA +-- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" +-- , archiveSize = FileSize 285152 +-- , archiveSubdir = "wai" +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 0, 2, 3] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") +-- (FileSize 710)) +-- , pmCabal = +-- toBlobKey +-- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" +-- 1717 +-- }) +-- ] +-- it "parses PackageLocationImmutable (PLIHackage)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - complete: +-- - hackage: persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058 +-- pantry-tree: +-- size: 2165 +-- sha256: 3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce +-- 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.parseAbsDir "/home/sibi" +-- pkgImm <- +-- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither (parseLockFile rootDir) pkgIm of +-- Left str -> +-- fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right xs -> do +-- xs' <- sequence xs +-- pure $ NonEmpty.toList xs' +-- Nothing -> fail "Can't parse PackageLocationImmutable" +-- pkgImm `shouldBe` [PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey +-- "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey +-- (BlobKey +-- (decodeSHA +-- "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") +-- (FileSize 2165)))] it "parses PackageLocationImmutable (PLIHackage & PLIArchive)" $ do let lockFile :: ByteString lockFile = [s|#some @@ -552,23 +556,24 @@ resolver: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a |] + rootDir <- Path.parseAbsDir "/home/sibi" pkgImm <- case Yaml.decodeThrow lockFile of Just (pkgIm :: Value) -> do - case Yaml.parseEither parseLockFile pkgIm of + case Yaml.parseEither (parseLockFile rootDir) pkgIm of Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right xs -> do - xs' <- sequence xs - pure $ NonEmpty.toList xs' + Right iopl -> do + pl <- iopl + pure $ NonEmpty.toList pl Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` [PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey + pkgImm `shouldBe` [PLImmutable (PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey (BlobKey (decodeSHA "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") - (FileSize 2165))), - PLIArchive + (FileSize 2165)))), + PLImmutable (PLIArchive (Archive { archiveLocation = ALUrl @@ -595,4 +600,4 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a toBlobKey "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" 1717 - })] + }))] From e4cd0abe3ec2d05b2dfdb3a0d52d8f7d9ac0ab89 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 12 Feb 2019 22:16:44 +0530 Subject: [PATCH 19/76] Add toJSON instance for PL --- subs/pantry/src/Pantry/Types.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 7310818d35..7f19a59c97 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -314,6 +314,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 From 79659e94d67073960c0c3d35d1b17d297f416dee Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 12 Feb 2019 22:17:01 +0530 Subject: [PATCH 20/76] Cleanup logic --- src/Stack/Freeze.hs | 80 ++++++++++++++++++++++----------------------- 1 file changed, 39 insertions(+), 41 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 3218b5bf2a..95115af3f8 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -19,7 +19,7 @@ import Stack.Prelude import Stack.Types.Config import Stack.Config (loadConfigYaml) import Path (addFileExtension, parent, fromAbsFile, toFilePath) -import Path.IO (doesFileExist) +import Path.IO (doesFileExist, getModificationTime) import qualified Data.List.NonEmpty as NE data FreezeMode = FreezeProject | FreezeSnapshot @@ -50,7 +50,7 @@ doFreeze p FreezeProject = do envConfig <- view envConfigL let bconfig = envConfigBuildConfig envConfig generateLockFile bconfig - isLockFileOutdated bconfig -- todo: remove this in future (just for testing) + -- isLockFileOutdated bconfig -- todo: remove this in future (just for testing) let deps :: [RawPackageLocation] = projectDependencies p resolver :: RawSnapshotLocation = projectResolver p resolver' :: SnapshotLocation <- completeSnapshotLocation resolver @@ -89,33 +89,34 @@ doFreeze p FreezeSnapshot = do logInfo "No freezing is required for the snapshot of this project" else liftIO $ B.putStr $ Yaml.encode snap' - -- BuildConfig is in Types/Config.hs generateLockFile :: HasEnvConfig env => BuildConfig -> RIO env () generateLockFile bconfig = do - let stackFile = bcStackYaml bconfig - lockFile <- liftIO $ addFileExtension "lock" stackFile - iosc <- loadConfigYaml (parseStackYamlConfig (parent stackFile)) stackFile - StackYamlConfig deps resolver <- liftIO iosc - resolver' :: SnapshotLocation <- completeSnapshotLocation resolver - deps' :: [PackageLocation] <- mapM completePackageLocation' deps - let deps'' = map toRawPL deps' - let depsObject = Yaml.object [ - ("resolver", - Yaml.array - [ - object [("original", Yaml.toJSON resolver)], - object [("complete", Yaml.toJSON resolver')] - ] - ), - ("dependencies", - Yaml.array - [ - object [("original", Yaml.toJSON deps)], - object [("complete", Yaml.toJSON deps'')] - ] - )] - B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) + let stackFile = bcStackYaml bconfig + lockFile <- liftIO $ addFileExtension "lock" stackFile + iosc <- loadConfigYaml (parseStackYamlConfig (parent stackFile)) stackFile + StackYamlConfig deps resolver <- liftIO iosc + resolver' :: SnapshotLocation <- completeSnapshotLocation resolver + deps' :: [PackageLocation] <- mapM completePackageLocation' deps + let deps'' = map (\x -> (x, toRawPL x)) deps' + let depsObject = + Yaml.object + [ ( "resolver" + , object + [ ("original", Yaml.toJSON resolver) + , ("complete", Yaml.toJSON resolver') + ]) + , ( "dependencies" + , Yaml.array + (map (\(comp, raw) -> + object + [ ("original", Yaml.toJSON raw) + , ("complete", Yaml.toJSON comp) + ]) + deps'')) + ] + B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) + hasLockFile :: HasEnvConfig env => BuildConfig -> RIO env Bool @@ -134,24 +135,21 @@ parsePLI bconfig = do plis' <- liftIO $ plis pure $ NE.toList plis' --- Parse the orignial stack file and then parse the lock file and then compare it with the original file content + isLockFileOutdated :: HasEnvConfig env => BuildConfig -> RIO env Bool isLockFileOutdated bconfig = do let stackFile = bcStackYaml bconfig - plis <- parsePLI bconfig lockFile <- liftIO $ addFileExtension "lock" stackFile - iosc <- loadConfigYaml (parseStackYamlConfig (parent stackFile)) stackFile - StackYamlConfig deps resolver <- liftIO iosc - resolver' :: SnapshotLocation <- completeSnapshotLocation resolver - deps' :: [PackageLocation] <- mapM completePackageLocation' deps - let deps'' = map toRawPL deps' - rawResolver = toRawSL resolver' - isUpdated = (deps'' == deps) && (resolver == rawResolver) - liftIO $ Prelude.print "raw PLI" - liftIO $ Prelude.print deps - liftIO $ Prelude.print "raw PLI from complete" - liftIO $ Prelude.print plis - pure $ not isUpdated - + smt <- liftIO $ getModificationTime stackFile + lmt <- liftIO $ do + exists <- doesFileExist lockFile + if exists + then do + mt <- getModificationTime lockFile + pure $ Just mt + else pure Nothing + case lmt of + Nothing -> return True + Just mt -> return $ smt /= mt -- Use loadProjectConfig and parseLockfile to see if lock file has been outdated From 7c4d1b511dd85cd113480d2b907c3ab68476d6dd Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 14 Feb 2019 16:12:24 +0530 Subject: [PATCH 21/76] Fix logic of freeze --- src/Stack/Freeze.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 95115af3f8..ecd87f1aa4 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -98,7 +98,7 @@ generateLockFile bconfig = do StackYamlConfig deps resolver <- liftIO iosc resolver' :: SnapshotLocation <- completeSnapshotLocation resolver deps' :: [PackageLocation] <- mapM completePackageLocation' deps - let deps'' = map (\x -> (x, toRawPL x)) deps' + let deps'' = map (\x -> (fst x, snd x)) (zip deps deps') let depsObject = Yaml.object [ ( "resolver" @@ -108,7 +108,7 @@ generateLockFile bconfig = do ]) , ( "dependencies" , Yaml.array - (map (\(comp, raw) -> + (map (\(raw, comp) -> object [ ("original", Yaml.toJSON raw) , ("complete", Yaml.toJSON comp) From 8958031fe8f3a3338f2e9a3c7e0c1552e323c58e Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 14 Feb 2019 18:29:08 +0530 Subject: [PATCH 22/76] Implement parseRPL function --- subs/pantry/src/Pantry/Types.hs | 107 ++++++++++++++++++++++++++++++++ 1 file changed, 107 insertions(+) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 7f19a59c97..4536b2fd53 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1624,6 +1624,111 @@ instance FromJSON (Unresolved PackageLocationImmutable) where -- archiveSubdir <- o ..: "subdir" -- pure $ pure $ pure $ PLIArchive Archive {..} pm) value +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' + + +parseRPLImmutable :: Value -> Parser (Unresolved RawPackageLocation) +parseRPLImmutable v = do + xs :: Unresolved RawPackageLocationImmutable <- parseRPLI v + pure $ RPLImmutable <$> xs + +parseRPL :: Value -> Parser (Unresolved RawPackageLocation) +parseRPL v = parseRPLImmutable v <|> parseResolvedPath v + + + + +parseRPLI :: Value -> Parser (Unresolved RawPackageLocationImmutable) +parseRPLI v = + parseRPLHttpText v <|> parseRPLHackageText v <|> parseRPLHackageObject v <|> + parseRPLRepo v <|> + parseArchiveRPLObject v <|> + parseGithubRPLObject v + +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 of -- if subdirs exists, it needs to be valid + 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" + ] + raHash <- o .:? "sha256" + raSize <- o .:? "size" + os <- optionalSubdirs o + pure $ pure $ NE.head $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) + + instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where parseJSON v = http v @@ -1652,6 +1757,8 @@ instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmu 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") From 624ffaf8a0409d2aa80f7151f6e6694d29f8bdbc Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 15:47:47 +0530 Subject: [PATCH 23/76] Implement resolveLockfile function --- subs/pantry/src/Pantry.hs | 2 +- subs/pantry/src/Pantry/Types.hs | 121 ++++++++++++++++++-------------- 2 files changed, 69 insertions(+), 54 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index b6f5adc173..453df97425 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -105,7 +105,7 @@ module Pantry , parseRawSnapshotLocation , parsePackageIdentifierRevision , parseHackageText - , parseLockFile + , resolveLockFile , parseAndResolvePackageLocation -- ** Cabal values diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 4536b2fd53..45dc719a17 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -66,7 +66,7 @@ module Pantry.Types , parseVersionThrowing , packageIdentifierString , packageNameString - , parseLockFile + , resolveLockFile , parseAndResolvePackageLocation , flagNameString , versionString @@ -1543,38 +1543,54 @@ parseAndResolvePackageLocation rootDir v = do (Unresolved unresolvedPL) <- parsePackageLocation v pure $ unresolvedPL (Just rootDir) +combineUnresolved :: Unresolved a -> Unresolved b -> Unresolved (a,b) +combineUnresolved a b = do + ua <- a + ub <- b + pure (ua, ub) + +parseSingleObject :: Value -> Parser (Unresolved (PackageLocation, RawPackageLocation)) +parseSingleObject value = withObject "LockFile" (\obj -> do + original <- obj .: "original" + complete <- obj .: "complete" + orig <- parseRPLImmutable original + comp <- parsePImmutable complete + pure $ combineUnresolved comp orig + ) value + + parseLockFile :: - Path Abs Dir -> Value -> Parser (IO (NonEmpty PackageLocation)) -parseLockFile rootDir value = do - (WithJSONWarnings val _) <- - withObjectWarnings - "PackageLocationimmutable" - (\obj -> do - deps <- obj ..: "dependencies" - lift $ - withArray - "Dependencies (Array)" - (\vector -> do - let vector' :: Array = - Vector.filter isCompleteObject vector - let pli :: Vector (Parser (IO (NonEmpty PackageLocation))) = - Vector.map - (\(Object o) -> do - complete <- o .: "complete" - pl :: (IO (NonEmpty PackageLocation)) <- - parseAndResolvePackageLocation rootDir complete - pure pl) - vector' - pliSeq = sequence pli - pli' :: Vector (IO (NonEmpty PackageLocation)) <- pliSeq - pure pli') - deps) - value - let pli :: Vector (IO (NonEmpty (PackageLocation))) = val - pure $ Vector.foldr1 appendPLI' pli + Value -> Parser [Unresolved (PackageLocation, RawPackageLocation)] +parseLockFile value = withObject "LockFile" (\obj -> do + vals :: Value <- obj .: "dependencies" + xs <- withArray "LockFileArray" (\vec -> sequence $ Vector.map parseSingleObject vec) vals + pure $ Vector.toList xs + ) value + +resolveLockFile :: Path Abs Dir -> Value -> Parser (IO [(PackageLocation, RawPackageLocation)]) +resolveLockFile rootDir v = do + val <- parseLockFile v + let val' = sequence val + val'' = resolvePaths (Just rootDir) val' + pure val'' + + +parsePImmutable :: Value -> Parser (Unresolved PackageLocation) +parsePImmutable v = do + xs :: Unresolved PackageLocationImmutable <- parseJSON v + pure $ PLImmutable <$> xs + +-- parsePL :: Value -> Parser (Unresolved RawPackageLocation) +-- parsePL v = parseRPLImmutable v <|> parseResolvedPath v + + + + + + instance FromJSON (Unresolved PackageLocationImmutable) where - parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v + 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) @@ -1586,11 +1602,11 @@ instance FromJSON (Unresolved PackageLocationImmutable) where archiveObject :: Value -> Parser (Unresolved PackageLocationImmutable) archiveObject value@(Object _) = do pm <- parseJSON value - (WithJSONWarnings pli _) <- withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do - Unresolved mkArchiveLocation <- parseArchiveLocationObject o - archiveHash <- o ..: "sha256" - archiveSize <- o ..: "size" - archiveSubdir <- o ..: "subdir" + 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 @@ -1606,23 +1622,23 @@ instance FromJSON (Unresolved PackageLocationImmutable) where Left e -> fail $ show e Right (pkgIdentifier, blobKey) -> pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)) value - -- github :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty PackageLocationImmutable))) - -- github value = do - -- (WithJSONWarnings pm _) <- parseJSON value - -- withObjectWarnings "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 $ pure $ PLIArchive Archive {..} pm) 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 parseResolvedPath :: Value -> Parser (Unresolved RawPackageLocation) parseResolvedPath value = mkMutable <$> parseJSON value @@ -1728,7 +1744,6 @@ parseGithubRPLObject = withObject "PLArchive:github" $ \o -> do os <- optionalSubdirs o pure $ pure $ NE.head $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) - instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where parseJSON v = http v From cd9b7a96838f290dabe0fe4c8b6117c1eb2cc9e0 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 15:48:13 +0530 Subject: [PATCH 24/76] Update test --- subs/pantry/test/Pantry/TypesSpec.hs | 633 ++++++++++++++++----------- 1 file changed, 383 insertions(+), 250 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index daf81a2f00..b600ef2bff 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -1,56 +1,69 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes#-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -module Pantry.TypesSpec (spec) where -import Test.Hspec -import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import qualified RIO.HashMap as HM -import Pantry -import qualified Pantry.SHA256 as SHA256 -import Pantry.Internal (parseTree, renderTree, Tree (..), TreeEntry (..), mkSafeFilePath) -import RIO -import Distribution.Types.Version (mkVersion) -import qualified RIO.Text as T -import qualified Data.Yaml as Yaml +module Pantry.TypesSpec + ( spec + ) where + import Data.Aeson.Extended -import Distribution.Types.PackageName (mkPackageName) import qualified Data.ByteString.Char8 as S8 -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty hiding (map) +import Data.Semigroup import Data.String.Quote 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 qualified Path as Path -import Data.Semigroup +import RIO +import qualified RIO.HashMap as HM +import qualified RIO.Text as T +import Test.Hspec 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 () decodeSHA :: ByteString -> SHA256 -decodeSHA string = case SHA256.fromHexBytes string of - Right csha -> csha - Left err -> error $ "Failed decoding. Error: " <> show err +decodeSHA string = + case SHA256.fromHexBytes string of + Right csha -> csha + Left err -> error $ "Failed decoding. Error: " <> show err toBlobKey :: ByteString -> Word -> BlobKey toBlobKey string size = BlobKey (decodeSHA string) (FileSize size) 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 = [s| +samplePLIRepo = + [s| subdir: wai cabal-file: size: 1765 @@ -66,167 +79,185 @@ 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])) - - 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]) - - it "parses PackageLocationImmutable (Repo)" $ do - let lockFile :: ByteString - lockFile = [s|#some -dependencies: -- 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 -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.parseAbsDir "/home/sibi" - pkgImm <- case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither (parseLockFile rootDir) pkgIm of - Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right iopl -> do - pl <- iopl - pure $ NonEmpty.toList pl - Nothing -> fail "Can't parse PackageLocationImmutable - 2" - pkgImm `shouldBe` - [ PLImmutable (PLIRepo - (Repo - { repoUrl = "https://github.com/yesodweb/wai.git" - , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" - , repoSubdir = "wai" - , repoType = RepoGit - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 2, 1, 2] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") - (FileSize 714)) - , pmCabal = - toBlobKey - "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" - 1765 - }))] - + 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]) +-- it "parses PackageLocationImmutable (Repo)" $ do +-- let lockFile :: ByteString +-- lockFile = [s|#some +-- dependencies: +-- - 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 +-- 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.parseAbsDir "/home/sibi" +-- pkgImm <- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither (parseLockFile rootDir) pkgIm of +-- Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str +-- Right iopl -> do +-- pl <- iopl +-- pure $ NonEmpty.toList pl +-- Nothing -> fail "Can't parse PackageLocationImmutable - 2" +-- pkgImm `shouldBe` +-- [ PLImmutable (PLIRepo +-- (Repo +-- { repoUrl = "https://github.com/yesodweb/wai.git" +-- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" +-- , repoSubdir = "wai" +-- , repoType = RepoGit +-- }) +-- (PackageMetadata +-- { pmIdent = +-- PackageIdentifier +-- { pkgName = mkPackageName "wai" +-- , pkgVersion = mkVersion [3, 2, 1, 2] +-- } +-- , pmTreeKey = +-- TreeKey +-- (BlobKey +-- (decodeSHA +-- "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") +-- (FileSize 714)) +-- , pmCabal = +-- toBlobKey +-- "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" +-- 1765 +-- }))] -- it "parses PackageLocationImmutable (Multiple Repos)" $ do -- let lockFile :: ByteString -- lockFile = [s|#some @@ -527,77 +558,179 @@ sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a -- (decodeSHA -- "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") -- (FileSize 2165)))] - it "parses PackageLocationImmutable (PLIHackage & PLIArchive)" $ do - let lockFile :: ByteString - lockFile = [s|#some + it "parses lock file (empty)" $ do + let lockFile :: ByteString + lockFile = + [s|#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.parseAbsDir "/home/sibi" + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither (resolveLockFile rootDir) pkgIm of + Left str -> + fail $ + "Can't parse PackageLocationImmutable - 1" <> + str <> + (show pkgIm) + Right iopl -> do + pl <- iopl + pure pl + Nothing -> fail "Can't parse PackageLocationImmutable" + pkgImm `shouldBe` [] + it "parses lock file (non empty)" $ do + let lockFile :: ByteString + lockFile = + [s|#some dependencies: -- complete: - - hackage: persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058 - pantry-tree: - size: 2165 - sha256: 3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce - - size: 285152 +- original: + subdir: wai + git: https://github.com/yesodweb/wai.git + commit: d11d63f1a6a92db8c637a8d33e7953ce6194a3e0 + complete: subdir: wai - url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip cabal-file: - size: 1717 - sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 + size: 1765 + sha256: eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410 name: wai - version: 3.0.2.3 - sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba + version: 3.2.1.2 + git: https://github.com/yesodweb/wai.git pantry-tree: - size: 710 - sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc -resolver: + 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: + complete: size: 527801 url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml -sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a + sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a |] - rootDir <- Path.parseAbsDir "/home/sibi" - pkgImm <- - case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither (parseLockFile rootDir) pkgIm of - Left str -> - fail $ "Can't parse PackageLocationImmutable - 1" <> str - Right iopl -> do - pl <- iopl - pure $ NonEmpty.toList pl - Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` [PLImmutable (PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey - "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey - (BlobKey - (decodeSHA - "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") - (FileSize 2165)))), - PLImmutable (PLIArchive - (Archive - { archiveLocation = - ALUrl - "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" - , archiveHash = - decodeSHA - "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" - , archiveSize = FileSize 285152 - , archiveSubdir = "wai" - }) - (PackageMetadata - { pmIdent = - PackageIdentifier - { pkgName = mkPackageName "wai" - , pkgVersion = mkVersion [3, 0, 2, 3] - } - , pmTreeKey = - TreeKey - (BlobKey - (decodeSHA - "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") - (FileSize 710)) - , pmCabal = - toBlobKey - "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" - 1717 - }))] + rootDir <- Path.parseAbsDir "/home/sibi" + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither (resolveLockFile rootDir) pkgIm of + Left str -> + fail $ + "Can't parse PackageLocationImmutable - 1" <> + str <> + (show pkgIm) + Right iopl -> do + pl <- iopl + pure pl + Nothing -> fail "Can't parse PackageLocationImmutable" + 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 + }))) + ] From b2553cb4aeb6c3fe55709ae42bfa44665e87dc6b Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 22:37:14 +0530 Subject: [PATCH 25/76] Cleanup Freeze module --- src/Stack/Freeze.hs | 187 ++++++++++++++------------------------------ 1 file changed, 58 insertions(+), 129 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index ecd87f1aa4..03828eea04 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -4,25 +4,25 @@ module Stack.Freeze ( freeze - , FreezeOpts (..) - , FreezeMode (..) - , hasLockFile - , isLockFileOutdated + , FreezeOpts(..) + , FreezeMode(..) ) where -import qualified Prelude as Prelude -import Data.Aeson ((.=), object) +import Data.Aeson ((.=), object) +import qualified Data.List.NonEmpty as NE import qualified Data.Yaml as Yaml -import RIO.Process +import Path (addFileExtension, fromAbsFile, parent, toFilePath) +import Path.IO (doesFileExist, getModificationTime) +import qualified Prelude as Prelude import qualified RIO.ByteString as B -import Stack.Prelude -import Stack.Types.Config +import RIO.Process import Stack.Config (loadConfigYaml) -import Path (addFileExtension, parent, fromAbsFile, toFilePath) -import Path.IO (doesFileExist, getModificationTime) -import qualified Data.List.NonEmpty as NE +import Stack.Prelude +import Stack.Types.Config -data FreezeMode = FreezeProject | FreezeSnapshot +data FreezeMode + = FreezeProject + | FreezeSnapshot newtype FreezeOpts = FreezeOpts { freezeMode :: FreezeMode @@ -30,126 +30,55 @@ 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" - -completePackageLocation' :: (HasProcessContext env, HasLogFunc env, HasPantryConfig env, HasEnvConfig env) => RawPackageLocation -> RIO env PackageLocation -completePackageLocation' pl = - case pl of - RPLImmutable pli -> PLImmutable <$> completePackageLocation pli - RPLMutable m -> pure $ PLMutable m + mproject <- view $ configL . to configMaybeProject + case mproject of + Just (p, _) -> doFreeze p mode + Nothing -> logWarn "No project was found: nothing to freeze" doFreeze :: - (HasProcessContext env, HasLogFunc env, HasPantryConfig env, HasEnvConfig env) + ( HasProcessContext env + , HasLogFunc env + , HasPantryConfig env + , HasEnvConfig env + ) => Project -> FreezeMode -> RIO env () doFreeze p FreezeProject = do - envConfig <- view envConfigL - let bconfig = envConfigBuildConfig envConfig - generateLockFile bconfig - -- isLockFileOutdated bconfig -- todo: remove this in future (just for testing) - let deps :: [RawPackageLocation] = projectDependencies p - resolver :: RawSnapshotLocation = projectResolver p - resolver' :: SnapshotLocation <- completeSnapshotLocation resolver - deps' :: [PackageLocation] <- 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] - -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' --- BuildConfig is in Types/Config.hs -generateLockFile :: HasEnvConfig env => BuildConfig -> RIO env () -generateLockFile bconfig = do - let stackFile = bcStackYaml bconfig - lockFile <- liftIO $ addFileExtension "lock" stackFile - iosc <- loadConfigYaml (parseStackYamlConfig (parent stackFile)) stackFile - StackYamlConfig deps resolver <- liftIO iosc + envConfig <- view envConfigL + let bconfig = envConfigBuildConfig envConfig + generateLockFile (bcStackYaml bconfig) + isLockFileOutdated bconfig -- todo: remove this in future (just for testing) + let deps :: [RawPackageLocation] = projectDependencies p + resolver :: RawSnapshotLocation = projectResolver p resolver' :: SnapshotLocation <- completeSnapshotLocation resolver - deps' :: [PackageLocation] <- mapM completePackageLocation' deps - let deps'' = map (\x -> (fst x, snd x)) (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 lockFile) (Yaml.encode depsObject) - - - -hasLockFile :: HasEnvConfig env => BuildConfig -> RIO env Bool -hasLockFile bconfig = do - let stackFile = bcStackYaml bconfig - lockFile <- liftIO $ addFileExtension "lock" stackFile - liftIO $ doesFileExist lockFile - -parsePLI :: HasEnvConfig env => BuildConfig -> RIO env [PackageLocation] -parsePLI bconfig = do - let stackFile = bcStackYaml bconfig - rootDir = parent stackFile - lockFile <- liftIO $ addFileExtension "lock" stackFile - (pli :: Yaml.Value) <- Yaml.decodeFileThrow (toFilePath lockFile) - plis <- Yaml.parseMonad (parseLockFile rootDir) pli - plis' <- liftIO $ plis - pure $ NE.toList plis' - - -isLockFileOutdated :: HasEnvConfig env => BuildConfig -> RIO env Bool -isLockFileOutdated bconfig = do - let stackFile = bcStackYaml bconfig - lockFile <- liftIO $ addFileExtension "lock" stackFile - smt <- liftIO $ getModificationTime stackFile - lmt <- liftIO $ do - exists <- doesFileExist lockFile - if exists - then do - mt <- getModificationTime lockFile - pure $ Just mt - else pure Nothing - case lmt of - Nothing -> return True - Just mt -> return $ smt /= mt - --- Use loadProjectConfig and parseLockfile to see if lock file has been outdated + deps' :: [PackageLocation] <- mapM undefined 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' From 4ea05bff3abd143e770fb56be8cf28a78cf1d4ab Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 22:52:44 +0530 Subject: [PATCH 26/76] Add loadLockfile --- subs/pantry/src/Pantry/Types.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 45dc719a17..6711f70c7f 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -67,6 +67,7 @@ module Pantry.Types , packageIdentifierString , packageNameString , resolveLockFile + , loadLockFile , parseAndResolvePackageLocation , flagNameString , versionString @@ -110,6 +111,7 @@ import RIO import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Conduit.Tar as Tar import qualified Data.Vector as Vector +import qualified Data.Yaml as Yaml import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL @@ -144,7 +146,7 @@ import Data.Store (Size (..), Store (..)) import Network.HTTP.Client (parseRequest) import Network.HTTP.Types (Status, statusCode) import Data.Text.Read (decimal) -import Path (Path, Abs, Dir, File, toFilePath, filename, (), parseRelFile) +import Path (Path, Abs, Dir, File, toFilePath, filename, (), parseRelFile, parent) import Path.IO (resolveFile, resolveDir) import Data.Pool (Pool) import Data.List.NonEmpty (NonEmpty) @@ -1574,21 +1576,20 @@ resolveLockFile rootDir v = do val'' = resolvePaths (Just rootDir) val' pure val'' +loadLockFile :: Path Abs File -> IO [(PackageLocation, RawPackageLocation)] +loadLockFile lockFile = do + val <- Yaml.decodeFileThrow (toFilePath lockFile) + case Yaml.parseEither (resolveLockFile (parent lockFile)) val of + Left str -> fail "Cannot parse lock file" -- todo: fix this + Right iopl -> do + pl <- iopl + pure pl parsePImmutable :: Value -> Parser (Unresolved PackageLocation) parsePImmutable v = do xs :: Unresolved PackageLocationImmutable <- parseJSON v pure $ PLImmutable <$> xs --- parsePL :: Value -> Parser (Unresolved RawPackageLocation) --- parsePL v = parseRPLImmutable v <|> parseResolvedPath v - - - - - - - instance FromJSON (Unresolved PackageLocationImmutable) where parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) From c05fc590ffe050acb1312d18ec3c0a62847c9574 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 23:03:03 +0530 Subject: [PATCH 27/76] Cleanup freeze module --- src/Stack/Freeze.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 03828eea04..d6033c11da 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -45,10 +45,6 @@ doFreeze :: -> FreezeMode -> RIO env () doFreeze p FreezeProject = do - envConfig <- view envConfigL - let bconfig = envConfigBuildConfig envConfig - generateLockFile (bcStackYaml bconfig) - isLockFileOutdated bconfig -- todo: remove this in future (just for testing) let deps :: [RawPackageLocation] = projectDependencies p resolver :: RawSnapshotLocation = projectResolver p resolver' :: SnapshotLocation <- completeSnapshotLocation resolver From dad2b16065eb87a44dc034390c79da507ed1053f Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 23:03:15 +0530 Subject: [PATCH 28/76] Fill remaining function --- subs/pantry/src/Pantry.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 453df97425..6ad3327bb5 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -97,6 +97,7 @@ module Pantry -- * Completion functions , completePackageLocation + , completePackageLocation' , completeSnapshotLayer , completeSnapshotLocation @@ -146,6 +147,7 @@ module Pantry -- * Cabal files , loadCabalFileRaw , loadCabalFile + , loadLockFile , loadCabalFileRawImmutable , loadCabalFileImmutable , loadCabalFilePath @@ -714,6 +716,15 @@ loadPackageRaw (RPLIRepo repo rpm) = getRepo repo rpm -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. -- -- @since 0.1.0.0 +completePackageLocation' :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => RawPackageLocation + -> RIO env PackageLocation +completePackageLocation' (RPLImmutable rpli) = do + pl <- completePackageLocation rpli + pure $ PLImmutable pl +completePackageLocation' (RPLMutable rplm) = pure $ PLMutable rplm + + completePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable From d211d2a5ab5ca550ede3ac0bed9b6ed013697821 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 23:03:23 +0530 Subject: [PATCH 29/76] Cleanup --- src/Stack/Types/Config.hs | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index d2f10bfca7..4b746b6fd8 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -91,8 +91,6 @@ module Stack.Types.Config ,Curator(..) ,ProjectAndConfigMonoid(..) ,parseProjectAndConfigMonoid - ,StackYamlConfig(..) - ,parseStackYamlConfig -- ** PvpBounds ,PvpBounds(..) ,PvpBoundsType(..) @@ -1435,25 +1433,6 @@ getCompilerPath wc = do data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid -data StackYamlConfig = StackYamlConfig { - sycDeps :: [RawPackageLocation], - sycResolver :: RawSnapshotLocation -} - -data StackLockConfig = StackLockConfig { - slcDeps :: [PackageLocation], - slcResolver :: SnapshotLocation -} - -parseStackYamlConfig :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO StackYamlConfig)) -parseStackYamlConfig rootDir = withObjectWarnings "StackYamlConfig" $ \o -> do - deps <- jsonSubWarningsTT (o ..:? "extra-deps") ..!= [] - resolver <- jsonSubWarnings $ o ...: ["snapshot", "resolver"] - return $ do - (deps' :: [NonEmpty RawPackageLocation]) <- mapM (resolvePaths (Just rootDir)) deps - resolver' <- resolvePaths (Just rootDir) resolver - pure $ StackYamlConfig { sycResolver = resolver', sycDeps = concatMap toList deps' } - parseProjectAndConfigMonoid :: Path Abs Dir -> Value -> Yaml.Parser (WithJSONWarnings (IO ProjectAndConfigMonoid)) parseProjectAndConfigMonoid rootDir = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do From 536929cd47d5f9fb4d9a3fba183f1b9a8200208f Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 23:03:39 +0530 Subject: [PATCH 30/76] Add an optimization step --- src/Stack/Config.hs | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 9bd6699130..f830574bbe 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -86,7 +86,9 @@ import System.Environment import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) import RIO.PrettyPrint +import Stack.Lock (generateLockFile, isLockFileOutdated) import RIO.Process +import Pantry (loadLockFile) -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. @@ -513,6 +515,22 @@ loadConfig :: HasRunner env loadConfig configArgs mresolver mstackYaml inner = loadProjectConfig mstackYaml >>= \x -> loadConfigMaybeProject configArgs mresolver x inner + + +stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(PackageLocation, RawPackageLocation)] + -> RawPackageLocation + -> RIO env PackageLocation +stackCompletePackageLocation cachePackages rp@(RPLImmutable rpli) = do + let xs = filter (\(_,x) -> x == rp) cachePackages + item <- case xs of + [] -> do + pl <- completePackageLocation rpli + pure $ PLImmutable pl + (x,_):_ -> pure x + pure item +stackCompletePackageLocation _ (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,6 +605,13 @@ loadBuildConfig mproject maresolver mcompiler = do { projectResolver = fromMaybe (projectResolver project') mresolver } + lockFileOutdated <- isLockFileOutdated stackYamlFP + when lockFileOutdated (generateLockFile stackYamlFP) + + -- liftIO $ resolveLockFile (parent stackYamlFP) + lockFile <- liftIO $ addFileExtension "lock" stackYamlFP + cachePL <- liftIO $ loadLockFile lockFile + resolver <- completeSnapshotLocation $ projectResolver project (snapshot, _completed) <- loadAndCompleteSnapshot resolver @@ -604,7 +629,7 @@ loadBuildConfig mproject maresolver mcompiler = do completeLocation (RPLImmutable im) = PLImmutable <$> completePackageLocation im deps0 <- forM (projectDependencies project) $ \rpl -> do - pl <- completeLocation rpl + pl <- stackCompletePackageLocation cachePL rpl dp <- additionalDepPackage (shouldHaddockDeps bopts) pl pure (cpName $ dpCommon dp, dp) From c0467f555b08bb8b712ff5263e1f78579210657a Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 23:03:50 +0530 Subject: [PATCH 31/76] Add initial lock file module --- src/Stack/Lock.hs | 82 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) create mode 100644 src/Stack/Lock.hs diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs new file mode 100644 index 0000000000..c7c7c0db8b --- /dev/null +++ b/src/Stack/Lock.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Stack.Lock where + +import Data.Aeson ((.=), object) +import qualified Data.List.NonEmpty as NE +import qualified Data.Yaml as Yaml +import Pantry (completePackageLocation) +import Path (addFileExtension, fromAbsFile, parent, toFilePath) +import Path.IO (doesFileExist, getModificationTime) +import qualified Prelude as Prelude +import qualified RIO.ByteString as B +import RIO.Process +import Stack.Prelude +import Stack.Types.Config + +-- BuildConfig is in Types/Config.hs +generateLockFile :: Path Abs File -> RIO Config () +generateLockFile stackFile = do + mproject <- view $ configL . to configMaybeProject + p <- + case mproject of + Just (p, _) -> return p + Nothing -> error "No project was found: nothing to freeze" -- todo + let deps :: [RawPackageLocation] = projectDependencies p + resolver :: RawSnapshotLocation = projectResolver p + lockFile <- liftIO $ addFileExtension "lock" stackFile + resolver' :: SnapshotLocation <- completeSnapshotLocation resolver + deps' :: [PackageLocation] <- mapM completePackageLocation' deps + let deps'' = map (\x -> (fst x, snd x)) (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 lockFile) (Yaml.encode depsObject) + +hasLockFile :: HasEnvConfig env => BuildConfig -> RIO env Bool +hasLockFile bconfig = do + let stackFile = bcStackYaml bconfig + lockFile <- liftIO $ addFileExtension "lock" stackFile + liftIO $ doesFileExist lockFile + +-- parsePLI :: HasEnvConfig env => BuildConfig -> RIO env [PackageLocation] +-- parsePLI bconfig = do +-- let stackFile = bcStackYaml bconfig +-- rootDir = parent stackFile +-- lockFile <- liftIO $ addFileExtension "lock" stackFile +-- (pli :: Yaml.Value) <- Yaml.decodeFileThrow (toFilePath lockFile) +-- plis <- Yaml.parseMonad (parseLockFile rootDir) pli +-- plis' <- liftIO $ plis +-- pure $ NE.toList plis' +isLockFileOutdated :: Path Abs File -> RIO Config Bool +isLockFileOutdated stackFile = do + lockFile <- liftIO $ addFileExtension "lock" stackFile + smt <- liftIO $ getModificationTime stackFile + lmt <- + liftIO $ do + exists <- doesFileExist lockFile + if exists + then do + mt <- getModificationTime lockFile + pure $ Just mt + else pure Nothing + case lmt of + Nothing -> return True + Just mt -> return $ smt > mt +-- lockfile modificaton time < stackfile modification time +-- Use loadProjectConfig and parseLockfile to see if lock file has been outdated From 1a6ada2d6a1180a67cccd91bb8604116ae467c6b Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 23:21:53 +0530 Subject: [PATCH 32/76] Add logDebug --- src/Stack/Config.hs | 3 ++- src/Stack/Lock.hs | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index f830574bbe..80f7114efa 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -606,7 +606,8 @@ loadBuildConfig mproject maresolver mcompiler = do } lockFileOutdated <- isLockFileOutdated stackYamlFP - when lockFileOutdated (generateLockFile stackYamlFP) + when (not lockFileOutdated) (logDebug "Lock file is upto date") + when lockFileOutdated (logDebug "Lock file is outdated" >> generateLockFile stackYamlFP) -- liftIO $ resolveLockFile (parent stackYamlFP) lockFile <- liftIO $ addFileExtension "lock" stackYamlFP diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index c7c7c0db8b..bc0a171d90 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -19,6 +19,7 @@ import Stack.Types.Config -- BuildConfig is in Types/Config.hs generateLockFile :: Path Abs File -> RIO Config () generateLockFile stackFile = do + logDebug "Gennerating lock file" mproject <- view $ configL . to configMaybeProject p <- case mproject of From 4060499eda6abd060c7cc124fef4e3eac5e904a3 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 23:51:49 +0530 Subject: [PATCH 33/76] Cleanup --- src/Stack/Build.hs | 8 - src/Stack/Build/ConstructPlan.hs | 1 - src/Stack/Config.hs | 13 +- src/Stack/Freeze.hs | 1 - src/Stack/Lock.hs | 1 - subs/pantry/test/Pantry/TypesSpec.hs | 358 --------------------------- 6 files changed, 6 insertions(+), 376 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 6c8bf62480..87922e1356 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -59,7 +59,6 @@ build :: HasEnvConfig env -> Maybe FileLock -> RIO env () build msetLocalFiles mbuildLk = do - logDebug $ "build: 0" mcp <- view $ configL.to configModifyCodePage ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion fixCodePage mcp ghcVersion $ do @@ -74,8 +73,6 @@ build msetLocalFiles mbuildLk = do -- Set local files, necessary for file watching stackYaml <- view stackYamlL - logDebug $ "build: 1" - logDebug $ displayShow $ toFilePath stackYaml for_ msetLocalFiles $ \setLocalFiles -> do files <- sequence [lpFiles lp | lp <- allLocals] @@ -95,9 +92,7 @@ build msetLocalFiles mbuildLk = do boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI baseConfigOpts <- mkBaseConfigOpts boptsCli plan <- constructPlan baseConfigOpts localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli) - logDebug $ "build: 2" allowLocals <- view $ configL.to configAllowLocals - logDebug $ "build: 3" unless allowLocals $ case justLocals plan of [] -> return () localsIdents -> throwM $ LocalPackagesPresent localsIdents @@ -111,14 +106,11 @@ build msetLocalFiles mbuildLk = do (Just lk,True) -> do logDebug "All installs are local; releasing snapshot lock early." liftIO $ unlockFile lk _ -> return () - logDebug $ "build: 4" checkCabalVersion warnAboutSplitObjs bopts warnIfExecutablesWithSameNameCouldBeOverwritten locals plan - logDebug $ "build: 5" when (boptsPreFetch bopts) $ preFetch plan - logDebug $ "build: 6" 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 f099681271..9cc512ba94 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -205,7 +205,6 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap BSAll -> id BSOnlySnapshot -> stripLocals BSOnlyDependencies -> stripNonDeps deps - logDebug "constructPlan: 1" return $ takeSubset Plan { planTasks = tasks , planFinals = M.fromList finals diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 80f7114efa..5653175f2a 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -523,12 +523,11 @@ stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcess -> RIO env PackageLocation stackCompletePackageLocation cachePackages rp@(RPLImmutable rpli) = do let xs = filter (\(_,x) -> x == rp) cachePackages - item <- case xs of - [] -> do - pl <- completePackageLocation rpli - pure $ PLImmutable pl - (x,_):_ -> pure x - pure item + case xs of + [] -> do + pl <- completePackageLocation rpli + pure $ PLImmutable pl + (x,_):_ -> pure x stackCompletePackageLocation _ (RPLMutable rplm) = pure $ PLMutable rplm -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. @@ -606,7 +605,7 @@ loadBuildConfig mproject maresolver mcompiler = do } lockFileOutdated <- isLockFileOutdated stackYamlFP - when (not lockFileOutdated) (logDebug "Lock file is upto date") + unless lockFileOutdated (logDebug "Lock file is upto date") when lockFileOutdated (logDebug "Lock file is outdated" >> generateLockFile stackYamlFP) -- liftIO $ resolveLockFile (parent stackYamlFP) diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index d6033c11da..69559e7ccd 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -13,7 +13,6 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Yaml as Yaml import Path (addFileExtension, fromAbsFile, parent, toFilePath) import Path.IO (doesFileExist, getModificationTime) -import qualified Prelude as Prelude import qualified RIO.ByteString as B import RIO.Process import Stack.Config (loadConfigYaml) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index bc0a171d90..e14a89cd80 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -10,7 +10,6 @@ import qualified Data.Yaml as Yaml import Pantry (completePackageLocation) import Path (addFileExtension, fromAbsFile, parent, toFilePath) import Path.IO (doesFileExist, getModificationTime) -import qualified Prelude as Prelude import qualified RIO.ByteString as B import RIO.Process import Stack.Prelude diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index b600ef2bff..adfa39352f 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -200,364 +200,6 @@ spec = do PackageIdentifier (mkPackageName "persistent") (mkVersion [2, 8, 2]) --- it "parses PackageLocationImmutable (Repo)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - 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 --- 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.parseAbsDir "/home/sibi" --- pkgImm <- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither (parseLockFile rootDir) pkgIm of --- Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right iopl -> do --- pl <- iopl --- pure $ NonEmpty.toList pl --- Nothing -> fail "Can't parse PackageLocationImmutable - 2" --- pkgImm `shouldBe` --- [ PLImmutable (PLIRepo --- (Repo --- { repoUrl = "https://github.com/yesodweb/wai.git" --- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" --- , repoSubdir = "wai" --- , repoType = RepoGit --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 2, 1, 2] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") --- (FileSize 714)) --- , pmCabal = --- toBlobKey --- "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" --- 1765 --- }))] --- it "parses PackageLocationImmutable (Multiple Repos)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - 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 --- - 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.parseAbsDir "/home/sibi" --- pkgImm <- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither (parseLockFile rootDir) pkgIm of --- Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right xs -> do --- xs' <- sequence xs --- pure $ NonEmpty.toList xs' --- Nothing -> fail "Can't parse PackageLocationImmutable - 2" --- pkgImm `shouldBe` --- [ PLIRepo --- (Repo --- { repoUrl = "https://github.com/yesodweb/wai.git" --- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" --- , repoSubdir = "wai" --- , repoType = RepoGit --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 2, 1, 2] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "ecfd0b4b75f435a3f362394807b35e5ef0647b1a25005d44a3632c49db4833d2") --- (FileSize 714)) --- , pmCabal = --- toBlobKey --- "eea52c4967d8609c2f79213d6dffe6d6601034f1471776208404781de7051410" --- 1765 --- }), --- PLIRepo --- (Repo --- { repoUrl = "https://github.com/yesodweb/wai.git" --- , repoCommit = "d11d63f1a6a92db8c637a8d33e7953ce6194a3e0" --- , repoSubdir = "warp" --- , repoType = RepoGit --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "warp" --- , pkgVersion = mkVersion [3, 2, 25] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "f808e075811b002563d24c393ce115be826bb66a317d38da22c513ee42b7443a") --- (FileSize 5103)) --- , pmCabal = --- toBlobKey --- "cfec5336260bb4b1ecbd833f7d6948fd1ee373770471fe79796cf9c389c71758" --- 10725 --- }) --- ] --- it "parses PackageLocationImmutable (RPLIArchive)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - complete: --- - size: 285152 --- subdir: wai --- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip --- cabal-file: --- size: 1717 --- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 --- name: wai --- version: 3.0.2.3 --- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba --- pantry-tree: --- size: 710 --- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc --- 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.parseAbsDir "/home/sibi" --- pkgImm <- --- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither (parseLockFile rootDir) pkgIm of --- Left str -> --- fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right xs -> do --- xs' <- sequence xs --- pure $ NonEmpty.toList xs' --- Nothing -> fail "Can't parse PackageLocationImmutable" --- pkgImm `shouldBe` --- [ PLIArchive --- (Archive --- { archiveLocation = --- ALUrl --- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" --- , archiveHash = --- decodeSHA --- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" --- , archiveSize = FileSize 285152 --- , archiveSubdir = "wai" --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 0, 2, 3] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") --- (FileSize 710)) --- , pmCabal = --- toBlobKey --- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" --- 1717 --- }) --- ] --- it "parses PackageLocationImmutable (multiple RPLIArchive)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - complete: --- - size: 285152 --- subdir: wai --- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip --- cabal-file: --- size: 1717 --- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 --- name: wai --- version: 3.0.2.3 --- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba --- pantry-tree: --- size: 710 --- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc --- - size: 285152 --- subdir: wai --- url: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip --- cabal-file: --- size: 1717 --- sha256: 7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056 --- name: wai --- version: 3.0.2.3 --- sha256: 3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba --- pantry-tree: --- size: 710 --- sha256: 754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc --- 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.parseAbsDir "/home/sibi" --- pkgImm <- --- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither (parseLockFile rootDir) pkgIm of --- Left str -> --- fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right xs -> do --- xs' <- sequence xs --- pure $ NonEmpty.toList xs' --- Nothing -> fail "Can't parse PackageLocationImmutable" --- pkgImm `shouldBe` --- [ PLIArchive --- (Archive --- { archiveLocation = --- ALUrl --- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" --- , archiveHash = --- decodeSHA --- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" --- , archiveSize = FileSize 285152 --- , archiveSubdir = "wai" --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 0, 2, 3] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") --- (FileSize 710)) --- , pmCabal = --- toBlobKey --- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" --- 1717 --- }), --- PLIArchive --- (Archive --- { archiveLocation = --- ALUrl --- "http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip" --- , archiveHash = --- decodeSHA --- "3b6eb04f3763ca16432f3ab2135d239161fbe2c8811b8cd1778ffa67469289ba" --- , archiveSize = FileSize 285152 --- , archiveSubdir = "wai" --- }) --- (PackageMetadata --- { pmIdent = --- PackageIdentifier --- { pkgName = mkPackageName "wai" --- , pkgVersion = mkVersion [3, 0, 2, 3] --- } --- , pmTreeKey = --- TreeKey --- (BlobKey --- (decodeSHA --- "754e9b9d6949e23fa5ca730f50453d7e91fd2bc2d9170537fa2d33db8d6138fc") --- (FileSize 710)) --- , pmCabal = --- toBlobKey --- "7b46e7a8b121d668351fa8a684810afadf58c39276125098485203ef274fd056" --- 1717 --- }) --- ] --- it "parses PackageLocationImmutable (PLIHackage)" $ do --- let lockFile :: ByteString --- lockFile = [s|#some --- dependencies: --- - complete: --- - hackage: persistent-2.8.2@sha256:df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1,5058 --- pantry-tree: --- size: 2165 --- sha256: 3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce --- 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.parseAbsDir "/home/sibi" --- pkgImm <- --- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither (parseLockFile rootDir) pkgIm of --- Left str -> --- fail $ "Can't parse PackageLocationImmutable - 1" <> str --- Right xs -> do --- xs' <- sequence xs --- pure $ NonEmpty.toList xs' --- Nothing -> fail "Can't parse PackageLocationImmutable" --- pkgImm `shouldBe` [PLIHackage (PackageIdentifier {pkgName = mkPackageName "persistent", pkgVersion = mkVersion [2,8,2]}) (toBlobKey --- "df118e99f0c46715e932fe82d787fc09689d87898f3a8b13f5954d25af6b46a1" 5058) (TreeKey --- (BlobKey --- (decodeSHA --- "3cb3a9ca3e373a152d9acf622706471578cc93b2ed20c893fc20a4814264f1ce") --- (FileSize 2165)))] it "parses lock file (empty)" $ do let lockFile :: ByteString lockFile = From 70db76870365ee2a038ef2b81e364246b7d9761c Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 15 Feb 2019 23:55:04 +0530 Subject: [PATCH 34/76] Cleanup --- src/Stack/Lock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index e14a89cd80..a4726a5d3c 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -29,7 +29,7 @@ generateLockFile stackFile = do lockFile <- liftIO $ addFileExtension "lock" stackFile resolver' :: SnapshotLocation <- completeSnapshotLocation resolver deps' :: [PackageLocation] <- mapM completePackageLocation' deps - let deps'' = map (\x -> (fst x, snd x)) (zip deps deps') + let deps'' = zip deps deps' let depsObject = Yaml.object [ ( "resolver" From 6d0516464d57311b38f433645e5f14070742380c Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Sat, 16 Feb 2019 00:28:20 +0530 Subject: [PATCH 35/76] Cleanup --- snapshot-lts-12.yaml | 1 + src/Stack/Config.hs | 3 -- src/Stack/Freeze.hs | 6 +--- src/Stack/Lock.hs | 19 +++++++----- src/Stack/Types/Config.hs | 5 +-- subs/pantry/src/Pantry/Types.hs | 55 ++++++++++++--------------------- 6 files changed, 35 insertions(+), 54 deletions(-) diff --git a/snapshot-lts-12.yaml b/snapshot-lts-12.yaml index ef5026ab8b..88c085a794 100644 --- a/snapshot-lts-12.yaml +++ b/snapshot-lts-12.yaml @@ -8,3 +8,4 @@ packages: - infer-license-0.2.0@rev:0 #for hpack-0.31 - tar-conduit-0.3.1@rev:0 - yaml-0.10.4.0@rev:0 #for hpack-0.31 +- string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3 diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 5653175f2a..17a2f1d19b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -625,9 +625,6 @@ 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 <- stackCompletePackageLocation cachePL rpl dp <- additionalDepPackage (shouldHaddockDeps bopts) pl diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 69559e7ccd..44c49845b5 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -9,13 +9,9 @@ module Stack.Freeze ) where import Data.Aeson ((.=), object) -import qualified Data.List.NonEmpty as NE import qualified Data.Yaml as Yaml -import Path (addFileExtension, fromAbsFile, parent, toFilePath) -import Path.IO (doesFileExist, getModificationTime) import qualified RIO.ByteString as B import RIO.Process -import Stack.Config (loadConfigYaml) import Stack.Prelude import Stack.Types.Config @@ -47,7 +43,7 @@ doFreeze p FreezeProject = do let deps :: [RawPackageLocation] = projectDependencies p resolver :: RawSnapshotLocation = projectResolver p resolver' :: SnapshotLocation <- completeSnapshotLocation resolver - deps' :: [PackageLocation] <- mapM undefined deps + deps' :: [PackageLocation] <- mapM completePackageLocation' deps let rawCompleted = map toRawPL deps' rawResolver = toRawSL resolver' if rawCompleted == deps && rawResolver == resolver diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index a4726a5d3c..ad5c51e7f8 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -4,18 +4,23 @@ module Stack.Lock where -import Data.Aeson ((.=), object) -import qualified Data.List.NonEmpty as NE import qualified Data.Yaml as Yaml -import Pantry (completePackageLocation) -import Path (addFileExtension, fromAbsFile, parent, toFilePath) +import Data.Yaml (object) +import Path (addFileExtension, fromAbsFile) import Path.IO (doesFileExist, getModificationTime) import qualified RIO.ByteString as B -import RIO.Process import Stack.Prelude import Stack.Types.Config --- BuildConfig is in Types/Config.hs +data LockException = + LockNoProject + deriving (Typeable) + +instance Exception LockException + +instance Show LockException where + show (LockNoProject) = "No project found for locking." + generateLockFile :: Path Abs File -> RIO Config () generateLockFile stackFile = do logDebug "Gennerating lock file" @@ -23,7 +28,7 @@ generateLockFile stackFile = do p <- case mproject of Just (p, _) -> return p - Nothing -> error "No project was found: nothing to freeze" -- todo + Nothing -> throwM LockNoProject let deps :: [RawPackageLocation] = projectDependencies p resolver :: RawSnapshotLocation = projectResolver p lockFile <- liftIO $ addFileExtension "lock" stackFile diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 4b746b6fd8..183dfdd517 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -169,12 +169,10 @@ module Stack.Types.Config import Control.Monad.Writer (tell) import Crypto.Hash (hashWith, SHA1(..)) import Stack.Prelude -import qualified Data.Aeson.Types as Aeson -import qualified Data.Vector as Vector import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object, (.=), (..:), (...:), (..:?), (..!=), Value(Bool), - withObjectWarnings, WarningParser, Object, jsonSubWarnings, unWarningParser, + withObjectWarnings, WarningParser, Object, jsonSubWarnings, jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings, FromJSONKeyFunction (FromJSONKeyTextParser)) import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) @@ -226,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) -import Data.Aeson (withArray, (.:)) -- Re-exports import Stack.Types.Config.Build as X diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 6711f70c7f..a280cb33ea 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -108,7 +108,6 @@ module Pantry.Types ) where import RIO -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Conduit.Tar as Tar import qualified Data.Vector as Vector import qualified Data.Yaml as Yaml @@ -1530,16 +1529,6 @@ rpmToPairs (RawPackageMetadata mname mversion mtree mcabal) = concat , maybe [] (\cabal -> ["cabal-file" .= cabal]) mcabal ] -appendPLI :: NonEmpty (IO PackageLocation) -> NonEmpty (IO PackageLocation) -> NonEmpty (IO PackageLocation) -appendPLI xs ys = xs <> ys - -appendPLI' :: IO (NonEmpty PackageLocation) -> IO (NonEmpty PackageLocation) -> IO (NonEmpty PackageLocation) -appendPLI' xs ys = xs <> ys - -isCompleteObject :: Value -> Bool -isCompleteObject obj@(Object xs) = HM.member "complete" xs -isCompleteObject _ = False - parseAndResolvePackageLocation :: Path Abs Dir -> Value -> Parser (IO (NonEmpty PackageLocation)) parseAndResolvePackageLocation rootDir v = do (Unresolved unresolvedPL) <- parsePackageLocation v @@ -1555,7 +1544,7 @@ parseSingleObject :: Value -> Parser (Unresolved (PackageLocation, RawPackageLoc parseSingleObject value = withObject "LockFile" (\obj -> do original <- obj .: "original" complete <- obj .: "complete" - orig <- parseRPLImmutable original + orig <- parseRPL original comp <- parsePImmutable complete pure $ combineUnresolved comp orig ) value @@ -1580,7 +1569,7 @@ loadLockFile :: Path Abs File -> IO [(PackageLocation, RawPackageLocation)] loadLockFile lockFile = do val <- Yaml.decodeFileThrow (toFilePath lockFile) case Yaml.parseEither (resolveLockFile (parent lockFile)) val of - Left str -> fail "Cannot parse lock file" -- todo: fix this + Left str -> fail $ "Cannot parse lock file: Got error " <> str Right iopl -> do pl <- iopl pure pl @@ -1595,13 +1584,13 @@ instance FromJSON (Unresolved PackageLocationImmutable) where <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) where repoObject :: Value -> Parser (Unresolved PackageLocationImmutable) - repoObject value@(Object _) = do + repoObject value = do repo <- parseJSON value pm <- parseJSON value pure $ pure $ PLIRepo repo pm archiveObject :: Value -> Parser (Unresolved PackageLocationImmutable) - archiveObject value@(Object _) = do + archiveObject value = do pm <- parseJSON value pli <- withObject "UnresolvedPackageLocationImmutable.PLIArchive" (\o -> do Unresolved mkArchiveLocation <- unWarningParser $ parseArchiveLocationObject o @@ -1641,18 +1630,6 @@ instance FromJSON (Unresolved PackageLocationImmutable) where archiveSubdir <- o .: "subdir" pure $ pure $ PLIArchive Archive {..} pm) value -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' - - parseRPLImmutable :: Value -> Parser (Unresolved RawPackageLocation) parseRPLImmutable v = do xs :: Unresolved RawPackageLocationImmutable <- parseRPLI v @@ -1661,9 +1638,6 @@ parseRPLImmutable v = do parseRPL :: Value -> Parser (Unresolved RawPackageLocation) parseRPL v = parseRPLImmutable v <|> parseResolvedPath v - - - parseRPLI :: Value -> Parser (Unresolved RawPackageLocationImmutable) parseRPLI v = parseRPLHttpText v <|> parseRPLHackageText v <|> parseRPLHackageObject v <|> @@ -1671,6 +1645,17 @@ parseRPLI v = parseArchiveRPLObject v <|> parseGithubRPLObject v +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' + parseRPLHttpText :: Value -> Parser (Unresolved RawPackageLocationImmutable) parseRPLHttpText = withText "UnresolvedPackageLocationImmutable.UPLIArchive (Text)" $ \t -> case parseArchiveLocationText t of @@ -1694,8 +1679,8 @@ parseRPLHackageObject = withObject "UnresolvedPackageLocationImmutable.UPLIHacka <$> o .: "hackage" <*> o .:? "pantry-tree") -optionalSubdirs :: Object -> Parser OptionalSubdirs -optionalSubdirs o = +optionalSubdirs' :: Object -> Parser OptionalSubdirs +optionalSubdirs' o = case HM.lookup "subdirs" o of -- if subdirs exists, it needs to be valid Just v' -> do subdirs <- parseJSON v' @@ -1716,7 +1701,7 @@ parseRPLRepo = withObject "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> ((RepoGit, ) <$> o .: "git") <|> ((RepoHg, ) <$> o .: "hg") repoCommit <- o .: "commit" - os <- optionalSubdirs o + os <- optionalSubdirs' o pure $ pure $ NE.head $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) parseArchiveRPLObject :: Value -> Parser (Unresolved RawPackageLocationImmutable) @@ -1724,7 +1709,7 @@ parseArchiveRPLObject = withObject "UnresolvedPackageLocationImmutable.UPLIArchi Unresolved mkArchiveLocation <- unWarningParser $ parseArchiveLocationObject o raHash <- o .:? "sha256" raSize <- o .:? "size" - os <- optionalSubdirs o + os <- optionalSubdirs' o pure $ Unresolved $ \mdir -> do raLocation <- mkArchiveLocation mdir pure $ NE.head $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) @@ -1742,7 +1727,7 @@ parseGithubRPLObject = withObject "PLArchive:github" $ \o -> do ] raHash <- o .:? "sha256" raSize <- o .:? "size" - os <- optionalSubdirs o + os <- optionalSubdirs' o pure $ pure $ NE.head $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where From d6cba4d17af81a321b97eab26ff515d648cc0b5f Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Sun, 17 Feb 2019 14:52:02 +0530 Subject: [PATCH 36/76] Fix style --- src/Stack/Lock.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index ad5c51e7f8..94a7c40dd8 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -19,7 +19,7 @@ data LockException = instance Exception LockException instance Show LockException where - show (LockNoProject) = "No project found for locking." + show LockNoProject = "No project found for locking." generateLockFile :: Path Abs File -> RIO Config () generateLockFile stackFile = do From 47573a0880eac2c444f14c1ea6d9430b9759b9c2 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Mon, 18 Feb 2019 18:18:49 +0530 Subject: [PATCH 37/76] Add parseRSL function --- subs/pantry/src/Pantry/Types.hs | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index a280cb33ea..4e169ba06c 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1970,6 +1970,29 @@ instance Display SnapshotLocation where display (SLUrl url blob) = display url <> " (" <> display blob <> ")" display (SLFilePath resolved) = display (resolvedRelative resolved) +-- use this +parseRSL :: Value -> Parser (Unresolved RawSnapshotLocation) +parseRSL v = txtParser v <|> parseRSLObject v + where + txtParser = withText "UnresolvedSnapshotLocation (Text)" (pure . parseRawSnapshotLocation) + +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") + + +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" + -- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. -- -- @since 0.1.0.0 From da27d9490cdbbd6953fd3e8223ccd4723868268d Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 00:45:14 +0530 Subject: [PATCH 38/76] Add parsing logic for resolver also --- subs/pantry/src/Pantry/Types.hs | 86 ++++++++++++++++++++++++++++----- 1 file changed, 74 insertions(+), 12 deletions(-) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 4e169ba06c..3795a5799b 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1549,30 +1549,51 @@ parseSingleObject value = withObject "LockFile" (\obj -> do pure $ combineUnresolved comp orig ) value +data LockFile a = LockFile { + lfPackageLocation :: a [(PackageLocation, RawPackageLocation)], + lfoResolver :: a RawSnapshotLocation, + lfcResolver :: a SnapshotLocation +} + parseLockFile :: - Value -> Parser [Unresolved (PackageLocation, RawPackageLocation)] + Value -> Parser (LockFile Unresolved) parseLockFile value = withObject "LockFile" (\obj -> do vals :: Value <- obj .: "dependencies" xs <- withArray "LockFileArray" (\vec -> sequence $ Vector.map parseSingleObject vec) vals - pure $ Vector.toList xs + resolver <- obj .: "resolver" + roriginal <- resolver .: "original" + rcomplete <- resolver .: "complete" + ro <- parseRSL roriginal + rc <- parseSL rcomplete + pure $ LockFile { + lfPackageLocation = sequence (Vector.toList xs), + lfoResolver = ro, + lfcResolver = rc + } ) value -resolveLockFile :: Path Abs Dir -> Value -> Parser (IO [(PackageLocation, RawPackageLocation)]) +resolveLockFile :: Path Abs Dir -> Value -> Parser (LockFile IO) resolveLockFile rootDir v = do - val <- parseLockFile v - let val' = sequence val - val'' = resolvePaths (Just rootDir) val' - pure val'' - -loadLockFile :: Path Abs File -> IO [(PackageLocation, RawPackageLocation)] + lockFile <- parseLockFile v + let pkgLoc = (lfPackageLocation lockFile) + origRes = lfoResolver lockFile + compRes = lfcResolver lockFile + pkgLoc' = resolvePaths (Just rootDir) pkgLoc + pure $ + LockFile + { lfPackageLocation = pkgLoc' + , lfoResolver = resolvePaths (Just rootDir) origRes + , lfcResolver = resolvePaths (Just rootDir) compRes + } + +loadLockFile :: Path Abs File -> IO (LockFile IO) loadLockFile lockFile = do val <- Yaml.decodeFileThrow (toFilePath lockFile) case Yaml.parseEither (resolveLockFile (parent lockFile)) val of Left str -> fail $ "Cannot parse lock file: Got error " <> str - Right iopl -> do - pl <- iopl - pure pl + Right lockFileIO -> pure lockFileIO + parsePImmutable :: Value -> Parser (Unresolved PackageLocation) parsePImmutable v = do @@ -1970,6 +1991,26 @@ instance Display SnapshotLocation where display (SLUrl url blob) = display url <> " (" <> display blob <> ")" display (SLFilePath resolved) = display (resolvedRelative resolved) +-- use this +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)) + + + +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") + -- use this parseRSL :: Value -> Parser (Unresolved RawSnapshotLocation) parseRSL v = txtParser v <|> parseRSLObject v @@ -1993,6 +2034,16 @@ parseBlobKey o = do (Just _sha, Nothing) -> fail "You must also specify the file size" (Nothing, Just _) -> fail "You must also specify the file's SHA256" +parseSnapshotLocation :: Value -> Parser (Unresolved SnapshotLocation) +parseSnapshotLocation = + withObject + "UnresolvedSnapshotLocation" + (\o -> do + url <- o .: "url" + bkey <- parseJSON (Object o) + pure $ pure $ SLUrl url bkey) + + -- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. -- -- @since 0.1.0.0 @@ -2034,6 +2085,15 @@ parseRawSnapshotLocationPath t = abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' +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' + githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation githubSnapshotLocation user repo path = let url = T.concat @@ -2052,6 +2112,8 @@ defUser = "commercialhaskell" defRepo :: Text defRepo = "stackage-snapshots" + + -- | Location of an LTS snapshot -- -- @since 0.1.0.0 From 6533f974df77d967ac01a4947c3789ab25e74be4 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 01:07:44 +0530 Subject: [PATCH 39/76] Add logic for reusing snapshot information from lock file --- src/Stack/Config.hs | 24 +++++++++++++++++++----- subs/pantry/src/Pantry.hs | 1 + subs/pantry/src/Pantry/Types.hs | 1 + 3 files changed, 21 insertions(+), 5 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 17a2f1d19b..8c9d38ab0c 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -88,7 +88,7 @@ import System.PosixCompat.User (getEffectiveUserID) import RIO.PrettyPrint import Stack.Lock (generateLockFile, isLockFileOutdated) import RIO.Process -import Pantry (loadLockFile) +import Pantry (loadLockFile, LockFile (..)) -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. @@ -608,11 +608,25 @@ loadBuildConfig mproject maresolver mcompiler = do unless lockFileOutdated (logDebug "Lock file is upto date") when lockFileOutdated (logDebug "Lock file is outdated" >> generateLockFile stackYamlFP) - -- liftIO $ resolveLockFile (parent stackYamlFP) lockFile <- liftIO $ addFileExtension "lock" stackYamlFP - cachePL <- liftIO $ loadLockFile lockFile - - resolver <- completeSnapshotLocation $ projectResolver project + (cachePL, origResolver, compResolver) <- liftIO $ do + lfio <- loadLockFile lockFile + let pkgLoc = lfPackageLocation lfio + origResolver = lfoResolver lfio + compResolver = lfcResolver lfio + cpl <- pkgLoc + or <- origResolver + cr <- compResolver + return (cpl, or, cr) + + + resolver <- if (projectResolver project == origResolver) + then do + logInfo "Resolver matches with the lock file" + pure compResolver + else do + logInfo "Resolving snapshot location" + completeSnapshotLocation $ projectResolver project (snapshot, _completed) <- loadAndCompleteSnapshot resolver extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 6ad3327bb5..a45c84c8e8 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -147,6 +147,7 @@ module Pantry -- * Cabal files , loadCabalFileRaw , loadCabalFile + , LockFile (..) , loadLockFile , loadCabalFileRawImmutable , loadCabalFileImmutable diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 3795a5799b..69e33a25b6 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -67,6 +67,7 @@ module Pantry.Types , packageIdentifierString , packageNameString , resolveLockFile + , LockFile (..) , loadLockFile , parseAndResolvePackageLocation , flagNameString From 6a5c179c19c87efd86bfa4658dabdb0e4f08fa9f Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 02:57:08 +0530 Subject: [PATCH 40/76] Fix tests --- subs/pantry/test/Pantry/TypesSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index adfa39352f..45e6eeb5ad 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -224,7 +224,7 @@ resolver: str <> (show pkgIm) Right iopl -> do - pl <- iopl + pl <- lfPackageLocation iopl pure pl Nothing -> fail "Can't parse PackageLocationImmutable" pkgImm `shouldBe` [] @@ -284,7 +284,7 @@ resolver: str <> (show pkgIm) Right iopl -> do - pl <- iopl + pl <- lfPackageLocation iopl pure pl Nothing -> fail "Can't parse PackageLocationImmutable" pkgImm `shouldBe` From fd6f0fb8b9fb84b8cdcf59d93c7fe261189cd311 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 03:36:27 +0530 Subject: [PATCH 41/76] Add resolveSnapshotFile function --- subs/pantry/src/Pantry.hs | 1 + subs/pantry/src/Pantry/Types.hs | 13 +++++++++++++ 2 files changed, 14 insertions(+) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index a45c84c8e8..e7f05ee97d 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -107,6 +107,7 @@ module Pantry , parsePackageIdentifierRevision , parseHackageText , resolveLockFile + , resolveSnapshotFile , parseAndResolvePackageLocation -- ** Cabal values diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 69e33a25b6..d97c3da69a 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -67,6 +67,7 @@ module Pantry.Types , packageIdentifierString , packageNameString , resolveLockFile + , resolveSnapshotFile , LockFile (..) , loadLockFile , parseAndResolvePackageLocation @@ -1556,6 +1557,18 @@ data LockFile a = LockFile { lfcResolver :: a SnapshotLocation } +parseSnapshotFile :: Value -> Parser (Unresolved [RawPackageLocation]) +parseSnapshotFile (Object obj) = do + packages <- obj .: "packages" + xs <- withArray "SnapshotFileArray" (\vec -> sequence $ Vector.map parseRPL vec) packages + pure $ sequence $ Vector.toList xs +parseSnapshotFile val = fail $ "Expected Object, but got: " <> (show val) + +resolveSnapshotFile :: Path Abs Dir -> Value -> Parser (IO [RawPackageLocation]) +resolveSnapshotFile rootDir val = do + unrpl <- parseSnapshotFile val + let pkgLoc = resolvePaths (Just rootDir) unrpl + pure pkgLoc parseLockFile :: Value -> Parser (LockFile Unresolved) From ed4e800f851ea9b91a867c9167e3f69c953d747e Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 14:45:45 +0530 Subject: [PATCH 42/76] Add more utility functions --- src/Stack/Lock.hs | 68 +++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 60 insertions(+), 8 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 94a7c40dd8..f6d8f82860 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -6,20 +6,24 @@ module Stack.Lock where import qualified Data.Yaml as Yaml import Data.Yaml (object) -import Path (addFileExtension, fromAbsFile) +import Pantry (resolveSnapshotFile) +import Path (addFileExtension, fromAbsFile, parent) import Path.IO (doesFileExist, getModificationTime) import qualified RIO.ByteString as B import Stack.Prelude import Stack.Types.Config -data LockException = - LockNoProject +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) generateLockFile :: Path Abs File -> RIO Config () generateLockFile stackFile = do @@ -53,12 +57,60 @@ generateLockFile stackFile = do ] B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) -hasLockFile :: HasEnvConfig env => BuildConfig -> RIO env Bool -hasLockFile bconfig = do - let stackFile = bcStackYaml bconfig - lockFile <- liftIO $ addFileExtension "lock" stackFile - liftIO $ doesFileExist lockFile +loadSnapshotFile :: Path Abs File -> Path Abs Dir -> IO [RawPackageLocation] +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 + +loadSnapshotLockFile :: + Path Abs File -- ^ Snapshot lock file + -> IO [(RawPackageLocation, PackageLocation)] +loadSnapshotLockFile = undefined +generateSnapshotLockFile :: + Path Abs File -- ^ Snapshot file + -> [RawPackageLocation] + -> RIO Config () +generateSnapshotLockFile path rpl = do + logInfo "Generating Lock file for snapshot" + deps :: [PackageLocation] <- mapM completePackageLocation' rpl + lockFile <- liftIO $ addFileExtension "lock" path + let depPairs :: [(PackageLocation, RawPackageLocation)] = zip deps rpl + depsObject = + Yaml.object + [ ( "dependencies" + , Yaml.array + (map (\(raw, comp) -> + object + [ ("original", Yaml.toJSON raw) + , ("complete", Yaml.toJSON comp) + ]) + depPairs)) + ] + B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) + +-- Things to do +-- 1. Creae function to write custom snapshot lock file. something like fn :: [RawPackageLocation] -> Path Abs File (snapshot file) -> IO () +-- 2. Create function to load data from custom snapshot file. Something like fn :: Path Abs File -> IO [(PackageLocation, RawPackageLocation)] +-- 3. Try to use the loaded data in the loadBuildconfig function +generateLockFileForCustomSnapshot :: + SnapshotLocation -> Path Abs File -> RIO Config () +generateLockFileForCustomSnapshot (SLFilePath path) stackFile + -- todo: see if there is existing and outdated file + = do + let snapshotPath = resolvedAbsolute path + rpl <- liftIO $ loadSnapshotFile snapshotPath (parent stackFile) + generateSnapshotLockFile snapshotPath rpl +generateLockFileForCustomSnapshot xs _ = throwM (LockCannotGenerate xs) + +-- hasLockFile :: HasEnvConfig env => RIO env Bool +-- hasLockFile = do +-- bconfig <- view $ envConfigL . to envConfigBuildConfig +-- let stackFile = bcStackYaml bconfig +-- lockFile <- liftIO $ addFileExtension "lock" stackFile +-- liftIO $ doesFileExist lockFile -- parsePLI :: HasEnvConfig env => BuildConfig -> RIO env [PackageLocation] -- parsePLI bconfig = do -- let stackFile = bcStackYaml bconfig From c99ecf57fd992c292816becc842c542d2abce061 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 14:46:16 +0530 Subject: [PATCH 43/76] Add logic for generating lock file for custom snapshot --- src/Stack/Config.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 8c9d38ab0c..870be96e5c 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -86,7 +86,7 @@ import System.Environment import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) import RIO.PrettyPrint -import Stack.Lock (generateLockFile, isLockFileOutdated) +import Stack.Lock (generateLockFile, isLockFileOutdated, generateLockFileForCustomSnapshot) import RIO.Process import Pantry (loadLockFile, LockFile (..)) @@ -627,6 +627,13 @@ loadBuildConfig mproject maresolver mcompiler = do else do logInfo "Resolving snapshot location" completeSnapshotLocation $ projectResolver project + + case resolver of + SLFilePath _ -> generateLockFileForCustomSnapshot resolver stackYamlFP + _ -> return () + + -- todo: loadAndCompleteSnapshot likely has to be cached in a new lock file + logDebug $ (displayShow resolver) (snapshot, _completed) <- loadAndCompleteSnapshot resolver extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) From f6885649a9478f54841d939dcc6dda54d1c8b953 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 15:00:48 +0530 Subject: [PATCH 44/76] Add other helper functions --- subs/pantry/src/Pantry/Types.hs | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index d97c3da69a..0d88912ab8 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1557,6 +1557,33 @@ data LockFile a = LockFile { lfcResolver :: a SnapshotLocation } +parseSnapshotLockFile :: + Value -> Parser (Unresolved [(PackageLocation, RawPackageLocation)]) +parseSnapshotLockFile = + withObject + "SnapshotLockFile" + (\obj -> do + vals <- obj .: "dependencies" + xs <- + withArray + "SnapshotLockArray" + (\vec -> sequence $ Vector.map parseSingleObject vec) + vals + pure $ sequence $ Vector.toList xs) + +resolveSnapshotLockFile :: Path Abs Dir -> Value -> Parser (IO [(PackageLocation, RawPackageLocation)]) +resolveSnapshotLockFile rootDir val = do + pkgs <- parseSnapshotLockFile val + let pkgsLoc = resolvePaths (Just rootDir) pkgs + pure pkgsLoc + +loadSnapshotLockFile :: Path Abs File -> Path Abs Dir -> IO [(PackageLocation, RawPackageLocation)] +loadSnapshotLockFile lockFile rootDir = do + val <- Yaml.decodeFileThrow (toFilePath lockFile) + case Yaml.parseEither (resolveSnapshotLockFile rootDir) val of + Left str -> fail $ "Cannot parse snapshot lock file: Got error " <> str + Right lockFileIO -> lockFileIO + parseSnapshotFile :: Value -> Parser (Unresolved [RawPackageLocation]) parseSnapshotFile (Object obj) = do packages <- obj .: "packages" From 016b16dc960746732cb28b21aa2428f9ed413cf1 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 16:55:24 +0530 Subject: [PATCH 45/76] Add test --- subs/pantry/test/Pantry/TypesSpec.hs | 52 ++++++++++++++++++++++++++++ 1 file changed, 52 insertions(+) diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 45e6eeb5ad..65da369b96 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -376,3 +376,55 @@ resolver: , rpmCabal = Nothing }))) ] + it "parses snapshot lock file (non empty)" $ do + let lockFile :: ByteString + lockFile = + [s|#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.parseAbsDir "/home/sibi" + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither + (resolveSnapshotLockFile rootDir) + pkgIm of + Left str -> + fail $ + "Can't parse PackageLocationImmutable - 1" <> + str <> + (show pkgIm) + Right iopl -> do + pl <- iopl + pure pl + Nothing -> fail "Can't parse PackageLocationImmutable" + pkgImm `shouldBe` + [ ( PLImmutable + (PLIHackage + (PackageIdentifier + { pkgName = mkPackageName "string-quote" + , pkgVersion = mkVersion [0, 0, 1] + }) + (toBlobKey + "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" + 758) + (TreeKey + (BlobKey + (decodeSHA + "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") + (FileSize 273)))) + , RPLImmutable + (RPLIHackage + (PackageIdentifierRevision + (mkPackageName "string-quote") + (mkVersion [0, 0, 1]) + CFILatest) + Nothing)) + ] From 86ff18cf5fdd84dc779e926f7e93e22ae08df539 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 16:55:36 +0530 Subject: [PATCH 46/76] Fix minor bug related to snapshot lock file --- src/Stack/Lock.hs | 7 +++---- subs/pantry/src/Pantry.hs | 1 + subs/pantry/src/Pantry/Types.hs | 1 + 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index f6d8f82860..597f41f089 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -82,7 +82,7 @@ generateSnapshotLockFile path rpl = do Yaml.object [ ( "dependencies" , Yaml.array - (map (\(raw, comp) -> + (map (\(comp, raw) -> object [ ("original", Yaml.toJSON raw) , ("complete", Yaml.toJSON comp) @@ -92,9 +92,8 @@ generateSnapshotLockFile path rpl = do B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) -- Things to do --- 1. Creae function to write custom snapshot lock file. something like fn :: [RawPackageLocation] -> Path Abs File (snapshot file) -> IO () --- 2. Create function to load data from custom snapshot file. Something like fn :: Path Abs File -> IO [(PackageLocation, RawPackageLocation)] --- 3. Try to use the loaded data in the loadBuildconfig function +-- 2. Try to use the loaded data in the loadBuildconfig function +-- 3. Finish todos generateLockFileForCustomSnapshot :: SnapshotLocation -> Path Abs File -> RIO Config () generateLockFileForCustomSnapshot (SLFilePath path) stackFile diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index e7f05ee97d..1051bd695f 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -108,6 +108,7 @@ module Pantry , parseHackageText , resolveLockFile , resolveSnapshotFile + , resolveSnapshotLockFile , parseAndResolvePackageLocation -- ** Cabal values diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 0d88912ab8..1f1a11ccf5 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -68,6 +68,7 @@ module Pantry.Types , packageNameString , resolveLockFile , resolveSnapshotFile + , resolveSnapshotLockFile , LockFile (..) , loadLockFile , parseAndResolvePackageLocation From 25e3427037bb4463ad70796fbd8ad774f92da727 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 19 Feb 2019 23:43:24 +0530 Subject: [PATCH 47/76] Add lock support for custom snapshot. --- src/Stack/Config.hs | 7 +++-- src/Stack/Lock.hs | 25 ++-------------- subs/pantry/src/Pantry.hs | 53 +++++++++++++++++++++++++++------ subs/pantry/src/Pantry/Types.hs | 1 + 4 files changed, 51 insertions(+), 35 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 870be96e5c..699f33bbe9 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -629,12 +629,13 @@ loadBuildConfig mproject maresolver mcompiler = do completeSnapshotLocation $ projectResolver project case resolver of - SLFilePath _ -> generateLockFileForCustomSnapshot resolver stackYamlFP + SLFilePath path -> do + outdated <- isLockFileOutdated (resolvedAbsolute path) + when outdated (generateLockFileForCustomSnapshot resolver stackYamlFP) _ -> return () -- todo: loadAndCompleteSnapshot likely has to be cached in a new lock file - logDebug $ (displayShow resolver) - (snapshot, _completed) <- loadAndCompleteSnapshot resolver + (snapshot, _completed) <- loadAndCompleteSnapshot resolver (parent stackYamlFP) extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 597f41f089..0cf01e2753 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -91,34 +91,15 @@ generateSnapshotLockFile path rpl = do ] B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) --- Things to do --- 2. Try to use the loaded data in the loadBuildconfig function --- 3. Finish todos generateLockFileForCustomSnapshot :: SnapshotLocation -> Path Abs File -> RIO Config () -generateLockFileForCustomSnapshot (SLFilePath path) stackFile - -- todo: see if there is existing and outdated file - = do +generateLockFileForCustomSnapshot (SLFilePath path) stackFile = do + logInfo "Generating lock file for custom snapshot" let snapshotPath = resolvedAbsolute path rpl <- liftIO $ loadSnapshotFile snapshotPath (parent stackFile) generateSnapshotLockFile snapshotPath rpl generateLockFileForCustomSnapshot xs _ = throwM (LockCannotGenerate xs) --- hasLockFile :: HasEnvConfig env => RIO env Bool --- hasLockFile = do --- bconfig <- view $ envConfigL . to envConfigBuildConfig --- let stackFile = bcStackYaml bconfig --- lockFile <- liftIO $ addFileExtension "lock" stackFile --- liftIO $ doesFileExist lockFile --- parsePLI :: HasEnvConfig env => BuildConfig -> RIO env [PackageLocation] --- parsePLI bconfig = do --- let stackFile = bcStackYaml bconfig --- rootDir = parent stackFile --- lockFile <- liftIO $ addFileExtension "lock" stackFile --- (pli :: Yaml.Value) <- Yaml.decodeFileThrow (toFilePath lockFile) --- plis <- Yaml.parseMonad (parseLockFile rootDir) pli --- plis' <- liftIO $ plis --- pure $ NE.toList plis' isLockFileOutdated :: Path Abs File -> RIO Config Bool isLockFileOutdated stackFile = do lockFile <- liftIO $ addFileExtension "lock" stackFile @@ -134,5 +115,3 @@ isLockFileOutdated stackFile = do case lmt of Nothing -> return True Just mt -> return $ smt > mt --- lockfile modificaton time < stackfile modification time --- Use loadProjectConfig and parseLockfile to see if lock file has been outdated diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 1051bd695f..bc9ac281f1 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -151,6 +151,7 @@ module Pantry , loadCabalFile , LockFile (..) , loadLockFile + , loadSnapshotLockFile , loadCabalFileRawImmutable , loadCabalFileImmutable , loadCabalFilePath @@ -988,9 +989,10 @@ type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation + -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshot loc = - loadAndCompleteSnapshotRaw (toRawSL loc) +loadAndCompleteSnapshot loc rootDir = + loadAndCompleteSnapshotRaw (toRawSL loc) rootDir -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations @@ -999,8 +1001,9 @@ loadAndCompleteSnapshot loc = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation + -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshotRaw loc = do +loadAndCompleteSnapshotRaw loc rootDir = do eres <- loadRawSnapshotLayer loc case eres of Left wc -> @@ -1012,10 +1015,11 @@ loadAndCompleteSnapshotRaw loc = do } in pure (snapshot, []) Right (rsl, _sha) -> do - (snap0, completed0) <- loadAndCompleteSnapshotRaw $ rslParent rsl + (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) rootDir (packages, completed, unused) <- addAndCompletePackagesToSnapshot - (display loc) + loc + rootDir (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl @@ -1145,6 +1149,20 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens pure (allPackages, unused) +stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => [(PackageLocation, RawPackageLocation)] + -> RawPackageLocationImmutable + -> RIO env PackageLocation +stackCompletePackageLocation cachePackages rpli = do + let rp = RPLImmutable rpli + xs = filter (\(_,x) -> x == rp) cachePackages + case xs of + [] -> do + pl <- completePackageLocation rpli + pure $ PLImmutable pl + (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 @@ -1157,17 +1175,31 @@ 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 + -> Path Abs Dir -> [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 +addAndCompletePackagesToSnapshot loc rootDir newPackages (AddPackagesConfig drops flags hiddens options) old = do + cachedPL <- case loc of + RSLFilePath path -> do + xs <- liftIO $ loadSnapshotLockFile (resolvedAbsolute path) rootDir + pure xs + _ -> pure [] + let source = display loc + addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => ([(PackageName, SnapshotPackage)],[CompletedPLI]) + -> RawPackageLocationImmutable + -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) + addPackage (ps, completed) loc = do name <- getPackageLocationName loc - loc' <- completePackageLocation loc + loc'' <- stackCompletePackageLocation cachedPL loc + let loc' = case loc'' of + PLImmutable pli -> pli + PLMutable _ -> error "should be immutable" let p = (name, SnapshotPackage { spLocation = loc' , spFlags = Map.findWithDefault mempty name flags @@ -1177,6 +1209,9 @@ addAndCompletePackagesToSnapshot source newPackages (AddPackagesConfig drops fla if toRawPLI loc' == loc then pure (p:ps, completed) else pure (p:ps, (loc, loc'):completed) + logInfo "Important" + logInfo (displayShow loc) + logInfo (displayShow newPackages) (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 1f1a11ccf5..9c8c90528b 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -71,6 +71,7 @@ module Pantry.Types , resolveSnapshotLockFile , LockFile (..) , loadLockFile + , loadSnapshotLockFile , parseAndResolvePackageLocation , flagNameString , versionString From 8e11c8abb530fd3ade1838f279f90fab27990d47 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 20 Feb 2019 01:52:59 +0530 Subject: [PATCH 48/76] Add Friendly recommendation for stack.yaml from now on --- src/Stack/Build/ConstructPlan.hs | 5 ++--- subs/pantry/src/Pantry.hs | 3 --- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 9cc512ba94..803a845474 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1016,7 +1016,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDe , line ] - extras = Map.unions $ map getExtras exceptions' + extras :: Map PackageName (Version, BlobKey) = Map.unions $ map getExtras exceptions' getExtras DependencyCycleDetected{} = Map.empty getExtras UnknownPackage{} = Map.empty getExtras (DependencyPlanFailures _ m) = @@ -1029,8 +1029,7 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDe 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 + let packageIdRev = PackageIdentifierRevision name version CFILatest in fromString $ T.unpack $ utf8BuilderToText $ RIO.display packageIdRev allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index bc9ac281f1..becb4738de 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1209,9 +1209,6 @@ addAndCompletePackagesToSnapshot loc rootDir newPackages (AddPackagesConfig drop if toRawPLI loc' == loc then pure (p:ps, completed) else pure (p:ps, (loc, loc'):completed) - logInfo "Important" - logInfo (displayShow loc) - logInfo (displayShow newPackages) (revNew, revCompleted) <- foldM addPackage ([], []) newPackages let (newSingles, newMultiples) = partitionEithers From fac02b02864a646153e8fcf260afbe235f6b5571 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 20 Feb 2019 02:19:41 +0530 Subject: [PATCH 49/76] Use Immutable types for custom snapshot --- src/Stack/Lock.hs | 10 ++++++---- subs/pantry/src/Pantry.hs | 16 +++++----------- subs/pantry/src/Pantry/Types.hs | 29 ++++++++++++++++++++++------- 3 files changed, 33 insertions(+), 22 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 0cf01e2753..6bdd566523 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -57,7 +57,8 @@ generateLockFile stackFile = do ] B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) -loadSnapshotFile :: Path Abs File -> Path Abs Dir -> IO [RawPackageLocation] +loadSnapshotFile :: + Path Abs File -> Path Abs Dir -> IO [RawPackageLocationImmutable] loadSnapshotFile path rootDir = do val <- Yaml.decodeFileThrow (toFilePath path) case Yaml.parseEither (resolveSnapshotFile rootDir) val of @@ -71,13 +72,14 @@ loadSnapshotLockFile = undefined generateSnapshotLockFile :: Path Abs File -- ^ Snapshot file - -> [RawPackageLocation] + -> [RawPackageLocationImmutable] -> RIO Config () generateSnapshotLockFile path rpl = do logInfo "Generating Lock file for snapshot" - deps :: [PackageLocation] <- mapM completePackageLocation' rpl + let rpl' :: [RawPackageLocation] = map RPLImmutable rpl + deps :: [PackageLocation] <- mapM completePackageLocation' rpl' lockFile <- liftIO $ addFileExtension "lock" path - let depPairs :: [(PackageLocation, RawPackageLocation)] = zip deps rpl + let depPairs :: [(PackageLocation, RawPackageLocation)] = zip deps rpl' depsObject = Yaml.object [ ( "dependencies" diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index becb4738de..2cf47cd365 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1150,16 +1150,13 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens pure (allPackages, unused) stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(PackageLocation, RawPackageLocation)] + => [(PackageLocationImmutable, RawPackageLocationImmutable)] -> RawPackageLocationImmutable - -> RIO env PackageLocation + -> RIO env PackageLocationImmutable stackCompletePackageLocation cachePackages rpli = do - let rp = RPLImmutable rpli - xs = filter (\(_,x) -> x == rp) cachePackages + let xs = filter (\(_,x) -> x == rpli) cachePackages case xs of - [] -> do - pl <- completePackageLocation rpli - pure $ PLImmutable pl + [] -> completePackageLocation rpli (x,_):_ -> pure x @@ -1196,10 +1193,7 @@ addAndCompletePackagesToSnapshot loc rootDir newPackages (AddPackagesConfig drop -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) addPackage (ps, completed) loc = do name <- getPackageLocationName loc - loc'' <- stackCompletePackageLocation cachedPL loc - let loc' = case loc'' of - PLImmutable pli -> pli - PLMutable _ -> error "should be immutable" + loc' <- stackCompletePackageLocation cachedPL loc let p = (name, SnapshotPackage { spLocation = loc' , spFlags = Map.findWithDefault mempty name flags diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 9c8c90528b..52e6fb0278 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1559,8 +1559,18 @@ data LockFile a = LockFile { lfcResolver :: a SnapshotLocation } +parseImmutableObject :: Value -> Parser (Unresolved (PackageLocationImmutable, RawPackageLocationImmutable)) +parseImmutableObject value = withObject "LockFile" (\obj -> do + original <- obj .: "original" + complete <- obj .: "complete" + orig <- parseRPLI original + comp <- parsePLI complete + pure $ combineUnresolved comp orig + ) value + + parseSnapshotLockFile :: - Value -> Parser (Unresolved [(PackageLocation, RawPackageLocation)]) + Value -> Parser (Unresolved [(PackageLocationImmutable, RawPackageLocationImmutable)]) parseSnapshotLockFile = withObject "SnapshotLockFile" @@ -1569,31 +1579,31 @@ parseSnapshotLockFile = xs <- withArray "SnapshotLockArray" - (\vec -> sequence $ Vector.map parseSingleObject vec) + (\vec -> sequence $ Vector.map parseImmutableObject vec) vals pure $ sequence $ Vector.toList xs) -resolveSnapshotLockFile :: Path Abs Dir -> Value -> Parser (IO [(PackageLocation, RawPackageLocation)]) +resolveSnapshotLockFile :: Path Abs Dir -> Value -> Parser (IO [(PackageLocationImmutable, RawPackageLocationImmutable)]) resolveSnapshotLockFile rootDir val = do pkgs <- parseSnapshotLockFile val let pkgsLoc = resolvePaths (Just rootDir) pkgs pure pkgsLoc -loadSnapshotLockFile :: Path Abs File -> Path Abs Dir -> IO [(PackageLocation, RawPackageLocation)] +loadSnapshotLockFile :: Path Abs File -> Path Abs Dir -> IO [(PackageLocationImmutable, RawPackageLocationImmutable)] loadSnapshotLockFile lockFile rootDir = do val <- Yaml.decodeFileThrow (toFilePath lockFile) case Yaml.parseEither (resolveSnapshotLockFile rootDir) val of Left str -> fail $ "Cannot parse snapshot lock file: Got error " <> str Right lockFileIO -> lockFileIO -parseSnapshotFile :: Value -> Parser (Unresolved [RawPackageLocation]) +parseSnapshotFile :: Value -> Parser (Unresolved [RawPackageLocationImmutable]) parseSnapshotFile (Object obj) = do packages <- obj .: "packages" - xs <- withArray "SnapshotFileArray" (\vec -> sequence $ Vector.map parseRPL vec) packages + xs <- withArray "SnapshotFileArray" (\vec -> sequence $ Vector.map parseRPLI vec) packages pure $ sequence $ Vector.toList xs parseSnapshotFile val = fail $ "Expected Object, but got: " <> (show val) -resolveSnapshotFile :: Path Abs Dir -> Value -> Parser (IO [RawPackageLocation]) +resolveSnapshotFile :: Path Abs Dir -> Value -> Parser (IO [RawPackageLocationImmutable]) resolveSnapshotFile rootDir val = do unrpl <- parseSnapshotFile val let pkgLoc = resolvePaths (Just rootDir) unrpl @@ -1643,6 +1653,11 @@ parsePImmutable v = do xs :: Unresolved PackageLocationImmutable <- parseJSON v pure $ PLImmutable <$> xs +parsePLI :: Value -> Parser (Unresolved PackageLocationImmutable) +parsePLI v = do + x <- parseJSON v + pure x + instance FromJSON (Unresolved PackageLocationImmutable) where parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) From acf2e044d677e6f65d81cc6ad6d8bd45908f9656 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 20 Feb 2019 03:22:55 +0530 Subject: [PATCH 50/76] Add some logic to find out the exact changes --- src/Stack/Lock.hs | 63 ++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 60 insertions(+), 3 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 6bdd566523..3626ac1f9d 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -4,9 +4,10 @@ module Stack.Lock where +import Data.List ((\\), intersect) import qualified Data.Yaml as Yaml import Data.Yaml (object) -import Pantry (resolveSnapshotFile) +import Pantry (loadLockFile, resolveSnapshotFile) import Path (addFileExtension, fromAbsFile, parent) import Path.IO (doesFileExist, getModificationTime) import qualified RIO.ByteString as B @@ -25,6 +26,32 @@ instance Show LockException where 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 :: [(PackageLocation, RawPackageLocation)] + } + +findChange :: + [(PackageLocation, RawPackageLocation)] -- ^ Lock file + -> [RawPackageLocation] -- ^ stack.yaml file + -> Change +findChange lrpl srpl = + let lr = map snd lrpl + unchangedOnes = intersect lr srpl + unchangedFull = filter (\(pl, rpl) -> rpl `elem` srpl) lrpl + in Change + { chAdded = srpl \\ unchangedOnes + , chRemoved = lr \\ unchangedOnes + , chUnchanged = unchangedFull + } + generateLockFile :: Path Abs File -> RIO Config () generateLockFile stackFile = do logDebug "Gennerating lock file" @@ -36,8 +63,38 @@ generateLockFile stackFile = do let deps :: [RawPackageLocation] = projectDependencies p resolver :: RawSnapshotLocation = projectResolver p lockFile <- liftIO $ addFileExtension "lock" stackFile - resolver' :: SnapshotLocation <- completeSnapshotLocation resolver - deps' :: [PackageLocation] <- mapM completePackageLocation' deps + lockFileExists <- liftIO $ doesFileExist lockFile + lockInfo <- + case lockFileExists of + True -> + liftIO $ do + lfio <- loadLockFile lockFile + let lfpl = lfPackageLocation lfio + lfor = lfoResolver lfio + lfcr = lfcResolver lfio + pl <- lfpl + or <- lfor + cr <- lfcr + pure $ Just (pl, or, cr) + False -> pure Nothing + (deps', resolver') <- + case lockInfo of + Just (pl, or, cr) -> do + let change = findChange pl deps + unchangedRes = map fst (chUnchanged change) + logInfo "Going to do these changes" + deps <- mapM completePackageLocation' (chAdded change) + let allDeps = unchangedRes <> deps + res <- + if or == resolver + then pure cr + else completeSnapshotLocation resolver + pure (allDeps, res) + Nothing -> do + resolver' :: SnapshotLocation <- + completeSnapshotLocation resolver + deps' :: [PackageLocation] <- mapM completePackageLocation' deps + pure (deps', resolver') let deps'' = zip deps deps' let depsObject = Yaml.object From 84940c27721f787af3546f55985eeebfd3b6a4a4 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 20 Feb 2019 03:43:25 +0530 Subject: [PATCH 51/76] Add info messages. --- src/Stack/Lock.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 3626ac1f9d..e4a1f70721 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -82,7 +82,21 @@ generateLockFile stackFile = do Just (pl, or, cr) -> do let change = findChange pl deps unchangedRes = map fst (chUnchanged change) - logInfo "Going to do these changes" + addedStr = + concat $ + map + (\x -> + "Adding " <> (show x) <> + " package to the lock file.\n") + (chAdded change) + deletedstr = + concat $ + map + (\x -> + "Removing " <> (show x) <> + " package from the lock file.\n") + (chRemoved change) + logInfo (displayShow $ addedStr <> deletedstr) deps <- mapM completePackageLocation' (chAdded change) let allDeps = unchangedRes <> deps res <- From 6d8cc54b4ce6e2189ef3ac52052e6b2df16a67da Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 27 Feb 2019 18:41:19 +0530 Subject: [PATCH 52/76] Fix lock file reading bug --- subs/pantry/src/Pantry.hs | 6 ++++-- subs/pantry/src/Pantry/Types.hs | 10 ++++++---- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 2cf47cd365..969bd1a531 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -187,7 +187,7 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile) +import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile, addFileExtension) import Path.IO (doesFileExist, resolveDir', listDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D @@ -1183,7 +1183,9 @@ addAndCompletePackagesToSnapshot addAndCompletePackagesToSnapshot loc rootDir newPackages (AddPackagesConfig drops flags hiddens options) old = do cachedPL <- case loc of RSLFilePath path -> do - xs <- liftIO $ loadSnapshotLockFile (resolvedAbsolute path) rootDir + let sf = resolvedAbsolute path -- com here + slf <- liftIO $ addFileExtension "lock" sf + xs <- liftIO $ loadSnapshotLockFile slf rootDir pure xs _ -> pure [] let source = display loc diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 52e6fb0278..74c79ad827 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -1593,17 +1593,19 @@ loadSnapshotLockFile :: Path Abs File -> Path Abs Dir -> IO [(PackageLocationImm loadSnapshotLockFile lockFile rootDir = do val <- Yaml.decodeFileThrow (toFilePath lockFile) case Yaml.parseEither (resolveSnapshotLockFile rootDir) val of - Left str -> fail $ "Cannot parse snapshot lock file: Got error " <> str + Left str -> fail $ "Cannot parse snapshot lock file: Got error " <> str <> (show val) Right lockFileIO -> lockFileIO -parseSnapshotFile :: Value -> Parser (Unresolved [RawPackageLocationImmutable]) +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 - pure $ sequence $ Vector.toList xs + 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]) +resolveSnapshotFile :: Path Abs Dir -> Value -> Parser (IO ([RawPackageLocationImmutable], RawSnapshotLocation)) resolveSnapshotFile rootDir val = do unrpl <- parseSnapshotFile val let pkgLoc = resolvePaths (Just rootDir) unrpl From 378f3c3cc5732085e21e565eb4c4a7236a607a83 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 28 Feb 2019 13:53:47 +0530 Subject: [PATCH 53/76] Minor refactor --- src/Stack/Lock.hs | 23 ++++++++++++++++------- subs/pantry/src/Pantry.hs | 2 +- 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index e4a1f70721..8bf4e21bcc 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -129,7 +129,9 @@ generateLockFile stackFile = do B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) loadSnapshotFile :: - Path Abs File -> Path Abs Dir -> IO [RawPackageLocationImmutable] + 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 @@ -144,13 +146,15 @@ loadSnapshotLockFile = undefined generateSnapshotLockFile :: Path Abs File -- ^ Snapshot file -> [RawPackageLocationImmutable] + -> RawSnapshotLocation -> RIO Config () -generateSnapshotLockFile path rpl = do +generateSnapshotLockFile path rpli rpl = do logInfo "Generating Lock file for snapshot" - let rpl' :: [RawPackageLocation] = map RPLImmutable rpl - deps :: [PackageLocation] <- mapM completePackageLocation' rpl' + let rpli' :: [RawPackageLocation] = map RPLImmutable rpli + deps :: [PackageLocation] <- mapM completePackageLocation' rpli' + rpl' :: SnapshotLocation <- completeSnapshotLocation rpl lockFile <- liftIO $ addFileExtension "lock" path - let depPairs :: [(PackageLocation, RawPackageLocation)] = zip deps rpl' + let depPairs :: [(PackageLocation, RawPackageLocation)] = zip deps rpli' depsObject = Yaml.object [ ( "dependencies" @@ -161,6 +165,11 @@ generateSnapshotLockFile path rpl = do , ("complete", Yaml.toJSON comp) ]) depPairs)) + , ( "resolver" + , object + [ ("original", Yaml.toJSON rpl) + , ("complete", Yaml.toJSON rpl') + ]) ] B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) @@ -169,8 +178,8 @@ generateLockFileForCustomSnapshot :: generateLockFileForCustomSnapshot (SLFilePath path) stackFile = do logInfo "Generating lock file for custom snapshot" let snapshotPath = resolvedAbsolute path - rpl <- liftIO $ loadSnapshotFile snapshotPath (parent stackFile) - generateSnapshotLockFile snapshotPath rpl + (rpli, rpl) <- liftIO $ loadSnapshotFile snapshotPath (parent stackFile) + generateSnapshotLockFile snapshotPath rpli rpl generateLockFileForCustomSnapshot xs _ = throwM (LockCannotGenerate xs) isLockFileOutdated :: Path Abs File -> RIO Config Bool diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 969bd1a531..9fd15342b6 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -1183,7 +1183,7 @@ addAndCompletePackagesToSnapshot addAndCompletePackagesToSnapshot loc rootDir newPackages (AddPackagesConfig drops flags hiddens options) old = do cachedPL <- case loc of RSLFilePath path -> do - let sf = resolvedAbsolute path -- com here + let sf = resolvedAbsolute path slf <- liftIO $ addFileExtension "lock" sf xs <- liftIO $ loadSnapshotLockFile slf rootDir pure xs From d755d25c6fe6446149311192049339530302227d Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 28 Feb 2019 16:10:03 +0530 Subject: [PATCH 54/76] Restructure from pantry to stack.lock --- src/Stack/Config.hs | 3 +- src/Stack/Lock.hs | 376 +++++++++++++++++++++++++++++++- subs/pantry/src/Pantry.hs | 33 ++- subs/pantry/src/Pantry/Types.hs | 298 +------------------------ 4 files changed, 391 insertions(+), 319 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 699f33bbe9..a2dcac3b85 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -86,9 +86,8 @@ import System.Environment import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) import RIO.PrettyPrint -import Stack.Lock (generateLockFile, isLockFileOutdated, generateLockFileForCustomSnapshot) +import Stack.Lock (generateLockFile, isLockFileOutdated, generateLockFileForCustomSnapshot, loadLockFile, LockFile (..)) import RIO.Process -import Pantry (loadLockFile, LockFile (..)) -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 8bf4e21bcc..fdbd31f942 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -1,16 +1,35 @@ {-# 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 qualified Data.Vector as Vector import qualified Data.Yaml as Yaml -import Data.Yaml (object) -import Pantry (loadLockFile, resolveSnapshotFile) +import Data.Yaml +import Pantry + ( GitHubRepo(..) + , OptionalSubdirs(..) + , Unresolved(..) + , osToRpms + , parseArchiveLocationObject + , parseArchiveLocationText + , parsePackageIdentifierRevision + , parseRawSnapshotLocation + , parseRawSnapshotLocationPath + , parseWantedCompiler + , rpmEmpty + ) import Path (addFileExtension, fromAbsFile, parent) -import Path.IO (doesFileExist, getModificationTime) +import Path.IO (doesFileExist, getModificationTime, resolveDir, resolveFile) import qualified RIO.ByteString as B +import qualified RIO.HashMap as HM +import qualified RIO.Text as T import Stack.Prelude import Stack.Types.Config @@ -138,11 +157,6 @@ loadSnapshotFile path rootDir = do Left str -> fail $ "Cannot parse snapshot file: Got error " <> str Right rplio -> rplio -loadSnapshotLockFile :: - Path Abs File -- ^ Snapshot lock file - -> IO [(RawPackageLocation, PackageLocation)] -loadSnapshotLockFile = undefined - generateSnapshotLockFile :: Path Abs File -- ^ Snapshot file -> [RawPackageLocationImmutable] @@ -197,3 +211,349 @@ isLockFileOutdated stackFile = do case lmt of Nothing -> return True Just mt -> return $ smt > mt + +loadLockFile :: Path Abs File -> IO (LockFile IO) +loadLockFile lockFile = do + val <- Yaml.decodeFileThrow (toFilePath lockFile) + case Yaml.parseEither (resolveLockFile (parent lockFile)) val of + Left str -> fail $ "Cannot parse lock file: Got error " <> str + Right lockFileIO -> pure lockFileIO + +data LockFile a = LockFile + { lfPackageLocation :: a [(PackageLocation, RawPackageLocation)] + , lfoResolver :: a RawSnapshotLocation + , lfcResolver :: a 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 (PackageLocation, RawPackageLocation)) +parseSingleObject value = + withObject + "LockFile" + (\obj -> do + original <- obj .: "original" + complete <- obj .: "complete" + orig <- parseRPL original + comp <- parsePImmutable complete + pure $ combineUnresolved comp orig) + 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)) + +parseLockFile :: Value -> Parser (LockFile Unresolved) +parseLockFile value = + withObject + "LockFile" + (\obj -> do + vals :: Value <- obj .: "dependencies" + xs <- + withArray + "LockFileArray" + (\vec -> sequence $ Vector.map parseSingleObject vec) + vals + resolver <- obj .: "resolver" + roriginal <- resolver .: "original" + rcomplete <- resolver .: "complete" + ro <- parseRSL roriginal + rc <- parseSL rcomplete + pure $ + LockFile + { lfPackageLocation = sequence (Vector.toList xs) + , lfoResolver = ro + , lfcResolver = rc + }) + value + +resolveLockFile :: Path Abs Dir -> Value -> Parser (LockFile IO) +resolveLockFile rootDir v = do + lockFile <- parseLockFile v + let pkgLoc = (lfPackageLocation lockFile) + origRes = lfoResolver lockFile + compRes = lfcResolver lockFile + pkgLoc' = resolvePaths (Just rootDir) pkgLoc + pure $ + LockFile + { lfPackageLocation = pkgLoc' + , lfoResolver = resolvePaths (Just rootDir) origRes + , lfcResolver = resolvePaths (Just rootDir) compRes + } + +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" + ] + raHash <- o .:? "sha256" + raSize <- o .:? "size" + 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 = do + x <- parseJSON v + pure x + +parseImmutableObject :: + Value + -> Parser (Unresolved ( PackageLocationImmutable + , RawPackageLocationImmutable)) +parseImmutableObject value = + withObject + "LockFile" + (\obj -> do + original <- obj .: "original" + complete <- obj .: "complete" + orig <- parseRPLI original + comp <- parsePLI complete + pure $ combineUnresolved comp orig) + value + +parseSnapshotLockFile :: + Value + -> Parser (Unresolved [( PackageLocationImmutable + , RawPackageLocationImmutable)]) +parseSnapshotLockFile = + withObject + "SnapshotLockFile" + (\obj -> do + vals <- obj .: "dependencies" + xs <- + withArray + "SnapshotLockArray" + (\vec -> sequence $ Vector.map parseImmutableObject vec) + vals + pure $ sequence $ Vector.toList xs) + +resolveSnapshotLockFile :: + Path Abs Dir + -> Value + -> Parser (IO [(PackageLocationImmutable, RawPackageLocationImmutable)]) +resolveSnapshotLockFile rootDir val = do + pkgs <- parseSnapshotLockFile val + let pkgsLoc = resolvePaths (Just rootDir) pkgs + pure pkgsLoc + +loadSnapshotLockFile :: + Path Abs File + -> Path Abs Dir + -> IO [(PackageLocationImmutable, RawPackageLocationImmutable)] +loadSnapshotLockFile lockFile rootDir = do + val <- Yaml.decodeFileThrow (toFilePath lockFile) + case Yaml.parseEither (resolveSnapshotLockFile rootDir) val of + Left str -> + fail $ + "Cannot parse snapshot lock file: Got error " <> str <> (show val) + Right lockFileIO -> lockFileIO diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 9fd15342b6..89290f4cee 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 (..) @@ -106,9 +110,9 @@ module Pantry , parseRawSnapshotLocation , parsePackageIdentifierRevision , parseHackageText - , resolveLockFile - , resolveSnapshotFile - , resolveSnapshotLockFile + , parseArchiveLocationText + , parseArchiveLocationObject + , parseRawSnapshotLocationPath , parseAndResolvePackageLocation -- ** Cabal values @@ -149,9 +153,6 @@ module Pantry -- * Cabal files , loadCabalFileRaw , loadCabalFile - , LockFile (..) - , loadLockFile - , loadSnapshotLockFile , loadCabalFileRawImmutable , loadCabalFileImmutable , loadCabalFilePath @@ -992,7 +993,7 @@ loadAndCompleteSnapshot -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshot loc rootDir = - loadAndCompleteSnapshotRaw (toRawSL loc) rootDir + loadAndCompleteSnapshotRaw (toRawSL loc) [] rootDir -- todo: fix empty list -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations @@ -1001,9 +1002,10 @@ loadAndCompleteSnapshot loc rootDir = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation + -> [(PackageLocationImmutable, RawPackageLocationImmutable)] -- ^ Cached data from snapshot lock file -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshotRaw loc rootDir = do +loadAndCompleteSnapshotRaw loc cachePL rootDir = do eres <- loadRawSnapshotLayer loc case eres of Left wc -> @@ -1015,10 +1017,11 @@ loadAndCompleteSnapshotRaw loc rootDir = do } in pure (snapshot, []) Right (rsl, _sha) -> do - (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) rootDir + (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL rootDir (packages, completed, unused) <- addAndCompletePackagesToSnapshot loc + cachePL rootDir (rslLocations rsl) AddPackagesConfig @@ -1175,19 +1178,13 @@ addAndCompletePackagesToSnapshot => RawSnapshotLocation -- ^ Text description of where these new packages are coming from, for error -- messages only + -> [(PackageLocationImmutable, RawPackageLocationImmutable)] -- ^ Cached data from snapshot lock file -> Path Abs Dir -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig -> Map PackageName SnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) -addAndCompletePackagesToSnapshot loc rootDir newPackages (AddPackagesConfig drops flags hiddens options) old = do - cachedPL <- case loc of - RSLFilePath path -> do - let sf = resolvedAbsolute path - slf <- liftIO $ addFileExtension "lock" sf - xs <- liftIO $ loadSnapshotLockFile slf rootDir - pure xs - _ -> pure [] +addAndCompletePackagesToSnapshot loc cachedPL rootDir newPackages (AddPackagesConfig drops flags hiddens options) old = do let source = display loc addPackage :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => ([(PackageName, SnapshotPackage)],[CompletedPLI]) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 74c79ad827..6d1dc7f898 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,17 +67,13 @@ module Pantry.Types , parseVersionThrowing , packageIdentifierString , packageNameString - , resolveLockFile - , resolveSnapshotFile - , resolveSnapshotLockFile - , LockFile (..) - , loadLockFile - , loadSnapshotLockFile , parseAndResolvePackageLocation + , parseRawSnapshotLocationPath , flagNameString , versionString , moduleNameString , OptionalSubdirs (..) + , osToRpms , ArchiveLocation (..) , RelFilePath (..) , CabalString (..) @@ -97,6 +94,8 @@ module Pantry.Types , SnapshotLocation (..) , toRawSL , parseRawSnapshotLocation + , parseArchiveLocationText + , parseArchiveLocationObject , RawSnapshotLayer (..) , SnapshotLayer (..) , toRawSnapshotLayer @@ -106,6 +105,7 @@ module Pantry.Types , SnapshotPackage (..) , parseWantedCompiler , RawPackageMetadata (..) + , rpmEmpty , PackageMetadata (..) , toRawPM , cabalFileName @@ -1538,128 +1538,6 @@ parseAndResolvePackageLocation rootDir v = do (Unresolved unresolvedPL) <- parsePackageLocation v pure $ unresolvedPL (Just rootDir) -combineUnresolved :: Unresolved a -> Unresolved b -> Unresolved (a,b) -combineUnresolved a b = do - ua <- a - ub <- b - pure (ua, ub) - -parseSingleObject :: Value -> Parser (Unresolved (PackageLocation, RawPackageLocation)) -parseSingleObject value = withObject "LockFile" (\obj -> do - original <- obj .: "original" - complete <- obj .: "complete" - orig <- parseRPL original - comp <- parsePImmutable complete - pure $ combineUnresolved comp orig - ) value - -data LockFile a = LockFile { - lfPackageLocation :: a [(PackageLocation, RawPackageLocation)], - lfoResolver :: a RawSnapshotLocation, - lfcResolver :: a SnapshotLocation -} - -parseImmutableObject :: Value -> Parser (Unresolved (PackageLocationImmutable, RawPackageLocationImmutable)) -parseImmutableObject value = withObject "LockFile" (\obj -> do - original <- obj .: "original" - complete <- obj .: "complete" - orig <- parseRPLI original - comp <- parsePLI complete - pure $ combineUnresolved comp orig - ) value - - -parseSnapshotLockFile :: - Value -> Parser (Unresolved [(PackageLocationImmutable, RawPackageLocationImmutable)]) -parseSnapshotLockFile = - withObject - "SnapshotLockFile" - (\obj -> do - vals <- obj .: "dependencies" - xs <- - withArray - "SnapshotLockArray" - (\vec -> sequence $ Vector.map parseImmutableObject vec) - vals - pure $ sequence $ Vector.toList xs) - -resolveSnapshotLockFile :: Path Abs Dir -> Value -> Parser (IO [(PackageLocationImmutable, RawPackageLocationImmutable)]) -resolveSnapshotLockFile rootDir val = do - pkgs <- parseSnapshotLockFile val - let pkgsLoc = resolvePaths (Just rootDir) pkgs - pure pkgsLoc - -loadSnapshotLockFile :: Path Abs File -> Path Abs Dir -> IO [(PackageLocationImmutable, RawPackageLocationImmutable)] -loadSnapshotLockFile lockFile rootDir = do - val <- Yaml.decodeFileThrow (toFilePath lockFile) - case Yaml.parseEither (resolveSnapshotLockFile rootDir) val of - Left str -> fail $ "Cannot parse snapshot lock file: Got error " <> str <> (show val) - Right lockFileIO -> lockFileIO - -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 - -parseLockFile :: - Value -> Parser (LockFile Unresolved) -parseLockFile value = withObject "LockFile" (\obj -> do - vals :: Value <- obj .: "dependencies" - xs <- withArray "LockFileArray" (\vec -> sequence $ Vector.map parseSingleObject vec) vals - resolver <- obj .: "resolver" - roriginal <- resolver .: "original" - rcomplete <- resolver .: "complete" - ro <- parseRSL roriginal - rc <- parseSL rcomplete - pure $ LockFile { - lfPackageLocation = sequence (Vector.toList xs), - lfoResolver = ro, - lfcResolver = rc - } - ) value - -resolveLockFile :: Path Abs Dir -> Value -> Parser (LockFile IO) -resolveLockFile rootDir v = do - lockFile <- parseLockFile v - let pkgLoc = (lfPackageLocation lockFile) - origRes = lfoResolver lockFile - compRes = lfcResolver lockFile - pkgLoc' = resolvePaths (Just rootDir) pkgLoc - pure $ - LockFile - { lfPackageLocation = pkgLoc' - , lfoResolver = resolvePaths (Just rootDir) origRes - , lfcResolver = resolvePaths (Just rootDir) compRes - } - -loadLockFile :: Path Abs File -> IO (LockFile IO) -loadLockFile lockFile = do - val <- Yaml.decodeFileThrow (toFilePath lockFile) - case Yaml.parseEither (resolveLockFile (parent lockFile)) val of - Left str -> fail $ "Cannot parse lock file: Got error " <> str - Right lockFileIO -> pure lockFileIO - - -parsePImmutable :: Value -> Parser (Unresolved PackageLocation) -parsePImmutable v = do - xs :: Unresolved PackageLocationImmutable <- parseJSON v - pure $ PLImmutable <$> xs - -parsePLI :: Value -> Parser (Unresolved PackageLocationImmutable) -parsePLI v = do - x <- parseJSON v - pure x - instance FromJSON (Unresolved PackageLocationImmutable) where parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) @@ -1711,106 +1589,6 @@ instance FromJSON (Unresolved PackageLocationImmutable) where archiveSubdir <- o .: "subdir" pure $ pure $ PLIArchive Archive {..} pm) value -parseRPLImmutable :: Value -> Parser (Unresolved RawPackageLocation) -parseRPLImmutable v = do - xs :: Unresolved RawPackageLocationImmutable <- parseRPLI v - pure $ RPLImmutable <$> xs - -parseRPL :: Value -> Parser (Unresolved RawPackageLocation) -parseRPL v = parseRPLImmutable v <|> parseResolvedPath v - -parseRPLI :: Value -> Parser (Unresolved RawPackageLocationImmutable) -parseRPLI v = - parseRPLHttpText v <|> parseRPLHackageText v <|> parseRPLHackageObject v <|> - parseRPLRepo v <|> - parseArchiveRPLObject v <|> - parseGithubRPLObject v - -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' - -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 of -- if subdirs exists, it needs to be valid - 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" - ] - raHash <- o .:? "sha256" - raSize <- o .:? "size" - os <- optionalSubdirs' o - pure $ pure $ NE.head $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) - instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where parseJSON v = http v @@ -2051,59 +1829,6 @@ instance Display SnapshotLocation where display (SLUrl url blob) = display url <> " (" <> display blob <> ")" display (SLFilePath resolved) = display (resolvedRelative resolved) --- use this -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)) - - - -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") - --- use this -parseRSL :: Value -> Parser (Unresolved RawSnapshotLocation) -parseRSL v = txtParser v <|> parseRSLObject v - where - txtParser = withText "UnresolvedSnapshotLocation (Text)" (pure . parseRawSnapshotLocation) - -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") - - -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" - -parseSnapshotLocation :: Value -> Parser (Unresolved SnapshotLocation) -parseSnapshotLocation = - withObject - "UnresolvedSnapshotLocation" - (\o -> do - url <- o .: "url" - bkey <- parseJSON (Object o) - pure $ pure $ SLUrl url bkey) - - -- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. -- -- @since 0.1.0.0 @@ -2145,15 +1870,6 @@ parseRawSnapshotLocationPath t = abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' -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' - githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation githubSnapshotLocation user repo path = let url = T.concat From 1afa890e46a610c49632935e5c69ff5a30160ca6 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 28 Feb 2019 16:20:57 +0530 Subject: [PATCH 55/76] Make it actually use of cahed ds. --- src/Stack/Config.hs | 20 +++++++++++++++++--- subs/pantry/src/Pantry.hs | 5 +++-- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index a2dcac3b85..ba89f41c78 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -86,8 +86,15 @@ import System.Environment import System.PosixCompat.Files (fileOwner, getFileStatus) import System.PosixCompat.User (getEffectiveUserID) import RIO.PrettyPrint -import Stack.Lock (generateLockFile, isLockFileOutdated, generateLockFileForCustomSnapshot, loadLockFile, LockFile (..)) import RIO.Process +import Stack.Lock + ( LockFile(..) + , generateLockFile + , generateLockFileForCustomSnapshot + , isLockFileOutdated + , loadLockFile + , loadSnapshotLockFile + ) -- | If deprecated path exists, use it and print a warning. -- Otherwise, return the new path. @@ -633,8 +640,15 @@ loadBuildConfig mproject maresolver mcompiler = do when outdated (generateLockFileForCustomSnapshot resolver stackYamlFP) _ -> return () - -- todo: loadAndCompleteSnapshot likely has to be cached in a new lock file - (snapshot, _completed) <- loadAndCompleteSnapshot resolver (parent stackYamlFP) + cachedPL <- case resolver of + SLFilePath path -> do + let sf = resolvedAbsolute path + slf <- liftIO $ addFileExtension "lock" sf + xs <- liftIO $ loadSnapshotLockFile slf (parent stackYamlFP) + pure xs + _ -> pure [] + + (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedPL (parent stackYamlFP) extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 89290f4cee..d269c3acce 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -990,10 +990,11 @@ type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation + -> [(PackageLocationImmutable, RawPackageLocationImmutable)] -- ^ Cached data from snapshot lock file -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshot loc rootDir = - loadAndCompleteSnapshotRaw (toRawSL loc) [] rootDir -- todo: fix empty list +loadAndCompleteSnapshot loc cachedPL rootDir = + loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL rootDir -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations From f168499a7532da5fee5dac67478a54299c67e299 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 28 Feb 2019 21:44:26 +0530 Subject: [PATCH 56/76] Address some of Kirill's comments --- src/Stack/Build/ConstructPlan.hs | 3 +- src/Stack/Config.hs | 27 ++--- src/Stack/Freeze.hs | 11 +- src/Stack/Lock.hs | 173 +++++++++++++++---------------- subs/pantry/src/Pantry.hs | 10 -- subs/pantry/src/Pantry/Types.hs | 13 +-- 6 files changed, 110 insertions(+), 127 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 803a845474..784566290e 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1016,7 +1016,8 @@ pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDe , line ] - extras :: Map PackageName (Version, BlobKey) = Map.unions $ map getExtras exceptions' + extras :: Map PackageName (Version, BlobKey) + extras = Map.unions $ map getExtras exceptions' getExtras DependencyCycleDetected{} = Map.empty getExtras UnknownPackage{} = Map.empty getExtras (DependencyPlanFailures _ m) = diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index ba89f41c78..7261bdb2aa 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -89,10 +89,10 @@ import RIO.PrettyPrint import RIO.Process import Stack.Lock ( LockFile(..) - , generateLockFile - , generateLockFileForCustomSnapshot + , generatePackageLockFile + , generateSnapshotLockFile , isLockFileOutdated - , loadLockFile + , loadPackageLockFile , loadSnapshotLockFile ) @@ -521,8 +521,6 @@ loadConfig :: HasRunner env loadConfig configArgs mresolver mstackYaml inner = loadProjectConfig mstackYaml >>= \x -> loadConfigMaybeProject configArgs mresolver x inner - - stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => [(PackageLocation, RawPackageLocation)] -> RawPackageLocation @@ -611,19 +609,16 @@ loadBuildConfig mproject maresolver mcompiler = do } lockFileOutdated <- isLockFileOutdated stackYamlFP - unless lockFileOutdated (logDebug "Lock file is upto date") - when lockFileOutdated (logDebug "Lock file is outdated" >> generateLockFile stackYamlFP) + if lockFileOutdated + then do + logDebug "Lock file is outdated" + generatePackageLockFile stackYamlFP + else logDebug "Lock file is upto date" lockFile <- liftIO $ addFileExtension "lock" stackYamlFP (cachePL, origResolver, compResolver) <- liftIO $ do - lfio <- loadLockFile lockFile - let pkgLoc = lfPackageLocation lfio - origResolver = lfoResolver lfio - compResolver = lfcResolver lfio - cpl <- pkgLoc - or <- origResolver - cr <- compResolver - return (cpl, or, cr) + lf <- loadPackageLockFile lockFile + return (lfPackageLocations lf, lfoResolver lf, lfcResolver lf) resolver <- if (projectResolver project == origResolver) @@ -637,7 +632,7 @@ loadBuildConfig mproject maresolver mcompiler = do case resolver of SLFilePath path -> do outdated <- isLockFileOutdated (resolvedAbsolute path) - when outdated (generateLockFileForCustomSnapshot resolver stackYamlFP) + when outdated (generateSnapshotLockFile resolver stackYamlFP) _ -> return () cachedPL <- case resolver of diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs index 44c49845b5..c9b46069a9 100644 --- a/src/Stack/Freeze.hs +++ b/src/Stack/Freeze.hs @@ -30,6 +30,15 @@ freeze (FreezeOpts mode) = do 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 @@ -43,7 +52,7 @@ doFreeze p FreezeProject = do let deps :: [RawPackageLocation] = projectDependencies p resolver :: RawSnapshotLocation = projectResolver p resolver' :: SnapshotLocation <- completeSnapshotLocation resolver - deps' :: [PackageLocation] <- mapM completePackageLocation' deps + deps' :: [PackageLocation] <- mapM completeFullPackageLocation deps let rawCompleted = map toRawPL deps' rawResolver = toRawSL resolver' if rawCompleted == deps && rawResolver == resolver diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index fdbd31f942..d0373926a7 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -16,6 +16,7 @@ import Pantry ( GitHubRepo(..) , OptionalSubdirs(..) , Unresolved(..) + , completePackageLocation , osToRpms , parseArchiveLocationObject , parseArchiveLocationText @@ -29,6 +30,7 @@ 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 @@ -57,6 +59,15 @@ data Change = Change , chUnchanged :: [(PackageLocation, RawPackageLocation)] } +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 :: [(PackageLocation, RawPackageLocation)] -- ^ Lock file -> [RawPackageLocation] -- ^ stack.yaml file @@ -71,8 +82,8 @@ findChange lrpl srpl = , chUnchanged = unchangedFull } -generateLockFile :: Path Abs File -> RIO Config () -generateLockFile stackFile = do +generatePackageLockFile :: Path Abs File -> RIO Config () +generatePackageLockFile stackFile = do logDebug "Gennerating lock file" mproject <- view $ configL . to configMaybeProject p <- @@ -81,25 +92,19 @@ generateLockFile stackFile = do Nothing -> throwM LockNoProject let deps :: [RawPackageLocation] = projectDependencies p resolver :: RawSnapshotLocation = projectResolver p - lockFile <- liftIO $ addFileExtension "lock" stackFile - lockFileExists <- liftIO $ doesFileExist lockFile - lockInfo <- - case lockFileExists of + packageLockFile <- liftIO $ addFileExtension "lock" stackFile + packageLockFileExists <- liftIO $ doesFileExist packageLockFile + lockInfo :: Maybe LockFile <- + case packageLockFileExists of True -> liftIO $ do - lfio <- loadLockFile lockFile - let lfpl = lfPackageLocation lfio - lfor = lfoResolver lfio - lfcr = lfcResolver lfio - pl <- lfpl - or <- lfor - cr <- lfcr - pure $ Just (pl, or, cr) + lfio <- loadPackageLockFile packageLockFile + pure $ Just lfio False -> pure Nothing (deps', resolver') <- case lockInfo of - Just (pl, or, cr) -> do - let change = findChange pl deps + Just lockData -> do + let change = findChange (lfPackageLocations lockData) deps unchangedRes = map fst (chUnchanged change) addedStr = concat $ @@ -116,17 +121,18 @@ generateLockFile stackFile = do " package from the lock file.\n") (chRemoved change) logInfo (displayShow $ addedStr <> deletedstr) - deps <- mapM completePackageLocation' (chAdded change) + deps <- mapM completeFullPackageLocation (chAdded change) let allDeps = unchangedRes <> deps res <- - if or == resolver - then pure cr + if (lfoResolver lockData) == resolver + then pure (lfcResolver lockData) else completeSnapshotLocation resolver pure (allDeps, res) Nothing -> do resolver' :: SnapshotLocation <- completeSnapshotLocation resolver - deps' :: [PackageLocation] <- mapM completePackageLocation' deps + deps' :: [PackageLocation] <- + mapM completeFullPackageLocation deps pure (deps', resolver') let deps'' = zip deps deps' let depsObject = @@ -145,7 +151,7 @@ generateLockFile stackFile = do ]) deps'')) ] - B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) + B.writeFile (fromAbsFile packageLockFile) (Yaml.encode depsObject) loadSnapshotFile :: Path Abs File @@ -157,17 +163,16 @@ loadSnapshotFile path rootDir = do Left str -> fail $ "Cannot parse snapshot file: Got error " <> str Right rplio -> rplio -generateSnapshotLockFile :: +createSnapshotLockFile :: Path Abs File -- ^ Snapshot file -> [RawPackageLocationImmutable] -> RawSnapshotLocation -> RIO Config () -generateSnapshotLockFile path rpli rpl = do - logInfo "Generating Lock file for snapshot" +createSnapshotLockFile path rpli rpl = do let rpli' :: [RawPackageLocation] = map RPLImmutable rpli - deps :: [PackageLocation] <- mapM completePackageLocation' rpli' + deps :: [PackageLocation] <- mapM completeFullPackageLocation rpli' rpl' :: SnapshotLocation <- completeSnapshotLocation rpl - lockFile <- liftIO $ addFileExtension "lock" path + snapshotLockFile <- liftIO $ addFileExtension "lock" path let depPairs :: [(PackageLocation, RawPackageLocation)] = zip deps rpli' depsObject = Yaml.object @@ -185,44 +190,68 @@ generateSnapshotLockFile path rpli rpl = do , ("complete", Yaml.toJSON rpl') ]) ] - B.writeFile (fromAbsFile lockFile) (Yaml.encode depsObject) + B.writeFile (fromAbsFile snapshotLockFile) (Yaml.encode depsObject) -generateLockFileForCustomSnapshot :: - SnapshotLocation -> Path Abs File -> RIO Config () -generateLockFileForCustomSnapshot (SLFilePath path) stackFile = do - logInfo "Generating lock file for custom snapshot" +generateSnapshotLockFile :: SnapshotLocation -> Path Abs File -> RIO Config () +generateSnapshotLockFile (SLFilePath path) stackFile = do + logInfo "Generating Lock file for custom snapshot" let snapshotPath = resolvedAbsolute path (rpli, rpl) <- liftIO $ loadSnapshotFile snapshotPath (parent stackFile) - generateSnapshotLockFile snapshotPath rpli rpl -generateLockFileForCustomSnapshot xs _ = throwM (LockCannotGenerate xs) + createSnapshotLockFile snapshotPath rpli rpl +generateSnapshotLockFile xs _ = throwM (LockCannotGenerate xs) isLockFileOutdated :: Path Abs File -> RIO Config Bool isLockFileOutdated stackFile = do lockFile <- liftIO $ addFileExtension "lock" stackFile smt <- liftIO $ getModificationTime stackFile - lmt <- - liftIO $ do - exists <- doesFileExist lockFile - if exists - then do - mt <- getModificationTime lockFile - pure $ Just mt - else pure Nothing - case lmt of - Nothing -> return True - Just mt -> return $ smt > mt - -loadLockFile :: Path Abs File -> IO (LockFile IO) -loadLockFile lockFile = do + 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 <- + 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 = lfpls + , lfoResolver = lfor + , lfcResolver = lfcr + }) + value + +loadPackageLockFile :: Path Abs File -> IO LockFile +loadPackageLockFile lockFile = do val <- Yaml.decodeFileThrow (toFilePath lockFile) - case Yaml.parseEither (resolveLockFile (parent lockFile)) val of + case Yaml.parseEither (parsePackageLockFile (parent lockFile)) val of Left str -> fail $ "Cannot parse lock file: Got error " <> str - Right lockFileIO -> pure lockFileIO + Right lockFileIO -> lockFileIO -data LockFile a = LockFile - { lfPackageLocation :: a [(PackageLocation, RawPackageLocation)] - , lfoResolver :: a RawSnapshotLocation - , lfcResolver :: a SnapshotLocation +data LockFile = LockFile + { lfPackageLocations :: [(PackageLocation, RawPackageLocation)] + , lfoResolver :: RawSnapshotLocation + , lfcResolver :: SnapshotLocation } combineUnresolved :: Unresolved a -> Unresolved b -> Unresolved (a, b) @@ -310,44 +339,6 @@ parseSL v = txtParser v <|> parseSLObject v ("UnresolvedSnapshotLocation (Text)") (\t -> pure $ fromMaybe (parseSnapshotLocationPath t) (txt t)) -parseLockFile :: Value -> Parser (LockFile Unresolved) -parseLockFile value = - withObject - "LockFile" - (\obj -> do - vals :: Value <- obj .: "dependencies" - xs <- - withArray - "LockFileArray" - (\vec -> sequence $ Vector.map parseSingleObject vec) - vals - resolver <- obj .: "resolver" - roriginal <- resolver .: "original" - rcomplete <- resolver .: "complete" - ro <- parseRSL roriginal - rc <- parseSL rcomplete - pure $ - LockFile - { lfPackageLocation = sequence (Vector.toList xs) - , lfoResolver = ro - , lfcResolver = rc - }) - value - -resolveLockFile :: Path Abs Dir -> Value -> Parser (LockFile IO) -resolveLockFile rootDir v = do - lockFile <- parseLockFile v - let pkgLoc = (lfPackageLocation lockFile) - origRes = lfoResolver lockFile - compRes = lfcResolver lockFile - pkgLoc' = resolvePaths (Just rootDir) pkgLoc - pure $ - LockFile - { lfPackageLocation = pkgLoc' - , lfoResolver = resolvePaths (Just rootDir) origRes - , lfcResolver = resolvePaths (Just rootDir) compRes - } - parseBlobKey :: Object -> Parser (Maybe BlobKey) parseBlobKey o = do msha <- o .:? "sha256" diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index d269c3acce..c4eb66ebf7 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -101,7 +101,6 @@ module Pantry -- * Completion functions , completePackageLocation - , completePackageLocation' , completeSnapshotLayer , completeSnapshotLocation @@ -721,15 +720,6 @@ loadPackageRaw (RPLIRepo repo rpm) = getRepo repo rpm -- | Fill in optional fields in a 'PackageLocationImmutable' for more reproducible builds. -- -- @since 0.1.0.0 -completePackageLocation' :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => RawPackageLocation - -> RIO env PackageLocation -completePackageLocation' (RPLImmutable rpli) = do - pl <- completePackageLocation rpli - pure $ PLImmutable pl -completePackageLocation' (RPLMutable rplm) = pure $ PLMutable rplm - - completePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawPackageLocationImmutable diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 6d1dc7f898..fcffbea667 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -720,10 +720,11 @@ parseHackageText t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ pure msize _ -> Nothing pure $ (PackageIdentifier name version, BlobKey csha csize) - where - splitColon t' = - let (x, y) = T.break (== ':') t' - in (x, ) <$> T.stripPrefix ":" y + +splitColon :: Text -> Maybe (Text, Text) +splitColon t' = + let (x, y) = T.break (== ':') t' + in (x, ) <$> T.stripPrefix ":" y -- | Parse a 'PackageIdentifierRevision' -- @@ -752,10 +753,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 From d463b762018e93c02e4abbe6bd577cc2d21f49d3 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 28 Feb 2019 22:40:01 +0530 Subject: [PATCH 57/76] Some cleanup for changing the locations --- src/Stack/Config.hs | 18 +++++++++++++++--- src/Stack/Lock.hs | 18 ++++++++++-------- subs/pantry/src/Pantry/Types.hs | 4 ++-- 3 files changed, 27 insertions(+), 13 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 7261bdb2aa..fe651cec65 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -521,17 +521,29 @@ 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 + stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(PackageLocation, RawPackageLocation)] + => [(RawPackageLocation, PackageLocation)] -> RawPackageLocation -> RIO env PackageLocation stackCompletePackageLocation cachePackages rp@(RPLImmutable rpli) = do - let xs = filter (\(_,x) -> x == rp) cachePackages + let xs = filter (\(x,_) -> x == rp) cachePackages case xs of [] -> do pl <- completePackageLocation rpli pure $ PLImmutable pl - (x,_):_ -> pure x + (_,x):_ -> pure x stackCompletePackageLocation _ (RPLMutable rplm) = pure $ PLMutable rplm -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index d0373926a7..8fb4895c75 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -9,6 +9,8 @@ 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 @@ -56,7 +58,7 @@ instance Show LockException where data Change = Change { chAdded :: [RawPackageLocation] , chRemoved :: [RawPackageLocation] - , chUnchanged :: [(PackageLocation, RawPackageLocation)] + , chUnchanged :: [(RawPackageLocation, PackageLocation)] } completeFullPackageLocation :: @@ -69,13 +71,13 @@ completeFullPackageLocation (RPLImmutable rpli) = do completeFullPackageLocation (RPLMutable rplm) = pure $ PLMutable rplm findChange :: - [(PackageLocation, RawPackageLocation)] -- ^ Lock file + [(RawPackageLocation, PackageLocation)] -- ^ Lock file -> [RawPackageLocation] -- ^ stack.yaml file -> Change findChange lrpl srpl = - let lr = map snd lrpl + let lr = map fst lrpl unchangedOnes = intersect lr srpl - unchangedFull = filter (\(pl, rpl) -> rpl `elem` srpl) lrpl + unchangedFull = filter (\(rpl, pl) -> rpl `elem` srpl) lrpl in Change { chAdded = srpl \\ unchangedOnes , chRemoved = lr \\ unchangedOnes @@ -105,7 +107,7 @@ generatePackageLockFile stackFile = do case lockInfo of Just lockData -> do let change = findChange (lfPackageLocations lockData) deps - unchangedRes = map fst (chUnchanged change) + unchangedRes = map snd (chUnchanged change) addedStr = concat $ map @@ -249,7 +251,7 @@ loadPackageLockFile lockFile = do Right lockFileIO -> lockFileIO data LockFile = LockFile - { lfPackageLocations :: [(PackageLocation, RawPackageLocation)] + { lfPackageLocations :: [(RawPackageLocation, PackageLocation)] , lfoResolver :: RawSnapshotLocation , lfcResolver :: SnapshotLocation } @@ -286,7 +288,7 @@ parsePImmutable v = do pure $ PLImmutable <$> xs parseSingleObject :: - Value -> Parser (Unresolved (PackageLocation, RawPackageLocation)) + Value -> Parser (Unresolved (RawPackageLocation, PackageLocation)) parseSingleObject value = withObject "LockFile" @@ -295,7 +297,7 @@ parseSingleObject value = complete <- obj .: "complete" orig <- parseRPL original comp <- parsePImmutable complete - pure $ combineUnresolved comp orig) + pure $ combineUnresolved orig comp) value parseSnapshotLocationPath :: Text -> Unresolved SnapshotLocation diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index fcffbea667..1cdd1076be 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -299,7 +299,7 @@ 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 @@ -311,7 +311,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 From f6559dbf3ecd837b9a2d36474c2b0fbfba8d5ba1 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 28 Feb 2019 23:10:21 +0530 Subject: [PATCH 58/76] Fix Pantry tests --- subs/pantry/package.yaml | 2 +- subs/pantry/test/Pantry/TypesSpec.hs | 232 +-------------------------- 2 files changed, 3 insertions(+), 231 deletions(-) diff --git a/subs/pantry/package.yaml b/subs/pantry/package.yaml index 3b289b9aab..a48ac8d65c 100644 --- a/subs/pantry/package.yaml +++ b/subs/pantry/package.yaml @@ -120,4 +120,4 @@ tests: - exceptions - hedgehog - QuickCheck - - string-quote + - raw-strings-qq diff --git a/subs/pantry/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index 65da369b96..e0d31606e3 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -16,7 +16,6 @@ import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty hiding (map) import Data.Semigroup -import Data.String.Quote import qualified Data.Vector as Vector import qualified Data.Yaml as Yaml import Distribution.Types.PackageName (mkPackageName) @@ -38,6 +37,7 @@ import RIO import qualified RIO.HashMap as HM import qualified RIO.Text as T import Test.Hspec +import Text.RawString.QQ hh :: HasCallStack => String -> Property -> Spec hh name p = @@ -63,7 +63,7 @@ genSha256 = SHA256.hashBytes <$> Gen.bytes (Range.linear 1 500) samplePLIRepo :: ByteString samplePLIRepo = - [s| + [r| subdir: wai cabal-file: size: 1765 @@ -200,231 +200,3 @@ spec = do PackageIdentifier (mkPackageName "persistent") (mkVersion [2, 8, 2]) - it "parses lock file (empty)" $ do - let lockFile :: ByteString - lockFile = - [s|#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.parseAbsDir "/home/sibi" - pkgImm <- - case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither (resolveLockFile rootDir) pkgIm of - Left str -> - fail $ - "Can't parse PackageLocationImmutable - 1" <> - str <> - (show pkgIm) - Right iopl -> do - pl <- lfPackageLocation iopl - pure pl - Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` [] - it "parses lock file (non empty)" $ do - let lockFile :: ByteString - lockFile = - [s|#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.parseAbsDir "/home/sibi" - pkgImm <- - case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither (resolveLockFile rootDir) pkgIm of - Left str -> - fail $ - "Can't parse PackageLocationImmutable - 1" <> - str <> - (show pkgIm) - Right iopl -> do - pl <- lfPackageLocation iopl - pure pl - Nothing -> fail "Can't parse PackageLocationImmutable" - 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 = - [s|#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.parseAbsDir "/home/sibi" - pkgImm <- - case Yaml.decodeThrow lockFile of - Just (pkgIm :: Value) -> do - case Yaml.parseEither - (resolveSnapshotLockFile rootDir) - pkgIm of - Left str -> - fail $ - "Can't parse PackageLocationImmutable - 1" <> - str <> - (show pkgIm) - Right iopl -> do - pl <- iopl - pure pl - Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` - [ ( PLImmutable - (PLIHackage - (PackageIdentifier - { pkgName = mkPackageName "string-quote" - , pkgVersion = mkVersion [0, 0, 1] - }) - (toBlobKey - "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" - 758) - (TreeKey - (BlobKey - (decodeSHA - "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") - (FileSize 273)))) - , RPLImmutable - (RPLIHackage - (PackageIdentifierRevision - (mkPackageName "string-quote") - (mkVersion [0, 0, 1]) - CFILatest) - Nothing)) - ] From a7e6c25b8200d44f8d952089c2e2ac8430e7326a Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 28 Feb 2019 23:10:38 +0530 Subject: [PATCH 59/76] Basic unit test works for lock file --- package.yaml | 2 + src/test/Stack/LockSpec.hs | 244 +++++++++++++++++++++++++++++++++++++ 2 files changed, 246 insertions(+) create mode 100644 src/test/Stack/LockSpec.hs 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/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs new file mode 100644 index 0000000000..7a9cfd024a --- /dev/null +++ b/src/test/Stack/LockSpec.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.LockSpec where + +import Data.ByteString (ByteString) +import Data.Monoid ((<>)) +import qualified Data.Yaml as Yaml +import Data.Yaml (Value) +import qualified Path as Path +import Stack.Lock +import Test.Hspec +import Text.RawString.QQ + +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.parseAbsDir "/home/sibi" + 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 -> do + pl <- iopl + pure (lfPackageLocations pl) + Nothing -> fail "Can't parse PackageLocationImmutable" + 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.parseAbsDir "/home/sibi" +-- pkgImm <- +-- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither (resolveLockFile rootDir) pkgIm of +-- Left str -> +-- fail $ +-- "Can't parse PackageLocationImmutable - 1" <> +-- str <> +-- (show pkgIm) +-- Right iopl -> do +-- pl <- lfPackageLocation iopl +-- pure pl +-- Nothing -> fail "Can't parse PackageLocationImmutable" +-- 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.parseAbsDir "/home/sibi" +-- pkgImm <- +-- case Yaml.decodeThrow lockFile of +-- Just (pkgIm :: Value) -> do +-- case Yaml.parseEither +-- (resolveSnapshotLockFile rootDir) +-- pkgIm of +-- Left str -> +-- fail $ +-- "Can't parse PackageLocationImmutable - 1" <> +-- str <> +-- (show pkgIm) +-- Right iopl -> do +-- pl <- iopl +-- pure pl +-- Nothing -> fail "Can't parse PackageLocationImmutable" +-- pkgImm `shouldBe` +-- [ ( PLImmutable +-- (PLIHackage +-- (PackageIdentifier +-- { pkgName = mkPackageName "string-quote" +-- , pkgVersion = mkVersion [0, 0, 1] +-- }) +-- (toBlobKey +-- "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" +-- 758) +-- (TreeKey +-- (BlobKey +-- (decodeSHA +-- "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") +-- (FileSize 273)))) +-- , RPLImmutable +-- (RPLIHackage +-- (PackageIdentifierRevision +-- (mkPackageName "string-quote") +-- (mkVersion [0, 0, 1]) +-- CFILatest) +-- Nothing)) +-- ] From a419587918d53b487c70572caa566fb064aa56d5 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 11:33:42 +0530 Subject: [PATCH 60/76] Move lock related parsing test to stack --- src/test/Stack/LockSpec.hs | 405 ++++++++++++++------------- subs/pantry/test/Pantry/TypesSpec.hs | 9 - 2 files changed, 205 insertions(+), 209 deletions(-) diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index 7a9cfd024a..c214fedd2e 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -8,11 +8,24 @@ import Data.ByteString (ByteString) 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 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 @@ -42,203 +55,195 @@ resolver: pure (lfPackageLocations pl) Nothing -> fail "Can't parse PackageLocationImmutable" 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.parseAbsDir "/home/sibi" --- pkgImm <- --- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither (resolveLockFile rootDir) pkgIm of --- Left str -> --- fail $ --- "Can't parse PackageLocationImmutable - 1" <> --- str <> --- (show pkgIm) --- Right iopl -> do --- pl <- lfPackageLocation iopl --- pure pl --- Nothing -> fail "Can't parse PackageLocationImmutable" --- 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.parseAbsDir "/home/sibi" --- pkgImm <- --- case Yaml.decodeThrow lockFile of --- Just (pkgIm :: Value) -> do --- case Yaml.parseEither --- (resolveSnapshotLockFile rootDir) --- pkgIm of --- Left str -> --- fail $ --- "Can't parse PackageLocationImmutable - 1" <> --- str <> --- (show pkgIm) --- Right iopl -> do --- pl <- iopl --- pure pl --- Nothing -> fail "Can't parse PackageLocationImmutable" --- pkgImm `shouldBe` --- [ ( PLImmutable --- (PLIHackage --- (PackageIdentifier --- { pkgName = mkPackageName "string-quote" --- , pkgVersion = mkVersion [0, 0, 1] --- }) --- (toBlobKey --- "7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3" --- 758) --- (TreeKey --- (BlobKey --- (decodeSHA --- "d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f") --- (FileSize 273)))) --- , RPLImmutable --- (RPLIHackage --- (PackageIdentifierRevision --- (mkPackageName "string-quote") --- (mkVersion [0, 0, 1]) --- CFILatest) --- Nothing)) --- ] + 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.parseAbsDir "/home/sibi" + 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 -> do + pl <- iopl + pure $ lfPackageLocations pl + Nothing -> fail "Can't parse PackageLocationImmutable" + let pkgImm' = map (\(a, b) -> (b, a)) 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.parseAbsDir "/home/sibi" + pkgImm <- + case Yaml.decodeThrow lockFile of + Just (pkgIm :: Value) -> do + case Yaml.parseEither + (resolveSnapshotLockFile rootDir) + pkgIm of + Left str -> + fail $ + "Can't parse PackageLocationImmutable - 1" <> str <> + (show pkgIm) + Right iopl -> do + pl <- iopl + pure pl + Nothing -> fail "Can't parse PackageLocationImmutable" + 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/test/Pantry/TypesSpec.hs b/subs/pantry/test/Pantry/TypesSpec.hs index e0d31606e3..d20807ba84 100644 --- a/subs/pantry/test/Pantry/TypesSpec.hs +++ b/subs/pantry/test/Pantry/TypesSpec.hs @@ -45,15 +45,6 @@ hh name p = result <- check p unless result $ throwString "Hedgehog property failed" :: IO () -decodeSHA :: ByteString -> SHA256 -decodeSHA string = - case SHA256.fromHexBytes string of - Right csha -> csha - Left err -> error $ "Failed decoding. Error: " <> show err - -toBlobKey :: ByteString -> Word -> BlobKey -toBlobKey string size = BlobKey (decodeSHA string) (FileSize size) - genBlobKey :: Gen BlobKey genBlobKey = BlobKey <$> genSha256 <*> (FileSize <$> (Gen.word (Range.linear 1 10000))) From d284f1032d7bcfd958f1695f5da0f6d252455209 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 12:11:51 +0530 Subject: [PATCH 61/76] Change to Map data type for better efficiency --- src/Stack/Config.hs | 2 +- src/Stack/Lock.hs | 15 +++++++++------ 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index fe651cec65..52f6e13410 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -668,7 +668,7 @@ loadBuildConfig mproject maresolver mcompiler = do pure (cpName $ ppCommon pp, pp) deps0 <- forM (projectDependencies project) $ \rpl -> do - pl <- stackCompletePackageLocation cachePL rpl + pl <- cachedCompletePackageLocation cachePL rpl dp <- additionalDepPackage (shouldHaddockDeps bopts) pl pure (cpName $ dpCommon dp, dp) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 8fb4895c75..53cf475f74 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -106,7 +106,10 @@ generatePackageLockFile stackFile = do (deps', resolver') <- case lockInfo of Just lockData -> do - let change = findChange (lfPackageLocations lockData) deps + let change = + findChange + (Map.toList $ lfPackageLocations lockData) + deps unchangedRes = map snd (chUnchanged change) addedStr = concat $ @@ -220,7 +223,7 @@ parsePackageLockFile rootDir value = "LockFile" (\obj -> do vals :: Value <- obj .: "dependencies" - xs <- + xs :: Vector (Unresolved (RawPackageLocation, PackageLocation)) <- withArray "LockFileArray" (\vec -> sequence $ Vector.map parseSingleObject vec) @@ -232,12 +235,12 @@ parsePackageLockFile rootDir value = rc <- parseSL rcomplete let rpaths = resolvePaths (Just rootDir) pure $ do - lfpls <- rpaths $ sequence (Vector.toList xs) + lfpls <- rpaths $ sequence $ Vector.toList xs lfor <- rpaths ro lfcr <- rpaths rc pure $ LockFile - { lfPackageLocations = lfpls + { lfPackageLocations = Map.fromList lfpls , lfoResolver = lfor , lfcResolver = lfcr }) @@ -247,11 +250,11 @@ 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 lock file: Got error " <> str + Left str -> fail $ "Cannot parse package lock file: Got error " <> str Right lockFileIO -> lockFileIO data LockFile = LockFile - { lfPackageLocations :: [(RawPackageLocation, PackageLocation)] + { lfPackageLocations :: Map RawPackageLocation PackageLocation , lfoResolver :: RawSnapshotLocation , lfcResolver :: SnapshotLocation } From 18058285775564fdd491a874e911dd86f701d1e0 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 12:16:19 +0530 Subject: [PATCH 62/76] Cleanup --- src/Stack/Config.hs | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 52f6e13410..0a47706493 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -533,19 +533,6 @@ cachedCompletePackageLocation cachePackages rp@(RPLImmutable rpli) = do Just pl -> pure pl cachedCompletePackageLocation _ (RPLMutable rplm) = pure $ PLMutable rplm -stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(RawPackageLocation, PackageLocation)] - -> RawPackageLocation - -> RIO env PackageLocation -stackCompletePackageLocation cachePackages rp@(RPLImmutable rpli) = do - let xs = filter (\(x,_) -> x == rp) cachePackages - case xs of - [] -> do - pl <- completePackageLocation rpli - pure $ PLImmutable pl - (_,x):_ -> pure x -stackCompletePackageLocation _ (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) From ed5e41d08f28db94f46d806573131673c59ee692 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 12:45:38 +0530 Subject: [PATCH 63/76] Do renaming --- src/Stack/Config.hs | 8 ++++---- src/Stack/Lock.hs | 33 +++++++++++++++++---------------- 2 files changed, 21 insertions(+), 20 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 0a47706493..fa0e17fe14 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -90,10 +90,10 @@ import RIO.Process import Stack.Lock ( LockFile(..) , generatePackageLockFile - , generateSnapshotLockFile + , generateSnapshotLayerLockFile , isLockFileOutdated , loadPackageLockFile - , loadSnapshotLockFile + , loadSnapshotLayerLockFile ) -- | If deprecated path exists, use it and print a warning. @@ -631,14 +631,14 @@ loadBuildConfig mproject maresolver mcompiler = do case resolver of SLFilePath path -> do outdated <- isLockFileOutdated (resolvedAbsolute path) - when outdated (generateSnapshotLockFile resolver stackYamlFP) + when outdated (generateSnapshotLayerLockFile resolver stackYamlFP) _ -> return () cachedPL <- case resolver of SLFilePath path -> do let sf = resolvedAbsolute path slf <- liftIO $ addFileExtension "lock" sf - xs <- liftIO $ loadSnapshotLockFile slf (parent stackYamlFP) + xs <- liftIO $ loadSnapshotLayerLockFile slf (parent stackYamlFP) pure xs _ -> pure [] diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 53cf475f74..6749d8fdf5 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -168,12 +168,12 @@ loadSnapshotFile path rootDir = do Left str -> fail $ "Cannot parse snapshot file: Got error " <> str Right rplio -> rplio -createSnapshotLockFile :: +createSnapshotLayerLockFile :: Path Abs File -- ^ Snapshot file -> [RawPackageLocationImmutable] -> RawSnapshotLocation -> RIO Config () -createSnapshotLockFile path rpli rpl = do +createSnapshotLayerLockFile path rpli rpl = do let rpli' :: [RawPackageLocation] = map RPLImmutable rpli deps :: [PackageLocation] <- mapM completeFullPackageLocation rpli' rpl' :: SnapshotLocation <- completeSnapshotLocation rpl @@ -197,13 +197,14 @@ createSnapshotLockFile path rpli rpl = do ] B.writeFile (fromAbsFile snapshotLockFile) (Yaml.encode depsObject) -generateSnapshotLockFile :: SnapshotLocation -> Path Abs File -> RIO Config () -generateSnapshotLockFile (SLFilePath path) stackFile = do +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) - createSnapshotLockFile snapshotPath rpli rpl -generateSnapshotLockFile xs _ = throwM (LockCannotGenerate xs) + createSnapshotLayerLockFile snapshotPath rpli rpl +generateSnapshotLayerLockFile xs _ = throwM (LockCannotGenerate xs) isLockFileOutdated :: Path Abs File -> RIO Config Bool isLockFileOutdated stackFile = do @@ -517,38 +518,38 @@ parseImmutableObject value = pure $ combineUnresolved comp orig) value -parseSnapshotLockFile :: +parseSnapshotLayerLockFile :: Value -> Parser (Unresolved [( PackageLocationImmutable , RawPackageLocationImmutable)]) -parseSnapshotLockFile = +parseSnapshotLayerLockFile = withObject - "SnapshotLockFile" + "SnapshotLayerLockFile" (\obj -> do vals <- obj .: "dependencies" xs <- withArray - "SnapshotLockArray" + "SnapshotLayerLockArray" (\vec -> sequence $ Vector.map parseImmutableObject vec) vals pure $ sequence $ Vector.toList xs) -resolveSnapshotLockFile :: +resolveSnapshotLayerLockFile :: Path Abs Dir -> Value -> Parser (IO [(PackageLocationImmutable, RawPackageLocationImmutable)]) -resolveSnapshotLockFile rootDir val = do - pkgs <- parseSnapshotLockFile val +resolveSnapshotLayerLockFile rootDir val = do + pkgs <- parseSnapshotLayerLockFile val let pkgsLoc = resolvePaths (Just rootDir) pkgs pure pkgsLoc -loadSnapshotLockFile :: +loadSnapshotLayerLockFile :: Path Abs File -> Path Abs Dir -> IO [(PackageLocationImmutable, RawPackageLocationImmutable)] -loadSnapshotLockFile lockFile rootDir = do +loadSnapshotLayerLockFile lockFile rootDir = do val <- Yaml.decodeFileThrow (toFilePath lockFile) - case Yaml.parseEither (resolveSnapshotLockFile rootDir) val of + case Yaml.parseEither (resolveSnapshotLayerLockFile rootDir) val of Left str -> fail $ "Cannot parse snapshot lock file: Got error " <> str <> (show val) From 27f3a887f73c08fa8d51be21fe006dcda30c5f74 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 13:02:21 +0530 Subject: [PATCH 64/76] Fix test for the Map data structure --- src/test/Stack/LockSpec.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index c214fedd2e..926a618bff 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -5,6 +5,7 @@ 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) @@ -54,7 +55,7 @@ resolver: pl <- iopl pure (lfPackageLocations pl) Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` [] + (Map.toList pkgImm) `shouldBe` [] it "parses lock file (non empty)" $ do let lockFile :: ByteString lockFile = @@ -113,7 +114,7 @@ resolver: pl <- iopl pure $ lfPackageLocations pl Nothing -> fail "Can't parse PackageLocationImmutable" - let pkgImm' = map (\(a, b) -> (b, a)) pkgImm + let pkgImm' = map (\(a, b) -> (b, a)) (Map.toList pkgImm) pkgImm' `shouldBe` [ ( PLImmutable (PLIRepo @@ -216,7 +217,7 @@ dependencies: case Yaml.decodeThrow lockFile of Just (pkgIm :: Value) -> do case Yaml.parseEither - (resolveSnapshotLockFile rootDir) + (resolveSnapshotLayerLockFile rootDir) pkgIm of Left str -> fail $ From 28921f58adb86521129c30c631e653bd07dd69aa Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 13:20:03 +0530 Subject: [PATCH 65/76] Change the type for parsing from snapshot lock file --- src/Stack/Config.hs | 8 ++++---- src/Stack/Lock.hs | 14 +++++++------- subs/pantry/src/Pantry.hs | 12 ++++++------ 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index fa0e17fe14..748c93e521 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -615,7 +615,7 @@ loadBuildConfig mproject maresolver mcompiler = do else logDebug "Lock file is upto date" lockFile <- liftIO $ addFileExtension "lock" stackYamlFP - (cachePL, origResolver, compResolver) <- liftIO $ do + (cachedPackageLock, origResolver, compResolver) <- liftIO $ do lf <- loadPackageLockFile lockFile return (lfPackageLocations lf, lfoResolver lf, lfcResolver lf) @@ -634,7 +634,7 @@ loadBuildConfig mproject maresolver mcompiler = do when outdated (generateSnapshotLayerLockFile resolver stackYamlFP) _ -> return () - cachedPL <- case resolver of + cachedSnapshotLock <- case resolver of SLFilePath path -> do let sf = resolvedAbsolute path slf <- liftIO $ addFileExtension "lock" sf @@ -642,7 +642,7 @@ loadBuildConfig mproject maresolver mcompiler = do pure xs _ -> pure [] - (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedPL (parent stackYamlFP) + (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedSnapshotLock (parent stackYamlFP) extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) @@ -655,7 +655,7 @@ loadBuildConfig mproject maresolver mcompiler = do pure (cpName $ ppCommon pp, pp) deps0 <- forM (projectDependencies project) $ \rpl -> do - pl <- cachedCompletePackageLocation cachePL rpl + pl <- cachedCompletePackageLocation cachedPackageLock rpl dp <- additionalDepPackage (shouldHaddockDeps bopts) pl pure (cpName $ dpCommon dp, dp) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 6749d8fdf5..2f1370d8f3 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -505,8 +505,8 @@ parsePLI v = do parseImmutableObject :: Value - -> Parser (Unresolved ( PackageLocationImmutable - , RawPackageLocationImmutable)) + -> Parser (Unresolved ( RawPackageLocationImmutable + , PackageLocationImmutable)) parseImmutableObject value = withObject "LockFile" @@ -515,13 +515,13 @@ parseImmutableObject value = complete <- obj .: "complete" orig <- parseRPLI original comp <- parsePLI complete - pure $ combineUnresolved comp orig) + pure $ combineUnresolved orig comp) value parseSnapshotLayerLockFile :: Value - -> Parser (Unresolved [( PackageLocationImmutable - , RawPackageLocationImmutable)]) + -> Parser (Unresolved [( RawPackageLocationImmutable + , PackageLocationImmutable)]) parseSnapshotLayerLockFile = withObject "SnapshotLayerLockFile" @@ -537,7 +537,7 @@ parseSnapshotLayerLockFile = resolveSnapshotLayerLockFile :: Path Abs Dir -> Value - -> Parser (IO [(PackageLocationImmutable, RawPackageLocationImmutable)]) + -> Parser (IO [(RawPackageLocationImmutable, PackageLocationImmutable)]) resolveSnapshotLayerLockFile rootDir val = do pkgs <- parseSnapshotLayerLockFile val let pkgsLoc = resolvePaths (Just rootDir) pkgs @@ -546,7 +546,7 @@ resolveSnapshotLayerLockFile rootDir val = do loadSnapshotLayerLockFile :: Path Abs File -> Path Abs Dir - -> IO [(PackageLocationImmutable, RawPackageLocationImmutable)] + -> IO [(RawPackageLocationImmutable, PackageLocationImmutable)] loadSnapshotLayerLockFile lockFile rootDir = do val <- Yaml.decodeFileThrow (toFilePath lockFile) case Yaml.parseEither (resolveSnapshotLayerLockFile rootDir) val of diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index c4eb66ebf7..37d8713391 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -980,7 +980,7 @@ type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation - -> [(PackageLocationImmutable, RawPackageLocationImmutable)] -- ^ Cached data from snapshot lock file + -> [(RawPackageLocationImmutable, PackageLocationImmutable)] -- ^ Cached data from snapshot lock file -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshot loc cachedPL rootDir = @@ -993,7 +993,7 @@ loadAndCompleteSnapshot loc cachedPL rootDir = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation - -> [(PackageLocationImmutable, RawPackageLocationImmutable)] -- ^ Cached data from snapshot lock file + -> [(RawPackageLocationImmutable, PackageLocationImmutable)] -- ^ Cached data from snapshot lock file -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshotRaw loc cachePL rootDir = do @@ -1144,14 +1144,14 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens pure (allPackages, unused) stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(PackageLocationImmutable, RawPackageLocationImmutable)] + => [(RawPackageLocationImmutable, PackageLocationImmutable)] -> RawPackageLocationImmutable -> RIO env PackageLocationImmutable stackCompletePackageLocation cachePackages rpli = do - let xs = filter (\(_,x) -> x == rpli) cachePackages + let xs = filter (\(x,_) -> x == rpli) cachePackages case xs of [] -> completePackageLocation rpli - (x,_):_ -> pure x + (_,x):_ -> pure x -- | Add more packages to a snapshot completing their locations if needed @@ -1169,7 +1169,7 @@ addAndCompletePackagesToSnapshot => RawSnapshotLocation -- ^ Text description of where these new packages are coming from, for error -- messages only - -> [(PackageLocationImmutable, RawPackageLocationImmutable)] -- ^ Cached data from snapshot lock file + -> [(RawPackageLocationImmutable, PackageLocationImmutable)] -- ^ Cached data from snapshot lock file -> Path Abs Dir -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig From 89da1efb1f227673e94aa94a329dce0603a0825a Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 13:31:07 +0530 Subject: [PATCH 66/76] Switch to map data structure for cached data --- src/Stack/Config.hs | 2 +- src/Stack/Lock.hs | 6 +++--- subs/pantry/src/Pantry.hs | 20 ++++++++++---------- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 748c93e521..94e0fd8fef 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -640,7 +640,7 @@ loadBuildConfig mproject maresolver mcompiler = do slf <- liftIO $ addFileExtension "lock" sf xs <- liftIO $ loadSnapshotLayerLockFile slf (parent stackYamlFP) pure xs - _ -> pure [] + _ -> pure Map.empty (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedSnapshotLock (parent stackYamlFP) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 2f1370d8f3..8848fbe903 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -537,16 +537,16 @@ parseSnapshotLayerLockFile = resolveSnapshotLayerLockFile :: Path Abs Dir -> Value - -> Parser (IO [(RawPackageLocationImmutable, PackageLocationImmutable)]) + -> Parser (IO (Map RawPackageLocationImmutable PackageLocationImmutable)) resolveSnapshotLayerLockFile rootDir val = do pkgs <- parseSnapshotLayerLockFile val let pkgsLoc = resolvePaths (Just rootDir) pkgs - pure pkgsLoc + pure $ Map.fromList <$> pkgsLoc loadSnapshotLayerLockFile :: Path Abs File -> Path Abs Dir - -> IO [(RawPackageLocationImmutable, PackageLocationImmutable)] + -> IO (Map RawPackageLocationImmutable PackageLocationImmutable) loadSnapshotLayerLockFile lockFile rootDir = do val <- Yaml.decodeFileThrow (toFilePath lockFile) case Yaml.parseEither (resolveSnapshotLayerLockFile rootDir) val of diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 37d8713391..dc086bacc9 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -980,7 +980,7 @@ type CompletedPLI = (RawPackageLocationImmutable, PackageLocationImmutable) loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation - -> [(RawPackageLocationImmutable, PackageLocationImmutable)] -- ^ Cached data from snapshot lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshot loc cachedPL rootDir = @@ -993,7 +993,7 @@ loadAndCompleteSnapshot loc cachedPL rootDir = loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation - -> [(RawPackageLocationImmutable, PackageLocationImmutable)] -- ^ Cached data from snapshot lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) loadAndCompleteSnapshotRaw loc cachePL rootDir = do @@ -1143,15 +1143,15 @@ addPackagesToSnapshot source newPackages (AddPackagesConfig drops flags hiddens pure (allPackages, unused) -stackCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) - => [(RawPackageLocationImmutable, PackageLocationImmutable)] +cachedSnapshotCompletePackageLocation :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) + => Map RawPackageLocationImmutable PackageLocationImmutable -> RawPackageLocationImmutable -> RIO env PackageLocationImmutable -stackCompletePackageLocation cachePackages rpli = do - let xs = filter (\(x,_) -> x == rpli) cachePackages +cachedSnapshotCompletePackageLocation cachePackages rpli = do + let xs = Map.lookup rpli cachePackages case xs of - [] -> completePackageLocation rpli - (_,x):_ -> pure x + Nothing -> completePackageLocation rpli + Just x -> pure x -- | Add more packages to a snapshot completing their locations if needed @@ -1169,7 +1169,7 @@ addAndCompletePackagesToSnapshot => RawSnapshotLocation -- ^ Text description of where these new packages are coming from, for error -- messages only - -> [(RawPackageLocationImmutable, PackageLocationImmutable)] -- ^ Cached data from snapshot lock file + -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file -> Path Abs Dir -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig @@ -1183,7 +1183,7 @@ addAndCompletePackagesToSnapshot loc cachedPL rootDir newPackages (AddPackagesCo -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) addPackage (ps, completed) loc = do name <- getPackageLocationName loc - loc' <- stackCompletePackageLocation cachedPL loc + loc' <- cachedSnapshotCompletePackageLocation cachedPL loc let p = (name, SnapshotPackage { spLocation = loc' , spFlags = Map.findWithDefault mempty name flags From 10ad675758dd5c70b0d6b0decc7509e47dfcb85e Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 14:08:18 +0530 Subject: [PATCH 67/76] Add Display instance for RawPackageLocation --- subs/pantry/src/Pantry/Types.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/subs/pantry/src/Pantry/Types.hs b/subs/pantry/src/Pantry/Types.hs index 1cdd1076be..49396c86f3 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -303,6 +303,10 @@ data RawPackageLocation 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. From 02efbec5601fd93dfc1fd85e0f98c5d62f549926 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 14:08:45 +0530 Subject: [PATCH 68/76] Cleanup, make fields strict --- src/Stack/Config.hs | 10 +++------- src/Stack/Lock.hs | 32 ++++++++++++++------------------ 2 files changed, 17 insertions(+), 25 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 94e0fd8fef..41e2ddaa7b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -610,7 +610,7 @@ loadBuildConfig mproject maresolver mcompiler = do lockFileOutdated <- isLockFileOutdated stackYamlFP if lockFileOutdated then do - logDebug "Lock file is outdated" + logDebug "Lock file is outdated or isn't present" generatePackageLockFile stackYamlFP else logDebug "Lock file is upto date" @@ -621,12 +621,8 @@ loadBuildConfig mproject maresolver mcompiler = do resolver <- if (projectResolver project == origResolver) - then do - logInfo "Resolver matches with the lock file" - pure compResolver - else do - logInfo "Resolving snapshot location" - completeSnapshotLocation $ projectResolver project + then pure compResolver + else completeSnapshotLocation $ projectResolver project case resolver of SLFilePath path -> do diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 8848fbe903..44ee5d5614 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} module Stack.Lock where @@ -56,9 +57,9 @@ instance Show LockException where -- * 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)] + { chAdded :: ![RawPackageLocation] + , chRemoved :: ![RawPackageLocation] + , chUnchanged :: ![(RawPackageLocation, PackageLocation)] } completeFullPackageLocation :: @@ -86,7 +87,7 @@ findChange lrpl srpl = generatePackageLockFile :: Path Abs File -> RIO Config () generatePackageLockFile stackFile = do - logDebug "Gennerating lock file" + logDebug "Generating lock file" mproject <- view $ configL . to configMaybeProject p <- case mproject of @@ -111,21 +112,16 @@ generatePackageLockFile stackFile = do (Map.toList $ lfPackageLocations lockData) deps unchangedRes = map snd (chUnchanged change) - addedStr = - concat $ + addedStr :: [Utf8Builder] = map - (\x -> - "Adding " <> (show x) <> - " package to the lock file.\n") + (\x -> "Lock file package added: " (display x)) (chAdded change) - deletedstr = - concat $ + deletedStr :: [Utf8Builder] = map - (\x -> - "Removing " <> (show x) <> - " package from the lock file.\n") + (\x -> "Lock file package removed: " (display x)) (chRemoved change) - logInfo (displayShow $ addedStr <> deletedstr) + mapM_ logDebug addedStr + mapM_ logDebug deletedStr deps <- mapM completeFullPackageLocation (chAdded change) let allDeps = unchangedRes <> deps res <- @@ -255,9 +251,9 @@ loadPackageLockFile lockFile = do Right lockFileIO -> lockFileIO data LockFile = LockFile - { lfPackageLocations :: Map RawPackageLocation PackageLocation - , lfoResolver :: RawSnapshotLocation - , lfcResolver :: SnapshotLocation + { lfPackageLocations :: !(Map RawPackageLocation PackageLocation) + , lfoResolver :: !RawSnapshotLocation + , lfcResolver :: !SnapshotLocation } combineUnresolved :: Unresolved a -> Unresolved b -> Unresolved (a, b) From 6e0be06eddbaf2daa3ec77e5388feaa5b57180ae Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 14:10:17 +0530 Subject: [PATCH 69/76] Fix compile error --- src/Stack/Lock.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 44ee5d5614..e97aa4d15c 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -114,11 +114,11 @@ generatePackageLockFile stackFile = do unchangedRes = map snd (chUnchanged change) addedStr :: [Utf8Builder] = map - (\x -> "Lock file package added: " (display x)) + (\x -> "Lock file package added: " <> (display x)) (chAdded change) deletedStr :: [Utf8Builder] = map - (\x -> "Lock file package removed: " (display x)) + (\x -> "Lock file package removed: " <> (display x)) (chRemoved change) mapM_ logDebug addedStr mapM_ logDebug deletedStr From 6e05cd006ff06c32228cdeb9401278a9a40eacd2 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 14:12:31 +0530 Subject: [PATCH 70/76] Fix test --- src/test/Stack/LockSpec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index 926a618bff..7ae2d570bc 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -227,7 +227,8 @@ dependencies: pl <- iopl pure pl Nothing -> fail "Can't parse PackageLocationImmutable" - pkgImm `shouldBe` + let pkgImm' = map (\(a, b) -> (b, a)) (Map.toList pkgImm) + pkgImm' `shouldBe` [ ( (PLIHackage (PackageIdentifier { pkgName = mkPackageName "string-quote" From 246ff8ed2bb07438dff48d546a32679f7a67f585 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 14:26:14 +0530 Subject: [PATCH 71/76] Remove rootDir parameter as it's not required --- src/Stack/Config.hs | 2 +- subs/pantry/src/Pantry.hs | 14 +++++--------- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 41e2ddaa7b..f9351c3039 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -638,7 +638,7 @@ loadBuildConfig mproject maresolver mcompiler = do pure xs _ -> pure Map.empty - (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedSnapshotLock (parent stackYamlFP) + (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedSnapshotLock extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project) diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index dc086bacc9..87d5b127f1 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -981,10 +981,9 @@ loadAndCompleteSnapshot :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => SnapshotLocation -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshot loc cachedPL rootDir = - loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL rootDir +loadAndCompleteSnapshot loc cachedPL = + loadAndCompleteSnapshotRaw (toRawSL loc) cachedPL -- | Parse a 'Snapshot' (all layers) from a 'RawSnapshotLocation' completing -- any incomplete package locations @@ -994,9 +993,8 @@ loadAndCompleteSnapshotRaw :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env) => RawSnapshotLocation -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> Path Abs Dir -> RIO env (Snapshot, [CompletedPLI]) -loadAndCompleteSnapshotRaw loc cachePL rootDir = do +loadAndCompleteSnapshotRaw loc cachePL = do eres <- loadRawSnapshotLayer loc case eres of Left wc -> @@ -1008,12 +1006,11 @@ loadAndCompleteSnapshotRaw loc cachePL rootDir = do } in pure (snapshot, []) Right (rsl, _sha) -> do - (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL rootDir + (snap0, completed0) <- loadAndCompleteSnapshotRaw (rslParent rsl) cachePL (packages, completed, unused) <- addAndCompletePackagesToSnapshot loc cachePL - rootDir (rslLocations rsl) AddPackagesConfig { apcDrop = rslDropPackages rsl @@ -1170,12 +1167,11 @@ addAndCompletePackagesToSnapshot -- ^ Text description of where these new packages are coming from, for error -- messages only -> Map RawPackageLocationImmutable PackageLocationImmutable -- ^ Cached data from snapshot lock file - -> Path Abs Dir -> [RawPackageLocationImmutable] -- ^ new packages -> AddPackagesConfig -> Map PackageName SnapshotPackage -- ^ packages from parent -> RIO env (Map PackageName SnapshotPackage, [CompletedPLI], AddPackagesConfig) -addAndCompletePackagesToSnapshot loc cachedPL rootDir newPackages (AddPackagesConfig drops flags hiddens options) old = do +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]) From 581951470f329b92490fdd0a9597619ed39ef83c Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 14:30:50 +0530 Subject: [PATCH 72/76] Don't new string-quote anymore --- snapshot-lts-12.yaml | 1 - snapshot.yaml | 1 - 2 files changed, 2 deletions(-) diff --git a/snapshot-lts-12.yaml b/snapshot-lts-12.yaml index 88c085a794..ef5026ab8b 100644 --- a/snapshot-lts-12.yaml +++ b/snapshot-lts-12.yaml @@ -8,4 +8,3 @@ packages: - infer-license-0.2.0@rev:0 #for hpack-0.31 - tar-conduit-0.3.1@rev:0 - yaml-0.10.4.0@rev:0 #for hpack-0.31 -- string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3 diff --git a/snapshot.yaml b/snapshot.yaml index ac7998c989..611ac9e5ce 100644 --- a/snapshot.yaml +++ b/snapshot.yaml @@ -17,7 +17,6 @@ packages: - cabal-doctest-1.0.6@rev:2 - unliftio-0.2.8.0@sha256:5a47f12ffcee837215c67b05abf35dffb792096564a6f81652d75a54668224cd,2250 - happy-1.19.9@sha256:f8c774230735a390c287b2980cfcd2703d24d8dde85a01ea721b7b4b4c82944f,4667 -- string-quote-0.0.1@sha256:7d91a0ba1be44b2443497c92f2f027cd4580453b893f8b5ebf061e1d85befaf3 - fsnotify-0.3.0.1@rev:1 flags: From c66249131360334dd7aaa2627e534b31b8f199a2 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 18:04:59 +0530 Subject: [PATCH 73/76] Fix pedantic warnings --- src/Stack/Build/ConstructPlan.hs | 2 +- src/Stack/Lock.hs | 14 +++++++++----- subs/pantry/src/Pantry.hs | 12 ++++++------ subs/pantry/src/Pantry/Types.hs | 4 +--- 4 files changed, 17 insertions(+), 15 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 784566290e..6d4d55c7b1 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -1029,7 +1029,7 @@ 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)) = + pprintExtra (name, (version, BlobKey _ _)) = let packageIdRev = PackageIdentifierRevision name version CFILatest in fromString $ T.unpack $ utf8BuilderToText $ RIO.display packageIdRev diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index e97aa4d15c..00ed07cf15 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -78,7 +78,11 @@ findChange :: findChange lrpl srpl = let lr = map fst lrpl unchangedOnes = intersect lr srpl - unchangedFull = filter (\(rpl, pl) -> rpl `elem` srpl) lrpl + -- 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 @@ -122,8 +126,8 @@ generatePackageLockFile stackFile = do (chRemoved change) mapM_ logDebug addedStr mapM_ logDebug deletedStr - deps <- mapM completeFullPackageLocation (chAdded change) - let allDeps = unchangedRes <> deps + cdeps <- mapM completeFullPackageLocation (chAdded change) + let allDeps = unchangedRes <> cdeps res <- if (lfoResolver lockData) == resolver then pure (lfcResolver lockData) @@ -377,8 +381,8 @@ parseSnapshotFile (Object obj) = do "SnapshotFileArray" (\vec -> sequence $ Vector.map parseRPLI vec) packages - resolver <- parseRSL resolver - pure $ combineUnresolved (sequence $ Vector.toList xs) resolver + resolver' <- parseRSL resolver + pure $ combineUnresolved (sequence $ Vector.toList xs) resolver' parseSnapshotFile val = fail $ "Expected Object, but got: " <> (show val) resolveSnapshotFile :: diff --git a/subs/pantry/src/Pantry.hs b/subs/pantry/src/Pantry.hs index 87d5b127f1..496ff3f436 100644 --- a/subs/pantry/src/Pantry.hs +++ b/subs/pantry/src/Pantry.hs @@ -187,7 +187,7 @@ import Pantry.Storage import Pantry.Tree import Pantry.Types import Pantry.Hackage -import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile, addFileExtension) +import Path (Path, Abs, File, toFilePath, Dir, (), filename, parseAbsDir, parent, parseRelFile) import Path.IO (doesFileExist, resolveDir', listDir) import Distribution.PackageDescription (GenericPackageDescription, FlagName) import qualified Distribution.PackageDescription as D @@ -1177,18 +1177,18 @@ addAndCompletePackagesToSnapshot loc cachedPL newPackages (AddPackagesConfig dro => ([(PackageName, SnapshotPackage)],[CompletedPLI]) -> RawPackageLocationImmutable -> RIO env ([(PackageName, SnapshotPackage)], [CompletedPLI]) - addPackage (ps, completed) loc = do - name <- getPackageLocationName loc - loc' <- cachedSnapshotCompletePackageLocation cachedPL loc + 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 49396c86f3..4946a205aa 100644 --- a/subs/pantry/src/Pantry/Types.hs +++ b/subs/pantry/src/Pantry/Types.hs @@ -113,8 +113,6 @@ module Pantry.Types import RIO import qualified Data.Conduit.Tar as Tar -import qualified Data.Vector as Vector -import qualified Data.Yaml as Yaml import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL @@ -149,7 +147,7 @@ import Data.Store (Size (..), Store (..)) import Network.HTTP.Client (parseRequest) import Network.HTTP.Types (Status, statusCode) import Data.Text.Read (decimal) -import Path (Path, Abs, Dir, File, toFilePath, filename, (), parseRelFile, parent) +import Path (Path, Abs, Dir, File, toFilePath, filename, (), parseRelFile) import Path.IO (resolveFile, resolveDir) import Data.Pool (Pool) import Data.List.NonEmpty (NonEmpty) From 281ed27c0b005f0236fa7fafdc6bd7e3b8b15c9a Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 18:26:16 +0530 Subject: [PATCH 74/76] Some hlint fixes --- src/Stack/Config.hs | 5 ++-- src/Stack/Lock.hs | 37 +++++++++++------------ src/test/Stack/LockSpec.hs | 60 +++++++++++++++++--------------------- 3 files changed, 46 insertions(+), 56 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index f9351c3039..4a9f841d68 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -620,7 +620,7 @@ loadBuildConfig mproject maresolver mcompiler = do return (lfPackageLocations lf, lfoResolver lf, lfcResolver lf) - resolver <- if (projectResolver project == origResolver) + resolver <- if projectResolver project == origResolver then pure compResolver else completeSnapshotLocation $ projectResolver project @@ -634,8 +634,7 @@ loadBuildConfig mproject maresolver mcompiler = do SLFilePath path -> do let sf = resolvedAbsolute path slf <- liftIO $ addFileExtension "lock" sf - xs <- liftIO $ loadSnapshotLayerLockFile slf (parent stackYamlFP) - pure xs + liftIO $ loadSnapshotLayerLockFile slf (parent stackYamlFP) _ -> pure Map.empty (snapshot, _completed) <- loadAndCompleteSnapshot resolver cachedSnapshotLock diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 00ed07cf15..7578a0ae6c 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -48,7 +48,7 @@ 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) + "Lock file cannot be generated for snapshot: " <> show e -- You need to keep track of the following things -- Has resolver changed. @@ -102,12 +102,11 @@ generatePackageLockFile stackFile = do packageLockFile <- liftIO $ addFileExtension "lock" stackFile packageLockFileExists <- liftIO $ doesFileExist packageLockFile lockInfo :: Maybe LockFile <- - case packageLockFileExists of - True -> - liftIO $ do - lfio <- loadPackageLockFile packageLockFile - pure $ Just lfio - False -> pure Nothing + if packageLockFileExists + then liftIO $ do + lfio <- loadPackageLockFile packageLockFile + pure $ Just lfio + else pure Nothing (deps', resolver') <- case lockInfo of Just lockData -> do @@ -118,18 +117,18 @@ generatePackageLockFile stackFile = do unchangedRes = map snd (chUnchanged change) addedStr :: [Utf8Builder] = map - (\x -> "Lock file package added: " <> (display x)) + (\x -> "Lock file package added: " <> display x) (chAdded change) deletedStr :: [Utf8Builder] = map - (\x -> "Lock file package removed: " <> (display x)) + (\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 + if lfoResolver lockData == resolver then pure (lfcResolver lockData) else completeSnapshotLocation resolver pure (allDeps, res) @@ -318,7 +317,7 @@ parseSnapshotLocationPath t = parseSLObject :: Value -> Parser (Unresolved SnapshotLocation) parseSLObject = withObject "UnresolvedSnapshotLocation (Object)" $ \o -> - ((pure . SLCompiler) <$> o .: "compiler") <|> + (pure . SLCompiler <$> o .: "compiler") <|> ((\x y -> pure $ SLUrl x y) <$> o .: "url" <*> parseJSON (Object o)) <|> (parseSnapshotLocationPath <$> o .: "filepath") @@ -342,7 +341,7 @@ parseSL v = txtParser v <|> parseSLObject v (parseWantedCompiler t) txtParser = withText - ("UnresolvedSnapshotLocation (Text)") + "UnresolvedSnapshotLocation (Text)" (\t -> pure $ fromMaybe (parseSnapshotLocationPath t) (txt t)) parseBlobKey :: Object -> Parser (Maybe BlobKey) @@ -358,7 +357,7 @@ parseBlobKey o = do parseRSLObject :: Value -> Parser (Unresolved RawSnapshotLocation) parseRSLObject = withObject "UnresolvedRawSnapshotLocation (Object)" $ \o -> - ((pure . RSLCompiler) <$> o .: "compiler") <|> + (pure . RSLCompiler <$> o .: "compiler") <|> ((\x y -> pure $ RSLUrl x y) <$> o .: "url" <*> parseBlobKey o) <|> (parseRawSnapshotLocationPath <$> o .: "filepath") @@ -383,7 +382,7 @@ parseSnapshotFile (Object obj) = do packages resolver' <- parseRSL resolver pure $ combineUnresolved (sequence $ Vector.toList xs) resolver' -parseSnapshotFile val = fail $ "Expected Object, but got: " <> (show val) +parseSnapshotFile val = fail $ "Expected Object, but got: " <> show val resolveSnapshotFile :: Path Abs Dir @@ -419,7 +418,7 @@ parseRPLHackageObject :: Value -> Parser (Unresolved RawPackageLocationImmutable) parseRPLHackageObject = withObject "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> - (pure) <$> (RPLIHackage <$> o .: "hackage" <*> o .:? "pantry-tree") + pure <$> (RPLIHackage <$> o .: "hackage" <*> o .:? "pantry-tree") optionalSubdirs' :: Object -> Parser OptionalSubdirs optionalSubdirs' o = @@ -481,8 +480,8 @@ parseGithubRPLObject = , commit , ".tar.gz" ] - raHash <- o .:? "sha256" raSize <- o .:? "size" + raHash <- o .:? "sha256" os <- optionalSubdirs' o pure $ pure $ @@ -499,9 +498,7 @@ parseRPLI v = parseGithubRPLObject v parsePLI :: Value -> Parser (Unresolved PackageLocationImmutable) -parsePLI v = do - x <- parseJSON v - pure x +parsePLI v = parseJSON v parseImmutableObject :: Value @@ -552,5 +549,5 @@ loadSnapshotLayerLockFile lockFile rootDir = do case Yaml.parseEither (resolveSnapshotLayerLockFile rootDir) val of Left str -> fail $ - "Cannot parse snapshot lock file: Got error " <> str <> (show val) + "Cannot parse snapshot lock file: Got error " <> str <> show val Right lockFileIO -> lockFileIO diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index 7ae2d570bc..81c63be1b4 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -13,7 +13,7 @@ import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) import Pantry import qualified Pantry.SHA256 as SHA256 -import qualified Path as Path +import qualified Path import Stack.Lock import Test.Hspec import Text.RawString.QQ @@ -50,12 +50,10 @@ resolver: Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str <> - (show pkgIm) - Right iopl -> do - pl <- iopl - pure (lfPackageLocations pl) + show pkgIm + Right iopl -> lfPackageLocations <$> iopl Nothing -> fail "Can't parse PackageLocationImmutable" - (Map.toList pkgImm) `shouldBe` [] + Map.toList pkgImm `shouldBe` [] it "parses lock file (non empty)" $ do let lockFile :: ByteString lockFile = @@ -109,10 +107,8 @@ resolver: Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str <> - (show pkgIm) - Right iopl -> do - pl <- iopl - pure $ lfPackageLocations pl + show pkgIm + Right iopl -> lfPackageLocations <$> iopl Nothing -> fail "Can't parse PackageLocationImmutable" let pkgImm' = map (\(a, b) -> (b, a)) (Map.toList pkgImm) pkgImm' `shouldBe` @@ -222,30 +218,28 @@ dependencies: Left str -> fail $ "Can't parse PackageLocationImmutable - 1" <> str <> - (show pkgIm) - Right iopl -> do - pl <- iopl - pure pl + 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)) + [ ( 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) ] From 6149c756ba2665297bdf4e53a73550137ca51086 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 18:27:18 +0530 Subject: [PATCH 75/76] Remove BangPatterns --- src/Stack/Lock.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Stack/Lock.hs b/src/Stack/Lock.hs index 7578a0ae6c..64ec365bd0 100644 --- a/src/Stack/Lock.hs +++ b/src/Stack/Lock.hs @@ -3,7 +3,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} module Stack.Lock where From 72b1867dc3fccaeb983b582e6b8821bfd6dd7023 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 1 Mar 2019 19:23:27 +0530 Subject: [PATCH 76/76] Fix windows build issue --- src/test/Stack/LockSpec.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/test/Stack/LockSpec.hs b/src/test/Stack/LockSpec.hs index 81c63be1b4..2cdae5ec12 100644 --- a/src/test/Stack/LockSpec.hs +++ b/src/test/Stack/LockSpec.hs @@ -13,7 +13,7 @@ import Distribution.Types.PackageName (mkPackageName) import Distribution.Types.Version (mkVersion) import Pantry import qualified Pantry.SHA256 as SHA256 -import qualified Path +import qualified Path.IO as Path import Stack.Lock import Test.Hspec import Text.RawString.QQ @@ -42,7 +42,7 @@ resolver: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/20.yaml sha256: 7373bd6e5bb08955cb30bc98afe38a06eadc44706d20aff896fd0376ec0de619 |] - rootDir <- Path.parseAbsDir "/home/sibi" + rootDir <- Path.getHomeDir pkgImm <- case Yaml.decodeThrow lockFile of Just (pkgIm :: Value) -> do @@ -99,7 +99,7 @@ resolver: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/22.yaml sha256: 7c8b1853da784bd7beb8728168bf4e879d8a2f6daf408ca0fa7933451864a96a |] - rootDir <- Path.parseAbsDir "/home/sibi" + rootDir <- Path.getHomeDir pkgImm <- case Yaml.decodeThrow lockFile of Just (pkgIm :: Value) -> do @@ -208,7 +208,7 @@ dependencies: size: 273 sha256: d291028785ad39f8d05cde91594f6b313e35ff76af66c0452ab599b1f1f59e5f |] - rootDir <- Path.parseAbsDir "/home/sibi" + rootDir <- Path.getHomeDir pkgImm <- case Yaml.decodeThrow lockFile of Just (pkgIm :: Value) -> do