haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-18 07:01:55 +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 env <- getEnvironment
let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0" 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 -- Start the cabal file loader
ifRunCabalLoader $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do ifRunCabalLoader $ forkIO $ forever $ flip runLoggingT (messageLoggerSource foundation logger) $ do
@ -225,8 +226,11 @@ cabalLoaderMain = do
manager <- newManager manager <- newManager
bs <- loadBlobStore manager conf bs <- loadBlobStore manager conf
hSetBuffering stdout LineBuffering hSetBuffering stdout LineBuffering
env <- getEnvironment
let forceUpdate = lookup "STACKAGE_FORCE_UPDATE" env == Just "1"
flip runLoggingT logFunc $ appLoadCabalFiles flip runLoggingT logFunc $ appLoadCabalFiles
True True -- update database?
forceUpdate
CabalLoaderEnv CabalLoaderEnv
{ cleSettings = conf { cleSettings = conf
, cleBlobStore = bs , cleBlobStore = bs
@ -246,11 +250,12 @@ appLoadCabalFiles :: ( PersistConfig c
, HasHttpManager env , HasHttpManager env
) )
=> Bool -- ^ update database? => Bool -- ^ update database?
-> Bool -- ^ force update?
-> env -> env
-> c -> c
-> PersistConfigPool c -> PersistConfigPool c
-> LoggingT IO () -> LoggingT IO ()
appLoadCabalFiles updateDB env dbconf p = do appLoadCabalFiles updateDB forceUpdate env dbconf p = do
eres <- tryAny $ flip runReaderT env $ do eres <- tryAny $ flip runReaderT env $ do
let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a let runDB' :: SqlPersistT (ResourceT (ReaderT env (LoggingT IO))) a
-> 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.^. MetadataVersion
, m E.^. MetadataHash , 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" $logInfo "Inserting to new uploads"
runDB' $ insertMany_ newUploads runDB' $ insertMany_ newUploads
$logInfo "Updating metadatas" $logInfo "Updating metadatas"

11
Data/Hackage.hs
View File

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