In memory upload history database

Application.hs

@@ -15,8 +15,8 @@ import Network.Wai.Middleware.RequestLogger
     )
 import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
 import qualified Database.Persist
-import Control.Monad.Logger (runLoggingT)
-import Control.Monad.Reader (runReaderT)
+import Control.Monad.Logger (runLoggingT, LoggingT)
+import Control.Monad.Reader (runReaderT, ReaderT)
 import Control.Concurrent (forkIO, threadDelay)
 import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
 import Network.Wai.Logger (clockDateCacher)
@@ -120,18 +120,16 @@ makeFoundation conf = do
 
     -- Start the cabal file loader
     void $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
-        when development $ liftIO $ threadDelay $ 5 * 60 * 1000000
+        --when development $ liftIO $ threadDelay $ 5 * 60 * 1000000
         eres <- tryAny $ flip runReaderT foundation $ do
-            loadCabalFiles $ \name version mmtime ->
-                runResourceT $ flip (Database.Persist.runPool dbconf) p $ do
-                    mx <- getBy $ UniqueUploaded name version
-                    case mx of
-                        Just {} -> return ()
-                        Nothing -> do
-                            mtime <- lift $ lift mmtime
-                            forM_ mtime $ void . insertBy . Uploaded name version
+            let runDB' :: SqlPersistT (ResourceT (ReaderT App (LoggingT IO))) a
+                       -> ReaderT App (LoggingT IO) a
+                runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p
+            uploadHistory0 <- runDB' $ selectSource [] [] $$ sinkUploadHistory
+            UploadState uploadHistory newUploads <- loadCabalFiles uploadHistory0
+            runDB' $ mapM_ insert newUploads
             let views =
-                    [ ("pvp", viewPVP)
+                    [ ("pvp", viewPVP uploadHistory)
                     , ("no-bounds", viewNoBounds)
                     , ("unchanged", viewUnchanged)
                     ]
@@ -139,7 +137,7 @@ makeFoundation conf = do
                 runResourceT $ flip (Database.Persist.runPool dbconf) p $ createView
                     name
                     func
-                    (selectSource [] [])
+                    (sourceHistory uploadHistory)
                     (storeWrite $ HackageViewIndex name)
         case eres of
             Left e -> $logError $ tshow e

Data/Hackage.hs

@@ -3,6 +3,10 @@ module Data.Hackage
     , sourceHackageSdist
     , createView
     , sourceHackageViewSdist
+    , sinkUploadHistory
+    , UploadState (..)
+    , UploadHistory
+    , sourceHistory
     ) where
 
 import ClassyPrelude.Yesod hiding (get)
@@ -26,9 +30,18 @@ import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResu
 import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
 import Distribution.PackageDescription (GenericPackageDescription, PackageDescription, packageDescription)
 import Control.Exception (throw)
-import Control.Monad.State (modify, put, get)
+import Control.Monad.State.Strict (modify, put, get, execStateT, MonadState)
 import Control.Concurrent.Lifted (fork)
 
+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
@@ -40,9 +53,9 @@ loadCabalFiles :: ( MonadActive m
                   , MonadLogger m
                   , MonadCatch m
                   )
-               => (PackageName -> Version -> m (Maybe UTCTime) -> m ()) -- ^ add upload
-               -> m ()
-loadCabalFiles addUpload = do
+               => UploadHistory -- ^ initial
+               -> m UploadState
+loadCabalFiles uploadHistory0 = flip execStateT (UploadState uploadHistory0 []) $ do
     HackageRoot root <- liftM getHackageRoot ask
     $logDebug $ "Entering loadCabalFiles, root == " ++ root
     req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
