Skip to content

Commit 3257691

Browse files
phadejphadej
authored
Merge pull request #6581 from phadej/reponame-newtype
Add RepoName newtype
2 parents 2e03231 + 2d0080c commit 3257691

File tree

15 files changed

+218
-186
lines changed

15 files changed

+218
-186
lines changed

‎cabal-install/Distribution/Client/CmdUpdate.hs

Lines changed: 20 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,7 @@ import Distribution.Client.ProjectConfig
2424
, projectConfigWithSolverRepoContext
2525
, withProjectOrGlobalConfig )
2626
import Distribution.Client.Types
27-
( Repo(..), RemoteRepo(..), isRepoRemote )
27+
( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), isRepoRemote )
2828
import Distribution.Client.HttpUtils
2929
( DownloadResult(..) )
3030
import Distribution.Client.FetchUtils
@@ -45,12 +45,12 @@ import Distribution.Client.IndexUtils.Timestamp
4545
import Distribution.Client.IndexUtils
4646
( updateRepoIndexCache, Index(..), writeIndexTimestamp
4747
, currentIndexTimestamp, indexBaseName )
48-
import Distribution.Deprecated.Text
49-
( Text(..), display, simpleParse )
48+
import Distribution.Pretty (Pretty (..), prettyShow)
49+
import Distribution.Parsec (Parsec (..), simpleParsec)
5050

5151
import Data.Maybe (fromJust)
52-
import qualified Distribution.Deprecated.ReadP as ReadP
53-
import qualified Text.PrettyPrint as Disp
52+
import qualified Distribution.Compat.CharParsing as P
53+
import qualified Text.PrettyPrint as Disp
5454

5555
import Control.Monad (mapM, mapM_)
5656
import qualified Data.ByteString.Lazy as BS
@@ -100,21 +100,18 @@ updateCommand = Client.installCommand {
100100
}
101101

