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

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

26
Data/Hackage.hs
View File

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