@@ -65,30 +78,46 @@ loadCabalFiles addUpload = do
                     store <- liftM getBlobStore ask
                     unless exists $ withAcquire (storeWrite' store key) $ \sink ->
                         sourceLazy lbs $$ sink
-                    setUploadDate name version addUpload
+                    setUploadDate name version
             _ -> return ()
 
 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 = UploadState
+    { usHistory :: !UploadHistory
+    , usChanges :: ![Uploaded]
+    }
+
 setUploadDate :: ( MonadBaseControl IO m
                  , MonadThrow m
                  , MonadIO m
                  , MonadReader env m
+                 , MonadState UploadState m
                  , HasHttpManager env
                  , MonadLogger m
                  )
               => PackageName
               -> Version
-              -> (PackageName -> Version -> m (Maybe UTCTime) -> m ())
               -> m ()
-setUploadDate name version addUpload = addUpload name version $ do
-    req <- parseUrl url
-    $logDebug $ "Requesting: " ++ tshow req
-    lbs <- withResponse req $ \res -> responseBody res $$ sinkLazy
-    let uploadDateT = decodeUtf8 $ toStrict lbs
-    return $ parseTime defaultTimeLocale "%c" $ unpack uploadDateT
+setUploadDate name version = do
+    UploadState history changes <- 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'
   where
     url = unpack $ concat
         [ "http://hackage.haskell.org/package/"
@@ -215,7 +244,7 @@ createView :: ( MonadResource m
               )
            => HackageView
            -> (PackageName -> Version -> UTCTime -> GenericPackageDescription -> m GenericPackageDescription)
-           -> Source m (Entity Uploaded)
+           -> Source m Uploaded
            -> Sink ByteString m ()
            -> m ()
 createView viewName modifyCabal src sink = withSystemTempDirectory "createview" $ \dir -> do
@@ -224,7 +253,7 @@ createView viewName modifyCabal src sink = withSystemTempDirectory "createview"
     entries <- liftIO $ Tar.pack dir (map fpToString $ setToList rels)
     sourceLazy (Tar.write entries) $$ gzip =$ sink
   where
-    uploadedConduit dir (Entity _ (Uploaded name version time)) = do
+    uploadedConduit dir (Uploaded name version time) = do
         let relfp = fpFromText (toPathPiece name)
                 </> fpFromText (toPathPiece version)
                 </> fpFromText (concat
@@ -250,6 +279,15 @@ createView viewName modifyCabal src sink = withSystemTempDirectory "createview"
                 writeFile fp new
                 return $ asSet $ singletonSet relfp
 
+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 _ = mapMC
 {- FIXME

Data/Hackage/Views.hs

@@ -9,6 +9,7 @@ import Types hiding (Version (..))
 import qualified Types
 import Model
 import Data.NonNull (fromNullable) -- FIXME expose from ClassyPrelude
+import Data.Hackage (UploadHistory)
 
 viewUnchanged :: Monad m
               => packageName -> version -> time
@@ -63,14 +64,15 @@ viewNoBounds _ _ _ =
   where
     go (Dependency name _range) = return $ Dependency name anyVersion
 
-viewPVP :: ( Monad m
-           , PersistMonadBackend m ~ SqlBackend
-           , PersistQuery m
-           )
-        => packageName -> version -> UTCTime
+getAvailable name maxUploaded =
+    map fst . filter ((<= maxUploaded) . snd) . mapToList . fromMaybe mempty . lookup name
+
+viewPVP :: Monad m
+        => UploadHistory
+        -> packageName -> version -> UTCTime
         -> GenericPackageDescription
         -> m GenericPackageDescription
-viewPVP _ _ uploaded =
+viewPVP uploadHistory _ _ uploaded =
     helper go
   where
     wiredIn = asSet $ setFromList $ words "base ghc template-haskell"
@@ -80,8 +82,8 @@ viewPVP _ _ uploaded =
     go (Dependency name _) | toStr name `member` wiredIn = return $ Dependency name anyVersion
     go orig@(Dependency _ range) | hasUpperBound range = return orig
     go orig@(Dependency nameO@(toStr -> name) range) = do
-        available <- selectList [UploadedName ==. fromString name, UploadedUploaded <=. uploaded] []
-        case fromNullable $ mapMaybe (simpleParse . unpack . toPathPiece . uploadedVersion . entityVal) available of
+        let available = getAvailable (fromString name) uploaded uploadHistory
+        case fromNullable $ mapMaybe (simpleParse . unpack . toPathPiece) available of
             Nothing -> return orig
             Just vs ->
                 case pvpBump $ maximum vs of