diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/pantry.cabal b/pantry.cabal --- a/pantry.cabal +++ b/pantry.cabal @@ -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 category: Development diff --git a/src/Pantry.hs b/src/Pantry.hs --- a/src/Pantry.hs +++ b/src/Pantry.hs @@ -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 diff --git a/src/Pantry/Repo.hs b/src/Pantry/Repo.hs --- a/src/Pantry/Repo.hs +++ b/src/Pantry/Repo.hs @@ -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 diff --git a/src/Pantry/Storage.hs b/src/Pantry/Storage.hs --- a/src/Pantry/Storage.hs +++ b/src/Pantry/Storage.hs @@ -68,6 +68,7 @@ , getSnapshotCacheId , storeSnapshotModuleCache , loadExposedModulePackages + , findOrGenerateCabalFile , PackageNameId , PackageName , VersionId diff --git a/src/Pantry/Types.hs b/src/Pantry/Types.hs --- a/src/Pantry/Types.hs +++ b/src/Pantry/Types.hs @@ -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