Skip to content

Commit f483e82

Browse files
snoybergsnoyberg
committed
Actually grab .cabal files via Git SHA when possible
1 parent ee71d62 commit f483e82

File tree

6 files changed

+93
-21
lines changed

6 files changed

+93
-21
lines changed

‎src/Stack/Build/Execute.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -775,7 +775,8 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
775775
TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp)
776776
TTUpstream package _ gitSHA1 -> do
777777
mdist <- liftM Just distRelativeDir
778-
m <- unpackPackageIdents eeEnvOverride eeTempDir mdist $ Set.singleton taskProvides
778+
m <- unpackPackageIdents eeEnvOverride eeTempDir mdist
779+
$ Map.singleton taskProvides gitSHA1
779780
case Map.toList m of
780781
[(ident, dir)]
781782
| ident == taskProvides -> do

‎src/Stack/Fetch.hs‎

Lines changed: 59 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ import Control.Concurrent.STM (TVar, atomically, modifyTVar,
3434
newTVarIO, readTVar,
3535
readTVarIO, writeTVar)
3636
import Control.Exception (assert)
37+
import Control.Exception.Enclosed (tryIO)
3738
import Control.Monad (join, liftM, unless, void,
3839
when)
3940
import Control.Monad.Catch
@@ -49,6 +50,10 @@ import qualified Data.ByteString.Lazy as L
4950
import Data.Either (partitionEithers)
5051
import qualified Data.Foldable as F
5152
import Data.Function (fix)
53+
import qualified Data.Git as Git
54+
import qualified Data.Git.Ref as Git
55+
import qualified Data.Git.Storage as Git
56+
import qualified Data.Git.Storage.Object as Git
5257
import Data.List (intercalate)
5358
import Data.List.NonEmpty (NonEmpty)
5459
import qualified Data.List.NonEmpty as NE
@@ -58,6 +63,7 @@ import Data.Maybe (maybeToList, catMaybes)
5863
import Data.Monoid ((<>))
5964
import Data.Set (Set)
6065
import qualified Data.Set as Set
66+
import Data.String (fromString)
6167
import qualified Data.Text as T
6268
import Data.Text.Encoding (decodeUtf8)
6369
import Data.Typeable (Typeable)
@@ -74,7 +80,8 @@ import System.FilePath ((<.>))
7480
import qualified System.FilePath as FP
7581
import System.IO (IOMode (ReadMode),
7682
SeekMode (AbsoluteSeek), hSeek,
77-
withBinaryFile)
83+
withBinaryFile, openBinaryFile,
84+
hClose)
7885
import System.PosixCompat (setFileMode)
7986
import Text.EditDistance as ED
8087

@@ -122,12 +129,16 @@ fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpMa
122129
=> EnvOverride
123130
-> Set PackageIdentifier
124131
-> m ()
125-
fetchPackages menv idents = do
132+
fetchPackages menv idents' = do
126133
resolved <- resolvePackages menv idents Set.empty
127134
ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved
128135
assert (Map.null alreadyUnpacked) (return ())
129136
nowUnpacked <- fetchPackages' Nothing toFetch
130137
assert (Map.null nowUnpacked) (return ())
138+
where
139+
-- Since we're just fetching tarballs and not unpacking cabal files, we can
140+
-- always provide a Nothing Git SHA
141+
idents = Map.fromList $ map (, Nothing) $ Set.toList idents'
131142

132143
-- | Intended to work for the command line command.
133144
unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m)
@@ -140,7 +151,9 @@ unpackPackages menv dest input = do
140151
(names, idents) <- case partitionEithers $ map parse input of
141152
([], x) -> return $ partitionEithers x
142153
(errs, _) -> throwM $ CouldNotParsePackageSelectors errs
143-
resolved <- resolvePackages menv (Set.fromList idents) (Set.fromList names)
154+
resolved <- resolvePackages menv
155+
(Map.fromList $ map (, Nothing) idents)
156+
(Set.fromList names)
144157
ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved
145158
unless (Map.null alreadyUnpacked) $
146159
throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked
@@ -168,7 +181,7 @@ unpackPackageIdents
168181
=> EnvOverride
169182
-> Path Abs Dir -- ^ unpack directory
170183
-> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157
171-
-> Set PackageIdentifier
184+
-> Map PackageIdentifier (Maybe GitSHA1)
172185
-> m (Map PackageIdentifier (Path Abs Dir))
173186
unpackPackageIdents menv unpackDir mdistDir idents = do
174187
resolved <- resolvePackages menv idents Set.empty
@@ -179,12 +192,13 @@ unpackPackageIdents menv unpackDir mdistDir idents = do
179192
data ResolvedPackage = ResolvedPackage
180193
{ rpCache :: !PackageCache
181194
, rpIndex :: !PackageIndex
195+
, rpGitSHA1 :: !(Maybe GitSHA1)
182196
}
183197

