From b2170578aeb6b412b7376090846ed23caafd7bcc Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 16 Apr 2014 15:29:24 +0300 Subject: [PATCH] In memory upload history database --- Application.hs | 24 ++++++++-------- Data/Hackage.hs | 66 ++++++++++++++++++++++++++++++++++--------- Data/Hackage/Views.hs | 18 ++++++------ 3 files changed, 73 insertions(+), 35 deletions(-) diff --git a/Application.hs b/Application.hs index e326685..7ff3954 100644 --- a/Application.hs +++ b/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 diff --git a/Data/Hackage.hs b/Data/Hackage.hs index a9fc269..a2b9b87 100644 --- a/Data/Hackage.hs +++ b/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 diff --git a/Data/Hackage/Views.hs b/Data/Hackage/Views.hs index f6675d1..b4f1523 100644 --- a/Data/Hackage/Views.hs +++ b/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