102102
data UpdateRequest = UpdateRequest
103-
{ _updateRequestRepoName :: String
103+
{ _updateRequestRepoName :: RepoName
104104
, _updateRequestRepoState :: IndexState
105105
} deriving (Show)
106106

107-
instance Text UpdateRequest where
108-
disp (UpdateRequest n s) = Disp.text n Disp.<> Disp.char ',' Disp.<> disp s
109-
parse = parseWithState ReadP.+++ parseHEAD
110-
where parseWithState = do
111-
name <- ReadP.many1 (ReadP.satisfy (\c -> c /= ','))
112-
_ <- ReadP.char ','
113-
state <- parse
114-
return (UpdateRequest name state)
115-
parseHEAD = do
116-
name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof
117-
return (UpdateRequest name IndexStateHead)
107+
instance Pretty UpdateRequest where
108+
pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s
109+
110+
instance Parsec UpdateRequest where
111+
parsec = do
112+
name <- parsec
113+
state <- P.char ',' *> parsec <|> pure IndexStateHead
114+
return (UpdateRequest name state)
118115

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

151148
let reposToUpdate :: [(Repo, IndexState)]
152149
reposToUpdate = case updateRepoRequests of
@@ -162,10 +159,10 @@ updateAction ( configFlags, configExFlags, installFlags
162159
[] -> return ()
163160
[(remoteRepo, _)] ->
164161
notice verbosity $ "Downloading the latest package list from "
165-
++ repoName remoteRepo
162+
++ unRepoName (repoName remoteRepo)
166163
_ -> notice verbosity . unlines
167164
$ "Downloading the latest package lists from: "
168-
: map (("- " ++) . repoName . fst) reposToUpdate
165+
: map (("- " ++) . unRepoName . repoName . fst) reposToUpdate
169166

170167
jobCtrl <- newParallelJobControl (length reposToUpdate)
171168
mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
@@ -224,5 +221,4 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
224221
when (current_ts /= nullTimestamp) $
225222
noticeNoWrap verbosity $
226223
"To revert to previous state run:\n" ++
227-
" cabal v2-update '" ++ remoteRepoName (repoRemote repo)
228-
++ "," ++ display current_ts ++ "'\n"
224+
" cabal v2-update '" ++ prettyShow (UpdateRequest (remoteRepoName (repoRemote repo)) (IndexStateTime current_ts)) ++ "'\n"

‎cabal-install/Distribution/Client/Config.hs

Lines changed: 18 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -53,6 +53,7 @@ import Distribution.Deprecated.ViewAsFieldDescr
5353
import Distribution.Client.Types
5454
( RemoteRepo(..), LocalRepo (..), Username(..), Password(..), emptyRemoteRepo
5555
, AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps
56+
, RepoName (..), unRepoName
5657
)
5758
import Distribution.Client.BuildReports.Types
5859
( ReportLevel(..) )
@@ -64,8 +65,7 @@ import Distribution.Client.Setup
6465
, initOptions
6566
, InstallFlags(..), installOptions, defaultInstallFlags
6667
, UploadFlags(..), uploadCommand
67-
, ReportFlags(..), reportCommand
68-
, showRemoteRepo, parseRemoteRepo, readRemoteRepo )
68+
, ReportFlags(..), reportCommand )
6969
import Distribution.Client.CmdInstall.ClientInstallFlags
7070
( ClientInstallFlags(..), defaultClientInstallFlags
7171
, clientInstallOptions )
@@ -128,6 +128,8 @@ import qualified Distribution.Deprecated.ReadP as Parse
128128
import Distribution.Compat.Semigroup
129129
import qualified Text.PrettyPrint as Disp
130130
( render, text, empty )
131+
import Distribution.Parsec (parsec, simpleParsec)
132+
import Distribution.Pretty (pretty)
131133
import Text.PrettyPrint
132134
( ($+$) )
133135
import Text.PrettyPrint.HughesPJ
@@ -645,8 +647,9 @@ defaultUserInstall = True
645647
defaultRemoteRepo :: RemoteRepo
646648
defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
647649
where
648-
name = "hackage.haskell.org"
649-
uri = URI "http:" (Just (URIAuth "" name "")) "/" "" ""
650+
str = "hackage.haskell.org"
651+
name = RepoName str
652+
uri = URI "http:" (Just (URIAuth "" str "")) "/" "" ""
650653
-- Note that lots of old ~/.cabal/config files will have the old url
651654
-- http://hackage.haskell.org/packages/archive
652655
-- but new config files can use the new url (without the /packages/archive)
@@ -1037,7 +1040,7 @@ deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
10371040
deprecatedFieldDescriptions =
10381041
[ liftGlobalFlag $
10391042
listField "repos"
1040-
(Disp.text . showRemoteRepo) parseRemoteRepo
1043+
pretty parsec
10411044
(fromNubList . globalRemoteRepos)
10421045
(\rs cfg -> cfg { globalRemoteRepos = toNubList rs })
10431046
, liftGlobalFlag $
@@ -1196,15 +1199,17 @@ parseConfig src initial = \str -> do
11961199

11971200
parseSections (rs, ls, h, i, u, g, p, a)
11981201
(ParseUtils.Section lineno "repository" name fs) = do
1199-
r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs
1202+
name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $
1203+
simpleParsec name
1204+
r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs
12001205
r'' <- postProcessRepo lineno name r'
12011206
case r'' of
12021207
Left local -> return (rs, local:ls, h, i, u, g, p, a)
12031208
Right remote -> return (remote:rs, ls, h, i, u, g, p, a)
12041209

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

@@ -1253,11 +1258,14 @@ parseConfig src initial = \str -> do
12531258
return accum
12541259

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

1266+
reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $
1267+
simpleParsec reponameStr
1268+
12611269
case uriScheme (remoteRepoURI repo0) of
12621270
-- TODO: check that there are no authority, query or fragment
12631271
-- Note: the trailing colon is important
@@ -1329,7 +1337,7 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
13291337
installDirsFields = map viewAsFieldDescr installDirsOptions
13301338

13311339
ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
1332-
ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals)
1340+
ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals))
13331341
remoteRepoFields (Just def) vals
13341342

13351343
remoteRepoFields :: [FieldDescr RemoteRepo]

‎cabal-install/Distribution/Client/GlobalFlags.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ import Prelude ()
1717
import Distribution.Client.Compat.Prelude
1818

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

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

‎cabal-install/Distribution/Client/HttpUtils.hs

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ import Distribution.Simple.Utils
4343
import Distribution.Client.Utils
4444
( withTempFileName )
4545
import Distribution.Client.Types
46-
( RemoteRepo(..) )
46+
( unRepoName, RemoteRepo(..) )
4747
import Distribution.System
4848
( buildOS, buildArch )
4949
import qualified System.FilePath.Posix as FilePath.Posix
@@ -204,8 +204,8 @@ remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
204204
remoteRepoCheckHttps verbosity transport repo
205205
| uriScheme (remoteRepoURI repo) == "https:"
206206
, not (transportSupportsHttps transport)
207-
= die' verbosity $ "The remote repository '" ++ remoteRepoName repo
208-
++ "' specifies a URL that " ++ requiresHttpsErrorMessage
207+
= die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo)
208+
++ "' specifies a URL that " ++ requiresHttpsErrorMessage
209209
| otherwise = return ()
210210