184198
-- | Resolve a set of package names and identifiers into @FetchPackage@ values.
185199
resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
186200
=> EnvOverride
187-
-> Set PackageIdentifier
201+
-> Map PackageIdentifier (Maybe GitSHA1)
188202
-> Set PackageName
189203
-> m (Map PackageIdentifier ResolvedPackage)
190204
resolvePackages menv idents0 names0 = do
@@ -203,7 +217,7 @@ resolvePackages menv idents0 names0 = do
203217

204218
resolvePackagesAllowMissing
205219
:: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
206-
=> Set PackageIdentifier
220+
=> Map PackageIdentifier (Maybe GitSHA1)
207221
-> Set PackageName
208222
-> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage)
209223
resolvePackagesAllowMissing idents0 names0 = do
@@ -214,16 +228,17 @@ resolvePackagesAllowMissing idents0 names0 = do
214228
(Map.lookup name versions))
215229
(Set.toList names0)
216230
(missingIdents, resolved) = partitionEithers $ map (goIdent caches)
217-
$ Set.toList
218-
$ idents0 <> Set.fromList idents1
231+
$ Map.toList
232+
$ idents0 <> Map.fromList (map (, Nothing) idents1)
219233
return (Set.fromList missingNames, Set.fromList missingIdents, Map.fromList resolved)
220234
where
221-
goIdent caches ident =
235+
goIdent caches (ident, mgitsha) =
222236
case Map.lookup ident caches of
223237
Nothing -> Left ident
224238
Just (index, cache) -> Right (ident, ResolvedPackage
225239
{ rpCache = cache
226240
, rpIndex = index
241+
, rpGitSHA1 = mgitsha
227242
})
228243

229244
data ToFetch = ToFetch
@@ -245,15 +260,42 @@ data ToFetchResult = ToFetchResult
245260
withCabalFiles
246261
:: (MonadMask m, MonadIO m, MonadLogger m, MonadReader env m, HasConfig env)
247262
=> IndexName
248-
-> [(PackageIdentifier, PackageCache, a)]
263+
-> [(PackageIdentifier, PackageCache, Maybe GitSHA1, a)]
249264
-> (PackageIdentifier -> a -> ByteString -> IO b)
250265
-> m [b]
251266
withCabalFiles name pkgs f = do
252267
indexPath <- configPackageIndex name
253-
liftIO $ withBinaryFile (toFilePath indexPath) ReadMode $ \h ->
254-
mapM (goPkg h) pkgs
268+
mgitRepo <- configPackageIndexRepo name
269+
bracket
270+
(liftIO $ openBinaryFile (toFilePath indexPath) ReadMode)
271+
(liftIO . hClose) $ \h ->
272+
let inner mgit = mapM (goPkg h mgit) pkgs
273+
in case mgitRepo of
274+
Nothing -> inner Nothing
275+
Just repo -> bracket
276+
(liftIO $ Git.openRepo
277+
$ fromString
278+
$ toFilePath repo FP.</> ".git")
279+
(liftIO . Git.closeRepo)
280+
(inner . Just)
255281
where
256-
goPkg h (ident, pc, tf) = do
282+
goPkg h (Just git) (ident, pc, Just (GitSHA1 sha), tf) = do
283+
let ref = Git.fromHex sha
284+
mobj <- liftIO $ tryIO $ Git.getObject git ref True
285+
case mobj of
286+
Right (Just (Git.ObjBlob (Git.Blob bs))) -> liftIO $ f ident tf (L.toStrict bs)
287+
-- fallback when the appropriate SHA isn't found
288+
e -> do
289+
$logWarn $ mconcat
290+
[ "Did not find .cabal file for "
291+
, T.pack $ packageIdentifierString ident
292+
, " with Git SHA of "
293+
, decodeUtf8 sha
294+
, "\n"
295+
, T.pack $ show e
296+
]
297+
goPkg h Nothing (ident, pc, Nothing, tf)
298+
goPkg h _mgit (ident, pc, _mgitsha, tf) = liftIO $ do
257299
hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc
258300
cabalBS <- S.hGet h $ fromIntegral $ pcSize pc
259301
f ident tf cabalBS
@@ -277,13 +319,14 @@ withCabalLoader menv inner = do
277319

278320
loadCaches <- getPackageCachesIO
279321
runInBase <- liftBaseWith $ \run -> return (void . run)
322+
unlift <- askRunBase
280323

281324
-- TODO in the future, keep all of the necessary @Handle@s open
282325
let doLookup :: PackageIdentifier
283326
-> IO ByteString
284327
doLookup ident = do
285328
caches <- loadCaches
286-
eres <- lookupPackageIdentifierExact ident env caches
329+
eres <- unlift $ lookupPackageIdentifierExact ident env cachesCurr
287330
case eres of
288331
Just bs -> return bs
289332
-- Update the cache and try again
@@ -327,7 +370,7 @@ lookupPackageIdentifierExact ident env caches =
327370
Nothing -> return Nothing
328371
Just (index, cache) -> do
329372
[bs] <- flip runReaderT env
330-
$ withCabalFiles (indexName index) [(ident, cache, ())]
373+
$ withCabalFiles (indexName index) [(ident, cache, Nothing, ())]
331374
$ \_ _ bs -> return bs
332375
return $ Just bs
333376

