Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add RepoName newtype #6581

Merged
merged 1 commit into from
Mar 13, 2020
Merged

Add RepoName newtype #6581

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
44 changes: 20 additions & 24 deletions cabal-install/Distribution/Client/CmdUpdate.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -24,7 +24,7 @@ import Distribution.Client.ProjectConfig
, projectConfigWithSolverRepoContext
, withProjectOrGlobalConfig )
import Distribution.Client.Types
( Repo(..), RemoteRepo(..), isRepoRemote )
( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), isRepoRemote )
import Distribution.Client.HttpUtils
( DownloadResult(..) )
import Distribution.Client.FetchUtils
Expand All @@ -45,12 +45,12 @@ import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.IndexUtils
( updateRepoIndexCache, Index(..), writeIndexTimestamp
, currentIndexTimestamp, indexBaseName )
import Distribution.Deprecated.Text
( Text(..), display, simpleParse )
import Distribution.Pretty (Pretty (..), prettyShow)
import Distribution.Parsec (Parsec (..), simpleParsec)

import Data.Maybe (fromJust)
import qualified Distribution.Deprecated.ReadP as ReadP
import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp

import Control.Monad (mapM, mapM_)
import qualified Data.ByteString.Lazy as BS
Expand Down Expand Up @@ -100,21 +100,18 @@ updateCommand = Client.installCommand {
}