211211
transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()

‎cabal-install/Distribution/Client/IndexUtils.hs

Lines changed: 19 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -223,13 +223,13 @@ getSourcePackagesAtIndexState verbosity repoCtxt _
223223
}
224224
getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
225225
let describeState IndexStateHead = "most recent state"
226-
describeState (IndexStateTime time) = "historical state as of " ++ display time
226+
describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
227227

228228
pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do
229229
let rname = case r of
230-
RepoRemote remote _ -> remoteRepoName remote
231-
RepoSecure remote _ -> remoteRepoName remote
232-
RepoLocalNoIndex local _ -> localRepoName local
230+
RepoRemote remote _ -> unRepoName $ remoteRepoName remote
231+
RepoSecure remote _ -> unRepoName $ remoteRepoName remote
232+
RepoLocalNoIndex local _ -> unRepoName $ localRepoName local
233233
RepoLocal _ -> ""
234234

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

266266
case idxState' of
267267
IndexStateHead -> do
268-
info verbosity ("index-state("++rname++") = " ++
269-
display (isiHeadTime isi))
268+
info verbosity ("index-state("++rname++") = " ++ prettyShow (isiHeadTime isi))
270269
return ()
271270
IndexStateTime ts0 -> do
272271
when (isiMaxTime isi /= ts0) $
273272
if ts0 > isiMaxTime isi
274273
then warn verbosity $
275-
"Requested index-state " ++ display ts0
274+
"Requested index-state " ++ prettyShow ts0
276275
++ " is newer than '" ++ rname ++ "'!"
277276
++ " Falling back to older state ("
278-
++ display (isiMaxTime isi) ++ ")."
277+
++ prettyShow (isiMaxTime isi) ++ ")."
279278
else info verbosity $
280-
"Requested index-state " ++ display ts0
279+
"Requested index-state " ++ prettyShow ts0
281280
++ " does not exist in '"++rname++"'!"
282281
++ " Falling back to older state ("
283-
++ display (isiMaxTime isi) ++ ")."
282+
++ prettyShow (isiMaxTime isi) ++ ")."
284283
info verbosity ("index-state("++rname++") = " ++
285-
display (isiMaxTime isi) ++ " (HEAD = " ++
286-
display (isiHeadTime isi) ++ ")")
284+
prettyShow (isiMaxTime isi) ++ " (HEAD = " ++
285+
prettyShow (isiHeadTime isi) ++ ")")
287286

288287
pure (pis,deps)
289288

@@ -346,7 +345,7 @@ readRepoIndex verbosity repoCtxt repo idxState =
346345
++ "' is missing. The repo is invalid."
347346
RepoLocalNoIndex local _ -> warn verbosity $
348347
"Error during construction of local+noindex "
349-
++ localRepoName local ++ " repository index: "
348+
++ unRepoName (localRepoName local) ++ " repository index: "
350349
++ show e
351350
return (mempty,mempty,emptyStateInfo)
352351
else ioError e
@@ -360,10 +359,10 @@ readRepoIndex verbosity repoCtxt repo idxState =
360359
RepoLocalNoIndex {} -> return ()
361360

362361
errMissingPackageList repoRemote =
363-
"The package list for '" ++ remoteRepoName repoRemote
362+
"The package list for '" ++ unRepoName (remoteRepoName repoRemote)
364363
++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote
365364
errOutdatedPackageList repoRemote dt =
366-
"The package list for '" ++ remoteRepoName repoRemote
365+
"The package list for '" ++ unRepoName (remoteRepoName repoRemote)
367366
++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
368367
++ "'cabal update' to get the latest list of available packages."
369368

@@ -603,7 +602,7 @@ updatePackageIndexCacheFile verbosity index = do
603602
}
604603
writeIndexCache index cache
605604
info verbosity ("Index cache updated to index-state "
606-
++ display (cacheHeadTs cache))
605+
++ prettyShow (cacheHeadTs cache))
607606

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

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

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

699698
isTarGz :: FilePath -> Maybe PackageIdentifier
700699
isTarGz fp = do
@@ -924,7 +923,7 @@ writeNoIndexCache verbosity index cache = do
924923
-- | Write the 'IndexState' to the filesystem
925924
writeIndexTimestamp :: Index -> IndexState -> IO ()
926925
writeIndexTimestamp index st
927-
= writeFile (timestampFile index) (display st)
926+
= writeFile (timestampFile index) (prettyShow st)
928927

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

0 commit comments

Comments
 (0)