haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-12 04:08:29 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

STACKAGE_FORCE_UPDATE

Browse Source
This commit is contained in:
Michael Snoyman 2014-11-24 11:35:01 +02:00
parent 4e945d5fd9
commit 3a8bdb2ade
2 changed files with 16 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
Application.hs
View File

@ -186,7 +186,8 @@ makeFoundation useEcho conf = do
env <- getEnvironment
let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0"
loadCabalFiles' = appLoadCabalFiles updateDB foundation dbconf p
forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
loadCabalFiles' = appLoadCabalFiles updateDB forceUpdate foundation dbconf p
-- Start the cabal file loader
ifRunCabalLoader $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
@ -225,8 +226,11 @@ cabalLoaderMain = do
manager <- newManager
bs <- loadBlobStore manager conf
hSetBuffering stdout LineBuffering
env <- getEnvironment
let forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
flip runLoggingT logFunc $ appLoadCabalFiles
True
True -- update database?
forceUpdate
CabalLoaderEnv
{ cleSettings = conf
, cleBlobStore = bs
@ -246,11 +250,12 @@ appLoadCabalFiles :: ( PersistConfig c
, HasHttpManager env
)
=> Bool -- ^ update database?
-> Bool -- ^ force update?
-> env
-> c
-> PersistConfigPool c
-> LoggingT IO ()
appLoadCabalFiles updateDB env dbconf p = do
appLoadCabalFiles updateDB forceUpdate env dbconf p = do
eres <- tryAny $ flip runReaderT env $ do
let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a
-> ReaderT env (LoggingT IO) a
@ -264,7 +269,7 @@ appLoadCabalFiles updateDB env dbconf p = do
, m E.^. MetadataVersion
, m E.^. MetadataHash
)
UploadState uploadHistory newUploads _ newMD <- loadCabalFiles updateDB uploadHistory0 metadata0
UploadState uploadHistory newUploads _ newMD <- loadCabalFiles updateDB forceUpdate uploadHistory0 metadata0
$logInfo "Inserting to new uploads"
runDB' $ insertMany_ newUploads
$logInfo "Updating metadatas"

11
Data/Hackage.hs
View File

@ -62,10 +62,11 @@ loadCabalFiles :: ( MonadActive m
, MonadMask m
)
=> Bool -- ^ do the database updating
-> Bool -- ^ force updates regardless of hash value?
-> UploadHistory -- ^ initial
-> HashMap PackageName (Version, ByteString)
-> m (UploadState Metadata)
loadCabalFiles dbUpdates uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata1 mempty) $ do
loadCabalFiles dbUpdates forceUpdate uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata1 mempty) $ do
HackageRoot root <- liftM getHackageRoot ask
$logDebug $ "Entering loadCabalFiles, root == " ++ root
req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
@ -116,6 +117,7 @@ loadCabalFiles dbUpdates uploadHistory0 metadata0 = (>>= runUploadState) $ flip
case readVersion version of
Nothing -> return ()
Just dataVersion -> setMetadata
forceUpdate
name
version
dataVersion
@ -199,13 +201,14 @@ setMetadata :: ( MonadBaseControl IO m
, HasBlobStore env StoreKey
, HasHackageRoot env
)
=> PackageName
=> Bool -- ^ force update?
-> PackageName
-> Version
-> UVector Int -- ^ versionBranch
-> ByteString
-> ParseResult PD.GenericPackageDescription
-> m ()
setMetadata name version dataVersion hash' gpdRes = do
setMetadata forceUpdate name version dataVersion hash' gpdRes = do
UploadState us1 us2 mdMap mdChanges <- get
let toUpdate =
case lookup name mdMap of
@ -213,7 +216,7 @@ setMetadata name version dataVersion hash' gpdRes = do
case compare currDataVersion dataVersion of
LT -> True
GT -> False
EQ -> currHash /= hash'
EQ -> currHash /= hash' || forceUpdate
Nothing -> True
if toUpdate
then case gpdRes of