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

Improve memory usage a bit

Browse Source
This commit is contained in:
Michael Snoyman 2014-11-17 07:32:37 +02:00
parent 3c61cd64af
commit 718a42701d
1 changed files with 15 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
Data/Hackage.hs
View File

@ -75,8 +75,10 @@ loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT
bss <- lazyConsume $ sourceHandle handleIn $= ungzip bss <- lazyConsume $ sourceHandle handleIn $= ungzip
tarSource (Tar.read $ fromChunks bss) $$ parMapMC 32 go =$ sinkNull -- FIXME parMapM_C tarSource (Tar.read $ fromChunks bss) $$ parMapMC 32 go =$ sinkNull -- FIXME parMapM_C
where where
metadata1 = flip fmap metadata0 $ \(v, h) -> metadata1 = flip fmap metadata0 $ \(v, h) -> MetaSig
(v, fromMaybe (Data.Version.Version [0, 0, 0] []) $ readVersion v, h) v
(fromMaybe (pack [0, 0, 0]) $ readVersion v)
h
withBinaryFile fp mode = bracket (liftIO $ openBinaryFile fp mode) (liftIO . hClose) withBinaryFile fp mode = bracket (liftIO $ openBinaryFile fp mode) (liftIO . hClose)
go entry = do go entry = do
@ -114,10 +116,10 @@ loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT
(parsePackageDescription $ unpack $ decodeUtf8 lbs) (parsePackageDescription $ unpack $ decodeUtf8 lbs)
_ -> return () _ -> return ()
readVersion :: Version -> Maybe Data.Version.Version readVersion :: Version -> Maybe (UVector Int)
readVersion v = readVersion v =
case filter (not . null . snd) $ readP_to_S Data.Version.parseVersion . unpack . unVersion $ v of case filter (not . null . snd) $ readP_to_S Data.Version.parseVersion . unpack . unVersion $ v of
(dv, _):_ -> Just dv (dv, _):_ -> Just $ pack $ Data.Version.versionBranch dv
[] -> Nothing [] -> Nothing
runUploadState :: MonadIO m => UploadState (IO a) -> m (UploadState a) runUploadState :: MonadIO m => UploadState (IO a) -> m (UploadState a)
@ -134,10 +136,15 @@ type UploadHistory = HashMap PackageName (HashMap Version UTCTime)
data UploadState md = UploadState data UploadState md = UploadState
{ usHistory :: !UploadHistory { usHistory :: !UploadHistory
, usChanges :: ![Uploaded] , usChanges :: ![Uploaded]
, usMetadata :: !(HashMap PackageName (Version, Data.Version.Version, ByteString)) , usMetadata :: !(HashMap PackageName MetaSig)
, usMetaChanges :: !(HashMap PackageName md) , usMetaChanges :: !(HashMap PackageName md)
} }
data MetaSig = MetaSig
{-# UNPACK #-} !Version
{-# UNPACK #-} !(UVector Int) -- versionBranch
{-# UNPACK #-} !ByteString -- hash
setUploadDate :: ( MonadBaseControl IO m setUploadDate :: ( MonadBaseControl IO m
, MonadThrow m , MonadThrow m
, MonadIO m , MonadIO m
@ -187,7 +194,7 @@ setMetadata :: ( MonadBaseControl IO m
) )
=> PackageName => PackageName
-> Version -> Version
-> Data.Version.Version -> UVector Int -- ^ versionBranch
-> ByteString -> ByteString
-> ParseResult PD.GenericPackageDescription -> ParseResult PD.GenericPackageDescription
-> m () -> m ()
@ -195,7 +202,7 @@ setMetadata 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
Just (_currVersion, currDataVersion, currHash) -> Just (MetaSig _currVersion currDataVersion currHash) ->
case compare currDataVersion dataVersion of case compare currDataVersion dataVersion of
LT -> True LT -> True
GT -> False GT -> False
@ -206,7 +213,7 @@ setMetadata name version dataVersion hash' gpdRes = do
ParseOk _ gpd -> do ParseOk _ gpd -> do
!md <- getMetadata name version hash' gpd !md <- getMetadata name version hash' gpd
put $! UploadState us1 us2 put $! UploadState us1 us2
(insertMap name (version, dataVersion, hash') mdMap) (insertMap name (MetaSig version dataVersion hash') mdMap)
(insertMap name md mdChanges) (insertMap name md mdChanges)
_ -> return () _ -> return ()
else return () else return ()