Merge 'cabal-2.0' branch

This upgrades hackage-server from Cabal-1.24 to Cabal-2.0.

A nice consequence is a signficant reduction of list-constructor
heap objects as well as a reduction of overall heap allocation.

See #600 (comment)
for a qualitative comparison of heap profiles before/after this
merge.

Closes #600

Author: hvr

.gitignore

@@ -1,11 +1,17 @@
-build-cache
-mirror-cache
-state
-dist
-dist-newstyle
+# hackage-server
+build-cache/
+mirror-cache/
+state/
+backups/
+# cabal
+.ghc.environment.*
+dist/
+dist-newstyle/
+.cabal-sandbox/
+cabal.sandbox.config
+cabal.project.local
+# editor
 tags
 *.swp
-.cabal-sandbox
-.stack-work
-cabal.sandbox.config
 TAGS
+*~

.gitmodules

@@ -0,0 +1,4 @@
+[submodule "vendor/cabal"]
+	path = vendor/cabal
+	url = ../cabal
+	branch = 2.0

.travis.yml

@@ -8,7 +8,7 @@ language: c
 sudo: false
 
 git:
-  submodules: false  # whether to recursively clone submodules
+  submodules: true  # whether to recursively clone submodules
 
 cache:
   directories:
@@ -55,7 +55,8 @@ before_install:
  - HC=${CC}
  - unset CC
  - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
- - PKGNAME='hackage-server'
+ - PKGNAME="hackage-server"
+ - TARGET=":pkg:$PKGNAME"
 
 install:
  - cabal --version
@@ -64,12 +65,10 @@ install:
  - TEST=${TEST---enable-tests}
  - travis_retry cabal update -v
  - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- - rm -fv cabal.project.local
- - "echo 'packages: .' > cabal.project"
  - if [ -e "cabal.project.local-${HC}" ]; then cp -v "cabal.project.local-${HC}" cabal.project.local; fi
  - rm -f cabal.project.freeze
- - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 all
- - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 all
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2 ${TARGET}
+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2 ${TARGET}
 
 # Here starts the actual work to be performed for the package under test;
 # any command which exits with a non-zero exit code causes the build to fail.
@@ -85,14 +84,16 @@ script:
 ## from here on, CWD is inside the extracted source-tarball
  - rm -fv cabal.project.local
  - "echo 'packages: .' > cabal.project"
+ - if [ -e "../../cabal.project" ]; then cp -v "../../cabal.project" cabal.project; fi
+ - ln -vs ../../vendor
  - if [ -e "../../cabal.project.local-${HC}" ]; then cp -v "../../cabal.project.local-${HC}" cabal.project.local; fi
  - rm -f cabal.project.freeze
  # this builds all libraries and executables (without tests/benchmarks)
  - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
  # this builds all libraries and executables (including tests/benchmarks)
  # - rm -rf ./dist-newstyle
- - cabal new-build -w ${HC} ${TEST} ${BENCH} all
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} ${TARGET}
 
- - cabal new-test -w ${HC} -j1 all
+ - cabal new-test -w ${HC} -j1 ${TARGET}
 
 # EOF

Distribution/Client.hs

@@ -37,11 +37,11 @@ import Distribution.Server.Users.Types (UserId(..), UserName(UserName))
 import Distribution.Server.Util.Merge
 import Distribution.Server.Util.Parse (unpackUTF8)
 import Distribution.Package
-import Distribution.Version
 import Distribution.Verbosity
 import Distribution.Simple.Utils
 import Distribution.Text
 
+import Data.Version
 import Data.List
 import Data.Maybe
 import Control.Applicative

Distribution/Client/Index.hs

@@ -53,8 +53,7 @@ read mkPackage includeFile indexFileContent = collect [] entries
     entry e
       | [pkgname,versionStr,_] <- splitDirectories (normalise (Tar.entryPath e))
       , Just version <- simpleParse versionStr
-      , [] <- versionTags version
       , True <- includeFile (Tar.entryPath e)
-      = let pkgid = PackageIdentifier (PackageName pkgname) version
+      = let pkgid = PackageIdentifier (mkPackageName pkgname) version
          in Just (mkPackage pkgid e)
     entry _ = Nothing

Distribution/Client/UploadLog.hs

@@ -25,7 +25,7 @@ import Distribution.Package
          ( PackageId, PackageName, packageName, PackageIdentifier(..))
 import Distribution.Text
          ( Text(..), simpleParse )
-import Distribution.ParseUtils ( parsePackageNameQ )
+import Distribution.ParseUtils ( parseMaybeQuoted )
 import qualified Distribution.Compat.ReadP as Parse
 import qualified Text.PrettyPrint          as Disp
 import Text.PrettyPrint
@@ -58,7 +58,7 @@ instance Text Entry where
     Parse.skipSpaces
     user <- parse
     Parse.skipSpaces
-    pkg  <- parsePackageNameQ
+    pkg  <- parseMaybeQuoted parse
     Parse.skipSpaces
     ver  <- parse
     let pkgid = PackageIdentifier pkg ver

Distribution/Server/Features/BuildReports.hs

@@ -24,7 +24,7 @@ import qualified Distribution.Server.Framework.BlobStorage as BlobStorage
 
 import Distribution.Text
 import Distribution.Package
-import Distribution.Version (Version(..))
+import Distribution.Version (nullVersion)
 
 import Control.Arrow (second)
 import Data.ByteString.Lazy.Char8 (unpack) -- Build reports are ASCII
@@ -150,13 +150,13 @@ buildReportsFeature name
     packageReports :: DynamicPath -> ([(BuildReportId, BuildReport)] -> ServerPartE Response) -> ServerPartE Response
     packageReports dpath continue = do
       pkgid <- packageInPath dpath
-      case pkgVersion pkgid of
-        Version [] [] -> do
+      if pkgVersion pkgid == nullVersion
+        then do
           -- Redirect to the latest version
           pkginfo <- lookupPackageId pkgid
           seeOther (reportsListUri reportsResource "" (pkgInfoId pkginfo)) $
             toResponse ()
-        _ -> do
+        else do
           guardValidPackageId pkgid
           queryPackageReports pkgid >>= continue
 

Distribution/Server/Features/BuildReports/Backup.hs

@@ -64,10 +64,11 @@ insertLog buildReps ((pkgId, reportId), buildLog) =
     Nothing -> fail $ "Build log #" ++ display reportId ++ " exists for " ++ display pkgId ++ " but report itself does not"
 
 checkPackageVersion :: String -> PackageIdentifier -> Restore ()
-checkPackageVersion pkgStr pkgId =
-  case packageVersion pkgId of
-    Version [] [] -> fail $ "Build report package id " ++ show pkgStr ++ " must specify a version"
-    _             -> return ()
+checkPackageVersion pkgStr pkgId
+  | packageVersion pkgId == nullVersion
+  = fail $ "Build report package id " ++ show pkgStr ++ " must specify a version"
+  | otherwise
+  = return ()
 
 importReport :: PackageId -> String -> ByteString -> BuildReports -> PartialLogs -> Restore (BuildReports, PartialLogs)
 importReport pkgId repIdStr contents buildReps partialLogs = do

Distribution/Server/Features/BuildReports/BuildReport.hs

@@ -32,8 +32,10 @@ module Distribution.Server.Features.BuildReports.BuildReport (
 
 import Distribution.Package
          ( PackageIdentifier(..) )
+import Distribution.Types.GenericPackageDescription
+         ( FlagName, mkFlagName, unFlagName )
 import Distribution.PackageDescription
-         ( FlagName(..), FlagAssignment )
+         ( FlagAssignment )
 --import Distribution.Version
 --         ( Version )
 import Distribution.System
@@ -271,15 +273,15 @@ sortedFieldDescrs :: [FieldDescr BuildReport]
 sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs
 
 dispFlag :: (FlagName, Bool) -> Disp.Doc
-dispFlag (FlagName name, True)  =                  Disp.text name
-dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name
+dispFlag (fn, True)  =                  Disp.text (unFlagName fn)
+dispFlag (fn, False) = Disp.char '-' <> Disp.text (unFlagName fn)
 
 parseFlag :: Parse.ReadP r (FlagName, Bool)
 parseFlag = do
   name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
   case name of
-    ('-':flag) -> return (FlagName flag, False)
-    flag       -> return (FlagName flag, True)
+    ('-':flag) -> return (mkFlagName flag, False)
+    flag       -> return (mkFlagName flag, True)
 
 instance Text.Text InstallOutcome where
   disp PlanningFailed  = Disp.text "PlanningFailed"

Distribution/Server/Features/Core.hs

@@ -49,7 +49,7 @@ import qualified Distribution.Server.Packages.PackageIndex          as PackageIn
 -- Cabal
 import Distribution.Text (display)
 import Distribution.Package
-import Distribution.Version (Version(..))
+import Distribution.Version (Version, nullVersion)
 
 -- | The core feature, responsible for the main package index and all access
 -- and modifications of it.
@@ -457,11 +457,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
           -- * the package name and tarball name must be the same
           -- * the tarball must specify a version
           -- * the package must either have no version or the same version as the tarball
-          guard $ name == name' && version' /= Version [] [] && (version == version' || version == Version [] [])
+          guard $ name == name' && version' /= nullVersion && (version == version' || version == nullVersion)
           return pkgid
 
     guardValidPackageId pkgid = do
-      guard (pkgVersion pkgid /= Version [] [])
+      guard (pkgVersion pkgid /= nullVersion)
       void $ lookupPackageId pkgid
 
     guardValidPackageName pkgname =
@@ -603,7 +603,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
         pkgs -> return pkgs
 
     lookupPackageId :: PackageId -> ServerPartE PkgInfo
-    lookupPackageId (PackageIdentifier name (Version [] [])) = do
+    lookupPackageId (PackageIdentifier name v) | nullVersion == v = do
       pkgs <- lookupPackageName name
       -- pkgs is sorted by version number and non-empty
       return (last pkgs)
@@ -660,7 +660,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
     servePackageTarball :: DynamicPath -> ServerPartE Response
     servePackageTarball dpath = do
       pkgid <- packageTarballInPath dpath
-      guard (pkgVersion pkgid /= Version [] [])
+      guard (pkgVersion pkgid /= nullVersion)
       pkg <- lookupPackageId pkgid
       case pkgLatestTarball pkg of
         Nothing -> errNotFound "Tarball not found"

Distribution/Server/Features/Distro.hs

@@ -21,7 +21,6 @@ import Distribution.Package
 
 import Data.List (intercalate)
 import Text.CSV (parseCSV)
-import Data.Version (showVersion)
 
 -- TODO:
 -- 1. write an HTML view for this module, and delete the text
@@ -252,7 +251,7 @@ lookCSVFile func = do
 
 packageListToCSV :: [(PackageName, DistroPackageInfo)] -> CSVFile
 packageListToCSV entries
-    = CSVFile $ map (\(pn,DistroPackageInfo version url) -> [display pn, showVersion version, url]) entries
+    = CSVFile $ map (\(pn,DistroPackageInfo version url) -> [display pn, display version, url]) entries
 
 csvToPackageList :: CSVFile -> Either String [(PackageName, DistroPackageInfo)]
 csvToPackageList (CSVFile records)

Distribution/Server/Features/Distro/Backup.hs

@@ -18,9 +18,9 @@ import Distribution.Server.Framework.BackupDump
 import Distribution.Server.Framework.BackupRestore
 
 import Distribution.Text
-import Data.Version
 import Text.CSV (CSV, Record)
 
+import Data.Version
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Data.List (foldl')
@@ -117,7 +117,7 @@ distroToCSV distro distInfo
          (distrosCSVKey:) $
          flip map stats . uncurry $
            \name (DistroPackageInfo version url) ->
-               [display name, showVersion version, url]
+               [display name, display version, url]
   where
     distrosCSVKey = ["package", "version", "url"]
     distrosCSVVer = Version [0,1] ["unstable"]

Distribution/Server/Features/Documentation.hs

@@ -24,7 +24,7 @@ import qualified Codec.Archive.Tar.Check as Tar
 
 import Distribution.Text
 import Distribution.Package
-import Distribution.Version (Version(..))
+import Distribution.Version (nullVersion)
 
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Map as Map
@@ -314,9 +314,9 @@ documentationFeature name
       -- See https://support.google.com/webmasters/answer/139066?hl=en#6
       setHeaderM "Link" canonicalHeader
 
-      case pkgVersion pkgid of
+      case pkgVersion pkgid == nullVersion of
         -- if no version is given we want to redirect to the latest version
-        Version [] _ -> tempRedirect latestPkgPath (toResponse "")
+        True -> tempRedirect latestPkgPath (toResponse "")
           where
             latest = packageId pkginfo
             dpath' = [ if var == "package"
@@ -325,7 +325,7 @@ documentationFeature name
                      | e@(var, _) <- dpath ]
             latestPkgPath = (renderResource' self dpath')
 
-        _             -> do
+        False -> do
           mdocs <- queryState documentationState $ LookupDocumentation pkgid
           case mdocs of
             Nothing ->

Distribution/Server/Features/DownloadCount/Backup.hs

@@ -10,7 +10,7 @@ import Distribution.Server.Framework.BackupDump
 import Distribution.Server.Features.DownloadCount.State
 import Distribution.Server.Util.CountingMap
 import Distribution.Text (display, simpleParse)
-import Distribution.Version
+import Data.Version
 import Text.CSV (CSV)
 
 onDiskBackup :: OnDiskStats -> [BackupEntry]

Distribution/Server/Features/DownloadCount/State.hs

@@ -4,7 +4,6 @@
 module Distribution.Server.Features.DownloadCount.State where
 
 import Data.Time.Calendar (Day(..))
-import Data.Version (Version)
 import Data.Typeable (Typeable)
 import Data.Foldable (forM_)
 import Control.Arrow (first)
@@ -31,6 +30,7 @@ import Data.SafeCopy (base, deriveSafeCopy, safeGet, safePut)
 import Data.Serialize.Get (runGetLazy)
 import Data.Serialize.Put (runPutLazy)
 
+import Distribution.Version (Version)
 import Distribution.Package (
     PackageId
   , PackageName

Distribution/Server/Features/Html.hs

@@ -1318,7 +1318,7 @@ mkHtmlPreferred HtmlUtilities{..}
         , h4 << "Versions affected"
         , paragraph << "Orange versions are normal versions. Green are those out of any preferred version ranges. Gray are deprecated."
         , paragraph << (snd $ Pages.renderVersion
-                                  (PackageIdentifier pkgname $ Version [] [])
+                                  (PackageIdentifier pkgname $ nullVersion)
                                   (classifyVersions prefInfo $ map packageVersion pkgs) Nothing)
         ]
 

Distribution/Server/Features/LegacyRedirects.hs

@@ -12,7 +12,7 @@ import Distribution.Package
 import Distribution.Text
          ( display, simpleParse )
 
-import Data.Version ( Version (..) )
+import Distribution.Version ( Version, nullVersion )
 
 import qualified System.FilePath.Posix as Posix (joinPath, splitExtension)
 
@@ -104,7 +104,7 @@ instance FromReqURI VersionOrLatest where
     fromReqURI str = V <$> fromReqURI str
 
 volToVersion :: VersionOrLatest -> Version
-volToVersion Latest = Version [] []
+volToVersion Latest = nullVersion
 volToVersion (V v)  = v
 
 serveArchiveTree :: ServerPartE Response

Distribution/Server/Features/PackageCandidates.hs

@@ -36,6 +36,8 @@ import Distribution.Server.Pages.Template (hackagePage)
 
 import Distribution.Text
 import Distribution.Package
+import Distribution.Version
+import Distribution.Types.Dependency
 
 import qualified Cheapskate      as Markdown (markdown, Options(..))
 import qualified Cheapskate.Html as Markdown (renderDoc)
@@ -279,7 +281,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
     putPackageCandidate :: DynamicPath -> ServerPartE Response
     putPackageCandidate dpath = do
       pkgid <- packageInPath dpath
-      guard (packageVersion pkgid /= Version [] [])
+      guard (packageVersion pkgid /= nullVersion)
       pkgInfo <- uploadCandidate (==pkgid)
       seeOther (corePackageIdUri candidatesCoreResource "" $ packageId pkgInfo) (toResponse ())
 
@@ -294,7 +296,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
     serveCandidateTarball :: DynamicPath -> ServerPartE Response
     serveCandidateTarball dpath = do
       pkgid <- packageTarballInPath dpath
-      guard (pkgVersion pkgid /= Version [] [])
+      guard (pkgVersion pkgid /= nullVersion)
       pkg   <- lookupCandidateId pkgid
       case pkgLatestTarball (candPkgInfo pkg) of
         Nothing -> errNotFound "Tarball not found"
@@ -434,7 +436,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
     -- (If we change that, we should move the 'guard' to 'guardValidPackageId')
     lookupCandidateId :: PackageId -> ServerPartE CandPkgInfo
     lookupCandidateId pkgid = do
-      guard (pkgVersion pkgid /= Version [] [])
+      guard (pkgVersion pkgid /= nullVersion)
       state <- queryState candidatesState GetCandidatePackages
       case PackageIndex.lookupPackageId (candidateList state) pkgid of
         Just pkg -> return pkg