data UpdateRequest = UpdateRequest
{ _updateRequestRepoName :: String
{ _updateRequestRepoName :: RepoName
, _updateRequestRepoState :: IndexState
} deriving (Show)

instance Text UpdateRequest where
disp (UpdateRequest n s) = Disp.text n Disp.<> Disp.char ',' Disp.<> disp s
parse = parseWithState ReadP.+++ parseHEAD
where parseWithState = do
name <- ReadP.many1 (ReadP.satisfy (\c -> c /= ','))
_ <- ReadP.char ','
state <- parse
return (UpdateRequest name state)
parseHEAD = do
name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof
return (UpdateRequest name IndexStateHead)
instance Pretty UpdateRequest where
pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s

instance Parsec UpdateRequest where
parsec = do
name <- parsec
state <- P.char ',' *> parsec <|> pure IndexStateHead
return (UpdateRequest name state)

updateAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
, HaddockFlags, TestFlags, BenchmarkFlags )
Expand All @@ -132,7 +129,7 @@ updateAction ( configFlags, configExFlags, installFlags
let repos = filter isRepoRemote $ repoContextRepos repoCtxt
repoName = remoteRepoName . repoRemote
parseArg :: String -> IO UpdateRequest
parseArg s = case simpleParse s of
parseArg s = case simpleParsec s of
Just r -> return r
Nothing -> die' verbosity $
"'v2-update' unable to parse repo: \"" ++ s ++ "\""
Expand All @@ -144,9 +141,9 @@ updateAction ( configFlags, configExFlags, installFlags
, not (r `elem` remoteRepoNames)]
unless (null unknownRepos) $
die' verbosity $ "'v2-update' repo(s): \""
++ intercalate "\", \"" unknownRepos
++ intercalate "\", \"" (map unRepoName unknownRepos)
++ "\" can not be found in known remote repo(s): "
++ intercalate ", " remoteRepoNames
++ intercalate ", " (map unRepoName remoteRepoNames)

let reposToUpdate :: [(Repo, IndexState)]
reposToUpdate = case updateRepoRequests of
Expand All @@ -162,10 +159,10 @@ updateAction ( configFlags, configExFlags, installFlags
[] -> return ()
[(remoteRepo, _)] ->
notice verbosity $ "Downloading the latest package list from "
++ repoName remoteRepo
++ unRepoName (repoName remoteRepo)
_ -> notice verbosity . unlines
$ "Downloading the latest package lists from: "
: map (("- " ++) . repoName . fst) reposToUpdate
: map (("- " ++) . unRepoName . repoName . fst) reposToUpdate

jobCtrl <- newParallelJobControl (length reposToUpdate)
mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
Expand Down Expand Up @@ -224,5 +221,4 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
when (current_ts /= nullTimestamp) $
noticeNoWrap verbosity $
"To revert to previous state run:\n" ++
" cabal v2-update '" ++ remoteRepoName (repoRemote repo)
++ "," ++ display current_ts ++ "'\n"
" cabal v2-update '" ++ prettyShow (UpdateRequest (remoteRepoName (repoRemote repo)) (IndexStateTime current_ts)) ++ "'\n"
28 changes: 18 additions & 10 deletions cabal-install/Distribution/Client/Config.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -53,6 +53,7 @@ import Distribution.Deprecated.ViewAsFieldDescr
import Distribution.Client.Types
( RemoteRepo(..), LocalRepo (..), Username(..), Password(..), emptyRemoteRepo
, AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps
, RepoName (..), unRepoName
)
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
Expand All @@ -64,8 +65,7 @@ import Distribution.Client.Setup
, initOptions
, InstallFlags(..), installOptions, defaultInstallFlags
, UploadFlags(..), uploadCommand
, ReportFlags(..), reportCommand
, showRemoteRepo, parseRemoteRepo, readRemoteRepo )
, ReportFlags(..), reportCommand )
import Distribution.Client.CmdInstall.ClientInstallFlags
( ClientInstallFlags(..), defaultClientInstallFlags
, clientInstallOptions )
Expand Down Expand Up @@ -128,6 +128,8 @@ import qualified Distribution.Deprecated.ReadP as Parse
import Distribution.Compat.Semigroup
import qualified Text.PrettyPrint as Disp
( render, text, empty )
import Distribution.Parsec (parsec, simpleParsec)
import Distribution.Pretty (pretty)
import Text.PrettyPrint
( ($+$) )
import Text.PrettyPrint.HughesPJ
Expand Down Expand Up @@ -645,8 +647,9 @@ defaultUserInstall = True
defaultRemoteRepo :: RemoteRepo
defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
where
name = "hackage.haskell.org"
uri = URI "http:" (Just (URIAuth "" name "")) "/" "" ""
str = "hackage.haskell.org"
name = RepoName str
uri = URI "http:" (Just (URIAuth "" str "")) "/" "" ""
-- Note that lots of old ~/.cabal/config files will have the old url
-- http://hackage.haskell.org/packages/archive
-- but new config files can use the new url (without the /packages/archive)
Expand Down Expand Up @@ -1037,7 +1040,7 @@ deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
deprecatedFieldDescriptions =
[ liftGlobalFlag $
listField "repos"
(Disp.text . showRemoteRepo) parseRemoteRepo
pretty parsec
(fromNubList . globalRemoteRepos)
(\rs cfg -> cfg { globalRemoteRepos = toNubList rs })
, liftGlobalFlag $
Expand Down Expand Up @@ -1196,15 +1199,17 @@ parseConfig src initial = \str -> do

parseSections (rs, ls, h, i, u, g, p, a)
(ParseUtils.Section lineno "repository" name fs) = do
r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs
name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $
simpleParsec name
r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs
r'' <- postProcessRepo lineno name r'
case r'' of
Left local -> return (rs, local:ls, h, i, u, g, p, a)
Right remote -> return (remote:rs, ls, h, i, u, g, p, a)

parseSections (rs, ls, h, i, u, g, p, a)
(ParseUtils.F lno "remote-repo" raw) = do
let mr' = readRemoteRepo raw
let mr' = simpleParsec raw
r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'
return (r':rs, ls, h, i, u, g, p, a)

Expand Down Expand Up @@ -1253,11 +1258,14 @@ parseConfig src initial = \str -> do
return accum

postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)
postProcessRepo lineno reponame repo0 = do
when (null reponame) $
postProcessRepo lineno reponameStr repo0 = do
when (null reponameStr) $
syntaxError lineno $ "a 'repository' section requires the "
++ "repository name as an argument"

reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $
simpleParsec reponameStr

case uriScheme (remoteRepoURI repo0) of
-- TODO: check that there are no authority, query or fragment
-- Note: the trailing colon is important
Expand Down Expand Up @@ -1329,7 +1337,7 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions

ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals)
ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals))
remoteRepoFields (Just def) vals

