Skip to content

Commit f30fe63

Browse files
phadejphadej
committed
Resolve #5472: Add SourceRepositoryPackage..
which can be parametrised over container of subdirs: [], Maybe, Proxy...
1 parent 1f5426c commit f30fe63

File tree

17 files changed

+329
-213
lines changed

17 files changed

+329
-213
lines changed

‎cabal-install/Distribution/Client/Compat/Prelude.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,9 @@
1313
module Distribution.Client.Compat.Prelude
1414
( module Distribution.Compat.Prelude.Internal
1515
, Prelude.IO
16+
, Proxy (..)
1617
) where
1718

1819
import Prelude (IO)
1920
import Distribution.Compat.Prelude.Internal hiding (IO)
21+
import Data.Proxy (Proxy (..))

‎cabal-install/Distribution/Client/Get.hs

Lines changed: 50 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,7 @@ module Distribution.Client.Get (
2424

2525
import Prelude ()
2626
import Distribution.Client.Compat.Prelude hiding (get)
27+
import Data.Ord (comparing)
2728
import Distribution.Compat.Directory
2829
( listDirectory )
2930
import Distribution.Package
@@ -38,6 +39,8 @@ import Distribution.Deprecated.Text (display)
3839
import qualified Distribution.PackageDescription as PD
3940
import Distribution.Simple.Program
4041
( programName )
42+
import Distribution.Types.SourceRepo (RepoKind (..))
43+
import Distribution.Client.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)
4144

4245
import Distribution.Client.Setup
4346
( GlobalFlags(..), GetFlags(..), RepoContext(..) )
@@ -114,7 +117,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
114117
. map (\pkg -> (packageId pkg, packageSourceRepos pkg))
115118
where
116119
kind = fromFlag . getSourceRepository $ getFlags
117-
packageSourceRepos :: SourcePackage loc -> [SourceRepo]
120+
packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]
118121
packageSourceRepos = PD.sourceRepos
119122
. PD.packageDescription
120123
. packageDescription
@@ -197,11 +200,11 @@ unpackPackage verbosity prefix pkgid descOverride pkgPath = do
197200
data ClonePackageException =
198201
ClonePackageNoSourceRepos PackageId
199202
| ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)
200-
| ClonePackageNoRepoType PackageId SourceRepo
201-
| ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType
202-
| ClonePackageNoRepoLocation PackageId SourceRepo
203+
| ClonePackageNoRepoType PackageId PD.SourceRepo
204+
| ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType
205+
| ClonePackageNoRepoLocation PackageId PD.SourceRepo
203206
| ClonePackageDestinationExists PackageId FilePath Bool
204-
| ClonePackageFailedWithExitCode PackageId SourceRepo String ExitCode
207+
| ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode
205208
deriving (Show, Eq)
206209

207210
instance Exception ClonePackageException where
@@ -237,7 +240,7 @@ instance Exception ClonePackageException where
237240
displayException (ClonePackageFailedWithExitCode
238241
pkgid repo vcsprogname exitcode) =
239242
"Failed to fetch the source repository for package " ++ display pkgid
240-
++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " ("
243+
++ ", repository location " ++ srpLocation repo ++ " ("
241244
++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."
242245

243246

@@ -248,7 +251,7 @@ instance Exception ClonePackageException where
248251
clonePackagesFromSourceRepo :: Verbosity
249252
-> FilePath -- ^ destination dir prefix
250253
-> Maybe RepoKind -- ^ preferred 'RepoKind'
251-
-> [(PackageId, [SourceRepo])]
254+
-> [(PackageId, [PD.SourceRepo])]
252255
-- ^ the packages and their
253256
-- available 'SourceRepo's
254257
-> IO ()
@@ -268,28 +271,28 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
268271
[ cloneSourceRepo verbosity vcs' repo destDir
269272
`catch` \exitcode ->
270273
throwIO (ClonePackageFailedWithExitCode
271-
pkgid repo (programName (vcsProgram vcs)) exitcode)
274+
pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode)
272275
| (pkgid, repo, vcs, destDir) <- pkgrepos'
273276
, let Just vcs' = Map.lookup (vcsRepoType vcs) vcss
274277
]
275278