@@ -390,7 +433,7 @@ getToFetch mdest resolvedAll = do
390433
d = pcDownload $ rpCache resolved
391434
targz = T.pack $ packageIdentifierString ident ++ ".tar.gz"
392435
tarball <- configPackageTarball (indexName index) ident
393-
return $ Left (indexName index, [(ident, rpCache resolved, ToFetch
436+
return $ Left (indexName index, [(ident, rpCache resolved, rpGitSHA1 resolved, ToFetch
394437
{ tfTarball = tarball
395438
, tfDestDir = mdestDir
396439
, tfUrl = case d of

‎src/Stack/Setup.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -486,7 +486,7 @@ upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env
486486
-> m ()
487487
upgradeCabal menv wc = do
488488
let name = $(mkPackageName "Cabal")
489-
rmap <- resolvePackages menv Set.empty (Set.singleton name)
489+
rmap <- resolvePackages menv Map.empty (Set.singleton name)
490490
newest <-
491491
case Map.keys rmap of
492492
[] -> error "No Cabal library found in index, cannot upgrade"
@@ -510,7 +510,8 @@ upgradeCabal menv wc = do
510510
, T.pack $ versionString installed
511511
]
512512
let ident = PackageIdentifier name newest
513-
m <- unpackPackageIdents menv tmpdir Nothing (Set.singleton ident)
513+
-- Nothing below: use the newest .cabal file revision
514+
m <- unpackPackageIdents menv tmpdir Nothing (Map.singleton ident Nothing)
514515

515516
compilerPath <- join $ findExecutable menv (compilerExeName wc)
516517
newestDir <- parseRelDir $ versionString newest

‎src/Stack/Types/Config.hs‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -72,6 +72,7 @@ module Stack.Types.Config
7272
,configPackageIndexCache
7373
,configPackageIndexGz
7474
,configPackageIndexRoot
75+
,configPackageIndexRepo
7576
,configPackageTarball
7677
,indexNameText
7778
,IndexLocation(..)
@@ -176,6 +177,7 @@ import Stack.Types.PackageIndex
176177
import Stack.Types.PackageName
177178
import Stack.Types.TemplateName
178179
import Stack.Types.Version
180+
import System.FilePath (takeBaseName)
179181
import System.PosixCompat.Types (UserID, GroupID, FileMode)
180182
import System.Process.Read (EnvOverride, findExecutable)
181183

@@ -1239,6 +1241,29 @@ configPackageIndexRoot (IndexName name) = do
12391241
dir <- parseRelDir $ S8.unpack name
12401242
return (configStackRoot config </> $(mkRelDir "indices") </> dir)
12411243

1244+
-- | Git repo directory for a specific package index, returns 'Nothing' if not
1245+
-- a Git repo
1246+
configPackageIndexRepo :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Maybe (Path Abs Dir))
1247+
configPackageIndexRepo name = do
1248+
indices <- asks $ configPackageIndices . getConfig
1249+
case filter (\p -> indexName p == name) indices of
1250+
[index] -> do
1251+
let murl =
1252+
case indexLocation index of
1253+
ILGit x -> Just x
1254+
ILHttp _ -> Nothing
1255+
ILGitHttp x _ -> Just x
1256+
case murl of
1257+
Nothing -> return Nothing
1258+
Just url -> do
1259+
sDir <- configPackageIndexRoot name
1260+
repoName <- parseRelDir $ takeBaseName $ T.unpack url
1261+
let suDir =
1262+
sDir </>
1263+
$(mkRelDir "git-update")
1264+
return $ Just $ suDir </> repoName
1265+
_ -> assert False $ return Nothing
1266+
12421267
-- | Location of the 00-index.cache file
12431268
configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
12441269
configPackageIndexCache = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot

‎src/Stack/Upgrade.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,6 @@ import qualified Data.Map as Map
1515
import Data.Maybe (isNothing)
1616
import Data.Monoid ((<>))
1717
import qualified Data.Monoid
18-
import qualified Data.Set as Set
1918
import qualified Data.Text as T
2019
import Lens.Micro (set)
2120
import Network.HTTP.Client.Conduit (HasHttpManager)
@@ -83,7 +82,9 @@ upgrade gitRepo mresolver builtHash =
8382
return Nothing
8483
Just version -> do
8584
let ident = PackageIdentifier $(mkPackageName "stack") version
86-
paths <- unpackPackageIdents menv tmp Nothing $ Set.singleton ident
85+
paths <- unpackPackageIdents menv tmp Nothing
86+
-- accept latest cabal revision by not supplying a Git SHA
87+
$ Map.singleton ident Nothing
8788
case Map.lookup ident paths of
8889
Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found"
8990
Just path -> return $ Just path

‎stack.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -168,6 +168,7 @@ library
168168
, filepath >= 1.3.0.2
169169
, fsnotify >= 0.2.1
170170
, hashable >= 1.2.3.2
171+
, hit
171172
, hpc
172173
, http-client >= 0.4.17
173174
, http-client-tls >= 0.2.2

0 commit comments

Comments
 (0)