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

Use proper version ordering #31

Browse Source
This commit is contained in:
Michael Snoyman 2014-11-16 17:29:01 +02:00
parent 8649e9d97b
commit 3c61cd64af
2 changed files with 28 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Application.hs
View File

@ -189,7 +189,9 @@ makeFoundation useEcho conf = do
) )
UploadState uploadHistory newUploads _ newMD <- loadCabalFiles uploadHistory0 metadata0 UploadState uploadHistory newUploads _ newMD <- loadCabalFiles uploadHistory0 metadata0
runDB' $ mapM_ insert_ newUploads runDB' $ mapM_ insert_ newUploads
runDB' $ mapM_ (void . insertBy) newMD runDB' $ forM_ newMD $ \x -> do
deleteBy $ UniqueMetadata $ metadataName x
insert_ x
let views = let views =
[ ("pvp", viewPVP uploadHistory) [ ("pvp", viewPVP uploadHistory)
, ("no-bounds", viewNoBounds) , ("no-bounds", viewNoBounds)

33
Data/Hackage.hs
View File

@ -37,6 +37,8 @@ import Distribution.Text (display)
import Text.Markdown (Markdown (Markdown)) import Text.Markdown (Markdown (Markdown))
import Data.Foldable (foldMap) import Data.Foldable (foldMap)
import qualified Data.Traversable as T import qualified Data.Traversable as T
import qualified Data.Version
import Text.ParserCombinators.ReadP (readP_to_S)
sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory sinkUploadHistory :: Monad m => Consumer (Entity Uploaded) m UploadHistory
sinkUploadHistory = sinkUploadHistory =
@ -61,7 +63,7 @@ loadCabalFiles :: ( MonadActive m
=> UploadHistory -- ^ initial => UploadHistory -- ^ initial
-> HashMap PackageName (Version, ByteString) -> HashMap PackageName (Version, ByteString)
-> m (UploadState Metadata) -> m (UploadState Metadata)
loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT (UploadState uploadHistory0 [] metadata0 mempty) $ do loadCabalFiles 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"
@ -73,6 +75,8 @@ 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) ->
(v, fromMaybe (Data.Version.Version [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
@ -100,10 +104,22 @@ loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT
sourceLazy lbs $$ sink sourceLazy lbs $$ sink
setUploadDate name version setUploadDate name version
setMetadata name version (toBytes newDigest) case readVersion version of
$ parsePackageDescription $ unpack $ decodeUtf8 lbs Nothing -> return ()
Just dataVersion -> setMetadata
name
version
dataVersion
(toBytes newDigest)
(parsePackageDescription $ unpack $ decodeUtf8 lbs)
_ -> return () _ -> return ()
readVersion :: Version -> Maybe Data.Version.Version
readVersion v =
case filter (not . null . snd) $ readP_to_S Data.Version.parseVersion . unpack . unVersion $ v of
(dv, _):_ -> Just dv
[] -> Nothing
runUploadState :: MonadIO m => UploadState (IO a) -> m (UploadState a) runUploadState :: MonadIO m => UploadState (IO a) -> m (UploadState a)
runUploadState (UploadState w x y z) = liftIO $ UploadState w x y <$> T.sequence z runUploadState (UploadState w x y z) = liftIO $ UploadState w x y <$> T.sequence z
@ -118,7 +134,7 @@ 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, ByteString)) , usMetadata :: !(HashMap PackageName (Version, Data.Version.Version, ByteString))
, usMetaChanges :: !(HashMap PackageName md) , usMetaChanges :: !(HashMap PackageName md)
} }
@ -171,15 +187,16 @@ setMetadata :: ( MonadBaseControl IO m
) )
=> PackageName => PackageName
-> Version -> Version
-> Data.Version.Version
-> ByteString -> ByteString
-> ParseResult PD.GenericPackageDescription -> ParseResult PD.GenericPackageDescription
-> m () -> m ()
setMetadata name version hash' gpdRes = do 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, currHash) -> Just (_currVersion, currDataVersion, currHash) ->
case compare currVersion version of case compare currDataVersion dataVersion of
LT -> True LT -> True
GT -> False GT -> False
EQ -> currHash /= hash' EQ -> currHash /= hash'
@ -189,7 +206,7 @@ setMetadata name version 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, hash') mdMap) (insertMap name (version, dataVersion, hash') mdMap)
(insertMap name md mdChanges) (insertMap name md mdChanges)
_ -> return () _ -> return ()
else return () else return ()