diff --git a/Distribution/Client/UploadLog.hs b/Distribution/Client/UploadLog.hs index 959bcc1b4..c7cd31219 100644 --- a/Distribution/Client/UploadLog.hs +++ b/Distribution/Client/UploadLog.hs @@ -28,6 +28,10 @@ import Distribution.Package ( PackageId, PackageName, packageName, PackageIdentifier(..)) import Distribution.Text ( Text(..), simpleParse ) +import Distribution.Pretty (Pretty(..)) +-- import Distribution.Parsec.Class (Parsec(..)) +-- import qualified Distribution.Parsec.Class as P +-- import qualified Distribution.Compat.CharParsing as P import Distribution.ParseUtils ( parseMaybeQuoted ) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp @@ -50,6 +54,7 @@ import Data.List data Entry = Entry UTCTime UserName PackageIdentifier deriving (Eq, Ord, Show) +-- TODO: remove this instance for Cabal 3.0 instance Text Entry where disp (Entry time user pkgid) = Disp.text (formatTime defaultTimeLocale "%c" time) @@ -65,6 +70,28 @@ instance Text Entry where let pkgid = PackageIdentifier pkg ver return (Entry (zonedTimeToUTC time) user pkgid) +instance Pretty Entry where + pretty (Entry time user pkgid) = + Disp.text (formatTime defaultTimeLocale "%c" time) + <+> pretty user <+> pretty pkgid + +{- TODO + +instance Parsec Entry where + parse = do + -- parseDateTimeFmt parses "%a %b %e %H:%M:%S %Z %Y", + time <- parseDateTimeFmt + P.skipSpaces1 + user <- parsec + P.skipSpaces1 + pkg <- parseMaybeQuoted parse + P.skipSpaces + ver <- parsec + let pkgid = PackageIdentifier pkg ver + return (Entry (zonedTimeToUTC time) user pkgid) + +-} + -- | Returns a list of log entries, however some packages have been uploaded -- more than once, so each entry is paired with any older entries for the same -- package. diff --git a/Distribution/Server/Features/BuildReports/BuildReports.hs b/Distribution/Server/Features/BuildReports/BuildReports.hs index 22ea31976..2bf7b618f 100644 --- a/Distribution/Server/Features/BuildReports/BuildReports.hs +++ b/Distribution/Server/Features/BuildReports/BuildReports.hs @@ -23,6 +23,11 @@ import Distribution.Server.Features.BuildReports.BuildReport import Distribution.Package (PackageId) import Distribution.Text (Text(..), display) +import Distribution.Pretty (Pretty(..)) +import Distribution.Parsec.Class (Parsec(..)) +import qualified Distribution.Parsec.Class as P +import qualified Distribution.Compat.Parsing as P +import qualified Distribution.Compat.CharParsing as P import Distribution.Server.Framework.MemSize import Distribution.Server.Framework.Instances @@ -34,6 +39,8 @@ import Data.Serialize (Serialize) import Data.SafeCopy import Data.Typeable (Typeable) import Control.Applicative ((<$>)) +import qualified Data.List as L +import qualified Data.Char as Char import qualified Distribution.Server.Util.Parse as Parse import qualified Text.PrettyPrint as Disp @@ -41,15 +48,32 @@ import Text.StringTemplate (ToSElem(..)) newtype BuildReportId = BuildReportId Int - deriving (Eq, Ord, Typeable, Show, MemSize) + deriving (Eq, Ord, Typeable, Show, MemSize, Pretty) incrementReportId :: BuildReportId -> BuildReportId incrementReportId (BuildReportId n) = BuildReportId (n+1) +-- TODO: remove this instance for Cabal 3.0 instance Text BuildReportId where disp (BuildReportId n) = Disp.int n parse = BuildReportId <$> Parse.int +-- TODO: factor out common code +instance Parsec BuildReportId where + -- parse a non-negative integer. No redundant leading zeros allowed. + -- (this is effectively a relabeled versionDigitParser) + parsec = (P.some d >>= (fmap BuildReportId . toNumber)) P. "BuildReportId (natural number without redunant leading zeroes)" + where + toNumber :: P.CabalParsing m => [Int] -> m Int + toNumber [0] = return 0 + toNumber (0:_) = P.unexpected "BuildReportId with redundant leading zero" + -- TODO: Add sanity check this doesn't overflow + toNumber xs = return $ L.foldl' (\a b -> a * 10 + b) 0 xs + + d :: P.CharParsing m => m Int + d = f <$> P.satisfyRange '0' '9' + f c = Char.ord c - Char.ord '0' + newtype BuildLog = BuildLog BlobStorage.BlobId deriving (Eq, Typeable, Show, MemSize) diff --git a/Distribution/Server/Framework/Instances.hs b/Distribution/Server/Framework/Instances.hs index 8efb2d0cf..28fa1ce4e 100644 --- a/Distribution/Server/Framework/Instances.hs +++ b/Distribution/Server/Framework/Instances.hs @@ -28,9 +28,12 @@ import Distribution.Types.PackageName import Distribution.Version import Distribution.Pretty (Pretty(pretty), prettyShow) import Distribution.Parsec.Class (Parsec(..), simpleParsec) +import qualified Distribution.Compat.CharParsing as P -import Data.Time (Day(..), DiffTime, UTCTime(..)) +import Data.Time (Day(..), DiffTime, UTCTime(..), fromGregorianValid) import Control.DeepSeq +import qualified Data.Char as Char +import Text.Read (readMaybe) import Data.Serialize as Serialize import Data.SafeCopy hiding (Version) @@ -307,9 +310,54 @@ instance Text UTCTime where instance Pretty Day where pretty = PP.text . show +instance Parsec Day where + parsec = do + -- imitate grammar of Read instance of 'Day' (i.e. "%Y-%m-%d") + yyyy <- P.integral + P.char '-' + mm <- replicateM 2 P.digit + P.char '-' + dd <- replicateM 2 P.digit + case fromGregorianValid yyyy (read mm) (read dd) of + Nothing -> fail "invalid Day" + Just day -> return day + instance Pretty UTCTime where pretty = PP.text . show + +instance Parsec UTCTime where + parsec = do + -- "%Y-%m-%d %H:%M:%S%Q%Z" + yyyy <- P.munch1 Char.isDigit + P.char '-' + mm <- digit2 + P.char '-' + dd <- digit2 + + P.skipSpaces1 + + h <- digit2 + P.char ':' + m <- digit2 + P.char ':' + s <- digit2 + + mq <- optional (liftM2 (:) (P.char '.') (P.munch Char.isDigit)) + + P.spaces + + -- TODO: more accurate timezone grammar + mtz <- optional (liftM2 (:) (P.satisfy (\c -> Char.isAsciiLower c || Char.isAsciiUpper c || c == '+' || c == '-')) + (P.munch (\c -> Char.isAsciiLower c || Char.isAsciiUpper c || Char.isDigit c))) + + let tstr = concat [ yyyy, "-", mm, "-", dd, " ", h, ":", m, ":", s, maybe "" id mq, maybe "" (' ':) mtz ] + + case readMaybe tstr of + Nothing -> fail "invalid UTCTime" + Just t -> return t + where + digit2 = replicateM 2 P.digit ------------------- -- Arbitrary instances -- diff --git a/Distribution/Server/Packages/Unpack.hs b/Distribution/Server/Packages/Unpack.hs index 1e9d66fb4..e061da26c 100644 --- a/Distribution/Server/Packages/Unpack.hs +++ b/Distribution/Server/Packages/Unpack.hs @@ -35,6 +35,10 @@ import Distribution.Parsec.Common ( showPError, showPWarning ) import Distribution.Text ( Text(..), display, simpleParse ) +import Distribution.Pretty (Pretty(..)) +-- import Distribution.Parsec.Class (Parsec(..)) +-- import qualified Distribution.Parsec.Class as P +-- import qualified Distribution.Compat.CharParsing as P import Distribution.Server.Util.ParseSpecVer import qualified Distribution.SPDX as SPDX import qualified Distribution.License as License @@ -101,11 +105,15 @@ unpackPackageRaw tarGzFile contents = where noTime = UTCTime (fromGregorian 1970 1 1) 0 +-- | Denotes a PackageId with extra version tags +-- +-- See also 893de51faf7802db007eedba7d1471da95863c3b which introduced 'TaggedPackageId' data TaggedPackageId = TaggedPackageId { _taggedPkgName :: PackageName, taggedPkgVersion :: Data.Version.Version } +-- TODO: remove this instance for Cabal 3.0 instance Text TaggedPackageId where disp (TaggedPackageId n v) | v == Data.Version.Version [] [] = disp n @@ -116,6 +124,14 @@ instance Text TaggedPackageId where v <- (Parse.char '-' >> parse) Parse.<++ return (Data.Version.Version [] []) return (TaggedPackageId n v) +instance Pretty TaggedPackageId where + pretty (TaggedPackageId n v) + | v == Data.Version.Version [] [] = pretty n + | otherwise = pretty n Disp.<> Disp.char '-' Disp.<> Disp.text (Data.Version.showVersion v) + +-- TODO: 'instance Parsec TaggedPackageId' +-- see also 893de51faf7802db007eedba7d1471da95863c3b which introduced 'TaggedPackageId' for why this is tricky + tarPackageChecks :: Bool -> UTCTime -> FilePath -> ByteString -> UploadMonad (PackageIdentifier, TarIndex) tarPackageChecks lax now tarGzFile contents = do