Lazier metadata loading

Data/Hackage.hs

@@ -14,7 +14,8 @@ import Types
 import Data.BlobStore
 import Data.Conduit.Lazy (MonadActive (..), lazyConsume)
 import qualified Codec.Archive.Tar as Tar
-import Control.Monad.Reader (MonadReader, ask)
+import Control.Monad.Reader (MonadReader, ask, runReaderT)
+import Control.Monad.Logger (runNoLoggingT)
 import qualified Data.Text as T
 import Data.Conduit.Zlib (ungzip, gzip)
 import System.IO.Temp (withSystemTempFile, withSystemTempDirectory)
@@ -35,6 +36,7 @@ import Data.Byteable (toBytes)
 import Distribution.Text (display)
 import Text.Markdown (Markdown (Markdown))
 import Data.Foldable (foldMap)
+import qualified Data.Traversable as T
 
 sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory
 sinkUploadHistory =
@@ -58,8 +60,8 @@ loadCabalFiles :: ( MonadActive m
                   )
                => UploadHistory -- ^ initial
                -> HashMap PackageName (Version, ByteString)
-               -> m UploadState
+               -> m (UploadState Metadata)
-loadCabalFiles uploadHistory0 metadata0 = flip execStateT (UploadState uploadHistory0 [] metadata0 mempty) $ do
+loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata0 mempty) $ do
     HackageRoot root <- liftM getHackageRoot ask
     $logDebug $ "Entering loadCabalFiles, root == " ++ root
     req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
@@ -102,6 +104,9 @@ loadCabalFiles uploadHistory0 metadata0 = flip execStateT (UploadState uploadHis
                               $ parsePackageDescription $ unpack $ decodeUtf8 lbs
             _ -> return ()
 
+runUploadState :: MonadIO m => UploadState (IO a) -> m (UploadState a)
+runUploadState (UploadState w x y z) = liftIO $ UploadState w x y <$> T.sequence z
+
 tarSource :: (Exception e, MonadThrow m)
           => Tar.Entries e
           -> Producer m Tar.Entry
@@ -110,18 +115,18 @@ tarSource (Tar.Fail e) = throwM e
 tarSource (Tar.Next e es) = yield e >> tarSource es
 
 type UploadHistory = HashMap PackageName (HashMap Version UTCTime)
-data UploadState = UploadState
+data UploadState md = UploadState
     { usHistory :: !UploadHistory
     , usChanges :: ![Uploaded]
     , usMetadata :: !(HashMap PackageName (Version, ByteString))
-    , usMetaChanges :: !(HashMap PackageName Metadata)
+    , usMetaChanges :: !(HashMap PackageName md)
     }
 
 setUploadDate :: ( MonadBaseControl IO m
                  , MonadThrow m
                  , MonadIO m
                  , MonadReader env m
-                 , MonadState UploadState m
+                 , MonadState (UploadState (IO Metadata)) m
                  , HasHttpManager env
                  , MonadLogger m
                  )
@@ -157,7 +162,7 @@ setMetadata :: ( MonadBaseControl IO m
                , MonadThrow m
                , MonadIO m
                , MonadReader env m
-               , MonadState UploadState m
+               , MonadState (UploadState (IO Metadata)) m
                , HasHttpManager env
                , MonadLogger m
                , MonadActive m
@@ -203,37 +208,39 @@ getMetadata :: ( MonadActive m
             -> Version
             -> ByteString
             -> PD.GenericPackageDescription
-            -> m Metadata
+            -> m (IO Metadata)
 getMetadata name version hash' gpd = do
     let pd = PD.packageDescription gpd
-    (mreadme, mchangelog, mlicenseContent) <-
+    env <- ask
-        grabExtraFiles name version $ PD.licenseFiles pd
+    return $ liftIO $ runNoLoggingT $ flip runReaderT env $ do
-    return Metadata
+        (mreadme, mchangelog, mlicenseContent) <-
-        { metadataName = name
+            grabExtraFiles name version $ PD.licenseFiles pd
-        , metadataVersion = version
+        return Metadata
-        , metadataHash = hash'
+            { metadataName = name
-        , metadataDeps = setToList
+            , metadataVersion = version
-                       $ asSet
+            , metadataHash = hash'
-                       $ concat
+            , metadataDeps = setToList
-              [ foldMap goTree $ PD.condLibrary gpd
+                           $ asSet
-              , foldMap (goTree . snd) $ PD.condExecutables gpd
+                           $ concat
-              ]
+                  [ foldMap goTree $ PD.condLibrary gpd
-        , metadataAuthor = pack $ PD.author pd
+                  , foldMap (goTree . snd) $ PD.condExecutables gpd
-        , metadataMaintainer = pack $ PD.maintainer pd
+                  ]
-        , metadataLicenseName = pack $ display $ PD.license pd
+            , metadataAuthor = pack $ PD.author pd
-        , metadataHomepage = pack $ PD.homepage pd
+            , metadataMaintainer = pack $ PD.maintainer pd
-        , metadataBugReports = pack $ PD.bugReports pd
+            , metadataLicenseName = pack $ display $ PD.license pd
-        , metadataSynopsis = pack $ PD.synopsis pd
+            , metadataHomepage = pack $ PD.homepage pd
-        , metadataSourceRepo = mapMaybe showSourceRepo $ PD.sourceRepos pd
+            , metadataBugReports = pack $ PD.bugReports pd
-        , metadataCategory = pack $ PD.category pd
+            , metadataSynopsis = pack $ PD.synopsis pd
-        , metadataLibrary = isJust $ PD.library pd
+            , metadataSourceRepo = mapMaybe showSourceRepo $ PD.sourceRepos pd
-        , metadataExes = length $ PD.executables pd
+            , metadataCategory = pack $ PD.category pd
-        , metadataTestSuites = length $ PD.testSuites pd
+            , metadataLibrary = isJust $ PD.library pd
-        , metadataBenchmarks = length $ PD.benchmarks pd
+            , metadataExes = length $ PD.executables pd
-        , metadataReadme = fromMaybe (toHtml $ Textarea $ pack $ PD.description pd) mreadme
+            , metadataTestSuites = length $ PD.testSuites pd
-        , metadataChangelog = mchangelog
+            , metadataBenchmarks = length $ PD.benchmarks pd
-        , metadataLicenseContent = mlicenseContent
+            , metadataReadme = fromMaybe (toHtml $ Textarea $ pack $ PD.description pd) mreadme
-        }
+            , metadataChangelog = mchangelog
+            , metadataLicenseContent = mlicenseContent
+            }
   where
     goTree (PD.CondNode _ deps comps) = concatMap goDep deps ++ concatMap goComp comps
     goDep (PD.Dependency (PD.PackageName n) _) = singletonSet $ pack n