Commit ef6fe247 authored by Edsko de Vries's avatar Edsko de Vries
Browse files

Address comments on #2949.

This changes the definition of `Index` to

``` haskell
data Index =
    -- | The main index for the specified repository
    RepoIndex Repo

    -- | A sandbox-local repository
    -- Argument is the location of the index file
  | SandboxIndex FilePath
```

with

```
cacheFile (SandboxIndex index) = index `replaceExtension` "cache"
```

This also renames `repoRemote'` to `maybeRepoRemote`.

I believe this addresses all comments.
parent a301b156
......@@ -80,7 +80,7 @@ storeAnonymous reports = sequence_
onlyRemote rs =
[ (report, repo, remoteRepo)
| (report, Just repo) <- rs
, Just remoteRepo <- [repoRemote' repo]
, Just remoteRepo <- [maybeRepoRemote repo]
]
storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]
......
......@@ -78,7 +78,8 @@ import Distribution.Client.Utils ( byteStringToFilePath
import Distribution.Compat.Exception (catchIO)
import Distribution.Client.Compat.Time (getFileAge, getModTime)
import System.Directory (doesFileExist, doesDirectoryExist)
import System.FilePath ((</>), takeExtension, splitDirectories, normalise)
import System.FilePath
( (</>), takeExtension, replaceExtension, splitDirectories, normalise )
import System.FilePath.Posix as FilePath.Posix
( takeFileName )
import System.IO
......@@ -153,8 +154,8 @@ readRepoIndex :: Verbosity -> Repo -> ReadPackageIndexMode
readRepoIndex verbosity repo mode =
handleNotFound $ do
warnIfIndexIsOld =<< getIndexFileAge repo
updateRepoIndexCache verbosity (GlobalIndex repo)
readPackageIndexCacheFile mkAvailablePackage (GlobalIndex repo) mode
updateRepoIndexCache verbosity (RepoIndex repo)
readPackageIndexCacheFile mkAvailablePackage (RepoIndex repo) mode
where
mkAvailablePackage pkgEntry =
......@@ -346,19 +347,20 @@ lazySequence (x:xs) = unsafeInterleaveIO $ do
-- | Which index do we mean?
data Index =
-- | The global index for the specified repository
GlobalIndex Repo
-- | The main index for the specified repository
RepoIndex Repo
-- | A (sandbox) local repository
| LocalIndex { localIndexFile :: FilePath, localCacheFile :: FilePath }
-- | A sandbox-local repository
-- Argument is the location of the index file
| SandboxIndex FilePath
indexFile :: Index -> FilePath
indexFile (GlobalIndex repo) = repoLocalDir repo </> "00-index.tar"
indexFile (LocalIndex{..}) = localIndexFile
indexFile (RepoIndex repo) = repoLocalDir repo </> "00-index.tar"
indexFile (SandboxIndex index) = index
cacheFile :: Index -> FilePath
cacheFile (GlobalIndex repo) = repoLocalDir repo </> "00-index.cache"
cacheFile (LocalIndex{..}) = localCacheFile
cacheFile (RepoIndex repo) = repoLocalDir repo </> "00-index.cache"
cacheFile (SandboxIndex index) = index `replaceExtension` "cache"
updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile verbosity index = do
......
......@@ -840,7 +840,7 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
writeFile reportFile (show (BuildReports.show report, buildLog))
| (report, Just repo) <- reports
, Just remoteRepo <- [repoRemote' repo]
, Just remoteRepo <- [maybeRepoRemote repo]
, isLikelyToHaveLogFile (BuildReports.installOutcome report) ]
where
......
......@@ -48,8 +48,7 @@ import Data.Either (partitionEithers)
import System.Directory ( createDirectoryIfMissing,
doesDirectoryExist, doesFileExist,
renameFile, canonicalizePath)
import System.FilePath ( (</>), (<.>), takeDirectory, takeExtension
, replaceExtension )
import System.FilePath ( (</>), (<.>), takeDirectory, takeExtension )
import System.IO ( IOMode(..), SeekMode(..)
, hSeek, withBinaryFile )
......@@ -156,10 +155,7 @@ addBuildTreeRefs verbosity path l' refType = do
hSeek h AbsoluteSeek (fromIntegral offset)
BS.hPut h (Tar.write entries)
debug verbosity $ "Successfully appended to '" ++ path ++ "'"
updatePackageIndexCacheFile verbosity $ LocalIndex {
localIndexFile = path
, localCacheFile = path `replaceExtension` "cache"
}
updatePackageIndexCacheFile verbosity $ SandboxIndex path
data DeleteSourceError = ErrNonregisteredSource { nrPath :: FilePath }
| ErrNonexistentSource { nePath :: FilePath } deriving Show
......@@ -194,10 +190,7 @@ removeBuildTreeRefs verbosity indexPath l = do
++ "' to '" ++ indexPath ++ "'"
unless (null removedRefs) $
updatePackageIndexCacheFile verbosity LocalIndex {
localIndexFile = indexPath
, localCacheFile = indexPath `replaceExtension` "cache"
}
updatePackageIndexCacheFile verbosity $ SandboxIndex indexPath
let results = fmap Right removedRefs
++ fmap Left failures
......
......@@ -255,9 +255,9 @@ data Repo =
deriving instance Show Repo
-- | Check if this is a remote repo
repoRemote' :: Repo -> Maybe RemoteRepo
repoRemote' (RepoLocal _localDir ) = Nothing
repoRemote' (RepoRemote r _localDir ) = Just r
maybeRepoRemote :: Repo -> Maybe RemoteRepo
maybeRepoRemote (RepoLocal _localDir ) = Nothing
maybeRepoRemote (RepoRemote r _localDir ) = Just r
-- ------------------------------------------------------------
-- * Build results
......
......@@ -16,7 +16,7 @@ module Distribution.Client.Update
) where
import Distribution.Client.Types
( Repo(..), RemoteRepo(..), repoRemote' )
( Repo(..), RemoteRepo(..), maybeRepoRemote )
import Distribution.Client.HttpUtils
( DownloadResult(..), HttpTransport(..) )
import Distribution.Client.FetchUtils
......@@ -43,7 +43,7 @@ update _ verbosity [] =
++ "you would have one specified in the config file."
update transport verbosity repos = do
jobCtrl <- newParallelJobControl
let remoteRepos = catMaybes (map repoRemote' repos)
let remoteRepos = catMaybes (map maybeRepoRemote repos)
case remoteRepos of
[] -> return ()
[remoteRepo] ->
......@@ -65,4 +65,4 @@ updateRepo transport verbosity repo = case repo of
FileDownloaded indexPath -> do
writeFileAtomic (dropExtension indexPath) . maybeDecompress
=<< BS.readFile indexPath
updateRepoIndexCache verbosity (GlobalIndex repo)
updateRepoIndexCache verbosity (RepoIndex repo)
......@@ -4,7 +4,7 @@
module Distribution.Client.Upload (check, upload, uploadDoc, report) where
import Distribution.Client.Types ( Username(..), Password(..)
, Repo(..), RemoteRepo(..), repoRemote' )
, Repo(..), RemoteRepo(..), maybeRepoRemote )
import Distribution.Client.HttpUtils
( HttpTransport(..), remoteRepoTryUpgradeToHttps )
......@@ -38,7 +38,7 @@ upload :: HttpTransport -> Verbosity -> [Repo]
-> IO ()
upload transport verbosity repos mUsername mPassword paths = do
targetRepo <-
case [ remoteRepo | Just remoteRepo <- map repoRemote' repos ] of
case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of
[] -> die "Cannot upload. No remote repositories are configured."
rs -> remoteRepoTryUpgradeToHttps transport (last rs)
let targetRepoURI = remoteRepoURI targetRepo
......@@ -59,7 +59,7 @@ uploadDoc :: HttpTransport -> Verbosity -> [Repo]
-> IO ()
uploadDoc transport verbosity repos mUsername mPassword path = do
targetRepo <-
case [ remoteRepo | Just remoteRepo <- map repoRemote' repos ] of
case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of
[] -> die $ "Cannot upload. No remote repositories are configured."
rs -> remoteRepoTryUpgradeToHttps transport (last rs)
let targetRepoURI = remoteRepoURI targetRepo
......@@ -113,7 +113,7 @@ report verbosity repos mUsername mPassword = do
Username username <- maybe promptUsername return mUsername
Password password <- maybe promptPassword return mPassword
let auth = (username,password)
let remoteRepos = catMaybes (map repoRemote' repos)
let remoteRepos = catMaybes (map maybeRepoRemote repos)
forM_ remoteRepos $ \remoteRepo ->
do dotCabal <- defaultCabalDir
let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment