Additions necessary for integration of pantry into stackage-server:

* Addition of few class instances and exports needed for stackage-server
* Fixed concurrent blob and file name writes in multi-connection sql pool setting. Added few more exports needed for stackage-server
* Improved speed and safety by added database aware queries. Switched all queries to MonadIO
* Removed pantry cabal file and added it to gitignore
* Export PackageName and Version and aded NFData instances for PackageNameP and VersionP
* Lower restriction from RIO to MonadUnliftIO for sql query running in `withStorage`
* Turned on `-Wall` for pantry tests.

.gitignore

@@ -29,3 +29,4 @@ tags
 /etc/scripts/stack-scripts.cabal
 .hspec-failures
 better-cache/
+/subs/*/*.cabal

subs/pantry/.hindent.yaml

@@ -0,0 +1 @@
+indent-size: 2

subs/pantry/package.yaml

@@ -86,6 +86,9 @@ dependencies:
 - directory
 - filepath
 
+ghc-options:
+  - -Wall
+
 library:
   source-dirs: src/
   when:
@@ -104,6 +107,10 @@ library:
   # For testing
   - Pantry.Internal
   - Pantry.Internal.StaticBytes
+  # For stackage-server
+  - Pantry.Storage
+  - Pantry.Types
+  - Pantry.Hackage
 
   # FIXME must be removed from pantry!
   - Data.Aeson.Extended

subs/pantry/src/Pantry.hs

@@ -179,7 +179,7 @@ import qualified RIO.FilePath as FilePath
 import Pantry.Archive
 import Pantry.Repo
 import qualified Pantry.SHA256 as SHA256
-import Pantry.Storage
+import Pantry.Storage hiding (TreeEntry, PackageName, Version)
 import Pantry.Tree
 import Pantry.Types
 import Pantry.Hackage
@@ -299,8 +299,8 @@ getLatestHackageLocation req name preferred = do
 
   forM mVerCfKey $ \(version, cfKey@(BlobKey sha size)) -> do
     let pir = PackageIdentifierRevision name version (CFIHash sha (Just size))
-    treeKey <- getHackageTarballKey pir
-    pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey
+    treeKey' <- getHackageTarballKey pir
+    pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey'
 
 -- | Returns the latest revision of the given package version available from
 -- Hackage.
@@ -318,8 +318,8 @@ getLatestHackageRevision req name version = do
     Nothing -> pure Nothing
     Just (revision, cfKey@(BlobKey sha size)) -> do
       let cfi = CFIHash sha (Just size)
-      treeKey <- getHackageTarballKey (PackageIdentifierRevision name version cfi)
-      return $ Just (revision, cfKey, treeKey)
+      treeKey' <- getHackageTarballKey (PackageIdentifierRevision name version cfi)
+      return $ Just (revision, cfKey, treeKey')
 
 fetchTreeKeys
   :: (HasPantryConfig env, HasLogFunc env, Foldable f)
@@ -739,8 +739,8 @@ completePackageLocation (RPLIHackage pir0@(PackageIdentifierRevision name versio
             pir = PackageIdentifierRevision name version cfi
         logDebug $ "Added in cabal file hash: " <> display pir
         pure (pir, BlobKey sha size)
-  treeKey <- getHackageTarballKey pir
-  pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey
+  treeKey' <- getHackageTarballKey pir
+  pure $ PLIHackage (PackageIdentifier name version) cfKey treeKey'
 completePackageLocation pl@(RPLIArchive archive rpm) = do
   -- getArchive checks archive and package metadata
   (sha, size, package) <- getArchive pl archive rpm
@@ -1344,7 +1344,7 @@ getRawPackageLocationTreeKey
   -> RIO env TreeKey
 getRawPackageLocationTreeKey pl =
   case getRawTreeKey pl of
-    Just treeKey -> pure treeKey
+    Just treeKey' -> pure treeKey'
     Nothing ->
       case pl of
         RPLIHackage pir _ -> getHackageTarballKey pir

subs/pantry/src/Pantry/Archive.hs

@@ -13,7 +13,7 @@ module Pantry.Archive
 
 import RIO
 import qualified Pantry.SHA256 as SHA256
-import Pantry.Storage
+import Pantry.Storage hiding (Tree, TreeEntry)
 import Pantry.Tree
 import Pantry.Types
 import RIO.Process
@@ -447,7 +447,7 @@ parseArchive rpli archive fp = do
             BFCabal _ _ -> when (buildFilePath /= cabalFileName name) $ throwIO $ WrongCabalFileName rpli buildFilePath name
             _ -> return ()
           -- It's good! Store the tree, let's bounce
-          (tid, treeKey) <- withStorage $ storeTree rpli ident tree buildFile
+          (tid, treeKey') <- withStorage $ storeTree rpli ident tree buildFile
           packageCabal <- case buildFile of
                             BFCabal _ _ -> pure $ PCCabalFile buildFileEntry
                             BFHpack _ -> do
@@ -458,7 +458,7 @@ parseArchive rpli archive fp = do
                               let cabalTreeEntry = TreeEntry cabalKey (teType buildFileEntry)
                               pure $ PCHpack $ PHpack { phOriginal = buildFileEntry, phGenerated = cabalTreeEntry, phVersion = hpackSoftwareVersion}
           pure Package
-            { packageTreeKey = treeKey
+            { packageTreeKey = treeKey'
             , packageTree = tree
             , packageCabalEntry = packageCabal
             , packageIdent = ident

subs/pantry/src/Pantry/Hackage.hs

@@ -4,10 +4,12 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Pantry.Hackage
   ( updateHackageIndex
+  , forceUpdateHackageIndex
   , DidUpdateOccur (..)
   , RequireHackageIndex (..)
   , hackageIndexTarballL
   , getHackageTarball
+  , getHackageTarballOnGPD
   , getHackageTarballKey
   , getHackageCabalFile
   , getHackagePackageVersions
@@ -28,7 +30,7 @@ import qualified RIO.ByteString as B
 import qualified RIO.ByteString.Lazy as BL
 import Pantry.Archive
 import Pantry.Types hiding (FileType (..))
-import Pantry.Storage
+import Pantry.Storage hiding (TreeEntry, PackageName, Version)
 import Pantry.Tree
 import qualified Pantry.SHA256 as SHA256
 import Network.URI (parseURI)
@@ -39,6 +41,7 @@ import qualified Distribution.PackageDescription as Cabal
 import System.IO (SeekMode (..))
 import qualified Data.List.NonEmpty as NE
 import Data.Text.Metrics (damerauLevenshtein)
+import Distribution.PackageDescription (GenericPackageDescription)
 import Distribution.Types.Version (versionNumbers)
 import Distribution.Types.VersionRange (withinRange)
 
@@ -80,7 +83,26 @@ updateHackageIndex
   :: (HasPantryConfig env, HasLogFunc env)
   => Maybe Utf8Builder -- ^ reason for updating, if any
   -> RIO env DidUpdateOccur
-updateHackageIndex mreason = do
+updateHackageIndex = updateHackageIndexInternal False
+
+-- | Same as `updateHackageIndex`, but force the database update even if hackage
+-- security tells that there is no change.  This can be useful in order to make
+-- sure the database is in sync with the locally downloaded tarball
+--
+-- @since 0.1.0.0
+forceUpdateHackageIndex
+  :: (HasPantryConfig env, HasLogFunc env)
+  => Maybe Utf8Builder
+  -> RIO env DidUpdateOccur
+forceUpdateHackageIndex = updateHackageIndexInternal True
+
+
+updateHackageIndexInternal
+  :: (HasPantryConfig env, HasLogFunc env)
+  => Bool -- ^ Force the database update.
+  -> Maybe Utf8Builder -- ^ reason for updating, if any
+  -> RIO env DidUpdateOccur
+updateHackageIndexInternal forceUpdate mreason = do
   storage <- view $ pantryConfigL.to pcStorage
   gateUpdate $ withWriteLock_ storage $ do
     for_ mreason logInfo
@@ -118,6 +140,9 @@ updateHackageIndex mreason = do
         HS.checkForUpdates repo maybeNow
 
     case didUpdate of
+      _ | forceUpdate -> do
+            logInfo "Forced package update is initialized"
+            updateCache tarball
       HS.NoUpdates -> do
         x <- needsCacheUpdate tarball
         if x
@@ -200,11 +225,13 @@ updateHackageIndex mreason = do
               if oldHash == oldHashCheck
                 then oldSize <$ logInfo "Updating preexisting cache, should be quick"
                 else 0 <$ do
-                  logInfo "Package index change detected, that's pretty unusual"
-                  logInfo $ "Old size: " <> display oldSize
-                  logInfo $ "Old hash (orig) : " <> display oldHash
-                  logInfo $ "New hash (check): " <> display oldHashCheck
-                  logInfo "Forcing a recache"
+                  logWarn $ mconcat [
+                    "Package index change detected, that's pretty unusual: "
+                    , "\n    Old size: " <> display oldSize
+                    , "\n    Old hash (orig) : " <> display oldHash
+                    , "\n    New hash (check): " <> display oldHashCheck
+                    , "\n    Forcing a recache"
+                    ]
             pure (offset, newHash, newSize)
 
       lift $ logInfo $ "Populating cache from file size " <> display newSize <> ", hash " <> display newHash
@@ -503,11 +530,22 @@ getHackageTarball
   => PackageIdentifierRevision
   -> Maybe TreeKey
   -> RIO env Package
-getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do
+getHackageTarball = getHackageTarballOnGPD (\ _ _ -> pure ())
+
+-- | Same as `getHackageTarball`, but allows an extra action to be performed on the parsed
+-- `GenericPackageDescription` and newly created `TreeId`.
+getHackageTarballOnGPD
+  :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
+  => (TreeId -> GenericPackageDescription -> RIO env ())
+  -> PackageIdentifierRevision
+  -> Maybe TreeKey
+  -> RIO env Package
+getHackageTarballOnGPD onGPD pir mtreeKey = do
+  let PackageIdentifierRevision name ver _cfi = pir
   cabalFile <- resolveCabalFileInfo pir
-  cabalFileKey <- withStorage $ getBlobKey cabalFile
   let rpli = RPLIHackage pir mtreeKey
   withCachedTree rpli name ver cabalFile $ do
+    cabalFileKey <- withStorage $ getBlobKey cabalFile
     mpair <- withStorage $ loadHackageTarballInfo name ver
     (sha, size) <-
       case mpair of
@@ -569,7 +607,8 @@ getHackageTarball pir@(PackageIdentifierRevision name ver _cfi) mtreeKey = do
             , mismatchActual = gpdIdent
             }
 
-        (_tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry)
+        (tid, treeKey') <- withStorage $ storeTree rpli ident tree' (BFCabal (cabalFileName name) cabalEntry)
+        onGPD tid gpd
         pure Package
           { packageTreeKey = treeKey'
           , packageTree = tree'