mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-11 19:58:28 +01:00
Stop tracking upload times from Hackage
This commit is contained in:
Michael Snoyman
parent
3f4e86e5fe
commit
70a59af6c1
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -26,12 +26,6 @@ Stackage
|
||||
UniqueStackage ident
|
||||
UniqueSnapshot slug
|
||||
|
||||
Uploaded
|
||||
name PackageName
|
||||
version Version
|
||||
uploaded UTCTime
|
||||
UniqueUploaded name version
|
||||
|
||||
Alias
|
||||
user UserId
|
||||
name Slug
|
||||
|
||||
Loading…
Reference in New Issue
Block a user