From 7bd14b8abaa6ef1aac08f25c525560017b0ce77a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 13 Mar 2020 14:46:43 +0200 Subject: [PATCH] Add RepoName newtype Make it, LocalRepo, RemoteRepo, IndexState and Timestamp use Pretty/Parsec instead of Text Mostly adding `unRepoName` to error printing statements --- Cabal/Distribution/Pretty.hs | 2 +- .../Distribution/Client/CmdUpdate.hs | 44 +++++----- cabal-install/Distribution/Client/Config.hs | 28 +++--- .../Distribution/Client/GlobalFlags.hs | 6 +- .../Distribution/Client/HttpUtils.hs | 6 +- .../Distribution/Client/IndexUtils.hs | 39 ++++----- .../Client/IndexUtils/Timestamp.hs | 87 +++++++++---------- cabal-install/Distribution/Client/Install.hs | 2 +- .../Client/ProjectConfig/Legacy.hs | 10 +-- cabal-install/Distribution/Client/Setup.hs | 65 ++++---------- cabal-install/Distribution/Client/Types.hs | 70 +++++++++++++-- cabal-install/Distribution/Client/Update.hs | 12 +-- cabal-install/Distribution/Client/Upload.hs | 4 +- 13 files changed, 200 insertions(+), 175 deletions(-) diff --git a/Cabal/Distribution/Pretty.hs b/Cabal/Distribution/Pretty.hs index ddf51c13652..a51fa4ca64f 100644 --- a/Cabal/Distribution/Pretty.hs +++ b/Cabal/Distribution/Pretty.hs @@ -34,7 +34,7 @@ instance Pretty a => Pretty (Identity a) where pretty = pretty . runIdentity prettyShow :: Pretty a => a -> String -prettyShow = PP.renderStyle defaultStyle . pretty +prettyShow = explicitPrettyShow . pretty -- | The default rendering style used in Cabal for console -- output. It has a fixed page width and adds line breaks diff --git a/cabal-install/Distribution/Client/CmdUpdate.hs b/cabal-install/Distribution/Client/CmdUpdate.hs index db0b7ce2a7f..b1b21023509 100644 --- a/cabal-install/Distribution/Client/CmdUpdate.hs +++ b/cabal-install/Distribution/Client/CmdUpdate.hs @@ -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 @@ -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 @@ -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 ) @@ -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 ++ "\"" @@ -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 @@ -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) @@ -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" diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 5072cab7189..f57b1f97ab1 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -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(..) ) @@ -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 ) @@ -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 @@ -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) @@ -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 $ @@ -1196,7 +1199,9 @@ 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) @@ -1204,7 +1209,7 @@ parseConfig src initial = \str -> do 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) @@ -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 @@ -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] diff --git a/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal-install/Distribution/Client/GlobalFlags.hs index fa1243bf677..9df50bdfee5 100644 --- a/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/Distribution/Client/GlobalFlags.hs @@ -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 @@ -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 @@ -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 ] diff --git a/cabal-install/Distribution/Client/HttpUtils.hs b/cabal-install/Distribution/Client/HttpUtils.hs index 6dee1c0552b..96e98cec69a 100644 --- a/cabal-install/Distribution/Client/HttpUtils.hs +++ b/cabal-install/Distribution/Client/HttpUtils.hs @@ -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 @@ -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 () diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs index b036f264874..c7c281c1f72 100644 --- a/cabal-install/Distribution/Client/IndexUtils.hs +++ b/cabal-install/Distribution/Client/IndexUtils.hs @@ -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 ++ "...") @@ -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) @@ -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 @@ -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." @@ -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 @@ -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 @@ -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 @@ -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 diff --git a/cabal-install/Distribution/Client/IndexUtils/Timestamp.hs b/cabal-install/Distribution/Client/IndexUtils/Timestamp.hs index 7ed3cd1d8e1..27fd8a7c207 100644 --- a/cabal-install/Distribution/Client/IndexUtils/Timestamp.hs +++ b/cabal-install/Distribution/Client/IndexUtils/Timestamp.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | @@ -26,15 +26,14 @@ import Distribution.Client.Compat.Prelude -- read is needed for Text instance import Prelude (read) -import qualified Codec.Archive.Tar.Entry as Tar -import Data.Time (UTCTime (..), fromGregorianValid, - makeTimeOfDayValid, showGregorian, - timeOfDayToTime, timeToTimeOfDay) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, - utcTimeToPOSIXSeconds) -import qualified Distribution.Deprecated.ReadP as ReadP -import Distribution.Deprecated.Text -import qualified Text.PrettyPrint as Disp +import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Distribution.Parsec (Parsec (..)) +import Distribution.Pretty (Pretty (..)) + +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp -- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). newtype Timestamp = TS Int64 -- Tar.EpochTime @@ -100,16 +99,18 @@ showTimestamp ts = case timestampToUTCTime ts of instance Binary Timestamp instance Structured Timestamp -instance Text Timestamp where - disp = Disp.text . showTimestamp +instance Pretty Timestamp where + pretty = Disp.text . showTimestamp - parse = parsePosix ReadP.+++ parseUTC +instance Parsec Timestamp where + parsec = parsePosix <|> parseUTC where -- | Parses unix timestamps, e.g. @"\@1474626019"@ parsePosix = do - _ <- ReadP.char '@' - t <- parseInteger - maybe ReadP.pfail return $ posixSecondsToTimestamp t + _ <- P.char '@' + t <- P.integral -- note, no negative timestamps + maybe (fail (show t ++ " is not representable as timestamp")) return $ + posixSecondsToTimestamp t -- | Parses ISO8601/RFC3339-style UTC timestamps, -- e.g. @"2017-12-31T23:59:59Z"@ @@ -120,46 +121,43 @@ instance Text Timestamp where -- we want more control over the accepted formats. ye <- parseYear - _ <- ReadP.char '-' + _ <- P.char '-' mo <- parseTwoDigits - _ <- ReadP.char '-' + _ <- P.char '-' da <- parseTwoDigits - _ <- ReadP.char 'T' + _ <- P.char 'T' - utctDay <- maybe ReadP.pfail return $ + utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $ fromGregorianValid ye mo da ho <- parseTwoDigits - _ <- ReadP.char ':' + _ <- P.char ':' mi <- parseTwoDigits - _ <- ReadP.char ':' + _ <- P.char ':' se <- parseTwoDigits - _ <- ReadP.char 'Z' + _ <- P.char 'Z' - utctDayTime <- maybe ReadP.pfail (return . timeOfDayToTime) $ + utctDayTime <- maybe (fail (show (ho,mi,se) ++ " is not valid time of day")) (return . timeOfDayToTime) $ makeTimeOfDayValid ho mi (realToFrac (se::Int)) - maybe ReadP.pfail return $ utcTimeToTimestamp (UTCTime{..}) + let utc = UTCTime {..} + + maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc parseTwoDigits = do - d1 <- ReadP.satisfy isDigit - d2 <- ReadP.satisfy isDigit + d1 <- P.satisfy isDigit + d2 <- P.satisfy isDigit return (read [d1,d2]) -- A year must have at least 4 digits; e.g. "0097" is fine, -- while "97" is not c.f. RFC3339 which -- deprecates 2-digit years parseYear = do - sign <- ReadP.option ' ' (ReadP.char '-') - ds <- ReadP.munch1 isDigit - when (length ds < 4) ReadP.pfail + sign <- P.option ' ' (P.char '-') + ds <- P.munch1 isDigit + when (length ds < 4) $ fail "Year should have at least 4 digits" return (read (sign:ds)) - parseInteger = do - sign <- ReadP.option ' ' (ReadP.char '-') - ds <- ReadP.munch1 isDigit - return (read (sign:ds) :: Integer) - -- | Special timestamp value to be used when 'timestamp' is -- missing/unknown/invalid nullTimestamp :: Timestamp @@ -178,14 +176,11 @@ instance Binary IndexState instance Structured IndexState instance NFData IndexState -instance Text IndexState where - disp IndexStateHead = Disp.text "HEAD" - disp (IndexStateTime ts) = disp ts - - parse = parseHead ReadP.+++ parseTime - where - parseHead = do - _ <- ReadP.string "HEAD" - return IndexStateHead +instance Pretty IndexState where + pretty IndexStateHead = Disp.text "HEAD" + pretty (IndexStateTime ts) = pretty ts - parseTime = IndexStateTime `fmap` parse +instance Parsec IndexState where + parsec = parseHead <|> parseTime where + parseHead = IndexStateHead <$ P.string "HEAD" + parseTime = IndexStateTime <$> parsec diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 229816d4457..90608416569 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -886,7 +886,7 @@ storeDetailedBuildReports verbosity logsDir reports = sequence_ [ do dotCabal <- getCabalDir let logFileName = prettyShow (BuildReports.package report) <.> "log" logFile = logsDir logFileName - reportsDir = dotCabal "reports" remoteRepoName remoteRepo + reportsDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) reportFile = reportsDir logFileName handleMissingLogFile $ do diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 66f009a5855..fc679ca593e 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -27,8 +27,8 @@ import Distribution.Deprecated.ParseUtils (parseFlagAssignment) import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types - ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo - , AllowNewer(..), AllowOlder(..) ) + ( RepoName (..), RemoteRepo(..), LocalRepo (..), emptyRemoteRepo + , AllowNewer(..), AllowOlder(..), unRepoName ) import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) import Distribution.Client.Config @@ -1397,7 +1397,7 @@ programDbOptions progDb showOrParseArgs get' set = remoteRepoSectionDescr :: SectionDescr GlobalFlags remoteRepoSectionDescr = SectionDescr { sectionName = "repository" - , sectionEmpty = emptyRemoteRepo "" + , sectionEmpty = emptyRemoteRepo (RepoName "") , sectionFields = remoteRepoFields , sectionSubsections = [] , sectionGet = getS @@ -1406,9 +1406,9 @@ remoteRepoSectionDescr = SectionDescr where getS :: GlobalFlags -> [(String, RemoteRepo)] getS gf = - map (\x->(remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) + map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) ++ - map (\x->(localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) + map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags setS lineno reponame repo0 conf = do diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index 8e0c11099c2..a8cbb18d6a8 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -60,10 +60,6 @@ module Distribution.Client.Setup , parsePackageArgs , liftOptions , yesNoOpt - --TODO: stop exporting these: - , showRemoteRepo - , parseRemoteRepo - , readRemoteRepo ) where import Prelude () @@ -73,7 +69,7 @@ import Distribution.Deprecated.ReadP (readP_to_E) import Distribution.Client.Types ( Username(..), Password(..), RemoteRepo(..) - , LocalRepo (..), emptyLocalRepo + , LocalRepo (..) , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , WriteGhcEnvironmentFilesPolicy(..) ) @@ -89,6 +85,8 @@ import Distribution.Client.Targets ( UserConstraint, readUserConstraint ) import Distribution.Utils.NubList ( NubList, toNubList, fromNubList) +import Distribution.Parsec (simpleParsec, parsec) +import Distribution.Pretty (prettyShow) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Settings @@ -131,9 +129,9 @@ import Distribution.System ( Platform ) import Distribution.Deprecated.Text ( Text(..), display ) import Distribution.ReadE - ( ReadE(..), succeedReadE ) + ( ReadE(..), succeedReadE, parsecToReadE ) import qualified Distribution.Deprecated.ReadP as Parse - ( ReadP, char, munch1, pfail, sepBy1, (+++) ) + ( ReadP, char, sepBy1, (+++) ) import Distribution.Deprecated.ParseUtils ( readPToMaybe ) import Distribution.Verbosity @@ -151,8 +149,6 @@ import Data.List import qualified Data.Set as Set import System.FilePath ( () ) -import Network.URI - ( parseAbsoluteURI, uriToString ) globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI { @@ -1367,12 +1363,12 @@ updateCommand = CommandUI { "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") updateIndexState (\v flags -> flags { updateIndexState = v }) - (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ + (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ "unix-timestamps (e.g. '@1474732068'), " ++ "a ISO8601 UTC timestamp " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parse)) - (flagToList . fmap display)) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) ] } @@ -1592,12 +1588,12 @@ getCommand = CommandUI { "This determines which package versions are available as well as " ++ ".cabal file revision is selected (unless --pristine is used).") getIndexState (\v flags -> flags { getIndexState = v }) - (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ + (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ "unix-timestamps (e.g. '@1474732068'), " ++ "a ISO8601 UTC timestamp " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parse)) - (flagToList . fmap display)) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) , option [] ["pristine"] ("Unpack the original pristine tarball, rather than updating the " @@ -2081,12 +2077,12 @@ installOptions showOrParseArgs = "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") installIndexState (\v flags -> flags { installIndexState = v }) - (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ + (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++ "unix-timestamps (e.g. '@1474732068'), " ++ "a ISO8601 UTC timestamp " ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") - (toFlag `fmap` parse)) - (flagToList . fmap display)) + (toFlag `fmap` parsec)) + (flagToList . fmap prettyShow)) , option [] ["root-cmd"] "(No longer supported, do not use.)" @@ -2974,41 +2970,16 @@ parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse | otherwise -> Dependency (packageName p) (thisVersion v) (Set.singleton LMainLibName) showRemoteRepo :: RemoteRepo -> String -showRemoteRepo repo = remoteRepoName repo ++ ":" - ++ uriToString id (remoteRepoURI repo) [] +showRemoteRepo = prettyShow readRemoteRepo :: String -> Maybe RemoteRepo -readRemoteRepo = readPToMaybe parseRemoteRepo - -parseRemoteRepo :: Parse.ReadP r RemoteRepo -parseRemoteRepo = do - name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") - _ <- Parse.char ':' - uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") - uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) - return RemoteRepo { - remoteRepoName = name, - remoteRepoURI = uri, - remoteRepoSecure = Nothing, - remoteRepoRootKeys = [], - remoteRepoKeyThreshold = 0, - remoteRepoShouldTryHttps = False - } +readRemoteRepo = simpleParsec showLocalRepo :: LocalRepo -> String -showLocalRepo repo = localRepoName repo ++ ":" ++ localRepoPath repo +showLocalRepo = prettyShow readLocalRepo :: String -> Maybe LocalRepo -readLocalRepo = readPToMaybe parseLocalRepo - -parseLocalRepo :: Parse.ReadP r LocalRepo -parseLocalRepo = do - name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") - _ <- Parse.char ':' - path <- Parse.munch1 (const True) - return $ (emptyLocalRepo name) - { localRepoPath = path - } +readLocalRepo = simpleParsec -- ------------------------------------------------------------ -- * Helpers for Documentation diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index aa2598480ac..d06bec24331 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -68,12 +68,16 @@ import Distribution.Deprecated.ParseUtils (parseOptCommaList) import Distribution.Simple.Utils (ordNub, toUTF8BS) import Distribution.Deprecated.Text (Text(..)) -import Network.URI (URI(..), nullURI) +import Network.URI (URI(..), nullURI, uriToString, parseAbsoluteURI) import Control.Exception (Exception, SomeException) import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.CharParsing as P import qualified Data.ByteString.Lazy.Char8 as LBS +import Distribution.Pretty (Pretty (..)) +import Distribution.Parsec (Parsec (..)) + newtype Username = Username { unUsername :: String } newtype Password = Password { unPassword :: String } @@ -268,6 +272,26 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) = -- * Package locations and repositories -- ------------------------------------------------------------ +-- | Repository name. +-- +-- May be used as path segment. +-- +newtype RepoName = RepoName String + deriving (Show, Eq, Ord, Generic) + +unRepoName :: RepoName -> String +unRepoName (RepoName n) = n + +instance Binary RepoName +instance Structured RepoName + +instance Pretty RepoName where + pretty = Disp.text . unRepoName + +instance Parsec RepoName where + parsec = RepoName <$> + P.munch1 (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.') + type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) type ResolvedPkgLoc = PackageLocation FilePath @@ -298,7 +322,7 @@ instance Structured local => Structured (PackageLocation local) data RemoteRepo = RemoteRepo { - remoteRepoName :: String, + remoteRepoName :: RepoName, remoteRepoURI :: URI, -- | Enable secure access? @@ -329,15 +353,36 @@ data RemoteRepo = instance Binary RemoteRepo instance Structured RemoteRepo +instance Pretty RemoteRepo where + pretty r = + pretty (remoteRepoName r) <<>> Disp.colon <<>> + Disp.text (uriToString id (remoteRepoURI r) []) + +-- | Note: serialised format represends 'RemoteRepo' only partially. +instance Parsec RemoteRepo where + parsec = do + name <- parsec + _ <- P.char ':' + uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") + uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr) + return RemoteRepo + { remoteRepoName = name + , remoteRepoURI = uri + , remoteRepoSecure = Nothing + , remoteRepoRootKeys = [] + , remoteRepoKeyThreshold = 0 + , remoteRepoShouldTryHttps = False + } + -- | Construct a partial 'RemoteRepo' value to fold the field parser list over. -emptyRemoteRepo :: String -> RemoteRepo +emptyRemoteRepo :: RepoName -> RemoteRepo emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False -- | /no-index/ style local repositories. -- -- https://github.com/haskell/cabal/issues/6359 data LocalRepo = LocalRepo - { localRepoName :: String + { localRepoName :: RepoName , localRepoPath :: FilePath , localRepoSharedCache :: Bool } @@ -346,8 +391,19 @@ data LocalRepo = LocalRepo instance Binary LocalRepo instance Structured LocalRepo +-- | Note: doesn't parse 'localRepoSharedCache' field. +instance Parsec LocalRepo where + parsec = do + n <- parsec + _ <- P.char ':' + p <- P.munch1 (const True) -- restrict what can be a path? + return (LocalRepo n p False) + +instance Pretty LocalRepo where + pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p + -- | Construct a partial 'LocalRepo' value to fold the field parser list over. -emptyLocalRepo :: String -> LocalRepo +emptyLocalRepo :: RepoName -> LocalRepo emptyLocalRepo name = LocalRepo name "" False -- | Calculate a cache key for local-repo. @@ -356,7 +412,7 @@ emptyLocalRepo name = LocalRepo name "" False -- all be named "local", so we add a bit of `localRepoPath` into the -- mix. localRepoCacheKey :: LocalRepo -> String -localRepoCacheKey local = localRepoName local ++ "-" ++ hashPart where +localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where hashPart = showHashValue $ truncateHash 8 $ hashValue $ LBS.fromStrict $ toUTF8BS $ localRepoPath local @@ -369,7 +425,7 @@ data Repo = RepoLocal { repoLocalDir :: FilePath } - + -- | Local repository, without index. -- -- https://github.com/haskell/cabal/issues/6359 diff --git a/cabal-install/Distribution/Client/Update.hs b/cabal-install/Distribution/Client/Update.hs index 52bb1f76c96..692437b531b 100644 --- a/cabal-install/Distribution/Client/Update.hs +++ b/cabal-install/Distribution/Client/Update.hs @@ -20,7 +20,7 @@ import Distribution.Simple.Setup import Distribution.Client.Compat.Directory ( setModificationTime ) import Distribution.Client.Types - ( Repo(..), RemoteRepo(..), maybeRepoRemote ) + ( Repo(..), RemoteRepo(..), maybeRepoRemote, unRepoName ) import Distribution.Client.HttpUtils ( DownloadResult(..) ) import Distribution.Client.FetchUtils @@ -33,8 +33,8 @@ import Distribution.Client.JobControl ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup ( RepoContext(..), UpdateFlags(..) ) -import Distribution.Deprecated.Text - ( display ) +import Distribution.Pretty + ( prettyShow ) import Distribution.Verbosity import Distribution.Simple.Utils @@ -61,10 +61,10 @@ update verbosity updateFlags repoCtxt = do [] -> return () [remoteRepo] -> notice verbosity $ "Downloading the latest package list from " - ++ remoteRepoName remoteRepo + ++ unRepoName (remoteRepoName remoteRepo) _ -> notice verbosity . unlines $ "Downloading the latest package lists from: " - : map (("- " ++) . remoteRepoName) remoteRepos + : map (("- " ++) . unRepoName . remoteRepoName) remoteRepos jobCtrl <- newParallelJobControl (length repos) mapM_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos mapM_ (\_ -> collectJob jobCtrl) repos @@ -108,4 +108,4 @@ updateRepo verbosity updateFlags repoCtxt repo = do when (current_ts /= nullTimestamp) $ noticeNoWrap verbosity $ "To revert to previous state run:\n" ++ - " cabal update --index-state='" ++ display current_ts ++ "'\n" + " cabal update --index-state='" ++ prettyShow current_ts ++ "'\n" diff --git a/cabal-install/Distribution/Client/Upload.hs b/cabal-install/Distribution/Client/Upload.hs index 1d96e4477c2..71c02f8c11d 100644 --- a/cabal-install/Distribution/Client/Upload.hs +++ b/cabal-install/Distribution/Client/Upload.hs @@ -1,7 +1,7 @@ module Distribution.Client.Upload (upload, uploadDoc, report) where import Distribution.Client.Types ( Username(..), Password(..) - , RemoteRepo(..), maybeRepoRemote ) + , RemoteRepo(..), maybeRepoRemote, unRepoName ) import Distribution.Client.HttpUtils ( HttpTransport(..), remoteRepoTryUpgradeToHttps ) import Distribution.Client.Setup @@ -177,7 +177,7 @@ report verbosity repoCtxt mUsername mPassword = do let auth = (username, password) dotCabal <- getCabalDir - let srcDir = dotCabal "reports" remoteRepoName remoteRepo + let srcDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) -- We don't want to bomb out just because we haven't built any packages -- from this repo yet. srcExists <- doesDirectoryExist srcDir