276279
where
277-
preCloneChecks :: (PackageId, [SourceRepo])
278-
-> IO (PackageId, SourceRepo, VCS Program, FilePath)
280+
preCloneChecks :: (PackageId, [PD.SourceRepo])
281+
-> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)
279282
preCloneChecks (pkgid, repos) = do
280283
repo <- case selectPackageSourceRepo preferredRepoKind repos of
281284
Just repo -> return repo
282285
Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid)
283286
Nothing -> throwIO (ClonePackageNoSourceReposOfKind
284287
pkgid preferredRepoKind)
285288

286-
vcs <- case validateSourceRepo repo of
287-
Right (_, _, _, vcs) -> return vcs
289+
(repo', vcs) <- case validatePDSourceRepo repo of
290+
Right (repo', _, _, vcs) -> return (repo', vcs)
288291
Left SourceRepoRepoTypeUnspecified ->
289292
throwIO (ClonePackageNoRepoType pkgid repo)
290293

291-
Left (SourceRepoRepoTypeUnsupported repoType) ->
292-
throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType)
294+
Left (SourceRepoRepoTypeUnsupported repo' repoType) ->
295+
throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType)
293296

294297
Left SourceRepoLocationUnspecified ->
295298
throwIO (ClonePackageNoRepoLocation pkgid repo)
@@ -300,5 +303,37 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
300303
when (destDirExists || destFileExists) $
301304
throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)
302305

303-
return (pkgid, repo, vcs, destDir)
306+
return (pkgid, repo', vcs, destDir)
304307

308+
-------------------------------------------------------------------------------
309+
-- Selecting
310+
-------------------------------------------------------------------------------
311+
312+
-- | Pick the 'SourceRepo' to use to get the package sources from.
313+
--
314+
-- Note that this does /not/ depend on what 'VCS' drivers we are able to
315+
-- successfully configure. It is based only on the 'SourceRepo's declared
316+
-- in the package, and optionally on a preferred 'RepoKind'.
317+
--
318+
selectPackageSourceRepo :: Maybe RepoKind
319+
-> [PD.SourceRepo]
320+
-> Maybe PD.SourceRepo
321+
selectPackageSourceRepo preferredRepoKind =
322+
listToMaybe
323+
-- Sort repositories by kind, from This to Head to Unknown. Repositories
324+
-- with equivalent kinds are selected based on the order they appear in
325+
-- the Cabal description file.
326+
. sortBy (comparing thisFirst)
327+
-- If the user has specified the repo kind, filter out the repositories
328+
-- they're not interested in.
329+
. filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind)
330+
where
331+
thisFirst :: PD.SourceRepo -> Int
332+
thisFirst r = case PD.repoKind r of
333+
RepoThis -> 0
334+
RepoHead -> case PD.repoTag r of
335+
-- If the type is 'head' but the author specified a tag, they
336+
-- probably meant to create a 'this' repository but screwed up.
337+
Just _ -> 0
338+
Nothing -> 1
339+
RepoKindUnknown _ -> 2

‎cabal-install/Distribution/Client/HttpUtils.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ module Distribution.Client.HttpUtils (
1515
) where
1616

1717
import Prelude ()
18-
import Distribution.Client.Compat.Prelude
18+
import Distribution.Client.Compat.Prelude hiding (Proxy (..))
1919