remoteRepoFields :: [FieldDescr RemoteRepo]
Expand Down
6 changes: 3 additions & 3 deletions cabal-install/Distribution/Client/GlobalFlags.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,7 @@ import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Client.Types
( Repo(..), RemoteRepo(..), LocalRepo (..), localRepoCacheKey )
( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey )
import Distribution.Simple.Setup
( Flag(..), fromFlag, flagToMaybe )
import Distribution.Utils.NubList
Expand Down Expand Up @@ -162,7 +162,7 @@ withRepoContext' verbosity remoteRepos localRepos localNoIndexRepos
sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do
for_ localNoIndexRepos $ \local ->
unless (FilePath.Posix.isAbsolute (localRepoPath local)) $
warn verbosity $ "file+noindex " ++ localRepoName local ++ " repository path is not absolute; this is fragile, and not recommended"
warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"

transportRef <- newMVar Nothing
let httpLib = Sec.HTTP.transportAdapter
Expand All @@ -185,7 +185,7 @@ withRepoContext' verbosity remoteRepos localRepos localNoIndexRepos
allRemoteRepos =
[ (if isSecure then RepoSecure else RepoRemote) remote cacheDir
| remote <- remoteRepos
, let cacheDir = sharedCacheDir </> remoteRepoName remote
, let cacheDir = sharedCacheDir </> unRepoName (remoteRepoName remote)
isSecure = remoteRepoSecure remote == Just True
]

Expand Down
6 changes: 3 additions & 3 deletions cabal-install/Distribution/Client/HttpUtils.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -43,7 +43,7 @@ import Distribution.Simple.Utils
import Distribution.Client.Utils
( withTempFileName )
import Distribution.Client.Types
( RemoteRepo(..) )
( unRepoName, RemoteRepo(..) )
import Distribution.System
( buildOS, buildArch )
import qualified System.FilePath.Posix as FilePath.Posix
Expand Down Expand Up @@ -204,8 +204,8 @@ remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps verbosity transport repo
| uriScheme (remoteRepoURI repo) == "https:"
, not (transportSupportsHttps transport)
= die' verbosity $ "The remote repository '" ++ remoteRepoName repo
++ "' specifies a URL that " ++ requiresHttpsErrorMessage
= die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo)
++ "' specifies a URL that " ++ requiresHttpsErrorMessage
| otherwise = return ()

transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
Expand Down
39 changes: 19 additions & 20 deletions cabal-install/Distribution/Client/IndexUtils.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -223,13 +223,13 @@ getSourcePackagesAtIndexState verbosity repoCtxt _
}
getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
let describeState IndexStateHead = "most recent state"
describeState (IndexStateTime time) = "historical state as of " ++ display time
describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time

pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do
let rname = case r of
RepoRemote remote _ -> remoteRepoName remote
RepoSecure remote _ -> remoteRepoName remote
RepoLocalNoIndex local _ -> localRepoName local
RepoRemote remote _ -> unRepoName $ remoteRepoName remote
RepoSecure remote _ -> unRepoName $ remoteRepoName remote
RepoLocalNoIndex local _ -> unRepoName $ localRepoName local
RepoLocal _ -> ""

info verbosity ("Reading available packages of " ++ rname ++ "...")
Expand Down Expand Up @@ -265,25 +265,24 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do

