diff --git a/Application.hs b/Application.hs index e2e4bec..31639b3 100644 --- a/Application.hs +++ b/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 - $logInfo "Inserting to new uploads" - runDB' $ insertMany_ newUploads + UploadState _ newMD <- loadCabalFiles updateDB forceUpdate metadata0 $logInfo $ "Updating metadatas: " ++ tshow (length newMD) runDB' $ do let newMD' = toList newMD diff --git a/Data/Hackage.hs b/Data/Hackage.hs index 4c5a466..17cf101 100644 --- a/Data/Hackage.hs +++ b/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 - , usChanges :: ![Uploaded] - , usMetadata :: !(HashMap PackageName MetaSig) + { 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 diff --git a/Handler/PackageList.hs b/Handler/PackageList.hs index aab68ce..655f421 100644 --- a/Handler/PackageList.hs +++ b/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.where_ (m E.^. MetadataName E.==. u E.^. UploadedName) - E.orderBy [E.asc $ u E.^. UploadedName] - return $ (u E.^. UploadedName + E.selectDistinct $ E.from $ \m -> do + E.orderBy [E.asc $ m E.^. MetadataName] + return $ (m E.^. MetadataName ,m E.^. MetadataSynopsis) $(widgetFile "package-list") where strip x = fromMaybe x (stripSuffix "." x) diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index 680948f..4a872ca 100644 --- a/Handler/StackageHome.hs +++ b/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.groupBy ( u E.^. UploadedName + E.orderBy [E.asc $ m E.^. MetadataName] + 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.groupBy ( u E.^. UploadedName + E.orderBy [E.asc $ m E.^. MetadataName] + 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 diff --git a/config/models b/config/models index 6e2f388..e4cc69b 100644 --- a/config/models +++ b/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