Stop tracking upload times from Hackage

Application.hs

@@ -300,7 +300,6 @@ appLoadCabalFiles updateDB forceUpdate env dbconf p = do
         let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a
                    -> ReaderT env (LoggingT IO) a
             runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p
-        uploadHistory0 <- runDB' $ selectSource [] [] $$ sinkUploadHistory
         let toMDPair (E.Value name, E.Value version, E.Value hash') =
                 (name, (version, hash'))
         metadata0 <- fmap (mapFromList . map toMDPair)
@@ -309,9 +308,7 @@ appLoadCabalFiles updateDB forceUpdate env dbconf p = do
             , m E.^. MetadataVersion
             , m E.^. MetadataHash
             )
-        UploadState uploadHistory newUploads _ newMD <- loadCabalFiles updateDB forceUpdate uploadHistory0 metadata0
+        UploadState _ newMD <- loadCabalFiles updateDB forceUpdate metadata0
-        $logInfo "Inserting to new uploads"
-        runDB' $ insertMany_ newUploads
         $logInfo $ "Updating metadatas: " ++ tshow (length newMD)
         runDB' $ do
             let newMD' = toList newMD

Data/Hackage.hs

@@ -1,10 +1,7 @@
 module Data.Hackage
     ( loadCabalFiles
     , sourceHackageSdist
-    , sinkUploadHistory
     , UploadState (..)
-    , UploadHistory
-    , sourceHistory
     ) where
 
 import ClassyPrelude.Yesod hiding (get)
@@ -17,7 +14,7 @@ import qualified Data.Text as T
 import Data.Conduit.Zlib (ungzip)
 import System.IO.Temp (withSystemTempFile)
 import System.IO (IOMode (ReadMode), openBinaryFile)
-import Model (Uploaded (Uploaded), Metadata (..))
+import Model (Metadata (..))
 import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult (ParseOk))
 import qualified Distribution.PackageDescription as PD
 import qualified Distribution.Package as PD
@@ -38,15 +35,6 @@ import qualified Documentation.Haddock.Parser as Haddock
 import Documentation.Haddock.Types (DocH (..), Hyperlink (..), Picture (..), Header (..), Example (..))
 import qualified Data.HashMap.Lazy as HM
 
-sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory
-sinkUploadHistory =
-    foldlC go mempty
-  where
-    go history (Entity _ (Uploaded name version time)) =
-        case lookup name history of
-            Nothing -> insertMap name (singletonMap version time) history
-            Just vhistory -> insertMap name (insertMap version time vhistory) history
-
 loadCabalFiles :: ( MonadActive m
                   , MonadBaseControl IO m
                   , MonadThrow m
@@ -60,10 +48,9 @@ loadCabalFiles :: ( MonadActive m
                   )
                => Bool -- ^ do the database updating
                -> Bool -- ^ force updates regardless of hash value?
-               -> UploadHistory -- ^ initial
                -> HashMap PackageName (Version, ByteString)
                -> m (UploadState Metadata)
-loadCabalFiles dbUpdates forceUpdate uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata1 mempty) $ do
+loadCabalFiles dbUpdates forceUpdate metadata0 = (>>= runUploadState) $ flip execStateT (UploadState metadata1 mempty) $ do
     HackageRoot root <- liftM getHackageRoot ask
     $logDebug $ "Entering loadCabalFiles, root == " ++ root
     req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
@@ -110,8 +97,6 @@ loadCabalFiles dbUpdates forceUpdate uploadHistory0 metadata0 = (>>= runUploadSt
                     when toStore $ withAcquire (storeWrite' store key) $ \sink ->
                         sourceLazy lbs $$ sink
                     when dbUpdates $ do
-                        setUploadDate name version
-
                         case readVersion version of
                             Nothing -> return ()
                             Just dataVersion -> setMetadata
@@ -130,7 +115,7 @@ readVersion v =
         [] -> Nothing
 
 runUploadState :: MonadIO m => UploadState (IO a) -> m (UploadState a)
-runUploadState (UploadState w x y z) = liftIO $ UploadState w x y <$> T.sequence z
+runUploadState (UploadState y z) = liftIO $ UploadState y <$> T.sequence z
 
 tarSource :: (Exception e, MonadThrow m)
           => Tar.Entries e
@@ -139,11 +124,8 @@ tarSource Tar.Done = return ()
 tarSource (Tar.Fail e) = throwM e
 tarSource (Tar.Next e es) = yield e >> tarSource es
 
-type UploadHistory = HashMap PackageName (HashMap Version UTCTime)
 data UploadState md = UploadState
-    { usHistory :: !UploadHistory
+    { usMetadata :: !(HashMap PackageName MetaSig)
-    , usChanges :: ![Uploaded]
-    , usMetadata :: !(HashMap PackageName MetaSig)
     , usMetaChanges :: (HashMap PackageName md)
     }
 
@@ -152,42 +134,6 @@ data MetaSig = MetaSig
     {-# UNPACK #-} !(UVector Int) -- versionBranch
     {-# UNPACK #-} !ByteString -- hash
 
-setUploadDate :: ( MonadBaseControl IO m
-                 , MonadThrow m
-                 , MonadIO m
-                 , MonadReader env m
-                 , MonadState (UploadState (IO Metadata)) m
-                 , HasHttpManager env
-                 , MonadLogger m
-                 )
-              => PackageName
-              -> Version
-              -> m ()
-setUploadDate name version = do
-    UploadState history changes us3 us4 <- get
-    case lookup name history >>= lookup version of
-        Just _ -> return ()
-        Nothing -> do
-            req <- parseUrl url
-            $logDebug $ "Requesting: " ++ tshow req
-            lbs <- withResponse req $ \res -> responseBody res $$ sinkLazy
-            let uploadDateT = decodeUtf8 $ toStrict lbs
-            case parseTime defaultTimeLocale "%c" $ unpack uploadDateT of
-                Nothing -> return ()
-                Just time -> do
-                    let vhistory = insertMap version time $ fromMaybe mempty $ lookup name history
-                        history' = insertMap name vhistory history
-                        changes' = Uploaded name version time : changes
-                    put $ UploadState history' changes' us3 us4
-  where
-    url = unpack $ concat
-        [ "http://hackage.haskell.org/package/"
-        , toPathPiece name
-        , "-"
-        , toPathPiece version
-        , "/upload-time"
-        ]
-
 setMetadata :: ( MonadBaseControl IO m
                , MonadThrow m
                , MonadIO m
@@ -207,7 +153,7 @@ setMetadata :: ( MonadBaseControl IO m
             -> ParseResult PD.GenericPackageDescription
             -> m ()
 setMetadata forceUpdate name version dataVersion hash' gpdRes = do
-    UploadState us1 us2 mdMap mdChanges <- get
+    UploadState mdMap mdChanges <- get
     let toUpdate =
             case lookup name mdMap of
                 Just (MetaSig _currVersion currDataVersion currHash) ->
@@ -220,7 +166,7 @@ setMetadata forceUpdate name version dataVersion hash' gpdRes = do
         then case gpdRes of
                 ParseOk _ gpd -> do
                     !md <- getMetadata name version hash' gpd
-                    put $! UploadState us1 us2
+                    put $! UploadState
                                 (insertMap name (MetaSig version dataVersion hash') mdMap)
                                 (HM.insert name md mdChanges)
                 _ -> return ()
@@ -427,15 +373,6 @@ sourceHackageSdist name version = do
                 then storeRead key
                 else return Nothing
 
-sourceHistory :: Monad m => UploadHistory -> Producer m Uploaded
-sourceHistory =
-    mapM_ go . mapToList
-  where
-    go (name, vhistory) =
-        mapM_ go' $ mapToList vhistory
-      where
-        go' (version, time) = yield $ Uploaded name version time
-
 -- FIXME put in conduit-combinators
 parMapMC :: (MonadIO m, MonadBaseControl IO m)
          => Int

Handler/PackageList.hs

@@ -17,10 +17,9 @@ getPackageListR = defaultLayout $ do
                 )
             addDocs (x, y) = (x, Nothing, y, Nothing)
         packages <- fmap (map addDocs . uniqueByKey . map clean) $ handlerToWidget $ runDB $
-            E.selectDistinct $ E.from $ \(u,m) -> do
+            E.selectDistinct $ E.from $ \m -> do
-              E.where_ (m E.^. MetadataName E.==. u E.^. UploadedName)
+              E.orderBy [E.asc $ m E.^. MetadataName]
-              E.orderBy [E.asc $ u E.^. UploadedName]
+              return $ (m E.^. MetadataName
-              return $ (u E.^. UploadedName
                        ,m E.^. MetadataSynopsis)
         $(widgetFile "package-list")
   where strip x = fromMaybe x (stripSuffix "." x)

Handler/StackageHome.hs

@@ -29,18 +29,17 @@ getStackageHomeR slug = do
         cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
             let maxPackages = 5000
             (packageListClipped, packages') <- handlerToWidget $ runDB $ do
-                packages' <- E.select $ E.from $ \(u,m,p) -> do
+                packages' <- E.select $ E.from $ \(m,p) -> do
                     E.where_ $
-                        (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
                         (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
                         (p E.^. PackageStackage E.==. E.val sid)
-                    E.orderBy [E.asc $ u E.^. UploadedName]
+                    E.orderBy [E.asc $ m E.^. MetadataName]
-                    E.groupBy ( u E.^. UploadedName
+                    E.groupBy ( m E.^. MetadataName
                               , m E.^. MetadataSynopsis
                               )
                     E.limit maxPackages
                     return
-                        ( u E.^. UploadedName
+                        ( m E.^. MetadataName
                         , m E.^. MetadataSynopsis
                         , E.max_ (p E.^. PackageVersion)
                         , E.max_ $ E.case_
@@ -186,17 +185,16 @@ getSnapshotPackagesR slug = do
     defaultLayout $ do
         setTitle $ toHtml $ "Package list for " ++ toPathPiece slug
         cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
-            packages' <- handlerToWidget $ runDB $ E.select $ E.from $ \(u,m,p) -> do
+            packages' <- handlerToWidget $ runDB $ E.select $ E.from $ \(m,p) -> do
                 E.where_ $
-                    (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
                     (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
                     (p E.^. PackageStackage E.==. E.val sid)
-                E.orderBy [E.asc $ u E.^. UploadedName]
+                E.orderBy [E.asc $ m E.^. MetadataName]
-                E.groupBy ( u E.^. UploadedName
+                E.groupBy ( m E.^. MetadataName
                           , m E.^. MetadataSynopsis
                           )
                 return
-                    ( u E.^. UploadedName
+                    ( m E.^. MetadataName
                     , m E.^. MetadataSynopsis
                     , E.max_ $ E.case_
                         [ ( p E.^. PackageHasHaddocks

config/models

@@ -26,12 +26,6 @@ Stackage
     UniqueStackage ident
     UniqueSnapshot slug
 
-Uploaded
-    name PackageName
-    version Version
-    uploaded UTCTime
-    UniqueUploaded name version
-
 Alias
     user UserId
     name Slug