pantry 0.5.2.3 → 0.5.3

raw patch · 6 files changed

+145/−32 lines, 6 filesdep ~aesonPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• pantry.cabal +1/−1
• src/Pantry.hs +4/−1
• src/Pantry/Repo.hs +83/−22
• src/Pantry/Storage.hs +1/−0
• src/Pantry/Types.hs +52/−8

@@ -1,5 +1,9 @@ # Changelog for pantry +## v0.5.3++* improve and expose `fetchRepos`/`fetchReposRaw`+ ## v0.5.2.3  * Support for GHC 9 [#39](https://github.com/commercialhaskell/pantry/pull/39)

@@ -7,7 +7,7 @@ -- hash: 290314cf42f0f169e5cb395c4b35e867438c4e2652df972ec59c548dc39f1b6d  name:           pantry-version:        0.5.2.3+version:        0.5.3 synopsis:       Content addressable Haskell package management description:    Please see the README on Github at <https://github.com/commercialhaskell/pantry#readme> category:       Development

@@ -67,7 +67,10 @@     -- ** Repos   , Repo (..)   , RepoType (..)+  , SimpleRepo (..)   , withRepo+  , fetchRepos+  , fetchReposRaw      -- ** Package location   , RawPackageLocation (..)@@ -193,7 +196,7 @@ import Casa.Client (thParserCasaRepo, CasaRepoPrefix) import Pantry.Repo import qualified Pantry.SHA256 as SHA256-import Pantry.Storage hiding (TreeEntry, PackageName, Version)+import Pantry.Storage hiding (TreeEntry, PackageName, Version, findOrGenerateCabalFile) import Pantry.Tree import Pantry.Types as P import Pantry.Hackage