2020
import Network.HTTP
2121
( Request (..), Response (..), RequestMethod (..)

‎cabal-install/Distribution/Client/ProjectConfig.hs

Lines changed: 30 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -100,7 +100,9 @@ import Distribution.Fields
100100
( runParseResult, PError, PWarning, showPWarning)
101101
import Distribution.Pretty ()
102102
import Distribution.Types.SourceRepo
103-
( SourceRepo(..), RepoType(..), )
103+
( RepoType(..) )
104+
import Distribution.Client.SourceRepo
105+
( SourceRepoList, SourceRepositoryPackage (..), srpFanOut )
104106
import Distribution.Simple.Compiler
105107
( Compiler, compilerInfo )
106108
import Distribution.Simple.Program
@@ -139,6 +141,7 @@ import Data.Either
139141
import qualified Data.ByteString as BS
140142
import qualified Data.ByteString.Lazy as LBS
141143
import qualified Data.Map as Map
144+
import qualified Data.List.NonEmpty as NE
142145
import Data.Set (Set)
143146
import qualified Data.Set as Set
144147
import qualified Data.Hashable as Hashable
@@ -647,7 +650,7 @@ data ProjectPackageLocation =
647650
| ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file
648651
| ProjectPackageLocalTarball FilePath
649652
| ProjectPackageRemoteTarball URI
650-
| ProjectPackageRemoteRepo SourceRepo
653+
| ProjectPackageRemoteRepo SourceRepoList
651654
| ProjectPackageNamed PackageVersionConstraint
652655
deriving Show
653656

@@ -1108,7 +1111,7 @@ syncAndReadSourcePackagesRemoteRepos
11081111
:: Verbosity
11091112
-> DistDirLayout
11101113
-> ProjectConfigShared
1111-
-> [SourceRepo]
1114+
-> [SourceRepoList]
11121115
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
11131116
syncAndReadSourcePackagesRemoteRepos verbosity
11141117
DistDirLayout{distDownloadSrcDirectory}
@@ -1123,7 +1126,7 @@ syncAndReadSourcePackagesRemoteRepos verbosity
11231126
-- All 'SourceRepo's grouped by referring to the "same" remote repo
11241127
-- instance. So same location but can differ in commit/tag/branch/subdir.
11251128
let reposByLocation :: Map (RepoType, String)
1126-
[(SourceRepo, RepoType)]
1129+
[(SourceRepoList, RepoType)]
11271130
reposByLocation = Map.fromListWith (++)
11281131
[ ((rtype, rloc), [(repo, vcsRepoType vcs)])
11291132
| (repo, rloc, rtype, vcs) <- repos' ]
@@ -1143,15 +1146,15 @@ syncAndReadSourcePackagesRemoteRepos verbosity
11431146
pathStem = distDownloadSrcDirectory
11441147
</> localFileNameForRemoteRepo primaryRepo
11451148
monitor :: FileMonitor
1146-
[SourceRepo]
1149+
[SourceRepoList]
11471150
[PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
11481151
monitor = newFileMonitor (pathStem <.> "cache")
11491152
]
11501153
where
11511154
syncRepoGroupAndReadSourcePackages
11521155
:: VCS ConfiguredProgram
11531156
-> FilePath
1154-
-> [SourceRepo]
1157+
-> [SourceRepoList]
11551158
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
11561159
syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do
11571160
liftIO $ createDirectoryIfMissingVerbose verbosity False
@@ -1168,24 +1171,33 @@ syncAndReadSourcePackagesRemoteRepos verbosity
11681171
sequence
11691172
[ readPackageFromSourceRepo repoWithSubdir repoPath
11701173
| (_, reposWithSubdir, repoPath) <- repoGroupWithPaths
1171-
, repoWithSubdir <- reposWithSubdir ]
1174+
, repoWithSubdir <- NE.toList reposWithSubdir ]
11721175
where
11731176
-- So to do both things above, we pair them up here.
1177+
repoGroupWithPaths
1178+
:: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)]
11741179
repoGroupWithPaths =
11751180
zipWith (\(x, y) z -> (x,y,z))
1176-
(Map.toList
1177-
(Map.fromListWith (++)
1178-
[ (repo { repoSubdir = Nothing }, [repo])
1179-
| repo <- repoGroup ]))
1181+
(mapGroup
1182+
[ (repo { srpSubdir = Proxy }, repo)
1183+
| repo <- foldMap (NE.toList . srpFanOut) repoGroup
1184+
])
11801185
repoPaths
11811186

