From fd89710c69c7f9e65ed3d579496069501f3b2a1a Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 18 Mar 2015 13:00:58 +0200
Subject: [PATCH] Better support for pre-existing snapshots

---
 Handler/UploadV2.hs | 32 +++++++++++++++++++++++++++++---
 1 file changed, 29 insertions(+), 3 deletions(-)

diff --git a/Handler/UploadV2.hs b/Handler/UploadV2.hs
index b7caa5e..cd3b2d9 100644
--- a/Handler/UploadV2.hs
+++ b/Handler/UploadV2.hs
@@ -151,6 +151,34 @@ doUpload status uid ident bundleFP = do
         when (slug' /= unSlug slug2) $ error $ "Slug not available: " ++ show slug'
         return $ SnapSlug slug2
 
+    mexisting <- runDB $ getBy $ UniqueSnapshot slug
+    route <- case mexisting of
+        Just _ -> do
+            say "Snapshot already exists"
+            return $ SnapshotR slug StackageHomeR
+        Nothing -> finishUpload
+              title ident ghcVersion slug now siType siPlan siDocMap
+              uid say
+    render <- getUrlRender
+    return $ render route
+  where
+    say = atomically . writeTVar status
+
+finishUpload
+    :: Text
+    -> PackageSetIdent
+    -> Text
+    -> SnapSlug
+    -> UTCTime
+    -> SnapshotType
+    -> BuildPlan
+    -> Map Text PackageDocs
+    -> UserId
+    -> (Text -> Handler ())
+    -> Handler (Route App)
+finishUpload
+  title ident ghcVersion slug now siType siPlan siDocMap
+  uid say = do
     say "Creating index tarball"
     withSystemTempDirectory "buildindex.v2" $ \(fpFromString -> dir) -> do
         files <- forM (mapToList $ fmap ppVersion $ bpPackages siPlan) $ \(name', version') -> do
@@ -263,6 +291,4 @@ doUpload status uid ident bundleFP = do
             let url = render $ HaddockR slug pieces
             insert_ $ Module did name url
 
-    return $ render $ SnapshotR slug StackageHomeR
-  where
-    say = atomically . writeTVar status
+    return $ SnapshotR slug StackageHomeR