never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE DeriveGeneric #-}
3 {-# LANGUAGE RecordWildCards #-}
4 {-# LANGUAGE BangPatterns #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE GADTs #-}
8
9 -----------------------------------------------------------------------------
10 -- |
11 -- Module : Distribution.Client.IndexUtils
12 -- Copyright : (c) Duncan Coutts 2008
13 -- License : BSD-like
14 --
15 -- Maintainer : duncan@community.haskell.org
16 -- Stability : provisional
17 -- Portability : portable
18 --
19 -- Extra utils related to the package indexes.
20 -----------------------------------------------------------------------------
21 module Distribution.Client.IndexUtils (
22 getIndexFileAge,
23 getInstalledPackages,
24 indexBaseName,
25 Configure.getInstalledPackagesMonitorFiles,
26 getSourcePackages,
27 getSourcePackagesMonitorFiles,
28
29 TotalIndexState,
30 getSourcePackagesAtIndexState,
31 ActiveRepos,
32 filterSkippedActiveRepos,
33
34 Index(..),
35 RepoIndexState (..),
36 PackageEntry(..),
37 parsePackageIndex,
38 updateRepoIndexCache,
39 updatePackageIndexCacheFile,
40 writeIndexTimestamp,
41 currentIndexTimestamp,
42
43 BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType
44 ) where
45
46 import Prelude ()
47 import Distribution.Client.Compat.Prelude
48
49 import qualified Codec.Archive.Tar as Tar
50 import qualified Codec.Archive.Tar.Entry as Tar
51 import qualified Codec.Archive.Tar.Index as Tar
52 import qualified Distribution.Client.Tar as Tar
53 import Distribution.Client.IndexUtils.ActiveRepos
54 import Distribution.Client.IndexUtils.IndexState
55 import Distribution.Client.IndexUtils.Timestamp
56 import Distribution.Client.Types
57 import Distribution.Verbosity
58 import Distribution.Parsec (simpleParsecBS)
59
60 import Distribution.Package
61 ( PackageId, PackageIdentifier(..), mkPackageName
62 , Package(..), packageVersion, packageName )
63 import Distribution.Types.Dependency
64 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
65 import Distribution.PackageDescription
66 ( GenericPackageDescription(..)
67 , PackageDescription(..), emptyPackageDescription )
68 import Distribution.Simple.Compiler
69 ( Compiler, PackageDBStack )
70 import Distribution.Simple.Program
71 ( ProgramDb )
72 import qualified Distribution.Simple.Configure as Configure
73 ( getInstalledPackages, getInstalledPackagesMonitorFiles )
74 import Distribution.Types.PackageName (PackageName)
75 import Distribution.Version
76 ( Version, VersionRange, mkVersion, intersectVersionRanges )
77 import Distribution.Simple.Utils
78 ( die', warn, info, createDirectoryIfMissingVerbose )
79 import Distribution.Client.Setup
80 ( RepoContext(..) )
81
82 import Distribution.PackageDescription.Parsec
83 ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe )
84 import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse
85
86 import Distribution.Solver.Types.PackageIndex (PackageIndex)
87 import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
88 import Distribution.Solver.Types.SourcePackage
89
90 import qualified Data.Map as Map
91 import qualified Data.Set as Set
92 import Control.Exception
93 import Data.List (stripPrefix)
94 import qualified Data.ByteString.Lazy as BS
95 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
96 import qualified Data.ByteString.Char8 as BSS
97 import Data.ByteString.Lazy (ByteString)
98 import Distribution.Client.GZipUtils (maybeDecompress)
99 import Distribution.Client.Utils ( byteStringToFilePath
100 , tryFindAddSourcePackageDesc )
101 import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail)
102 import Distribution.Compat.Time (getFileAge, getModTime)
103 import System.Directory (doesFileExist, doesDirectoryExist)
104 import System.FilePath
105 ( (</>), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory )
106 import qualified System.FilePath.Posix as FilePath.Posix
107 import System.IO
108 import System.IO.Unsafe (unsafeInterleaveIO)
109 import System.IO.Error (isDoesNotExistError)
110 import Distribution.Compat.Directory (listDirectory)
111 import Distribution.Utils.Generic (fstOf3)
112
113 import qualified Codec.Compression.GZip as GZip
114
115 import qualified Hackage.Security.Client as Sec
116 import qualified Hackage.Security.Util.Some as Sec
117
118 -- | Reduced-verbosity version of 'Configure.getInstalledPackages'
119 getInstalledPackages :: Verbosity -> Compiler
120 -> PackageDBStack -> ProgramDb
121 -> IO InstalledPackageIndex
122 getInstalledPackages verbosity comp packageDbs progdb =
123 Configure.getInstalledPackages verbosity' comp packageDbs progdb
124 where
125 verbosity' = lessVerbose verbosity
126
127
128 -- | Get filename base (i.e. without file extension) for index-related files
129 --
130 -- /Secure/ cabal repositories use a new extended & incremental
131 -- @01-index.tar@. In order to avoid issues resulting from clobbering
132 -- new/old-style index data, we save them locally to different names.
133 --
134 -- Example: Use @indexBaseName repo <.> "tar.gz"@ to compute the 'FilePath' of the
135 -- @00-index.tar.gz@/@01-index.tar.gz@ file.
136 indexBaseName :: Repo -> FilePath
137 indexBaseName repo = repoLocalDir repo </> fn
138 where
139 fn = case repo of
140 RepoSecure {} -> "01-index"
141 RepoRemote {} -> "00-index"
142 RepoLocalNoIndex {} -> "noindex"
143
144 ------------------------------------------------------------------------
145 -- Reading the source package index
146 --
147
148 -- Note: 'data IndexState' is defined in
149 -- "Distribution.Client.IndexUtils.Timestamp" to avoid import cycles
150
151 -- | 'IndexStateInfo' contains meta-information about the resulting
152 -- filtered 'Cache' 'after applying 'filterCache' according to a
153 -- requested 'IndexState'.
154 data IndexStateInfo = IndexStateInfo
155 { isiMaxTime :: !Timestamp
156 -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current
157 -- filtered view of the cache.
158 --
159 -- The following property holds
160 --
161 -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)
162 --
163
164 , isiHeadTime :: !Timestamp
165 -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest
166 -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to
167 -- 'isiMaxTime'.
168 }
169
170 emptyStateInfo :: IndexStateInfo
171 emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp
172
173 -- | Filters a 'Cache' according to an 'IndexState'
174 -- specification. Also returns 'IndexStateInfo' describing the
175 -- resulting index cache.
176 --
177 -- Note: 'filterCache' is idempotent in the 'Cache' value
178 filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo)
179 filterCache IndexStateHead cache = (cache, IndexStateInfo{..})
180 where
181 isiMaxTime = cacheHeadTs cache
182 isiHeadTime = cacheHeadTs cache
183 filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
184 where
185 cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime }
186 isiHeadTime = cacheHeadTs cache0
187 isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents)
188 ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0)
189
190 -- | Read a repository index from disk, from the local files specified by
191 -- a list of 'Repo's.
192 --
193 -- All the 'SourcePackage's are marked as having come from the appropriate
194 -- 'Repo'.
195 --
196 -- This is a higher level wrapper used internally in cabal-install.
197 getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
198 getSourcePackages verbosity repoCtxt =
199 fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
200
201 -- | Variant of 'getSourcePackages' which allows getting the source
202 -- packages at a particular 'IndexState'.
203 --
204 -- Current choices are either the latest (aka HEAD), or the index as
205 -- it was at a particular time.
206 --
207 -- Returns also the total index where repositories'
208 -- RepoIndexState's are not HEAD. This is used in v2-freeze.
209 --
210 getSourcePackagesAtIndexState
211 :: Verbosity
212 -> RepoContext
213 -> Maybe TotalIndexState
214 -> Maybe ActiveRepos
215 -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
216 getSourcePackagesAtIndexState verbosity repoCtxt _ _
217 | null (repoContextRepos repoCtxt) = do
218 -- In the test suite, we routinely don't have any remote package
219 -- servers, so don't bleat about it
220 warn (verboseUnmarkOutput verbosity) $
221 "No remote package servers have been specified. Usually " ++
222 "you would have one specified in the config file."
223 return (SourcePackageDb {
224 packageIndex = mempty,
225 packagePreferences = mempty
226 }, headTotalIndexState, ActiveRepos [])
227 getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
228 let describeState IndexStateHead = "most recent state"
229 describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
230
231 pkgss <- for (repoContextRepos repoCtxt) $ \r -> do
232 let rname :: RepoName
233 rname = repoName r
234
235 info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
236
237 idxState <- case mb_idxState of
238 Just totalIdxState -> do
239 let idxState = lookupIndexState rname totalIdxState
240 info verbosity $ "Using " ++ describeState idxState ++
241 " as explicitly requested (via command line / project configuration)"
242 return idxState
243 Nothing -> do
244 mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r)
245 case mb_idxState' of
246 Nothing -> do
247 info verbosity "Using most recent state (could not read timestamp file)"
248 return IndexStateHead
249 Just idxState -> do
250 info verbosity $ "Using " ++ describeState idxState ++
251 " specified from most recent cabal update"
252 return idxState
253
254 unless (idxState == IndexStateHead) $
255 case r of
256 RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories"
257 RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")
258 RepoSecure {} -> pure ()
259
260 let idxState' = case r of
261 RepoSecure {} -> idxState
262 _ -> IndexStateHead
263
264 (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState'
265
266 case idxState' of
267 IndexStateHead -> do
268 info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi))
269 return ()
270 IndexStateTime ts0 -> do
271 when (isiMaxTime isi /= ts0) $
272 if ts0 > isiMaxTime isi
273 then warn verbosity $
274 "Requested index-state " ++ prettyShow ts0
275 ++ " is newer than '" ++ unRepoName rname ++ "'!"
276 ++ " Falling back to older state ("
277 ++ prettyShow (isiMaxTime isi) ++ ")."
278 else info verbosity $
279 "Requested index-state " ++ prettyShow ts0
280 ++ " does not exist in '"++ unRepoName rname ++"'!"
281 ++ " Falling back to older state ("
282 ++ prettyShow (isiMaxTime isi) ++ ")."
283 info verbosity ("index-state("++ unRepoName rname ++") = " ++
284 prettyShow (isiMaxTime isi) ++ " (HEAD = " ++
285 prettyShow (isiHeadTime isi) ++ ")")
286
287 pure RepoData
288 { rdRepoName = rname
289 , rdTimeStamp = isiMaxTime isi
290 , rdIndex = pis
291 , rdPreferences = deps
292 }
293
294 let activeRepos :: ActiveRepos
295 activeRepos = fromMaybe defaultActiveRepos mb_activeRepos
296
297 pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of
298 Right x -> return x
299 Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)
300
301 let activeRepos' :: ActiveRepos
302 activeRepos' = ActiveRepos
303 [ ActiveRepo (rdRepoName rd) strategy
304 | (rd, strategy) <- pkgss'
305 ]
306
307 let totalIndexState :: TotalIndexState
308 totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList
309 [ (n, IndexStateTime ts)
310 | (RepoData n ts _idx _prefs, _strategy) <- pkgss'
311 -- e.g. file+noindex have nullTimestamp as their timestamp
312 , ts /= nullTimestamp
313 ]
314
315 let addIndex
316 :: PackageIndex UnresolvedSourcePackage
317 -> (RepoData, CombineStrategy)
318 -> PackageIndex UnresolvedSourcePackage
319 addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc
320 addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx
321 addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx
322
323 let pkgs :: PackageIndex UnresolvedSourcePackage
324 pkgs = foldl' addIndex mempty pkgss'
325
326 -- Note: preferences combined without using CombineStrategy
327 let prefs :: Map PackageName VersionRange
328 prefs = Map.fromListWith intersectVersionRanges
329 [ (name, range)
330 | (RepoData _n _ts _idx prefs', _strategy) <- pkgss'
331 , Dependency name range _ <- prefs'
332 ]
333
334 _ <- evaluate pkgs
335 _ <- evaluate prefs
336 _ <- evaluate totalIndexState
337 return (SourcePackageDb {
338 packageIndex = pkgs,
339 packagePreferences = prefs
340 }, totalIndexState, activeRepos')
341
342 -- auxiliary data used in getSourcePackagesAtIndexState
343 data RepoData = RepoData
344 { rdRepoName :: RepoName
345 , rdTimeStamp :: Timestamp
346 , rdIndex :: PackageIndex UnresolvedSourcePackage
347 , rdPreferences :: [Dependency]
348 }
349
350 -- | Read a repository index from disk, from the local file specified by
351 -- the 'Repo'.
352 --
353 -- All the 'SourcePackage's are marked as having come from the given 'Repo'.
354 --
355 -- This is a higher level wrapper used internally in cabal-install.
356 --
357 readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState
358 -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)
359 readRepoIndex verbosity repoCtxt repo idxState =
360 handleNotFound $ do
361 when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo
362 updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
363 readPackageIndexCacheFile verbosity mkAvailablePackage
364 (RepoIndex repoCtxt repo)
365 idxState
366
367 where
368 mkAvailablePackage pkgEntry = SourcePackage
369 { srcpkgPackageId = pkgid
370 , srcpkgDescription = pkgdesc
371 , srcpkgSource = case pkgEntry of
372 NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing
373 BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path
374 , srcpkgDescrOverride = case pkgEntry of
375 NormalPackage _ _ pkgtxt _ -> Just pkgtxt
376 _ -> Nothing
377 }
378 where
379 pkgdesc = packageDesc pkgEntry
380 pkgid = packageId pkgEntry
381
382 handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
383 then do
384 case repo of
385 RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote
386 RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote
387 RepoLocalNoIndex local _ -> warn verbosity $
388 "Error during construction of local+noindex "
389 ++ unRepoName (localRepoName local) ++ " repository index: "
390 ++ show e
391 return (mempty,mempty,emptyStateInfo)
392 else ioError e
393
394 isOldThreshold = 15 --days
395 warnIfIndexIsOld dt = do
396 when (dt >= isOldThreshold) $ case repo of
397 RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt
398 RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt
399 RepoLocalNoIndex {} -> return ()
400
401 errMissingPackageList repoRemote =
402 "The package list for '" ++ unRepoName (remoteRepoName repoRemote)
403 ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote
404 errOutdatedPackageList repoRemote dt =
405 "The package list for '" ++ unRepoName (remoteRepoName repoRemote)
406 ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
407 ++ "'cabal update' to get the latest list of available packages."
408
409 -- | Return the age of the index file in days (as a Double).
410 getIndexFileAge :: Repo -> IO Double
411 getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar"
412
413 -- | A set of files (or directories) that can be monitored to detect when
414 -- there might have been a change in the source packages.
415 --
416 getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]
417 getSourcePackagesMonitorFiles repos =
418 concat [ [ indexBaseName repo <.> "cache"
419 , indexBaseName repo <.> "timestamp" ]
420 | repo <- repos ]
421
422 -- | It is not necessary to call this, as the cache will be updated when the
423 -- index is read normally. However you can do the work earlier if you like.
424 --
425 updateRepoIndexCache :: Verbosity -> Index -> IO ()
426 updateRepoIndexCache verbosity index =
427 whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index
428
429 whenCacheOutOfDate :: Index -> IO () -> IO ()
430 whenCacheOutOfDate index action = do
431 exists <- doesFileExist $ cacheFile index
432 if not exists
433 then action
434 else if localNoIndex index
435 then return () -- TODO: don't update cache for local+noindex repositories
436 else do
437 indexTime <- getModTime $ indexFile index
438 cacheTime <- getModTime $ cacheFile index
439 when (indexTime > cacheTime) action
440
441 localNoIndex :: Index -> Bool
442 localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True
443 localNoIndex _ = False
444
445 ------------------------------------------------------------------------
446 -- Reading the index file
447 --
448
449 -- | An index entry is either a normal package, or a local build tree reference.
450 data PackageEntry
451 = NormalPackage PackageId GenericPackageDescription ByteString BlockNo
452 | BuildTreeRef BuildTreeRefType
453 PackageId GenericPackageDescription FilePath BlockNo
454
455 -- | A build tree reference is either a link or a snapshot.
456 data BuildTreeRefType = SnapshotRef | LinkRef
457 deriving (Eq,Show,Generic)
458
459 instance Binary BuildTreeRefType
460 instance Structured BuildTreeRefType
461
462 refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType
463 refTypeFromTypeCode t
464 | t == Tar.buildTreeRefTypeCode = LinkRef
465 | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef
466 | otherwise =
467 error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"
468
469 typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode
470 typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode
471 typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode
472
473 instance Package PackageEntry where
474 packageId (NormalPackage pkgid _ _ _) = pkgid
475 packageId (BuildTreeRef _ pkgid _ _ _) = pkgid
476
477 packageDesc :: PackageEntry -> GenericPackageDescription
478 packageDesc (NormalPackage _ descr _ _) = descr
479 packageDesc (BuildTreeRef _ _ descr _ _) = descr
480
481 -- | Parse an uncompressed \"00-index.tar\" repository index file represented
482 -- as a 'ByteString'.
483 --
484
485 data PackageOrDep = Pkg PackageEntry | Dep Dependency
486
487 -- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files
488 --
489 -- We read the index using 'Tar.read', which gives us a lazily constructed
490 -- 'TarEntries'. We translate it to a list of entries using 'tarEntriesList',
491 -- which preserves the lazy nature of 'TarEntries', and finally 'concatMap' a
492 -- function over this to translate it to a list of IO actions returning
493 -- 'PackageOrDep's. We can use 'lazySequence' to turn this into a list of
494 -- 'PackageOrDep's, still maintaining the lazy nature of the original tar read.
495 parsePackageIndex :: Verbosity -> ByteString -> [IO (Maybe PackageOrDep)]
496 parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar.read
497 where
498 extract :: BlockNo -> Tar.Entry -> [IO (Maybe PackageOrDep)]
499 extract blockNo entry = tryExtractPkg ++ tryExtractPrefs
500 where
501 tryExtractPkg = do
502 mkPkgEntry <- maybeToList $ extractPkg verbosity entry blockNo
503 return $ fmap (fmap Pkg) mkPkgEntry
504
505 tryExtractPrefs = do
506 prefs' <- maybeToList $ extractPrefs entry
507 fmap (return . Just . Dep) prefs'
508
509 -- | Turn the 'Entries' data structure from the @tar@ package into a list,
510 -- and pair each entry with its block number.
511 --
512 -- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read
513 -- as far as the list is evaluated.
514 tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
515 tarEntriesList = go 0
516 where
517 go !_ Tar.Done = []
518 go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e)
519 go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
520
521 extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
522 extractPkg verbosity entry blockNo = case Tar.entryContent entry of
523 Tar.NormalFile content _
524 | takeExtension fileName == ".cabal"
525 -> case splitDirectories (normalise fileName) of
526 [pkgname,vers,_] -> case simpleParsec vers of
527 Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
528 where
529 pkgid = PackageIdentifier (mkPackageName pkgname) ver
530 parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)
531 descr = case parsed of
532 Just d -> d
533 Nothing -> error $ "Couldn't read cabal file "
534 ++ show fileName
535 _ -> Nothing
536 _ -> Nothing
537
538 Tar.OtherEntryType typeCode content _
539 | Tar.isBuildTreeRefTypeCode typeCode ->
540 Just $ do
541 let path = byteStringToFilePath content
542 dirExists <- doesDirectoryExist path
543 result <- if not dirExists then return Nothing
544 else do
545 cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index."
546 descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile
547 return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)
548 descr path blockNo
549 return result
550
551 _ -> Nothing
552
553 where
554 fileName = Tar.entryPath entry
555
556 extractPrefs :: Tar.Entry -> Maybe [Dependency]
557 extractPrefs entry = case Tar.entryContent entry of
558 Tar.NormalFile content _
559 | FilePath.Posix.takeFileName entrypath == "preferred-versions"
560 -> Just prefs
561 where
562 entrypath = Tar.entryPath entry
563 prefs = parsePreferredVersions content
564 _ -> Nothing
565
566 parsePreferredVersions :: ByteString -> [Dependency]
567 parsePreferredVersions = mapMaybe simpleParsec
568 . filter (not . isPrefixOf "--")
569 . lines
570 . BS.Char8.unpack -- TODO: Are we sure no unicode?
571
572 ------------------------------------------------------------------------
573 -- Reading and updating the index cache
574 --
575
576 -- | Variation on 'sequence' which evaluates the actions lazily
577 --
578 -- Pattern matching on the result list will execute just the first action;
579 -- more generally pattern matching on the first @n@ '(:)' nodes will execute
580 -- the first @n@ actions.
581 lazySequence :: [IO a] -> IO [a]
582 lazySequence = unsafeInterleaveIO . go
583 where
584 go [] = return []
585 go (x:xs) = do x' <- x
586 xs' <- lazySequence xs
587 return (x' : xs')
588
589 -- | A lazy unfolder for lookup operations which return the current
590 -- value and (possibly) the next key
591 lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)]
592 lazyUnfold step = goLazy . Just
593 where
594 goLazy s = unsafeInterleaveIO (go s)
595
596 go Nothing = return []
597 go (Just k) = do
598 (v, mk') <- step k
599 vs' <- goLazy mk'
600 return ((k,v):vs')
601
602 -- | Which index do we mean?
603 data Index =
604 -- | The main index for the specified repository
605 RepoIndex RepoContext Repo
606
607 -- | A sandbox-local repository
608 -- Argument is the location of the index file
609 | SandboxIndex FilePath
610
611 indexFile :: Index -> FilePath
612 indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar"
613 indexFile (SandboxIndex index) = index
614
615 cacheFile :: Index -> FilePath
616 cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache"
617 cacheFile (SandboxIndex index) = index `replaceExtension` "cache"
618
619 timestampFile :: Index -> FilePath
620 timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp"
621 timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp"
622
623 -- | Return 'True' if 'Index' uses 01-index format (aka secure repo)
624 is01Index :: Index -> Bool
625 is01Index (RepoIndex _ repo) = case repo of
626 RepoSecure {} -> True
627 RepoRemote {} -> False
628 RepoLocalNoIndex {} -> True
629 is01Index (SandboxIndex _) = False
630
631
632 updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
633 updatePackageIndexCacheFile verbosity index = do
634 info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")
635 withIndexEntries verbosity index callback callbackNoIndex
636 where
637 callback entries = do
638 let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)
639 cache = Cache { cacheHeadTs = maxTs
640 , cacheEntries = entries
641 }
642 writeIndexCache index cache
643 info verbosity ("Index cache updated to index-state "
644 ++ prettyShow (cacheHeadTs cache))
645
646 callbackNoIndex entries = do
647 writeNoIndexCache verbosity index $ NoIndexCache entries
648 info verbosity "Index cache updated"
649
650 -- | Read the index (for the purpose of building a cache)
651 --
652 -- The callback is provided with list of cache entries, which is guaranteed to
653 -- be lazily constructed. This list must ONLY be used in the scope of the
654 -- callback; when the callback is terminated the file handle to the index will
655 -- be closed and further attempts to read from the list will result in (pure)
656 -- I/O exceptions.
657 --
658 -- In the construction of the index for a secure repo we take advantage of the
659 -- index built by the @hackage-security@ library to avoid reading the @.tar@
660 -- file as much as possible (we need to read it only to extract preferred
661 -- versions). This helps performance, but is also required for correctness:
662 -- the new @01-index.tar.gz@ may have multiple versions of preferred-versions
663 -- files, and 'parsePackageIndex' does not correctly deal with that (see #2956);
664 -- by reading the already-built cache from the security library we will be sure
665 -- to only read the latest versions of all files.
666 --
667 -- TODO: It would be nicer if we actually incrementally updated @cabal@'s
668 -- cache, rather than reconstruct it from zero on each update. However, this
669 -- would require a change in the cache format.
670 withIndexEntries
671 :: Verbosity -> Index
672 -> ([IndexCacheEntry] -> IO a)
673 -> ([NoIndexCacheEntry] -> IO a)
674 -> IO a
675 withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ =
676 repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
677 Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do
678 -- Incrementally (lazily) read all the entries in the tar file in order,
679 -- including all revisions, not just the last revision of each file
680 indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory)
681 callback [ cacheEntry
682 | (dirEntry, indexEntry) <- indexEntries
683 , cacheEntry <- toCacheEntries dirEntry indexEntry ]
684 where
685 toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry
686 -> [IndexCacheEntry]
687 toCacheEntries dirEntry (Sec.Some sie) =
688 case Sec.indexEntryPathParsed sie of
689 Nothing -> [] -- skip unrecognized file
690 Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata
691 Just (Sec.IndexPkgCabal pkgId) -> force
692 [CachePackageId pkgId blockNo timestamp]
693 Just (Sec.IndexPkgPrefs _pkgName) -> force
694 [ CachePreference dep blockNo timestamp
695 | dep <- parsePreferredVersions (Sec.indexEntryContent sie)
696 ]
697 where
698 blockNo = Sec.directoryEntryBlockNo dirEntry
699 timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $
700 epochTimeToTimestamp $ Sec.indexEntryTime sie
701
702 withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do
703 dirContents <- listDirectory localDir
704 let contentSet = Set.fromList dirContents
705
706 entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do
707 case isTarGz file of
708 Nothing -> do
709 unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $
710 info verbosity $ "Skipping " ++ file
711 return Nothing
712 Just pkgid | cabalPath `Set.member` contentSet -> do
713 contents <- BSS.readFile (localDir </> cabalPath)
714 for (parseGenericPackageDescriptionMaybe contents) $ \gpd ->
715 return (CacheGPD gpd contents)
716 where
717 cabalPath = prettyShow pkgid ++ ".cabal"
718 Just pkgId -> do
719 -- check for the right named .cabal file in the compressed tarball
720 tarGz <- BS.readFile (localDir </> file)
721 let tar = GZip.decompress tarGz
722 entries = Tar.read tar
723
724 case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of
725 Just ce -> return (Just ce)
726 Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file
727
728 info verbosity $ "Entries in file+noindex repository " ++ unRepoName name
729 for_ entries $ \(CacheGPD gpd _) ->
730 info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)
731
732 callback entries
733 where
734 handler :: IOException -> IO a
735 handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e
736
737 isTarGz :: FilePath -> Maybe PackageIdentifier
738 isTarGz fp = do
739 pfx <- stripSuffix ".tar.gz" fp
740 simpleParsec pfx
741
742 stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str))
743
744 -- look for <pkgid>/<pkgname>.cabal inside the tarball
745 readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry
746 readCabalEntry pkgId entry Nothing
747 | filename == Tar.entryPath entry
748 , Tar.NormalFile contents _ <- Tar.entryContent entry
749 = let bs = BS.toStrict contents
750 in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs
751 where
752 filename = prettyShow pkgId FilePath.Posix.</> prettyShow (packageName pkgId) ++ ".cabal"
753 readCabalEntry _ _ x = x
754
755 withIndexEntries verbosity index callback _ = do -- non-secure repositories
756 withFile (indexFile index) ReadMode $ \h -> do
757 bs <- maybeDecompress `fmap` BS.hGetContents h
758 pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs
759 callback $ map toCache (catMaybes pkgsOrPrefs)
760 where
761 toCache :: PackageOrDep -> IndexCacheEntry
762 toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp
763 toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
764 toCache (Dep d) = CachePreference d 0 nullTimestamp
765
766 readPackageIndexCacheFile :: Package pkg
767 => Verbosity
768 -> (PackageEntry -> pkg)
769 -> Index
770 -> RepoIndexState
771 -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
772 readPackageIndexCacheFile verbosity mkPkg index idxState
773 | localNoIndex index = do
774 cache0 <- readNoIndexCache verbosity index
775 pkgs <- packageNoIndexFromCache verbosity mkPkg cache0
776 pure (pkgs, [], emptyStateInfo)
777
778 | otherwise = do
779 cache0 <- readIndexCache verbosity index
780 indexHnd <- openFile (indexFile index) ReadMode
781 let (cache,isi) = filterCache idxState cache0
782 (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache
783 pure (pkgs,deps,isi)
784
785 packageIndexFromCache :: Package pkg
786 => Verbosity
787 -> (PackageEntry -> pkg)
788 -> Handle
789 -> Cache
790 -> IO (PackageIndex pkg, [Dependency])
791 packageIndexFromCache verbosity mkPkg hnd cache = do
792 (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache
793 pkgIndex <- evaluate $ PackageIndex.fromList pkgs
794 return (pkgIndex, prefs)
795
796 packageNoIndexFromCache
797 :: forall pkg. Package pkg
798 => Verbosity
799 -> (PackageEntry -> pkg)
800 -> NoIndexCache
801 -> IO (PackageIndex pkg)
802 packageNoIndexFromCache _verbosity mkPkg cache =
803 evaluate $ PackageIndex.fromList pkgs
804 where
805 pkgs =
806 [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0
807 | CacheGPD gpd bs <- noIndexCacheEntries cache
808 , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd
809 ]
810
811 -- | Read package list
812 --
813 -- The result package releases and preference entries are guaranteed
814 -- to be unique.
815 --
816 -- Note: 01-index.tar is an append-only index and therefore contains
817 -- all .cabal edits and preference-updates. The masking happens
818 -- here, i.e. the semantics that later entries in a tar file mask
819 -- earlier ones is resolved in this function.
820 packageListFromCache :: Verbosity
821 -> (PackageEntry -> pkg)
822 -> Handle
823 -> Cache
824 -> IO ([pkg], [Dependency])
825 packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries
826 where
827 accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)
828
829 accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do
830 -- Given the cache entry, make a package index entry.
831 -- The magic here is that we use lazy IO to read the .cabal file
832 -- from the index tarball if it turns out that we need it.
833 -- Most of the time we only need the package id.
834 ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do
835 pkgtxt <- getEntryContent blockno
836 pkg <- readPackageDescription pkgid pkgtxt
837 return (pkg, pkgtxt)
838
839 let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno)
840 accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries
841
842 accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do
843 -- We have to read the .cabal file eagerly here because we can't cache the
844 -- package id for build tree references - the user might edit the .cabal
845 -- file after the reference was added to the index.
846 path <- liftM byteStringToFilePath . getEntryContent $ blockno
847 pkg <- do let err = "Error reading package index from cache."
848 file <- tryFindAddSourcePackageDesc verbosity path err
849 PackageDesc.Parse.readGenericPackageDescription normal file
850 let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)
851 accum srcpkgs (srcpkg:btrs) prefs entries
852
853 accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) =
854 accum srcpkgs btrs (Map.insert pn pref prefs) entries
855
856 getEntryContent :: BlockNo -> IO ByteString
857 getEntryContent blockno = do
858 entry <- Tar.hReadEntry hnd blockno
859 case Tar.entryContent entry of
860 Tar.NormalFile content _size -> return content
861 Tar.OtherEntryType typecode content _size
862 | Tar.isBuildTreeRefTypeCode typecode
863 -> return content
864 _ -> interror "unexpected tar entry type"
865
866 readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription
867 readPackageDescription pkgid content =
868 case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of
869 Right gpd -> return gpd
870 Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer)
871 Left _ -> interror "failed to parse .cabal file"
872 where
873 dummyPackageDescription :: Version -> GenericPackageDescription
874 dummyPackageDescription specVer = GenericPackageDescription
875 { packageDescription = emptyPackageDescription
876 { package = pkgid
877 , synopsis = dummySynopsis
878 }
879 , gpdScannedVersion = Just specVer -- tells index scanner to skip this file.
880 , genPackageFlags = []
881 , condLibrary = Nothing
882 , condSubLibraries = []
883 , condForeignLibs = []
884 , condExecutables = []
885 , condTestSuites = []
886 , condBenchmarks = []
887 }
888
889 dummySynopsis = "<could not be parsed due to unsupported CABAL spec-version>"
890
891 interror :: String -> IO a
892 interror msg = die' verbosity $ "internal error when reading package index: " ++ msg
893 ++ "The package index or index cache is probably "
894 ++ "corrupt. Running cabal update might fix it."
895
896
897
898 ------------------------------------------------------------------------
899 -- Index cache data structure --
900
901 -- | Read the 'Index' cache from the filesystem
902 --
903 -- If a corrupted index cache is detected this function regenerates
904 -- the index cache and then reattempt to read the index once (and
905 -- 'die's if it fails again).
906 readIndexCache :: Verbosity -> Index -> IO Cache
907 readIndexCache verbosity index = do
908 cacheOrFail <- readIndexCache' index
909 case cacheOrFail of
910 Left msg -> do
911 warn verbosity $ concat
912 [ "Parsing the index cache failed (", msg, "). "
913 , "Trying to regenerate the index cache..."
914 ]
915
916 updatePackageIndexCacheFile verbosity index
917
918 either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index
919
920 Right res -> return (hashConsCache res)
921
922 readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache
923 readNoIndexCache verbosity index = do
924 cacheOrFail <- readNoIndexCache' index
925 case cacheOrFail of
926 Left msg -> do
927 warn verbosity $ concat
928 [ "Parsing the index cache failed (", msg, "). "
929 , "Trying to regenerate the index cache..."
930 ]
931
932 updatePackageIndexCacheFile verbosity index
933
934 either (die' verbosity) return =<< readNoIndexCache' index
935
936 -- we don't hash cons local repository cache, they are hopefully small
937 Right res -> return res
938
939 -- | Read the 'Index' cache from the filesystem without attempting to
940 -- regenerate on parsing failures.
941 readIndexCache' :: Index -> IO (Either String Cache)
942 readIndexCache' index
943 | is01Index index = structuredDecodeFileOrFail (cacheFile index)
944 | otherwise = liftM (Right .read00IndexCache) $
945 BSS.readFile (cacheFile index)
946
947 readNoIndexCache' :: Index -> IO (Either String NoIndexCache)
948 readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index)
949
950 -- | Write the 'Index' cache to the filesystem
951 writeIndexCache :: Index -> Cache -> IO ()
952 writeIndexCache index cache
953 | is01Index index = structuredEncodeFile (cacheFile index) cache
954 | otherwise = writeFile (cacheFile index) (show00IndexCache cache)
955
956 writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO ()
957 writeNoIndexCache verbosity index cache = do
958 let path = cacheFile index
959 createDirectoryIfMissingVerbose verbosity True (takeDirectory path)
960 structuredEncodeFile path cache
961
962 -- | Write the 'IndexState' to the filesystem
963 writeIndexTimestamp :: Index -> RepoIndexState -> IO ()
964 writeIndexTimestamp index st
965 = writeFile (timestampFile index) (prettyShow st)
966
967 -- | Read out the "current" index timestamp, i.e., what
968 -- timestamp you would use to revert to this version
969 currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp
970 currentIndexTimestamp verbosity repoCtxt r = do
971 mb_is <- readIndexTimestamp (RepoIndex repoCtxt r)
972 case mb_is of
973 Just (IndexStateTime ts) -> return ts
974 _ -> do
975 (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead
976 return (isiHeadTime isi)
977
978 -- | Read the 'IndexState' from the filesystem
979 readIndexTimestamp :: Index -> IO (Maybe RepoIndexState)
980 readIndexTimestamp index
981 = fmap simpleParsec (readFile (timestampFile index))
982 `catchIO` \e ->
983 if isDoesNotExistError e
984 then return Nothing
985 else ioError e
986
987 -- | Optimise sharing of equal values inside 'Cache'
988 --
989 -- c.f. https://en.wikipedia.org/wiki/Hash_consing
990 hashConsCache :: Cache -> Cache
991 hashConsCache cache0
992 = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) }
993 where
994 -- TODO/NOTE:
995 --
996 -- If/when we redo the binary serialisation via e.g. CBOR and we
997 -- are able to use incremental decoding, we may want to move the
998 -- hash-consing into the incremental deserialisation, or
999 -- alterantively even do something like
1000 -- http://cbor.schmorp.de/value-sharing
1001 --
1002 go _ _ [] = []
1003 -- for now we only optimise only CachePackageIds since those
1004 -- represent the vast majority
1005 go !pns !pvs (CachePackageId pid bno ts : rest)
1006 = CachePackageId pid' bno ts : go pns' pvs' rest
1007 where
1008 !pid' = PackageIdentifier pn' pv'
1009 (!pn',!pns') = mapIntern pn pns
1010 (!pv',!pvs') = mapIntern pv pvs
1011 PackageIdentifier pn pv = pid
1012
1013 go pns pvs (x:xs) = x : go pns pvs xs
1014
1015 mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k)
1016 mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m)
1017
1018 -- | Cabal caches various information about the Hackage index
1019 data Cache = Cache
1020 { cacheHeadTs :: Timestamp
1021 -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the
1022 -- invariant of 'cacheEntries' being in chronological order is
1023 -- violated, this corresponds to the last (seen) 'Timestamp' in
1024 -- 'cacheEntries'
1025 , cacheEntries :: [IndexCacheEntry]
1026 }
1027 deriving (Show, Generic)
1028
1029 instance NFData Cache where
1030 rnf = rnf . cacheEntries
1031
1032 -- | Cache format for 'file+noindex' repositories
1033 newtype NoIndexCache = NoIndexCache
1034 { noIndexCacheEntries :: [NoIndexCacheEntry]
1035 }
1036 deriving (Show, Generic)
1037
1038 instance NFData NoIndexCache where
1039 rnf = rnf . noIndexCacheEntries
1040
1041 -- | Tar files are block structured with 512 byte blocks. Every header and file
1042 -- content starts on a block boundary.
1043 --
1044 type BlockNo = Word32 -- Tar.TarEntryOffset
1045
1046 data IndexCacheEntry
1047 = CachePackageId PackageId !BlockNo !Timestamp
1048 | CachePreference Dependency !BlockNo !Timestamp
1049 | CacheBuildTreeRef !BuildTreeRefType !BlockNo
1050 -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build
1051 deriving (Eq,Show,Generic)
1052
1053 data NoIndexCacheEntry
1054 = CacheGPD GenericPackageDescription !BSS.ByteString
1055 deriving (Eq,Show,Generic)
1056
1057 instance NFData IndexCacheEntry where
1058 rnf (CachePackageId pkgid _ _) = rnf pkgid
1059 rnf (CachePreference dep _ _) = rnf dep
1060 rnf (CacheBuildTreeRef _ _) = ()
1061
1062 instance NFData NoIndexCacheEntry where
1063 rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs
1064
1065 cacheEntryTimestamp :: IndexCacheEntry -> Timestamp
1066 cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp
1067 cacheEntryTimestamp (CachePreference _ _ ts) = ts
1068 cacheEntryTimestamp (CachePackageId _ _ ts) = ts
1069
1070 ----------------------------------------------------------------------------
1071 -- new binary 01-index.cache format
1072
1073 instance Binary Cache
1074 instance Binary IndexCacheEntry
1075 instance Binary NoIndexCache
1076
1077 instance Structured Cache
1078 instance Structured IndexCacheEntry
1079 instance Structured NoIndexCache
1080
1081 -- | We need to save only .cabal file contents
1082 instance Binary NoIndexCacheEntry where
1083 put (CacheGPD _ bs) = put bs
1084
1085 get = do
1086 bs <- get
1087 case parseGenericPackageDescriptionMaybe bs of
1088 Just gpd -> return (CacheGPD gpd bs)
1089 Nothing -> fail "Failed to parse GPD"
1090
1091 instance Structured NoIndexCacheEntry where
1092 structure = nominalStructure
1093
1094 ----------------------------------------------------------------------------
1095 -- legacy 00-index.cache format
1096
1097 packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
1098 packageKey = "pkg:"
1099 blocknoKey = "b#"
1100 buildTreeRefKey = "build-tree-ref:"
1101 preferredVersionKey = "pref-ver:"
1102
1103 -- legacy 00-index.cache format
1104 read00IndexCache :: BSS.ByteString -> Cache
1105 read00IndexCache bs = Cache
1106 { cacheHeadTs = nullTimestamp
1107 , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs
1108 }
1109
1110 read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry
1111 read00IndexCacheEntry = \line ->
1112 case BSS.words line of
1113 [key, pkgnamestr, pkgverstr, sep, blocknostr]
1114 | key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->
1115 case (parseName pkgnamestr, parseVer pkgverstr [],
1116 parseBlockNo blocknostr) of
1117 (Just pkgname, Just pkgver, Just blockno)
1118 -> Just (CachePackageId (PackageIdentifier pkgname pkgver)
1119 blockno nullTimestamp)
1120 _ -> Nothing
1121 [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->
1122 case (parseRefType typecodestr, parseBlockNo blocknostr) of
1123 (Just refType, Just blockno)
1124 -> Just (CacheBuildTreeRef refType blockno)
1125 _ -> Nothing
1126
1127 (key: remainder) | key == BSS.pack preferredVersionKey -> do
1128 pref <- simpleParsecBS (BSS.unwords remainder)
1129 return $ CachePreference pref 0 nullTimestamp
1130
1131 _ -> Nothing
1132 where
1133 parseName str
1134 | BSS.all (\c -> isAlphaNum c || c == '-') str
1135 = Just (mkPackageName (BSS.unpack str))
1136 | otherwise = Nothing
1137
1138 parseVer str vs =
1139 case BSS.readInt str of
1140 Nothing -> Nothing
1141 Just (v, str') -> case BSS.uncons str' of
1142 Just ('.', str'') -> parseVer str'' (v:vs)
1143 Just _ -> Nothing
1144 Nothing -> Just (mkVersion (reverse (v:vs)))
1145
1146 parseBlockNo str =
1147 case BSS.readInt str of
1148 Just (blockno, remainder)
1149 | BSS.null remainder -> Just (fromIntegral blockno)
1150 _ -> Nothing
1151
1152 parseRefType str =
1153 case BSS.uncons str of
1154 Just (typeCode, remainder)
1155 | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode
1156 -> Just (refTypeFromTypeCode typeCode)
1157 _ -> Nothing
1158
1159 -- legacy 00-index.cache format
1160 show00IndexCache :: Cache -> String
1161 show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries
1162
1163 show00IndexCacheEntry :: IndexCacheEntry -> String
1164 show00IndexCacheEntry entry = unwords $ case entry of
1165 CachePackageId pkgid b _ ->
1166 [ packageKey
1167 , prettyShow (packageName pkgid)
1168 , prettyShow (packageVersion pkgid)
1169 , blocknoKey
1170 , show b
1171 ]
1172 CacheBuildTreeRef tr b ->
1173 [ buildTreeRefKey
1174 , [typeCodeFromRefType tr]
1175 , show b
1176 ]
1177 CachePreference dep _ _ ->
1178 [ preferredVersionKey
1179 , prettyShow dep
1180 ]