Skip to content

Commit

Permalink
Merge pull request #6581 from phadej/reponame-newtype
Browse files Browse the repository at this point in the history 
Add RepoName newtype
  • Loading branch information
@phadej
phadej authored Mar 13, 2020
2 parents 2e03231 + 2d0080c commit 3257691
Show file tree
Hide file tree
Showing 15 changed files with 218 additions and 186 deletions.
44 changes: 20 additions & 24 deletions cabal-install/Distribution/Client/CmdUpdate.hs
View file
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
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
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
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
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

0 comments on commit 3257691

Please sign in to comment.