From 3c61cd64af571f0cd2ce1037a83391fee5cbd8a1 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 16 Nov 2014 17:29:01 +0200
Subject: [PATCH] Use proper version ordering #31

---
 Application.hs  |  4 +++-
 Data/Hackage.hs | 33 +++++++++++++++++++++++++--------
 2 files changed, 28 insertions(+), 9 deletions(-)

diff --git a/Application.hs b/Application.hs
index f69e54a..a4924a4 100644
--- a/Application.hs
+++ b/Application.hs
@@ -189,7 +189,9 @@ makeFoundation useEcho conf = do
                 )
             UploadState uploadHistory newUploads _ newMD <- loadCabalFiles uploadHistory0 metadata0
             runDB' $ mapM_ insert_ newUploads
-            runDB' $ mapM_ (void . insertBy) newMD
+            runDB' $ forM_ newMD $ \x -> do
+                deleteBy $ UniqueMetadata $ metadataName x
+                insert_ x
             let views =
                     [ ("pvp", viewPVP uploadHistory)
                     , ("no-bounds", viewNoBounds)
diff --git a/Data/Hackage.hs b/Data/Hackage.hs
index 3aa0baf..0c44f53 100644
--- a/Data/Hackage.hs
+++ b/Data/Hackage.hs
@@ -37,6 +37,8 @@ import Distribution.Text (display)
 import Text.Markdown (Markdown (Markdown))
 import Data.Foldable (foldMap)
 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 =
@@ -61,7 +63,7 @@ loadCabalFiles :: ( MonadActive m
                => UploadHistory -- ^ initial
                -> HashMap PackageName (Version, ByteString)
                -> 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
     $logDebug $ "Entering loadCabalFiles, root == " ++ root
     req <- parseUrl $ unpack $ root ++ "/00-index.tar.gz"
@@ -73,6 +75,8 @@ loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT
             bss <- lazyConsume $ sourceHandle handleIn $= ungzip
             tarSource (Tar.read $ fromChunks bss) $$ parMapMC 32 go =$ sinkNull -- FIXME parMapM_C
   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)
 
     go entry = do
@@ -100,10 +104,22 @@ loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT
                         sourceLazy lbs $$ sink
                     setUploadDate name version
 
-                    setMetadata name version (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 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 (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
     { usHistory :: !UploadHistory
     , usChanges :: ![Uploaded]
-    , usMetadata :: !(HashMap PackageName (Version, ByteString))
+    , usMetadata :: !(HashMap PackageName (Version, Data.Version.Version, ByteString))
     , usMetaChanges :: !(HashMap PackageName md)
     }
 
@@ -171,15 +187,16 @@ setMetadata :: ( MonadBaseControl IO m
                )
             => PackageName
             -> Version
+            -> Data.Version.Version
             -> ByteString
             -> ParseResult PD.GenericPackageDescription
             -> m ()
-setMetadata name version hash' gpdRes = do
+setMetadata name version dataVersion hash' gpdRes = do
     UploadState us1 us2 mdMap mdChanges <- get
     let toUpdate =
             case lookup name mdMap of
-                Just (currVersion, currHash) ->
-                    case compare currVersion version of
+                Just (_currVersion, currDataVersion, currHash) ->
+                    case compare currDataVersion dataVersion of
                         LT -> True
                         GT -> False
                         EQ -> currHash /= hash'
@@ -189,7 +206,7 @@ setMetadata name version hash' gpdRes = do
                 ParseOk _ gpd -> do
                     !md <- getMetadata name version hash' gpd
                     put $! UploadState us1 us2
-                                (insertMap name (version, hash') mdMap)
+                                (insertMap name (version, dataVersion, hash') mdMap)
                                 (insertMap name md mdChanges)
                 _ -> return ()
         else return ()