1187+
mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]
1188+
mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))
1189+
11821190
-- The repos in a group are given distinct names by simple enumeration
11831191
-- foo, foo-2, foo-3 etc
1192+
repoPaths :: [FilePath]
11841193
repoPaths = pathStem
11851194
: [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ]
11861195

1196+
readPackageFromSourceRepo
1197+
:: SourceRepositoryPackage Maybe -> FilePath
1198+
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
11871199
readPackageFromSourceRepo repo repoPath = do
1188-
let packageDir = maybe repoPath (repoPath </>) (repoSubdir repo)
1200+
let packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)
11891201
entries <- liftIO $ getDirectoryContents packageDir
11901202
--TODO: wrap exceptions
11911203
case filter (\e -> takeExtension e == ".cabal") entries of
@@ -1201,10 +1213,10 @@ syncAndReadSourcePackagesRemoteRepos verbosity
12011213
location = RemoteSourceRepoPackage repo packageDir
12021214

12031215

1204-
reportSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> Rebuild a
1216+
reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
12051217
reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems
12061218

1207-
renderSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> String
1219+
renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String
12081220
renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems"
12091221

12101222

@@ -1357,18 +1369,17 @@ localFileNameForRemoteTarball uri =
13571369
-- This is deterministic based on the source repo identity details, and
13581370
-- intended to produce non-clashing file names for different repos.
13591371
--
1360-
localFileNameForRemoteRepo :: SourceRepo -> FilePath
1361-
localFileNameForRemoteRepo SourceRepo{repoType, repoLocation, repoModule} =
1362-
maybe "" ((++ "-") . mangleName) repoLocation
1363-
++ showHex locationHash ""
1372+
localFileNameForRemoteRepo :: SourceRepoList -> FilePath
1373+
localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} =
1374+
mangleName srpLocation ++ "-" ++ showHex locationHash ""
13641375
where
13651376
mangleName = truncateString 10 . dropExtension
13661377
. takeFileName . dropTrailingPathSeparator
13671378

13681379
-- just the parts that make up the "identity" of the repo
13691380
locationHash :: Word
13701381
locationHash =
1371-
fromIntegral (Hashable.hash (show repoType, repoLocation, repoModule))
1382+
fromIntegral (Hashable.hash (show srpType, srpLocation))
13721383

13731384

13741385
-- | Truncate a string, with a visual indication that it is truncated.

‎cabal-install/Distribution/Client/ProjectConfig/Legacy.hs

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Distribution.Client.ProjectConfig.Types
2929
import Distribution.Client.Types
3030
( RemoteRepo(..), emptyRemoteRepo
3131
, AllowNewer(..), AllowOlder(..) )
32+
import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)
3233

3334
import Distribution.Client.Config
3435
( SavedConfig(..), remoteRepoFields )
@@ -41,9 +42,7 @@ import Distribution.Solver.Types.ConstraintSource
4142

4243
import Distribution.Package
4344
import Distribution.PackageDescription
44-
( SourceRepo(..), RepoKind(..)
45-
, dispFlagAssignment )
46-
import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar)
45+
( dispFlagAssignment )
4746
import Distribution.Simple.Compiler
4847
( OptimisationLevel(..), DebugInfoLevel(..) )
4948
import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )
@@ -90,6 +89,7 @@ import Distribution.Types.PackageVersionConstraint
9089
( PackageVersionConstraint )
9190

