diff --git a/src/Distribution/Server/Features/Core/State.hs b/src/Distribution/Server/Features/Core/State.hs index 91dd51c47..401eb5132 100644 --- a/src/Distribution/Server/Features/Core/State.hs +++ b/src/Distribution/Server/Features/Core/State.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} module Distribution.Server.Features.Core.State ( -- * DB state @@ -33,6 +34,7 @@ import Distribution.Server.Users.Types (UserId, UserName(..), UserInfo(..)) import Distribution.Server.Users.Users (Users, lookupUserId) import Distribution.Server.Framework.MemSize +import Data.Coerce (Coercible, coerce) import Data.Acid (Query, Update, makeAcidic) import Data.SafeCopy (Migrate(..), base, extension, deriveSafeCopy) import Control.Monad.Reader @@ -103,7 +105,7 @@ addPackage2 pkgid cabalfile uploadinfo@(timestamp, uid) username mtarball = do Nothing -> do let !pkginfo = mkPackageInfo pkgid cabalfile uploadinfo mtarball pkgindex' = PackageIndex.insert pkginfo pkgindex - !pkgentry = CabalFileEntry pkgid 0 timestamp uid username + !pkgentry = CabalFileEntry pkgid (MetadataRevIx 0) timestamp uid username updatelog' = fmap (Seq.|> pkgentry) updatelog State.put $! PackagesState pkgindex' updatelog' return (Just pkginfo) @@ -116,7 +118,7 @@ addPackage3 !pkginfo (timestamp,uid) username entries = do Just _ -> return False Nothing -> do let pkgindex' = PackageIndex.insert pkginfo pkgindex - !pkgentry = CabalFileEntry (pkgInfoId pkginfo) 0 timestamp uid username + !pkgentry = CabalFileEntry (pkgInfoId pkginfo) (MetadataRevIx 0) timestamp uid username updatelog' = fmap (\ul -> foldr (\e s -> s Seq.|> e) ul (pkgentry:entries)) updatelog State.put $! PackagesState pkgindex' updatelog' return True @@ -160,7 +162,7 @@ addPackageRevision2 pkgid cabalfile uploadinfo@(timestamp, uid) username = do `Vec.snoc` (cabalfile, uploadinfo) } pkgindex' = PackageIndex.insert pkginfo' pkgindex - newrevision = Vec.length (pkgMetadataRevisions pkginfo) + newrevision = MetadataRevIx $ Vec.length (pkgMetadataRevisions pkginfo) !pkgentry = CabalFileEntry pkgid newrevision timestamp uid username updatelog' = fmap (Seq.|> pkgentry) updatelog State.put $! PackagesState pkgindex' updatelog' @@ -172,7 +174,7 @@ addPackageRevision2 pkgid cabalfile uploadinfo@(timestamp, uid) username = do pkgTarballRevisions = Vec.empty } pkgindex' = PackageIndex.insert pkginfo pkgindex - !pkgentry = CabalFileEntry pkgid 0 timestamp uid username + !pkgentry = CabalFileEntry pkgid (MetadataRevIx 0) timestamp uid username updatelog' = fmap (Seq.|> pkgentry) updatelog State.put $! PackagesState pkgindex' updatelog' return (Nothing, pkginfo) @@ -279,11 +281,11 @@ initialUpdateLog oldExtras users pkgs = where pkgId = pkgInfoId pkgInfo - entryCabal :: PackageId -> (Int, (a, UploadInfo)) -> TarIndexEntry + entryCabal :: PackageId -> (MetadataRevIx, (a, UploadInfo)) -> TarIndexEntry entryCabal pkgId (revNo, (_cabalFile, (timestamp, uid))) = CabalFileEntry pkgId revNo timestamp uid (uidToName uid) - entryTUF :: PackageId -> (Int, (a, UploadInfo)) -> TarIndexEntry + entryTUF :: PackageId -> (TarballRevIx, (a, UploadInfo)) -> TarIndexEntry entryTUF pkgId (revNo, (_tarball, (timestamp, _uid))) = MetadataEntry pkgId revNo timestamp @@ -295,8 +297,8 @@ initialUpdateLog oldExtras users pkgs = entryTimestamp (MetadataEntry _ _ timestamp ) = timestamp entryTimestamp (ExtraEntry _ _ timestamp ) = timestamp - vecToList :: Vec.Vector a -> [(Int, a)] - vecToList = zip [0..] . Vec.toList + vecToList :: Coercible Int ix => Vec.Vector a -> [(ix, a)] + vecToList = coerce . zip [(0 :: Int)..] . Vec.toList ------------------------------------------------------------------------------ diff --git a/src/Distribution/Server/Features/PackageInfoJSON.hs b/src/Distribution/Server/Features/PackageInfoJSON.hs index 665bd076e..91f9b5cfc 100644 --- a/src/Distribution/Server/Features/PackageInfoJSON.hs +++ b/src/Distribution/Server/Features/PackageInfoJSON.hs @@ -38,7 +38,7 @@ import qualified Distribution.Server.Framework as Framework import Distribution.Server.Features.Core (CoreFeature(..), CoreResource(..)) import qualified Distribution.Server.Features.PreferredVersions as Preferred -import Distribution.Server.Packages.Types (CabalFileText(..), pkgSpecificRevision, pkgLatestRevision, pkgMaxRevision, pkgNumRevisions) +import Distribution.Server.Packages.Types (CabalFileText(..), MetadataRevIx(..), pkgSpecificRevision, pkgLatestRevision, pkgMaxRevision, pkgNumRevisions) import Distribution.Utils.ShortText (fromShortText) import Data.Foldable (toList) @@ -55,7 +55,7 @@ data PackageBasicDescription = PackageBasicDescription , pbd_description :: !T.Text , pbd_author :: !T.Text , pbd_homepage :: !T.Text - , pbd_metadata_revision :: !Int + , pbd_metadata_revision :: !MetadataRevIx , pbd_uploaded_at :: !UTCTime } deriving (Eq, Show) @@ -69,7 +69,7 @@ data PackageBasicDescriptionDTO = PackageBasicDescriptionDTO , description :: !T.Text , author :: !T.Text , homepage :: !T.Text - , metadata_revision :: !Int + , metadata_revision :: !MetadataRevIx , uploaded_at :: !UTCTime , uploader :: !UserName } deriving (Eq, Show) @@ -173,7 +173,7 @@ getBasicDescription :: UTCTime -- ^ Time of upload -> CabalFileText - -> Int + -> MetadataRevIx -- ^ Metadata revision. This will be added to the resulting -- @PackageBasicDescription@ -> Either String PackageBasicDescription @@ -225,7 +225,7 @@ servePackageBasicDescription -> Framework.ServerPartE Framework.Response servePackageBasicDescription resource userFeature preferred dpath = do - let metadataRev :: Maybe Int = lookup "revision" dpath >>= Framework.fromReqURI + let metadataRev :: Maybe MetadataRevIx = lookup "revision" dpath >>= Framework.fromReqURI pkgid@(PackageIdentifier name version) <- packageInPath resource dpath guardValidPackageName resource name @@ -238,7 +238,7 @@ servePackageBasicDescription resource userFeature preferred dpath = do fetchDescr :: PackageIdentifier - -> Maybe Int + -> Maybe MetadataRevIx -> Framework.ServerPartE Framework.Response fetchDescr pkgid metadataRev = do guardValidPackageId resource pkgid diff --git a/src/Distribution/Server/Features/Security.hs b/src/Distribution/Server/Features/Security.hs index 91a178401..71780d0ce 100644 --- a/src/Distribution/Server/Features/Security.hs +++ b/src/Distribution/Server/Features/Security.hs @@ -85,7 +85,7 @@ initSecurityFeature env = do case pkgLatestTarball pkgInfo of Nothing -> [] Just (_tarball, (uploadTime, _uploadUserId), latestRev) -> - [MetadataEntry (pkgInfoId pkgInfo) latestRev uploadTime] + [MetadataEntry (pkgInfoId pkgInfo) (TarballRevIx latestRev) uploadTime] -- | The main security feature -- diff --git a/src/Distribution/Server/Packages/Index.hs b/src/Distribution/Server/Packages/Index.hs index 55a87de59..76ac2098f 100644 --- a/src/Distribution/Server/Packages/Index.hs +++ b/src/Distribution/Server/Packages/Index.hs @@ -17,6 +17,7 @@ import Distribution.Server.Framework.MemSize import Distribution.Server.Packages.Types ( CabalFileText(..), PkgInfo(..) + , TarballRevIx, MetadataRevIx , pkgSpecificRevision , pkgLatestCabalFileText, pkgLatestUploadInfo ) @@ -57,7 +58,7 @@ data TarIndexEntry = -- can also be changed (this is used during mirroring, for instance). -- -- The UTCTime and userName are used as file metadata in the tarball. - CabalFileEntry !PackageId !RevisionNo !UTCTime !UserId !UserName + CabalFileEntry !PackageId !MetadataRevIx !UTCTime !UserId !UserName -- | Package metadata -- @@ -69,7 +70,7 @@ data TarIndexEntry = -- Although we do not currently allow to change the upload time for package -- tarballs, but I'm not sure why not (TODO) and it's conceivable we may -- change this, so we record the original upload time. - | MetadataEntry !PackageId !RevisionNo !UTCTime + | MetadataEntry !PackageId !TarballRevIx !UTCTime -- | Additional entries that we add to the tarball -- @@ -77,8 +78,6 @@ data TarIndexEntry = | ExtraEntry !FilePath !LazyByteString !UTCTime deriving (Eq, Show) -type RevisionNo = Int - instance MemSize TarIndexEntry where memSize (CabalFileEntry a b c d e) = memSize5 a b c d e memSize (MetadataEntry a b c) = memSize3 a b c diff --git a/src/Distribution/Server/Packages/Metadata.hs b/src/Distribution/Server/Packages/Metadata.hs index 7f6f6662c..11239225b 100644 --- a/src/Distribution/Server/Packages/Metadata.hs +++ b/src/Distribution/Server/Packages/Metadata.hs @@ -24,8 +24,8 @@ import qualified Hackage.Security.TUF.FileMap as Sec.FileMap -- -- Revisions numbers count from 0; we use the revision number as is for the -- TUF file version. -computePkgMetadata :: PkgInfo -- ^ Package - -> Int -- ^ Tarball revision +computePkgMetadata :: PkgInfo -- ^ Package + -> TarballRevIx -- ^ Tarball revision -> (FilePath, BS.Lazy.ByteString) computePkgMetadata pkg revNo = (inIndexPkgMetadata pkgId, raw) where @@ -35,9 +35,9 @@ computePkgMetadata pkg revNo = (inIndexPkgMetadata pkgId, raw) signed = Sec.withSignatures' [] targets raw = Sec.renderJSON_NoLayout signed -pkgTarballTargets :: Int -> PackageIdentifier -> PkgTarball -> Sec.Targets +pkgTarballTargets :: TarballRevIx -> PackageIdentifier -> PkgTarball -> Sec.Targets pkgTarballTargets revNo pkgId pkgTarball = Sec.Targets { - targetsVersion = Sec.FileVersion (fromIntegral revNo) + targetsVersion = Sec.FileVersion (fromIntegral $ getTarballRevIx revNo) , targetsExpires = Sec.expiresNever , targetsTargets = Sec.FileMap.fromList [ (inRepoPkgTarGz pkgId, secFileInfo pkgTarballGz) diff --git a/src/Distribution/Server/Packages/Render.hs b/src/Distribution/Server/Packages/Render.hs index 22506cd43..83eed1675 100644 --- a/src/Distribution/Server/Packages/Render.hs +++ b/src/Distribution/Server/Packages/Render.hs @@ -87,7 +87,7 @@ data PackageRender = PackageRender { rendChangeLog :: Maybe (FilePath, ETag, TarEntryOffset, FilePath), rendReadme :: Maybe (FilePath, ETag, TarEntryOffset, FilePath), rendUploadInfo :: (UTCTime, Maybe UserInfo), - rendUpdateInfo :: Maybe (Int, UTCTime, Maybe UserInfo), + rendUpdateInfo :: Maybe (MetadataRevIx, UTCTime, Maybe UserInfo), rendPkgUri :: String, rendFlags :: [PackageFlag], -- rendOther contains other useful fields which are merely strings, possibly empty @@ -127,7 +127,7 @@ doPackageRender users info = PackageRender , rendUpdateInfo = let maxrevision = pkgMaxRevision info (utime, uid) = pkgLatestUploadInfo info uinfo = Users.lookupUserId uid users - in if maxrevision > 0 + in if maxrevision > MetadataRevIx 0 then Just (maxrevision, utime, uinfo) else Nothing , rendPkgUri = pkgUri diff --git a/src/Distribution/Server/Packages/Types.hs b/src/Distribution/Server/Packages/Types.hs index abe4e93df..9da48e183 100644 --- a/src/Distribution/Server/Packages/Types.hs +++ b/src/Distribution/Server/Packages/Types.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, StandaloneDeriving, TemplateHaskell, TypeFamilies, RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : Distribution.Server.Packages.Types @@ -17,6 +19,7 @@ module Distribution.Server.Packages.Types where import Distribution.Server.Prelude +import Distribution.Server.Framework (FromReqURI(..)) import Distribution.Server.Users.Types (UserId(..)) import Distribution.Server.Framework.BlobStorage (BlobId, BlobId_v0, BlobStorage) import Distribution.Server.Framework.Instances (PackageIdentifier_v0) @@ -34,6 +37,7 @@ import Distribution.PackageDescription import Distribution.PackageDescription.Parsec ( parseGenericPackageDescription, runParseResult ) +import Data.Aeson (ToJSON) import Data.Serialize (Serialize) import Data.ByteString (StrictByteString) import Data.ByteString.Lazy (LazyByteString) @@ -158,6 +162,22 @@ instance Package PkgInfo where Utility -------------------------------------------------------------------------------} +newtype MetadataRevIx = MetadataRevIx { getMetadataRevIx :: Int } + deriving newtype (Eq, Ord, Show, MemSize, Read, FromReqURI, ToJSON, Serialize) + +instance SafeCopy MetadataRevIx where + getCopy = contain Serialize.get + putCopy = contain . Serialize.put + errorTypeName _ = "MetadataRevIx" + +newtype TarballRevIx = TarballRevIx { getTarballRevIx :: Int } + deriving newtype (Eq, Ord, Show, MemSize, Read, FromReqURI, ToJSON, Serialize) + +instance SafeCopy TarballRevIx where + getCopy = contain Serialize.get + putCopy = contain . Serialize.put + errorTypeName _ = "TarballRevIx" + cabalFileString :: CabalFileText -> String cabalFileString = unpackUTF8Strict . cabalFileByteString @@ -176,14 +196,14 @@ pkgOriginalUploadUser = snd . pkgOriginalUploadInfo pkgLatestRevision :: PkgInfo -> (CabalFileText, UploadInfo) pkgLatestRevision = Vec.last . pkgMetadataRevisions -pkgSpecificRevision :: PkgInfo -> Int -> Maybe (CabalFileText, UploadInfo) -pkgSpecificRevision pkg revno = pkgMetadataRevisions pkg Vec.!? revno +pkgSpecificRevision :: PkgInfo -> MetadataRevIx -> Maybe (CabalFileText, UploadInfo) +pkgSpecificRevision pkg (MetadataRevIx revno) = pkgMetadataRevisions pkg Vec.!? revno pkgAllRevisionsCabalFiles :: PkgInfo -> [CabalFileText] pkgAllRevisionsCabalFiles = fmap fst . Vec.toList . pkgMetadataRevisions -pkgSpecificTarball :: PkgInfo -> Int -> Maybe (PkgTarball, UploadInfo) -pkgSpecificTarball pkg revno = pkgTarballRevisions pkg Vec.!? revno +pkgSpecificTarball :: PkgInfo -> TarballRevIx -> Maybe (PkgTarball, UploadInfo) +pkgSpecificTarball pkg (TarballRevIx revno) = pkgTarballRevisions pkg Vec.!? revno pkgAllTarballs :: PkgInfo -> [(PkgTarball, UploadInfo)] pkgAllTarballs = Vec.toList . pkgTarballRevisions @@ -206,8 +226,8 @@ pkgLatestUploadUser = snd . pkgLatestUploadInfo pkgNumRevisions :: PkgInfo -> Int pkgNumRevisions = Vec.length . pkgMetadataRevisions -pkgMaxRevision :: PkgInfo -> Int -pkgMaxRevision = subtract 1 . pkgNumRevisions +pkgMaxRevision :: PkgInfo -> MetadataRevIx +pkgMaxRevision = MetadataRevIx . subtract 1 . pkgNumRevisions -- | The latest tarball for a package (if any) -- @@ -360,3 +380,4 @@ instance Migrate PkgInfo where } deriveSafeCopy 4 'extension ''PkgInfo + diff --git a/src/Distribution/Server/Pages/PackageFromTemplate.hs b/src/Distribution/Server/Pages/PackageFromTemplate.hs index 1d3ca249f..d1b919857 100644 --- a/src/Distribution/Server/Pages/PackageFromTemplate.hs +++ b/src/Distribution/Server/Pages/PackageFromTemplate.hs @@ -269,7 +269,7 @@ packagePageTemplate render "" -> "None provided" x -> x - renderUpdateInfo :: Int -> UTCTime -> Maybe UserInfo -> Html + renderUpdateInfo :: MetadataRevIx -> UTCTime -> Maybe UserInfo -> Html renderUpdateInfo revisionNo utime uinfo = anchor ! [href revisionsURL] << ("Revision " +++ show revisionNo) +++ " made " +++