Complete (but untested) UploadV2

Foundation.hs

@@ -49,12 +49,6 @@ data App = App
     , websiteContent :: GitRepo WebsiteContent
     }
 
-data SnapshotInfo = SnapshotInfo
-    { siType :: !SnapshotType
-    , siPlan :: !BuildPlan
-    , siDocMap :: !DocMap
-    }
-
 data DocUnpacker = DocUnpacker
     { duRequestDocs :: Entity Stackage -> IO UnpackStatus
     , duGetStatus   :: IO Text

Handler/UploadV2.hs

@@ -23,6 +23,7 @@ import Stackage.Prelude (display)
 import Filesystem (createTree)
 import Filesystem.Path (parent)
 import Data.Conduit.Process
+import Data.Yaml (decodeEither')
 
 putUploadV2R :: Handler TypedContent
 putUploadV2R = do
@@ -94,10 +95,26 @@ doUpload status uid ident bundleFP = do
     threadDelay 1000000 -- FIXME remove
 
     say $ "Unpacking bundle"
-    master <- getYesod
-    -- FIXME liftIO $ haddockUnpacker master True ident
 
-    SnapshotInfo {..} <- error "FIXME getSnapshotInfoByIdent ident"
+    (siType, siPlan, siDocMap :: DocMap) <-
+      withSystemTempDirectory "uploadv2" $ \dir' -> do
+        let dir = fpFromString dir'
+        withCheckedProcess
+            (proc "tar" ["xf", fpToString bundleFP])
+                { cwd = Just dir'
+                } $ \ClosedStream ClosedStream ClosedStream -> return ()
+
+        let maxFileSize = 1024 * 1024 * 5
+            yaml :: FromJSON a => FilePath -> Handler a
+            yaml fp = do
+                say $ "Parsing " ++ fpToText fp
+                bs <- sourceFile (dir </> fp) $$ takeCE maxFileSize =$ foldC
+                either throwM return $ decodeEither' bs
+
+        (,,)
+            <$> yaml "build-type.yaml"
+            <*> yaml "build-plan.yaml"
+            <*> yaml "docs-map.yaml"
 
     now <- liftIO getCurrentTime
     let day = tshow $ utctDay now
@@ -129,7 +146,10 @@ doUpload status uid ident bundleFP = do
                     , ghcVersion
                     ]
 
-    slug <- SnapSlug <$> mkSlug slug'
+    slug <- do
+        slug2 <- mkSlug slug'
+        when (slug' /= unSlug slug2) $ error $ "Slug not available: " ++ show slug'
+        return $ SnapSlug slug2
 
     say "Creating index tarball"
     withSystemTempDirectory "buildindex.v2" $ \(fpFromString -> dir) -> do
@@ -195,6 +215,30 @@ doUpload status uid ident bundleFP = do
                 , ltsMinor = minor
                 , ltsStackage = sid
                 }
+
+        let cores :: Set PackageName
+            cores = setFromList
+                  $ map (PackageName . display . fst)
+                  $ mapToList
+                  $ siCorePackages
+                  $ bpSystemInfo siPlan
+        forM_ (mapToList $ fmap ppVersion $ bpPackages siPlan) $ \(name', version') -> do
+            let nameT = display name'
+                mpair = (,)
+                    <$> fromPathPiece nameT
+                    <*> fromPathPiece (display version')
+            (name, version) <-
+                case mpair of
+                    Nothing -> error $ "Could not parse: " ++ show (name', version')
+                    Just pair -> return pair
+            insert_ Package
+                { packageStackage = sid
+                , packageName' = name
+                , packageVersion = version
+                , packageHasHaddocks = nameT `member` siDocMap
+                , packageOverwrite = False
+                , packageCore = Just $ name `member` cores
+                }
         return sid
 
     say $ concat
@@ -206,6 +250,19 @@ doUpload status uid ident bundleFP = do
         ]
 
     render <- getUrlRender
+
+    say "Updating docmap"
+    runDB $ forM_ (mapToList siDocMap) $ \(package, PackageDocs version ms) -> do
+        did <- insert Docs
+            { docsName = PackageName package
+            , docsVersion = Version version
+            , docsUploaded = now
+            , docsSnapshot = Just sid
+            }
+        forM_ (mapToList ms) $ \(name, pieces) -> do
+            let url = render $ HaddockR slug pieces
+            insert_ $ Module did name url
+
     return $ render $ SnapshotR slug StackageHomeR
   where
     say = atomically . writeTVar status