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

Better production cabal file loading

Browse Source 
We still need to load the cabal files to get them onto the system. Now
we just don't do any expensive processing.
This commit is contained in:
Michael Snoyman 2014-11-18 18:13:18 +02:00
parent b21694cbd6
commit cce7fb3ddf
2 changed files with 21 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
Application.hs
View File

@ -188,10 +188,8 @@ makeFoundation useEcho conf = do
(messageLoggerSource foundation logger) (messageLoggerSource foundation logger)
env <- getEnvironment env <- getEnvironment
let loadCabalFiles' = let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0"
case lookup "STACKAGE_CABAL_LOADER" env of loadCabalFiles' = appLoadCabalFiles updateDB foundation dbconf p
Just "0" -> return ()
_ -> appLoadCabalFiles 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
@ -231,6 +229,7 @@ cabalLoaderMain = do
bs <- loadBlobStore manager conf bs <- loadBlobStore manager conf
hSetBuffering stdout LineBuffering hSetBuffering stdout LineBuffering
flip runLoggingT logFunc $ appLoadCabalFiles flip runLoggingT logFunc $ appLoadCabalFiles
True
CabalLoaderEnv CabalLoaderEnv
{ cleSettings = conf { cleSettings = conf
, cleBlobStore = bs , cleBlobStore = bs
@ -249,11 +248,12 @@ appLoadCabalFiles :: ( PersistConfig c
, HasBlobStore env StoreKey , HasBlobStore env StoreKey
, HasHttpManager env , HasHttpManager env
) )
=> env => Bool -- ^ update database?
-> env
-> c -> c
-> PersistConfigPool c -> PersistConfigPool c
-> LoggingT IO () -> LoggingT IO ()
appLoadCabalFiles env dbconf p = do appLoadCabalFiles updateDB 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
@ -267,7 +267,7 @@ appLoadCabalFiles env dbconf p = do
, m E.^. MetadataVersion , m E.^. MetadataVersion
, m E.^. MetadataHash , m E.^. MetadataHash
) )
UploadState uploadHistory newUploads _ newMD <- loadCabalFiles uploadHistory0 metadata0 UploadState uploadHistory newUploads _ newMD <- loadCabalFiles updateDB uploadHistory0 metadata0
$logInfo "Inserting to new uploads" $logInfo "Inserting to new uploads"
runDB' $ mapM_ insert_ newUploads runDB' $ mapM_ insert_ newUploads
$logInfo "Updating metadatas" $logInfo "Updating metadatas"

26
Data/Hackage.hs
View File

@ -61,10 +61,11 @@ loadCabalFiles :: ( MonadActive m
, MonadLogger m , MonadLogger m
, MonadMask m , MonadMask m
) )
=> UploadHistory -- ^ initial => Bool -- ^ do the database updating
-> UploadHistory -- ^ initial
-> HashMap PackageName (Version, ByteString) -> HashMap PackageName (Version, ByteString)
-> m (UploadState Metadata) -> m (UploadState Metadata)
loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata1 mempty) $ do loadCabalFiles dbUpdates 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"
@ -76,7 +77,7 @@ loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT
bss <- lazyConsume $ sourceHandle handleIn $= ungzip bss <- lazyConsume $ sourceHandle handleIn $= ungzip
tarSource (Tar.read $ fromChunks bss) tarSource (Tar.read $ fromChunks bss)
$$ parMapMC 32 go $$ parMapMC 32 go
=$ scanlC (\x _ -> x + 1) 0 =$ scanlC (\x _ -> x + 1) (0 :: Int)
=$ filterC ((== 0) . (`mod` 1000)) =$ filterC ((== 0) . (`mod` 1000))
=$ mapM_C (\i -> $logInfo $ "Processing cabal file #" ++ tshow i) =$ mapM_C (\i -> $logInfo $ "Processing cabal file #" ++ tshow i)
where where
@ -109,16 +110,17 @@ loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT
return $! currDigest /= newDigest return $! currDigest /= newDigest
when toStore $ withAcquire (storeWrite' store key) $ \sink -> when toStore $ withAcquire (storeWrite' store key) $ \sink ->
sourceLazy lbs $$ sink sourceLazy lbs $$ sink
setUploadDate name version when dbUpdates $ do
setUploadDate name version
case readVersion version of case readVersion version of
Nothing -> return () Nothing -> return ()
Just dataVersion -> setMetadata Just dataVersion -> setMetadata
name name
version version
dataVersion dataVersion
(toBytes newDigest) (toBytes newDigest)
(parsePackageDescription $ unpack $ decodeUtf8 lbs) (parsePackageDescription $ unpack $ decodeUtf8 lbs)
_ -> return () _ -> return ()
readVersion :: Version -> Maybe (UVector Int) readVersion :: Version -> Maybe (UVector Int)