9291
import qualified Data.Map as Map
92+
9393
------------------------------------------------------------------
9494
-- Representing the project config file in terms of legacy types
9595
--
@@ -106,7 +106,7 @@ import qualified Data.Map as Map
106106
data LegacyProjectConfig = LegacyProjectConfig {
107107
legacyPackages :: [String],
108108
legacyPackagesOptional :: [String],
109-
legacyPackagesRepo :: [SourceRepo],
109+
legacyPackagesRepo :: [SourceRepoList],
110110
legacyPackagesNamed :: [PackageVersionConstraint],
111111

112112
legacySharedConfig :: LegacySharedConfig,
@@ -1195,7 +1195,7 @@ legacyPackageConfigSectionDescrs =
11951195
packageRepoSectionDescr :: FGSectionDescr LegacyProjectConfig
11961196
packageRepoSectionDescr = FGSectionDescr
11971197
{ fgSectionName = "source-repository-package"
1198-
, fgSectionGrammar = sourceRepoFieldGrammar (RepoKindUnknown "unused")
1198+
, fgSectionGrammar = sourceRepositoryPackageGrammar
11991199
, fgSectionGet = map (\x->("", x)) . legacyPackagesRepo
12001200
, fgSectionSet =
12011201
\lineno unused pkgrepo projconf -> do

‎cabal-install/Distribution/Client/ProjectConfig/Types.hs

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Distribution.Client.Targets
2929
( UserConstraint )
3030
import Distribution.Client.BuildReports.Types
3131
( ReportLevel(..) )
32+
import Distribution.Client.SourceRepo (SourceRepoList)
3233

3334
import Distribution.Client.IndexUtils.Timestamp
3435
( IndexState )
@@ -48,7 +49,7 @@ import Distribution.Version
4849
import Distribution.System
4950
( Platform )
5051
import Distribution.PackageDescription
51-
( FlagAssignment, SourceRepo(..) )
52+
( FlagAssignment )
5253
import Distribution.Simple.Compiler
5354
( Compiler, CompilerFlavor
5455
, OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )
@@ -107,7 +108,7 @@ data ProjectConfig
107108
projectPackagesOptional :: [String],
108109

109110
-- | Packages in this project from remote source repositories.
110-
projectPackagesRepo :: [SourceRepo],
111+
projectPackagesRepo :: [SourceRepoList],
111112

112113
-- | Packages in this project from hackage repositories.
113114
projectPackagesNamed :: [PackageVersionConstraint],

‎cabal-install/Distribution/Client/ProjectPlanOutput.hs

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import Distribution.Client.ProjectBuilding.Types
2020
import Distribution.Client.DistDirLayout
2121
import Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId)
2222
import Distribution.Client.PackageHash (showHashValue, hashValue)
23+
import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))
2324

2425
import qualified Distribution.Client.InstallPlan as InstallPlan
2526
import qualified Distribution.Client.Utils.Json as J
@@ -212,15 +213,14 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
212213
, "uri" J..= J.String (show (remoteRepoURI repoRemote))
213214
]
214215

215-
sourceRepoToJ :: PD.SourceRepo -> J.Value
216-
sourceRepoToJ PD.SourceRepo{..} =
216+
sourceRepoToJ :: SourceRepoMaybe -> J.Value
217+
sourceRepoToJ SourceRepositoryPackage{..} =
217218
J.object $ filter ((/= J.Null) . snd) $
218-
[ "type" J..= fmap jdisplay repoType
219-
, "location" J..= fmap J.String repoLocation
220-
, "module" J..= fmap J.String repoModule
221-
, "branch" J..= fmap J.String repoBranch
222-
, "tag" J..= fmap J.String repoTag
223-
, "subdir" J..= fmap J.String repoSubdir
219+
[ "type" J..= jdisplay srpType
220+
, "location" J..= J.String srpLocation
221+
, "branch" J..= fmap J.String srpBranch
222+
, "tag" J..= fmap J.String srpTag
223+
, "subdir" J..= fmap J.String srpSubdir
224224
]
225225

226226
dist_dir = distBuildDirectory distDirLayout

0 commit comments

Comments
 (0)