case idxState' of
IndexStateHead -> do
info verbosity ("index-state("++rname++") = " ++
display (isiHeadTime isi))
info verbosity ("index-state("++rname++") = " ++ prettyShow (isiHeadTime isi))
return ()
IndexStateTime ts0 -> do
when (isiMaxTime isi /= ts0) $
if ts0 > isiMaxTime isi
then warn verbosity $
"Requested index-state " ++ display ts0
"Requested index-state " ++ prettyShow ts0
++ " is newer than '" ++ rname ++ "'!"
++ " Falling back to older state ("
++ display (isiMaxTime isi) ++ ")."
++ prettyShow (isiMaxTime isi) ++ ")."
else info verbosity $
"Requested index-state " ++ display ts0
"Requested index-state " ++ prettyShow ts0
++ " does not exist in '"++rname++"'!"
++ " Falling back to older state ("
++ display (isiMaxTime isi) ++ ")."
++ prettyShow (isiMaxTime isi) ++ ")."
info verbosity ("index-state("++rname++") = " ++
display (isiMaxTime isi) ++ " (HEAD = " ++
display (isiHeadTime isi) ++ ")")
prettyShow (isiMaxTime isi) ++ " (HEAD = " ++
prettyShow (isiHeadTime isi) ++ ")")

pure (pis,deps)

Expand Down Expand Up @@ -346,7 +345,7 @@ readRepoIndex verbosity repoCtxt repo idxState =
++ "' is missing. The repo is invalid."
RepoLocalNoIndex local _ -> warn verbosity $
"Error during construction of local+noindex "
++ localRepoName local ++ " repository index: "
++ unRepoName (localRepoName local) ++ " repository index: "
++ show e
return (mempty,mempty,emptyStateInfo)
else ioError e
Expand All @@ -360,10 +359,10 @@ readRepoIndex verbosity repoCtxt repo idxState =
RepoLocalNoIndex {} -> return ()

errMissingPackageList repoRemote =
"The package list for '" ++ remoteRepoName repoRemote
"The package list for '" ++ unRepoName (remoteRepoName repoRemote)
++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote
errOutdatedPackageList repoRemote dt =
"The package list for '" ++ remoteRepoName repoRemote
"The package list for '" ++ unRepoName (remoteRepoName repoRemote)
++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
++ "'cabal update' to get the latest list of available packages."

Expand Down Expand Up @@ -603,7 +602,7 @@ updatePackageIndexCacheFile verbosity index = do
}
writeIndexCache index cache
info verbosity ("Index cache updated to index-state "
++ display (cacheHeadTs cache))
++ prettyShow (cacheHeadTs cache))

callbackNoIndex entries = do
writeNoIndexCache verbosity index $ NoIndexCache entries
Expand Down Expand Up @@ -687,14 +686,14 @@ withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo nam
Just ce -> return (Just ce)
Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file

info verbosity $ "Entries in file+noindex repository " ++ name
info verbosity $ "Entries in file+noindex repository " ++ unRepoName name
for_ entries $ \(CacheGPD gpd _) ->
info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)

callback entries
where
handler :: IOException -> IO a
handler e = die' verbosity $ "Error while updating index for " ++ name ++ " repository " ++ show e
handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e

isTarGz :: FilePath -> Maybe PackageIdentifier
isTarGz fp = do
Expand Down Expand Up @@ -924,7 +923,7 @@ writeNoIndexCache verbosity index cache = do
-- | Write the 'IndexState' to the filesystem
writeIndexTimestamp :: Index -> IndexState -> IO ()
writeIndexTimestamp index st
= writeFile (timestampFile index) (display st)
= writeFile (timestampFile index) (prettyShow st)

-- | Read out the "current" index timestamp, i.e., what
-- timestamp you would use to revert to this version
Expand All @@ -940,7 +939,7 @@ currentIndexTimestamp verbosity repoCtxt r = do
-- | Read the 'IndexState' from the filesystem
readIndexTimestamp :: Index -> IO (Maybe IndexState)
readIndexTimestamp index
= fmap simpleParse (readFile (timestampFile index))
= fmap simpleParsec (readFile (timestampFile index))
`catchIO` \e ->
if isDoesNotExistError e
then return Nothing
Expand Down
Loading