From a8056d4716101c707743824775bab58670873542 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Wed, 16 Dec 2015 14:37:19 +0100
Subject: [PATCH] Change Repo type
The old Repo type has a repoKind
repoKind :: Either RemoteRepo LocalRepo,
where LocalRepo was isomorphic to unit:
data LocalRepo = LocalRepo
This commit changes Repo to
data Repo =
-- | Local repositories
RepoLocal {
repoLocalDir :: FilePath
}
-- | Standard (unsecured) remote repositores
| RepoRemote {
repoRemote :: RemoteRepo
, repoLocalDir :: FilePath
}
instead, which is a little more idiomatic and will make adding more repository
types easier.
---
.../Client/BuildReports/Storage.hs | 4 ++-
.../Distribution/Client/FetchUtils.hs | 17 ++++++------
.../Distribution/Client/IndexUtils.hs | 18 ++++++-------
cabal-install/Distribution/Client/Install.hs | 3 ++-
.../Distribution/Client/Sandbox/Index.hs | 5 ++--
cabal-install/Distribution/Client/Setup.hs | 6 ++---
cabal-install/Distribution/Client/Types.hs | 27 +++++++++++++------
cabal-install/Distribution/Client/Update.hs | 15 ++++++-----
cabal-install/Distribution/Client/Upload.hs | 12 ++++-----
9 files changed, 61 insertions(+), 46 deletions(-)
diff --git a/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal-install/Distribution/Client/BuildReports/Storage.hs
index a4e17af306..be8464b098 100644
--- a/cabal-install/Distribution/Client/BuildReports/Storage.hs
+++ b/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -79,7 +79,9 @@ storeAnonymous reports = sequence_
-> [(BuildReport, Repo, RemoteRepo)]
onlyRemote rs =
[ (report, repo, remoteRepo)
- | (report, Just repo@Repo { repoKind = Left remoteRepo }) <- rs ]
+ | (report, Just repo) <- rs
+ , Just remoteRepo <- [repoRemote' repo]
+ ]
storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]
-> Platform -> IO ()
diff --git a/cabal-install/Distribution/Client/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs
index 7f126dd762..2838a4d130 100644
--- a/cabal-install/Distribution/Client/FetchUtils.hs
+++ b/cabal-install/Distribution/Client/FetchUtils.hs
@@ -11,6 +11,7 @@
--
-- Functions for fetching packages
-----------------------------------------------------------------------------
+{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.FetchUtils (
-- * fetching packages
@@ -131,14 +132,14 @@ fetchRepoTarball transport verbosity repo pkgid = do
else do setupMessage verbosity "Downloading" pkgid
downloadRepoPackage
where
- downloadRepoPackage = case repoKind repo of
- Right LocalRepo -> return (packageFile repo pkgid)
-
- Left remoteRepo -> do
- remoteRepoCheckHttps transport remoteRepo
- let uri = packageURI remoteRepo pkgid
- dir = packageDir repo pkgid
- path = packageFile repo pkgid
+ downloadRepoPackage = case repo of
+ RepoLocal{..} -> return (packageFile repo pkgid)
+
+ RepoRemote{..} -> do
+ remoteRepoCheckHttps transport repoRemote
+ let uri = packageURI repoRemote pkgid
+ dir = packageDir repo pkgid
+ path = packageFile repo pkgid
createDirectoryIfMissing True dir
_ <- downloadURI transport verbosity uri path
return path
diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs
index 7b2d8bd1f1..f5b00d004c 100644
--- a/cabal-install/Distribution/Client/IndexUtils.hs
+++ b/cabal-install/Distribution/Client/IndexUtils.hs
@@ -173,24 +173,24 @@ readRepoIndex verbosity repo mode =
handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
then do
- case repoKind repo of
- Left remoteRepo -> warn verbosity $
- "The package list for '" ++ remoteRepoName remoteRepo
+ case repo of
+ RepoRemote{..} -> warn verbosity $
+ "The package list for '" ++ remoteRepoName repoRemote
++ "' does not exist. Run 'cabal update' to download it."
- Right _localRepo -> warn verbosity $
- "The package list for the local repo '" ++ repoLocalDir repo
+ RepoLocal{..} -> warn verbosity $
+ "The package list for the local repo '" ++ repoLocalDir
++ "' is missing. The repo is invalid."
return mempty
else ioError e
isOldThreshold = 15 --days
warnIfIndexIsOld dt = do
- when (dt >= isOldThreshold) $ case repoKind repo of
- Left remoteRepo -> warn verbosity $
- "The package list for '" ++ remoteRepoName remoteRepo
+ when (dt >= isOldThreshold) $ case repo of
+ RepoRemote{..} -> warn verbosity $
+ "The package list for '" ++ remoteRepoName repoRemote
++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
++ "'cabal update' to get the latest list of available packages."
- Right _localRepo -> return ()
+ RepoLocal{..} -> return ()
-- | Return the age of the index file in days (as a Double).
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 7ea7a03ffb..931970dbec 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -839,7 +839,8 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_
createDirectoryIfMissing True reportsDir -- FIXME
writeFile reportFile (show (BuildReports.show report, buildLog))
- | (report, Just Repo { repoKind = Left remoteRepo }) <- reports
+ | (report, Just repo) <- reports
+ , Just remoteRepo <- [repoRemote' repo]
, isLikelyToHaveLogFile (BuildReports.installOutcome report) ]
where
diff --git a/cabal-install/Distribution/Client/Sandbox/Index.hs b/cabal-install/Distribution/Client/Sandbox/Index.hs
index 92897fe5bb..05f64039de 100644
--- a/cabal-install/Distribution/Client/Sandbox/Index.hs
+++ b/cabal-install/Distribution/Client/Sandbox/Index.hs
@@ -27,7 +27,7 @@ import Distribution.Client.IndexUtils ( BuildTreeRefType(..)
, getSourcePackagesStrict
, Index(..) )
import Distribution.Client.PackageIndex ( allPackages )
-import Distribution.Client.Types ( Repo(..), LocalRepo(..)
+import Distribution.Client.Types ( Repo(..)
, SourcePackageDb(..)
, SourcePackage(..), PackageLocation(..) )
import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString
@@ -271,8 +271,7 @@ listBuildTreeRefs verbosity listIgnored refTypesToList path = do
listWithoutIgnored :: IO [FilePath]
listWithoutIgnored = do
- let repo = Repo { repoKind = Right LocalRepo
- , repoLocalDir = takeDirectory path }
+ let repo = RepoLocal { repoLocalDir = takeDirectory path }
pkgIndex <- fmap packageIndex
. getSourcePackagesStrict verbosity $ [repo]
return [ pkgPath | (LocalUnpackedPackage pkgPath) <-
diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
index 70e774bd63..0e99947995 100644
--- a/cabal-install/Distribution/Client/Setup.hs
+++ b/cabal-install/Distribution/Client/Setup.hs
@@ -49,7 +49,7 @@ module Distribution.Client.Setup
) where
import Distribution.Client.Types
- ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )
+ ( Username(..), Password(..), Repo(..), RemoteRepo(..) )
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
@@ -381,12 +381,12 @@ globalRepos :: GlobalFlags -> [Repo]
globalRepos globalFlags = remoteRepos ++ localRepos
where
remoteRepos =
- [ Repo (Left remote) cacheDir
+ [ RepoRemote remote cacheDir
| remote <- fromNubList $ globalRemoteRepos globalFlags
, let cacheDir = fromFlag (globalCacheDir globalFlags)
</> remoteRepoName remote ]
localRepos =
- [ Repo (Right LocalRepo) local
+ [ RepoLocal local
| local <- fromNubList $ globalLocalRepos globalFlags ]
-- ------------------------------------------------------------
diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs
index 5b36a90b1e..916a8c5a7c 100644
--- a/cabal-install/Distribution/Client/Types.hs
+++ b/cabal-install/Distribution/Client/Types.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE StandaloneDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Types
@@ -208,9 +209,6 @@ data PackageLocation local =
-- | ScmPackage
deriving (Show, Functor)
-data LocalRepo = LocalRepo
- deriving (Show,Eq)
-
data RemoteRepo =
RemoteRepo {
remoteRepoName :: String,
@@ -242,11 +240,24 @@ data RemoteRepo =
emptyRemoteRepo :: String -> RemoteRepo
emptyRemoteRepo name = RemoteRepo name nullURI False [] 0 False
-data Repo = Repo {
- repoKind :: Either RemoteRepo LocalRepo,
- repoLocalDir :: FilePath
- }
- deriving (Show,Eq)
+data Repo =
+ -- | Local repositories
+ RepoLocal {
+ repoLocalDir :: FilePath
+ }
+
+ -- | Standard (unsecured) remote repositores
+ | RepoRemote {
+ repoRemote :: RemoteRepo
+ , repoLocalDir :: FilePath
+ }
+
+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
-- ------------------------------------------------------------
-- * Build results
diff --git a/cabal-install/Distribution/Client/Update.hs b/cabal-install/Distribution/Client/Update.hs
index 01a291f602..7157d0c75c 100644
--- a/cabal-install/Distribution/Client/Update.hs
+++ b/cabal-install/Distribution/Client/Update.hs
@@ -10,12 +10,13 @@
--
--
-----------------------------------------------------------------------------
+{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.Update
( update
) where
import Distribution.Client.Types
- ( Repo(..), RemoteRepo(..), LocalRepo(..) )
+ ( Repo(..), RemoteRepo(..), repoRemote' )
import Distribution.Client.HttpUtils
( DownloadResult(..), HttpTransport(..) )
import Distribution.Client.FetchUtils
@@ -33,7 +34,7 @@ import Distribution.Verbosity
import qualified Data.ByteString.Lazy as BS
import Distribution.Client.GZipUtils (maybeDecompress)
import System.FilePath (dropExtension)
-import Data.Either (lefts)
+import Data.Maybe (catMaybes)
-- | 'update' downloads the package list from all known servers
update :: HttpTransport -> Verbosity -> [Repo] -> IO ()
@@ -42,7 +43,7 @@ update _ verbosity [] =
++ "you would have one specified in the config file."
update transport verbosity repos = do
jobCtrl <- newParallelJobControl
- let remoteRepos = lefts (map repoKind repos)
+ let remoteRepos = catMaybes (map repoRemote' repos)
case remoteRepos of
[] -> return ()
[remoteRepo] ->
@@ -55,10 +56,10 @@ update transport verbosity repos = do
mapM_ (\_ -> collectJob jobCtrl) repos
updateRepo :: HttpTransport -> Verbosity -> Repo -> IO ()
-updateRepo transport verbosity repo = case repoKind repo of
- Right LocalRepo -> return ()
- Left remoteRepo -> do
- downloadResult <- downloadIndex transport verbosity remoteRepo (repoLocalDir repo)
+updateRepo transport verbosity repo = case repo of
+ RepoLocal{..} -> return ()
+ RepoRemote{..} -> do
+ downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir
case downloadResult of
FileAlreadyInCache -> return ()
FileDownloaded indexPath -> do
diff --git a/cabal-install/Distribution/Client/Upload.hs b/cabal-install/Distribution/Client/Upload.hs
index a27982f274..3167887526 100644
--- a/cabal-install/Distribution/Client/Upload.hs
+++ b/cabal-install/Distribution/Client/Upload.hs
@@ -4,7 +4,7 @@
module Distribution.Client.Upload (check, upload, uploadDoc, report) where
import Distribution.Client.Types ( Username(..), Password(..)
- , Repo(..), RemoteRepo(..) )
+ , Repo(..), RemoteRepo(..), repoRemote' )
import Distribution.Client.HttpUtils
( HttpTransport(..), remoteRepoTryUpgradeToHttps )
@@ -25,6 +25,7 @@ import System.FilePath ((</>), takeExtension, takeFileName)
import qualified System.FilePath.Posix as FilePath.Posix ((</>))
import System.Directory
import Control.Monad (forM_, when)
+import Data.Maybe (catMaybes)
type Auth = Maybe (String, String)
@@ -37,7 +38,7 @@ upload :: HttpTransport -> Verbosity -> [Repo]
-> IO ()
upload transport verbosity repos mUsername mPassword paths = do
targetRepo <-
- case [ remoteRepo | Left remoteRepo <- map repoKind repos ] of
+ case [ remoteRepo | Just remoteRepo <- map repoRemote' repos ] of
[] -> die "Cannot upload. No remote repositories are configured."
rs -> remoteRepoTryUpgradeToHttps transport (last rs)
let targetRepoURI = remoteRepoURI targetRepo
@@ -58,7 +59,7 @@ uploadDoc :: HttpTransport -> Verbosity -> [Repo]
-> IO ()
uploadDoc transport verbosity repos mUsername mPassword path = do
targetRepo <-
- case [ remoteRepo | Left remoteRepo <- map repoKind repos ] of
+ case [ remoteRepo | Just remoteRepo <- map repoRemote' repos ] of
[] -> die $ "Cannot upload. No remote repositories are configured."
rs -> remoteRepoTryUpgradeToHttps transport (last rs)
let targetRepoURI = remoteRepoURI targetRepo
@@ -112,8 +113,8 @@ report verbosity repos mUsername mPassword = do
Username username <- maybe promptUsername return mUsername
Password password <- maybe promptPassword return mPassword
let auth = (username,password)
- forM_ repos $ \repo -> case repoKind repo of
- Left remoteRepo ->
+ let remoteRepos = catMaybes (map repoRemote' repos)
+ forM_ remoteRepos $ \remoteRepo ->
do dotCabal <- defaultCabalDir
let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo
-- We don't want to bomb out just because we haven't built any packages
@@ -132,7 +133,6 @@ report verbosity repos mUsername mPassword = do
BuildReport.uploadReports verbosity auth
(remoteRepoURI remoteRepo) [(report', Just buildLog)]
return ()
- Right{} -> return ()
check :: HttpTransport -> Verbosity -> [FilePath] -> IO ()
check transport verbosity paths =
--
GitLab