Separate out Package utilities & enforce better typing discipline

hackage-server.cabal

@@ -255,6 +255,8 @@ library
     Distribution.Server.Packages.PackageIndex
     Distribution.Server.Packages.Types
     Distribution.Server.Packages.Unpack
+    Distribution.Server.Packages.Utils
+    Distribution.Server.Packages.Utils.Acid
     Distribution.Server.Packages.Render
     Distribution.Server.Packages.ChangeLog
     Distribution.Server.Packages.Readme

src/Distribution/Server/Features/Core.hs

@@ -50,6 +50,7 @@ import qualified Distribution.Server.Packages.Index                 as Packages.
 import           Distribution.Server.Packages.PackageIndex          (PackageIndex)
 import qualified Distribution.Server.Packages.PackageIndex          as PackageIndex
 import           Distribution.Server.Packages.Types
+import           Distribution.Server.Packages.Utils
 import           Distribution.Server.Users.Types                    (UserId,
                                                                      userName)
 import           Distribution.Server.Users.Users                    (lookupUserId,
@@ -88,7 +89,7 @@ data CoreFeature = CoreFeature {
     -- If a package was able to be newly added, runs a `PackageChangeAdd` hook
     -- when done and returns True.
     updateAddPackage         :: forall m. MonadIO m => PackageId ->
-                                CabalFileText -> UploadInfo ->
+                                CabalFileText -> OldUploadInfo ->
                                 Maybe PkgTarball -> m Bool,
     -- | Deletes a version of an existing package, deleting the package if it
     -- was the last version.
@@ -103,14 +104,14 @@ data CoreFeature = CoreFeature {
     -- Runs either a `PackageChangeAdd` or `PackageChangeInfo` hook, depending
     -- on whether a package with the given version already existed.
     updateAddPackageRevision :: forall m. MonadIO m => PackageId ->
-                                CabalFileText -> UploadInfo -> m (),
+                                CabalFileText -> OldUploadInfo -> m (),
     -- | Sets the source tarball for an existing package version. References to
     -- previous tarballs, if any, are kept around.
     --
     -- If this package was found, runs a `PackageChangeInfo` hook when done and
     -- returns True.
     updateAddPackageTarball  :: forall m. MonadIO m => PackageId ->
-                                PkgTarball -> UploadInfo -> m Bool,
+                                PkgTarball -> OldUploadInfo -> m Bool,
     -- | Sets the uploader of an existing package version.
     --
     -- If this package was found, runs a `PackageChangeInfo` hook when done and
@@ -210,7 +211,7 @@ isPackageIndexChange = Just
 isPackageAddVersion                :: Maybe PackageId,
 isPackageDeleteVersion             :: Maybe PackageId,
 isPackageChangeCabalFile           :: Maybe (PackageId, CabalFileText),
-isPackageChangeCabalFileUploadInfo :: Maybe (PackageId, UploadInfo),
+isPackageChangeCabalFileUploadInfo :: Maybe (PackageId, OldUploadInfo),
 isPackageChangeTarball             :: Maybe (PackageId, PkgTarball),
 isPackageIndexExtraChange          :: Maybe (String, LazyByteString, UTCTime)
 -}
@@ -517,7 +518,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
     -- Update transactions
     --
     updateAddPackage :: MonadIO m => PackageId
-                     -> CabalFileText -> UploadInfo
+                     -> CabalFileText -> OldUploadInfo
                      -> Maybe PkgTarball -> m Bool
     updateAddPackage pkgid cabalFile uploadinfo@(_, uid) mtarball = logTiming maxBound ("updateAddPackage " ++ display pkgid) $ do
       usersdb <- queryGetUserDb
@@ -548,7 +549,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
           runHook_ packageChangeHook (PackageChangeDelete pkginfo)
           return True
 
-    updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> UploadInfo -> m ()
+    updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> OldUploadInfo -> m ()
     updateAddPackageRevision pkgid cabalfile uploadinfo@(_, uid) = logTiming maxBound ("updateAddPackageRevision " ++ display pkgid) $ do
       usersdb <- queryGetUserDb
       let Just userInfo = lookupUserId uid usersdb
@@ -565,7 +566,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
         Just oldpkginfo ->
           runHook_ packageChangeHook  (PackageChangeInfo PackageUpdatedCabalFile oldpkginfo newpkginfo)
 
-    updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m Bool
+    updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> OldUploadInfo -> m Bool
     updateAddPackageTarball pkgid tarball uploadinfo = logTiming maxBound ("updateAddPackageTarball " ++ display pkgid) $ do
       mpkginfo <- updateState packagesState (Acid.AddPackageTarball pkgid tarball uploadinfo)
 
@@ -720,9 +721,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
       pkginfo <- packageInPath dpath >>= lookupPackageId
       -- check that the cabal name matches the package
       guard (lookup "cabal" dpath == Just (display $ packageName pkginfo))
-      let (fileRev, (utime, _uid)) = pkgLatestRevision pkginfo
-          cabalfile = Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) utime
-      return $ toResponse cabalfile
+      let rev = pkgLatestRevision pkginfo
+      return $ toResponse $ toCabalResource rev
 
     serveCabalFileRevisionsList :: DynamicPath -> ServerPartE Response
     serveCabalFileRevisionsList dpath = do
@@ -746,13 +746,10 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
       pkginfo <- packageInPath dpath >>= lookupPackageId
       let mrev      = lookup "revision" dpath >>= fromReqURI
       case mrev >>= pkgSpecificRevision pkginfo of
-        Just (fileRev, (utime, _uid)) -> return $ toResponse cabalfile
-          where
-            cabalfile = Resource.CabalFile (fromStrict $ cabalFileByteString fileRev) utime
+        Just rev -> return $ toResponse $ toCabalResource rev
         Nothing -> errNotFound "Package revision not found"
                      [MText "Cannot parse revision, or revision out of range."]
 
-
     deauth :: DynamicPath -> ServerPartE Response
     deauth _ = do
       return $ (toResponse ("<script>window.location='/'</script>"::String)) {

src/Distribution/Server/Features/Core/Backup.hs

@@ -65,9 +65,9 @@ data PartialIndex = PartialIndex !(Map PackageId PartialPkg)
 
 data PartialPkg = PartialPkg {
     partialCabal         :: [(Int, CabalFileText)],
-    partialCabalUpload   :: [(Int, UploadInfo)],
+    partialCabalUpload   :: [(Int, OldUploadInfo)],
     partialTarball       :: [(Int, (FilePath, BlobId))],
-    partialTarballUpload :: [(Int, (UploadInfo, Maybe TarballInfo))]
+    partialTarballUpload :: [(Int, (OldUploadInfo, Maybe TarballInfo))]
 }
 
 data TarballInfo = TarballInfo {
@@ -132,11 +132,11 @@ parsePackageId pkgStr = case simpleParse pkgStr of
   Nothing    -> fail $ "Package directory " ++ show pkgStr ++ " isn't a valid package id"
   Just pkgId -> return pkgId
 
-importCabalMetadata :: [String] -> CSV -> Restore [(Int, UploadInfo)]
+importCabalMetadata :: [String] -> CSV -> Restore [(Int, OldUploadInfo)]
 importCabalMetadata _fp (_versionStr:_headers:body) =
     mapM fromRecord body
   where
-    fromRecord :: Record -> Restore (Int, UploadInfo)
+    fromRecord :: Record -> Restore (Int, OldUploadInfo)
     fromRecord [strIndex, strTime, strUser] = do
        index   <- parseRead    "index"   strIndex
        utcTime <- parseUTCTime "time"    strTime
@@ -146,14 +146,14 @@ importCabalMetadata _fp (_versionStr:_headers:body) =
 importCabalMetadata fp _ =
     fail $ "Invalid cabal metadata in " ++ foldr1 (</>) fp
 
-importTarballMetadata :: [String] -> CSV -> Restore [(Int, (UploadInfo, Maybe TarballInfo))]
+importTarballMetadata :: [String] -> CSV -> Restore [(Int, (OldUploadInfo, Maybe TarballInfo))]
 importTarballMetadata _fp ([strVersion]:_headers:body) = do
     version <- parseVersion "CSV version header" strVersion
     if version >= Version [0,2] []
       then mapM fromRecord_v2 body
       else mapM fromRecord_v1 body
   where
-    fromRecord_v2 :: Record -> Restore (Int, (UploadInfo, Maybe TarballInfo))
+    fromRecord_v2 :: Record -> Restore (Int, (OldUploadInfo, Maybe TarballInfo))
     fromRecord_v2 [strIndex, strTime, strUser, strTarGzMD5, strTarGzLen, strTarGzSHA256, strTarMD5] = do
        index   <- parseRead    "index"   strIndex
        utcTime <- parseUTCTime "time"    strTime
@@ -165,7 +165,7 @@ importTarballMetadata _fp ([strVersion]:_headers:body) = do
        return (index, ((utcTime, user), Just TarballInfo{..}))
     fromRecord_v2 x = fail $ "Error processing versions list: " ++ show x
 
-    fromRecord_v1 :: Record -> Restore (Int, (UploadInfo, Maybe TarballInfo))
+    fromRecord_v1 :: Record -> Restore (Int, (OldUploadInfo, Maybe TarballInfo))
     fromRecord_v1 [strIndex, strTime, strUser] = do
        index   <- parseRead    "index"   strIndex
        utcTime <- parseUTCTime "time"    strTime
@@ -208,10 +208,10 @@ partialToFullPkg (pkgId, PartialPkg{..}) = do
       pkgTarballRevisions  = Vec.fromList tarballRevisions
     }
   where
-    combineCabal :: CabalFileText -> UploadInfo -> Restore (CabalFileText, UploadInfo)
+    combineCabal :: CabalFileText -> OldUploadInfo -> Restore (CabalFileText, OldUploadInfo)
     combineCabal cabalFile uploadInfo = return (cabalFile, uploadInfo)
 
-    combineTarball :: (FilePath, BlobId) -> (UploadInfo, Maybe TarballInfo) -> Restore (PkgTarball, UploadInfo)
+    combineTarball :: (FilePath, BlobId) -> (OldUploadInfo, Maybe TarballInfo) -> Restore (PkgTarball, OldUploadInfo)
     combineTarball (filename, blobId) (uploadInfo, Just TarballInfo{..}) = do
       pkgTarballGz <-
         -- If the blob ID of the restored file matches the one in the metadata,
@@ -281,7 +281,7 @@ partialToFullPkg (pkgId, PartialPkg{..}) = do
        fail $ "Upload log entry for " ++ item ++ " (index "
            ++ show (fst y) ++") found, but file itself missing"
 
-    sortByUploadTimes :: [(a, UploadInfo)] -> [(a, UploadInfo)]
+    sortByUploadTimes :: [(a, OldUploadInfo)] -> [(a, OldUploadInfo)]
     sortByUploadTimes = sortBy (comparing (fst . snd))
 
 -- Workaround: in zlib prior to 0.5.4.1, GZip.decompress would not fully
@@ -313,7 +313,7 @@ infoToAllEntries pkg =
     in cabals ++ tarballs
 
 ----------- Converting pieces of PkgInfo to entries
-cabalListToExport :: PackageId -> [(CabalFileText, UploadInfo)] -> [BackupEntry]
+cabalListToExport :: PackageId -> [(CabalFileText, OldUploadInfo)] -> [BackupEntry]
 cabalListToExport pkgId cabalInfos =
       csvToBackup (pkgPath pkgId "uploads.csv") cabalMetadata
     : map blobEntry (zip [0..] cabals)
@@ -334,14 +334,14 @@ cabalListToExport pkgId cabalInfos =
         versionCSVVer = Version [0,1] ["unstable"]
         versionCSVKey = ["index", "time", "user-id"]
 
-    metadataEntry :: (Int, UploadInfo) -> Record
+    metadataEntry :: (Int, OldUploadInfo) -> Record
     metadataEntry (index, (time, user)) = [
         show (index :: Int)
       , formatUTCTime time
       , display user
       ]
 
-tarballListToExport :: PackageId -> [(PkgTarball, UploadInfo)] -> [BackupEntry]
+tarballListToExport :: PackageId -> [(PkgTarball, OldUploadInfo)] -> [BackupEntry]
 tarballListToExport pkgId tarballInfos =
       csvToBackup (pkgPath pkgId "tarball.csv") tarballMetadata
     : map blobEntry (zip [0..] (map fst tarballInfos))
@@ -372,7 +372,7 @@ tarballListToExport pkgId tarballInfos =
                         , "tar-md5"
                         ]
 
-    metadataEntry :: (Int, (TarballInfo, UploadInfo)) -> Record
+    metadataEntry :: (Int, (TarballInfo, OldUploadInfo)) -> Record
     metadataEntry (index, (TarballInfo{..}, (time, user))) = [
         show (index :: Int)
       , formatUTCTime time

src/Distribution/Server/Features/Core/State.hs

@@ -29,6 +29,7 @@ import Distribution.Package
 import Distribution.Server.Packages.PackageIndex (PackageIndex)
 import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
 import Distribution.Server.Packages.Types
+import Distribution.Server.Packages.Utils.Acid
 import Distribution.Server.Packages.Index
 import Distribution.Server.Users.Types (UserId, UserName(..), UserInfo(..))
 import Distribution.Server.Users.Users (Users, lookupUserId)
@@ -88,14 +89,14 @@ initialPackagesState freshDB = PackagesState {
   }
 
 -- old v0 transaction
-addPackage :: PackageId -> CabalFileText -> UploadInfo
+addPackage :: PackageId -> CabalFileText -> OldUploadInfo
            -> Maybe PkgTarball
            -> Update PackagesState (Maybe PkgInfo)
 addPackage pkgid cabalfile uploadinfo mtarball =
     addPackage2 pkgid cabalfile uploadinfo (UserName "") mtarball
 
 -- v1  transaction (adds username)
-addPackage2 :: PackageId -> CabalFileText -> UploadInfo -> UserName
+addPackage2 :: PackageId -> CabalFileText -> OldUploadInfo -> UserName
             -> Maybe PkgTarball
             -> Update PackagesState (Maybe PkgInfo)
 addPackage2 pkgid cabalfile uploadinfo@(timestamp, uid) username mtarball = do
@@ -111,7 +112,7 @@ addPackage2 pkgid cabalfile uploadinfo@(timestamp, uid) username mtarball = do
         return (Just pkginfo)
 
 -- current transaction (takes tar index entries as well)
-addPackage3 :: PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> Update PackagesState Bool
+addPackage3 :: PkgInfo -> OldUploadInfo -> UserName -> [TarIndexEntry] -> Update PackagesState Bool
 addPackage3 !pkginfo (timestamp,uid) username entries = do
     PackagesState pkgindex updatelog <- State.get
     case PackageIndex.lookupPackageId pkgindex (pkgInfoId pkginfo) of
@@ -123,7 +124,7 @@ addPackage3 !pkginfo (timestamp,uid) username entries = do
         State.put $! PackagesState pkgindex' updatelog'
         return True
 
-mkPackageInfo :: PackageIdentifier -> CabalFileText -> UploadInfo -> Maybe PkgTarball -> PkgInfo
+mkPackageInfo :: PackageIdentifier -> CabalFileText -> OldUploadInfo -> Maybe PkgTarball -> PkgInfo
 mkPackageInfo pkgid cabalfile uploadinfo mtarball =
             PkgInfo {
               pkgInfoId            = pkgid,
@@ -146,12 +147,12 @@ deletePackage pkgid = do
         State.put $! PackagesState pkgindex' updatelog
         return (Just pkginfo)
 
-addPackageRevision :: PackageId -> CabalFileText -> UploadInfo
+addPackageRevision :: PackageId -> CabalFileText -> OldUploadInfo
                    -> Update PackagesState (Maybe PkgInfo, PkgInfo)
 addPackageRevision pkgid cabalfile uploadinfo =
     addPackageRevision2 pkgid cabalfile uploadinfo (UserName "")
 
-addPackageRevision2 :: PackageId -> CabalFileText -> UploadInfo -> UserName
+addPackageRevision2 :: PackageId -> CabalFileText -> OldUploadInfo -> UserName
                     -> Update PackagesState (Maybe PkgInfo, PkgInfo)
 addPackageRevision2 pkgid cabalfile uploadinfo@(timestamp, uid) username = do
     PackagesState pkgindex updatelog <- State.get
@@ -179,7 +180,7 @@ addPackageRevision2 pkgid cabalfile uploadinfo@(timestamp, uid) username = do
         State.put $! PackagesState pkgindex' updatelog'
         return (Nothing, pkginfo)
 
-addPackageTarball :: PackageId -> PkgTarball -> UploadInfo
+addPackageTarball :: PackageId -> PkgTarball -> OldUploadInfo
                   -> Update PackagesState (Maybe (PkgInfo, PkgInfo))
 addPackageTarball pkgid tarball uploadinfo =
     alterPackage pkgid $ \pkginfo ->
@@ -281,11 +282,11 @@ initialUpdateLog oldExtras users pkgs =
       where
         pkgId = pkgInfoId pkgInfo
 
-    entryCabal :: PackageId -> (MetadataRevIx, (a, UploadInfo)) -> TarIndexEntry
+    entryCabal :: PackageId -> (MetadataRevIx, (a, OldUploadInfo)) -> TarIndexEntry
     entryCabal pkgId (revNo, (_cabalFile, (timestamp, uid))) =
         CabalFileEntry pkgId revNo timestamp uid (uidToName uid)
 
-    entryTUF :: PackageId -> (TarballRevIx, (a, UploadInfo)) -> TarIndexEntry
+    entryTUF :: PackageId -> (TarballRevIx, (a, OldUploadInfo)) -> TarIndexEntry
     entryTUF pkgId (revNo, (_tarball, (timestamp, _uid))) =
         MetadataEntry pkgId revNo timestamp
 

src/Distribution/Server/Features/EditCabalFiles.hs

@@ -13,6 +13,7 @@ import Distribution.Server.Framework.Templating
 import Distribution.Server.Features.Users
 import Distribution.Server.Features.Core
 import Distribution.Server.Packages.Types
+import Distribution.Server.Packages.Utils
 import Distribution.Server.Features.Upload
 
 import Distribution.Package

src/Distribution/Server/Features/Html.hs

@@ -42,6 +42,7 @@ import qualified Distribution.Server.Features.BuildReports.BuildReport as BR
 import Distribution.Server.Users.Types
 import qualified Distribution.Server.Users.Group as Group
 import Distribution.Server.Packages.Types
+import Distribution.Server.Packages.Utils
 import Distribution.Server.Packages.Render
 import qualified Distribution.Server.Users.Users as Users
 import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
@@ -640,7 +641,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
             pkgname = packageName realpkg
             docURL  = packageDocsContentUri docs realpkg
             execs   = rendExecNames render
-            pkgdesc = flattenPackageDescription $ pkgDesc pkg
+            pkgdesc = flattenPackageDescription $ pkgDesc $ pkgLatestRevision pkg
             maintainers = maintainersGroup pkgname
 
         prefInfo      <- queryGetPreferredInfo pkgname
@@ -838,7 +839,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
         revisionToTemplate :: Users.Users -> UploadInfo -> Int
                            -> (SHA256Digest, [Change])
                            -> TemplateVal
-        revisionToTemplate users (utime, uid) revision (sha256hash, changes) =
+        revisionToTemplate users (UploadInfo utime uid) revision (sha256hash, changes) =
           let uname = Users.userIdToName users uid
            in templateDict
                 [ templateVal "number" revision

src/Distribution/Server/Features/Mirror.hs

@@ -15,6 +15,7 @@ import Distribution.Server.Features.Users
 
 import Distribution.Server.Users.State
 import Distribution.Server.Packages.Types
+import Distribution.Server.Packages.Utils
 import Distribution.Server.Users.Backup
 import Distribution.Server.Users.Types
 import Distribution.Server.Users.Users hiding (lookupUserName)

src/Distribution/Server/Features/PackageCandidates.hs

@@ -20,6 +20,7 @@ import Distribution.Server.Features.Users
 import Distribution.Server.Features.TarIndexCache
 
 import Distribution.Server.Packages.Types
+import Distribution.Server.Packages.Utils
 import Distribution.Server.Packages.Render
 import Distribution.Server.Packages.ChangeLog
 import Distribution.Server.Packages.Readme
@@ -384,9 +385,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
     serveCandidateCabal dpath = do
       pkg <- packageInPath dpath >>= lookupCandidateId
       guard (lookup "cabal" dpath == Just (display $ packageName pkg))
-      let (fileRev, (utime, _uid)) = pkgLatestRevision (candPkgInfo pkg)
-          cabalfile = Resource.CabalFile (BS.fromStrict (cabalFileByteString fileRev)) utime
-      return $ toResponse cabalfile
+      return $ toResponse $ toCabalResource $ pkgLatestRevision $ candPkgInfo pkg
 
     uploadCandidate :: (PackageId -> Bool) -> ServerPartE CandPkgInfo
     uploadCandidate isRight = do
@@ -457,7 +456,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
         Nothing -> do
           -- run filters
           let pkgInfo = candPkgInfo candidate
-              uresult = UploadResult (pkgDesc pkgInfo)
+              uresult = UploadResult (pkgDesc $ pkgLatestRevision pkgInfo)
                                      (BS.fromStrict (cabalFileByteString (pkgLatestCabalFileText pkgInfo)))
                                      (candWarnings candidate)
           time <- liftIO getCurrentTime