@@ -1,6 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-} module Pantry.Repo   ( fetchReposRaw   , fetchRepos@@ -11,6 +14,7 @@   , withRepo   ) where + import Pantry.Types import Pantry.Archive import Pantry.Storage@@ -35,12 +39,21 @@   let bs = toStrict stdoutBS   pure $ if "GNU" `isInfixOf` bs then Gnu else Bsd +-- | Like 'fetchRepos', except with 'RawPackageMetadata' instead of 'PackageMetadata'.+--+-- @since 0.5.3 fetchReposRaw   :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)   => [(Repo, RawPackageMetadata)]   -> RIO env ()-fetchReposRaw pairs = for_ pairs $ uncurry getRepo+fetchReposRaw pairs = do+  let repos = toAggregateRepos pairs+  logDebug (displayShow repos)+  for_ repos getRepos +-- | Fetch the given repositories at once and populate the pantry database.+--+-- @since 0.5.3 fetchRepos   :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)   => [(Repo, PackageMetadata)]@@ -61,7 +74,7 @@   => Repo   -> RawPackageMetadata   -> RIO env Package-getRepo repo pm =+getRepo repo pm = do   withCache $ getRepo' repo pm   where     withCache@@ -85,8 +98,8 @@   => Repo   -> RawPackageMetadata   -> RIO env Package-getRepo' repo rpm = do-  withRepoArchive repo $ \tarball -> do+getRepo' repo@Repo{..} rpm = do+  withRepoArchive (rToSimpleRepo repo) $ \tarball -> do     abs' <- resolveFile' tarball     getArchivePackage       (RPLIRepo repo rpm)@@ -97,21 +110,69 @@             }         , raHash = Nothing         , raSize = Nothing-        , raSubdir = repoSubdir repo+        , raSubdir = repoSubdir         }       rpm +getRepos+  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)+  => AggregateRepo+  -> RIO env [Package]+getRepos repo@(AggregateRepo (SimpleRepo{..}) repoSubdirs) =+  withCache getRepos'+  where+    withCache inner = do+      pkgs <- forM repoSubdirs $ \(subdir, rpm) -> withStorage $ do+        loadRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) subdir >>= \case+          Just tid -> fmap Right $ (, subdir) <$> loadPackageById (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm) tid+          Nothing  -> pure $ Left (subdir, rpm)+      let (missingPkgs, cachedPkgs) = partitionEithers pkgs+      newPkgs <-+        if null missingPkgs+        then pure []+        else do+          packages <- inner repo { aRepoSubdirs = missingPkgs }+          forM packages $ \(package, subdir) -> do+            withStorage $ do+              ment <- getTreeForKey $ packageTreeKey package+              case ment of+                Nothing -> error $ "invariant violated, Tree not found: " ++ show (packageTreeKey package)+                Just (Entity tid _) -> storeRepoCache (Repo sRepoUrl sRepoCommit sRepoType subdir) subdir tid+            pure package+      pure (nubOrd ((fst <$> cachedPkgs) ++ newPkgs))++getRepos'+  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)+  => AggregateRepo+  -> RIO env [(Package, Text)] -- ^ [(package, subdir)]+getRepos' ar@(AggregateRepo (SimpleRepo{..}) repoSubdirs) = do+  withRepoArchive (arToSimpleRepo ar) $ \tarball -> do+    abs' <- resolveFile' tarball+    forM repoSubdirs $ \(subdir, rpm) -> do+      (,subdir) <$> getArchivePackage+        (RPLIRepo (Repo sRepoUrl sRepoCommit sRepoType subdir) rpm)+        RawArchive+          { raLocation = ALFilePath $ ResolvedPath+              { resolvedRelative = RelFilePath $ T.pack tarball+              , resolvedAbsolute = abs'+              }+          , raHash = Nothing+          , raSize = Nothing+          , raSubdir = subdir+          }+        rpm+ -- | Fetch a repository and create a (temporary) tar archive from it. Pass the -- path of the generated tarball to the given action. withRepoArchive   :: forall env a. (HasLogFunc env, HasProcessContext env)-  => Repo+  => SimpleRepo   -> (FilePath -> RIO env a)   -> RIO env a-withRepoArchive repo action =-  withSystemTempDirectory "with-repo-archive" $ \tmpdir -> do-    let tarball = tmpdir </> "foo.tar"-    createRepoArchive repo tarball+withRepoArchive sr action =+  withSystemTempDirectory "with-repo-archive" $ \tmpdirArchive -> do+    let tarball = tmpdirArchive </> "foo.tar"+    createRepoArchive sr tarball     action tarball  -- | Run a git command, setting appropriate environment variable settings. See@@ -174,12 +235,12 @@ -- | Create a tarball containing files from a repository createRepoArchive ::      forall env. (HasLogFunc env, HasProcessContext env)-  => Repo+  => SimpleRepo   -> FilePath -- ^ Output tar archive filename   -> RIO env ()-createRepoArchive repo tarball = do-  withRepo repo $-    case repoType repo of+createRepoArchive sr tarball = do+  withRepo sr $+    case sRepoType sr of       RepoGit -> do         runGitCommand           ["-c", "core.autocrlf=false", "archive", "-o", tarball, "HEAD"]@@ -193,10 +254,10 @@ -- @since 0.1.0.0 withRepo   :: forall env a. (HasLogFunc env, HasProcessContext env)-  => Repo+  => SimpleRepo   -> RIO env a   -> RIO env a-withRepo repo@(Repo url commit repoType' _subdir) action =+withRepo sr@SimpleRepo{..} action =   withSystemTempDirectory "with-repo" $ \tmpDir -> do     -- Note we do not immediately change directories into the new temporary directory,     -- but instead wait until we have finished cloning the repo. This is because the@@ -204,15 +265,15 @@     -- it as relative to the current directory, not the temporary directory.     let dir = tmpDir </> "cloned"         (runCommand, resetArgs, submoduleArgs) =-          case repoType' of+          case sRepoType of             RepoGit ->               ( runGitCommand-              , ["reset", "--hard", T.unpack commit]+              , ["reset", "--hard", T.unpack sRepoCommit]               , Just ["submodule", "update", "--init", "--recursive"]               )             RepoHg ->               ( runHgCommand-              , ["update", "-C", T.unpack commit]+              , ["update", "-C", T.unpack sRepoCommit]               , Nothing               )         fixANSIForWindows =@@ -222,11 +283,11 @@           -- folowing hack re-enables the lost ANSI-capability.           when osIsWindows $ void $ liftIO $ hSupportsANSIWithoutEmulation stdout -    logInfo $ "Cloning " <> display commit <> " from " <> display url-    runCommand ["clone", T.unpack url, dir]+    logInfo $ "Cloning " <> display sRepoCommit <> " from " <> display sRepoUrl+    runCommand ["clone", T.unpack sRepoUrl, dir]     fixANSIForWindows     created <- doesDirectoryExist dir-    unless created $ throwIO $ FailedToCloneRepo repo+    unless created $ throwIO $ FailedToCloneRepo sr      withWorkingDir dir $ do       runCommand resetArgs

@@ -68,6 +68,7 @@   , getSnapshotCacheId   , storeSnapshotModuleCache   , loadExposedModulePackages+  , findOrGenerateCabalFile   , PackageNameId   , PackageName   , VersionId

@@ -12,6 +12,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} module Pantry.Types   ( PantryConfig (..)   , HackageSecurityConfig (..)@@ -61,6 +62,11 @@   , Archive (..)   , toRawArchive   , Repo (..)+  , AggregateRepo (..)+  , SimpleRepo (..)+  , toAggregateRepos+  , rToSimpleRepo+  , arToSimpleRepo   , RepoType (..)   , parsePackageIdentifier   , parsePackageName@@ -120,7 +126,7 @@ import qualified RIO.Text as T import qualified RIO.ByteString as B import qualified RIO.ByteString.Lazy as BL-import RIO.List (intersperse)+import RIO.List (intersperse, groupBy) import RIO.Time (toGregorian, Day, UTCTime) import qualified RIO.Map as Map import qualified RIO.HashMap as HM@@ -181,18 +187,18 @@   --   -- @since 0.1.0.0   }-  deriving (Show, Eq)+  deriving (Show, Eq, Ord)  data PHpack = PHpack     {       phOriginal :: !TreeEntry, -- ^ Original hpack file       phGenerated :: !TreeEntry, -- ^ Generated Cabal file       phVersion :: !Version -- ^ Version of Hpack used-    } deriving (Show, Eq)+    } deriving (Show, Eq, Ord)  data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file                   | PCHpack !PHpack-                  deriving (Show, Eq)+                  deriving (Show, Eq, Ord)  cabalFileName :: PackageName -> SafeFilePath cabalFileName name =@@ -530,7 +536,45 @@       then mempty       else " in subdirectory " <> display subdir) +rToSimpleRepo :: Repo -> SimpleRepo+rToSimpleRepo Repo {..} = SimpleRepo { sRepoUrl = repoUrl, sRepoCommit = repoCommit, sRepoType = repoType } +data AggregateRepo = AggregateRepo+  { aRepo :: !SimpleRepo+  , aRepoSubdirs :: [(Text, RawPackageMetadata)]+  }+    deriving (Show, Generic, Eq, Ord, Typeable)+++-- | Group input repositories by non-subdir values.+toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo]+toAggregateRepos =+  fmap (\xs@((repo, _):_) -> AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs))+  . groupBy (\(Repo url1 commit1 type1 _, _) (Repo url2 commit2 type2 _, _) -> (url1, commit1 ,type1) == (url2, commit2, type2))++arToSimpleRepo :: AggregateRepo -> SimpleRepo+arToSimpleRepo AggregateRepo {..} = aRepo++-- | Repository without subdirectory information.+--+-- @since 0.5.3+data SimpleRepo = SimpleRepo+  { sRepoUrl :: !Text+  , sRepoCommit :: !Text+  , sRepoType :: !RepoType+  }+    deriving (Show, Generic, Eq, Ord, Typeable)++instance Display SimpleRepo where+  display (SimpleRepo url commit typ) =+    (case typ of+       RepoGit -> "Git"+       RepoHg -> "Mercurial") <>+    " repo at " <>+    display url <>+    ", commit " <>+    display commit+ -- 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". newtype GitHubRepo = GitHubRepo Text@@ -844,7 +888,7 @@   | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType   | UnsupportedTarball !ArchiveLocation !Text   | NoHackageCryptographicHash !PackageIdentifier-  | FailedToCloneRepo !Repo+  | FailedToCloneRepo !SimpleRepo   | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey   | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata   | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32)@@ -1101,7 +1145,7 @@   deriving (Show, Eq)  data FileType = FTNormal | FTExecutable-  deriving (Show, Eq, Enum, Bounded)+  deriving (Show, Eq, Enum, Bounded, Ord) instance PersistField FileType where   toPersistValue FTNormal = PersistInt64 1   toPersistValue FTExecutable = PersistInt64 2@@ -1119,7 +1163,7 @@   { teBlob :: !BlobKey   , teType :: !FileType   }-  deriving (Show, Eq)+  deriving (Show, Eq, Ord)  newtype SafeFilePath = SafeFilePath Text   deriving (Show, Eq, Ord, Display)@@ -1177,7 +1221,7 @@   -- In the future, consider allowing more lax parsing   -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys   -- TreeTarball !PackageTarball-  deriving (Show, Eq)+  deriving (Show, Eq, Ord)  renderTree :: Tree -> ByteString renderTree = BL.toStrict . toLazyByteString . go