Merge branch 'master' into new-upload

Conflicts:
	Application.hs
	Handler/Haddock.hs
	Handler/StackageHome.hs
	Import.hs
	cabal.config
	config/routes
	stackage-server.cabal
	templates/doc-list.hamlet

Application.hs

@@ -28,7 +28,7 @@ import           Network.Wai.Middleware.RequestLogger
     )
 import qualified Network.Wai.Middleware.RequestLogger as RequestLogger
 import           Settings
-import           System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, flushLogStr, fromLogStr)
+import           System.Log.FastLogger (newStdoutLoggerSet, newFileLoggerSet, defaultBufSize, fromLogStr)
 import qualified System.Random.MWC as MWC
 import           Yesod.Core.Types (loggerSet, Logger (Logger))
 import           Yesod.Default.Config
@@ -66,6 +66,7 @@ import           Handler.CompressorStatus
 import           Handler.Tag
 import           Handler.BannedTags
 import           Handler.RefreshDeprecated
+import           Handler.UploadV2
 import           Handler.Hoogle
 import           Handler.BuildVersion
 import           Handler.PackageCounts
@@ -145,18 +146,7 @@ makeFoundation useEcho conf = do
     loggerSet' <- if useEcho
                      then newFileLoggerSet defaultBufSize "/dev/null"
                      else newStdoutLoggerSet defaultBufSize
-    (getter, updater) <- clockDateCacher
-
-    -- If the Yesod logger (as opposed to the request logger middleware) is
-    -- used less than once a second on average, you may prefer to omit this
-    -- thread and use "(updater >> getter)" in place of "getter" below.  That
-    -- would update the cache every time it is used, instead of every second.
-    let updateLoop = do
-            threadDelay 1000000
-            updater
-            flushLogStr loggerSet'
-            updateLoop
-    _ <- forkIO updateLoop
+    (getter, _) <- clockDateCacher
 
     gen <- MWC.createSystemRandom
 
@@ -183,6 +173,8 @@ makeFoundation useEcho conf = do
         runDB' = flip (Database.Persist.runPool dbconf) p
     docUnpacker <- newDocUnpacker haddockRootDir' blobStore' runDB'
 
+    snapshotInfoCache' <- newIORef mempty
+
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App
             { settings = conf
@@ -197,6 +189,7 @@ makeFoundation useEcho conf = do
             , appDocUnpacker = docUnpacker
             , widgetCache = widgetCache'
             , websiteContent = websiteContent'
+            , snapshotInfoCache = snapshotInfoCache'
             }
 
     let urlRender' = yesodRender foundation (appRoot conf)

Foundation.hs

@@ -23,6 +23,8 @@ import           Yesod.Core.Types (Logger, GWData)
 import           Yesod.Default.Config
 import           Yesod.Default.Util (addStaticContentExternal)
 import           Yesod.GitRepo
+import Stackage.ServerBundle (SnapshotType, DocMap)
+import Stackage.BuildPlan (BuildPlan)
 
 -- | The site argument for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
@@ -45,6 +47,13 @@ data App = App
     -- unpack job.
     , widgetCache :: IORef (HashMap Text (UTCTime, GWData (Route App)))
     , websiteContent :: GitRepo WebsiteContent
+    , snapshotInfoCache :: !(IORef (HashMap PackageSetIdent SnapshotInfo))
+    }
+
+data SnapshotInfo = SnapshotInfo
+    { siType :: !SnapshotType
+    , siPlan :: !BuildPlan
+    , siDocMap :: !DocMap
     }
 
 data DocUnpacker = DocUnpacker
@@ -158,6 +167,7 @@ instance Yesod App where
 
     maximumContentLength _ (Just UploadStackageR) = Just 50000000
     maximumContentLength _ (Just UploadHaddockR{}) = Just 100000000
+    maximumContentLength _ (Just UploadV2R) = Just 100000000
     maximumContentLength _ _ = Just 2000000
 
 instance ToMarkup (Route App) where

Handler/Haddock.hs

@@ -198,34 +198,6 @@ gzipHash dirs suffix = do
     src = dirRawRoot dirs </> suffix
     dst = dirGzRoot dirs </> suffix
 
-data Dirs = Dirs
-    { dirRawRoot :: !FilePath
-    , dirGzRoot :: !FilePath
-    , dirCacheRoot :: !FilePath
-    , dirHoogleRoot :: !FilePath
-    }
-
-getDirs :: Handler Dirs
-getDirs = mkDirs . haddockRootDir <$> getYesod
-
-mkDirs :: FilePath -> Dirs
-mkDirs dir = Dirs
-    { dirRawRoot = dir </> "idents-raw"
-    , dirGzRoot = dir </> "idents-gz"
-    , dirCacheRoot = dir </> "cachedir"
-    , dirHoogleRoot = dir </> "hoogle"
-    }
-
-dirGzIdent, dirRawIdent, dirHoogleIdent :: Dirs -> PackageSetIdent -> FilePath
-dirGzIdent dirs ident = dirGzRoot dirs </> fpFromText (toPathPiece ident)
-dirRawIdent dirs ident = dirRawRoot dirs </> fpFromText (toPathPiece ident)
-dirHoogleIdent dirs ident = dirHoogleRoot dirs </> fpFromText (toPathPiece ident)
-
-dirGzFp, dirRawFp, dirHoogleFp :: Dirs -> PackageSetIdent -> [Text] -> FilePath
-dirGzFp dirs ident rest = dirGzIdent dirs ident </> mconcat (map fpFromText rest)
-dirRawFp dirs ident rest = dirRawIdent dirs ident </> mconcat (map fpFromText rest)
-dirHoogleFp dirs ident rest = dirHoogleIdent dirs ident </> mconcat (map fpFromText rest)
-
 dirCacheFp :: Dirs -> Digest SHA1 -> FilePath
 dirCacheFp dirs digest =
     dirCacheRoot dirs </> fpFromText x </> fpFromText y <.> "gz"

Handler/StackageHome.hs

@@ -6,12 +6,21 @@ import Data.Time (FormatTime)
 import Data.Slug (SnapSlug)
 import qualified Database.Esqueleto as E
 import Handler.PackageList (cachedWidget)
+import Stackage.ServerBundle (PackageDocs (..))
+import Control.Monad.Writer.Strict (tell, execWriter)
+import Stackage.BuildPlan (bpSystemInfo, bpPackages, ppVersion)
+import Stackage.BuildConstraints (siCorePackages)
+import Stackage.Prelude (display)
+
+allPackageVersions :: SnapshotInfo -> Map Text Text
+allPackageVersions SnapshotInfo {..} =
+    mapKeysWith const display $ map display $
+    fmap ppVersion (bpPackages siPlan) ++
+    siCorePackages (bpSystemInfo siPlan)
 
 getStackageHomeR :: SnapSlug -> Handler Html
 getStackageHomeR slug = do
-    stackage <- runDB $ do
-        Entity _ stackage <- getBy404 $ UniqueSnapshot slug
-        return stackage
+    (Entity sid stackage, msi) <- getStackage slug
 
     hasBundle <- storeExists $ SnapshotBundle $ stackageIdent stackage
     let minclusive =
@@ -21,67 +30,109 @@ getStackageHomeR slug = do
                        then Just False
                        else Nothing
         base = maybe 0 (const 1) minclusive :: Int
+
         hoogleForm =
             let queryText = "" :: Text
                 exact = False
             in $(widgetFile "hoogle-form")
     Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
+
     defaultLayout $ do
         setTitle $ toHtml $ stackageTitle stackage
         cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
-            let maxPackages = 5000
-            (packageListClipped, packages') <- handlerToWidget $ runDB $ do
-                packages' <- E.select $ E.from $ \(u,m,p) -> do
-                    E.where_ $
-                        (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
-                        (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
-                        (p E.^. PackageStackage E.==. E.val sid)
-                    E.orderBy [E.asc $ u E.^. UploadedName]
-                    E.groupBy ( u E.^. UploadedName
-                              , m E.^. MetadataSynopsis
-                              )
-                    E.limit maxPackages
-                    return
-                        ( u E.^. UploadedName
-                        , m E.^. MetadataSynopsis
-                        , E.max_ (p E.^. PackageVersion)
-                        , E.max_ $ E.case_
-                            [ ( p E.^. PackageHasHaddocks
-                              , p E.^. PackageVersion
-                              )
-                            ]
-                            (E.val (Version ""))
-                        )
-                packageCount <- count [PackageStackage ==. sid]
-                let packageListClipped = packageCount > maxPackages
-                return (packageListClipped, packages')
-            let packages = flip map packages' $ \(name, syn, latestVersion, forceNotNull -> mversion) ->
-                    ( E.unValue name
-                    , fmap unVersion $ E.unValue latestVersion
-                    , strip $ E.unValue syn
-                    , (<$> mversion) $ \version -> HaddockR slug $ return $ concat
-                        [ toPathPiece $ E.unValue name
-                        , "-"
-                        , version
-                        ]
-                    )
-                forceNotNull (E.Value Nothing) = Nothing
-                forceNotNull (E.Value (Just (Version v)))
-                    | null v = Nothing
-                    | otherwise = Just v
+            (packages, packageListClipped) <- handlerToWidget $ case msi of
+                Nothing -> packagesFromDB sid
+                Just si -> packagesFromSI si
             $(widgetFile "stackage-home")
-  where strip x = fromMaybe x (stripSuffix "." x)
+  where
+    strip x = fromMaybe x (stripSuffix "." x)
+
+    -- name, maybe version, synopsis, maybe doc route
+    packagesFromSI :: SnapshotInfo -> Handler ([(PackageName, Maybe Text, Text, Maybe (Route App))], Bool)
+    packagesFromSI si@SnapshotInfo {..} =
+        fmap (, False) $ runDB $ mapM go $ mapToList $ allPackageVersions si
+      where
+        go :: (Text, Text) -> YesodDB App (PackageName, Maybe Text, Text, Maybe (Route App))
+        go (name, version) = do
+            let name' = PackageName name
+            -- FIXME cache the synopsis metadata somewhere
+            s <- E.select $ E.from $ \m -> do
+                E.where_ $ m E.^. MetadataName E.==. E.val name'
+                return $ m E.^. MetadataSynopsis
+            return
+                ( name'
+                , Just version
+                , fromMaybe "No synopsis available" $ listToMaybe $ map E.unValue $ s
+                , case lookup name siDocMap of
+                    Nothing -> Nothing
+                    Just _ -> Just $ SnapshotR slug $ StackageSdistR
+                            $ PNVNameVersion name' (Version version)
+                )
+
+    packagesFromDB :: StackageId -> Handler ([(PackageName, Maybe Text, Text, Maybe (Route App))], Bool)
+    packagesFromDB sid = do
+        let maxPackages = 5000
+        (packageListClipped, packages') <- runDB $ do
+            packages' <- E.select $ E.from $ \(u,m,p) -> do
+                E.where_ $
+                    (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
+                    (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
+                    (p E.^. PackageStackage E.==. E.val sid)
+                E.orderBy [E.asc $ u E.^. UploadedName]
+                E.groupBy ( u E.^. UploadedName
+                          , m E.^. MetadataSynopsis
+                          )
+                E.limit maxPackages
+                return
+                    ( u E.^. UploadedName
+                    , m E.^. MetadataSynopsis
+                    , E.max_ (p E.^. PackageVersion)
+                    , E.max_ $ E.case_
+                        [ ( p E.^. PackageHasHaddocks
+                          , p E.^. PackageVersion
+                          )
+                        ]
+                        (E.val (Version ""))
+                    )
+            packageCount <- count [PackageStackage ==. sid]
+            let packageListClipped = packageCount > maxPackages
+            return (packageListClipped, packages')
+        let packages = flip map packages' $ \(name, syn, latestVersion, forceNotNull -> mversion) ->
+                ( E.unValue name
+                , fmap unVersion $ E.unValue latestVersion
+                , strip $ E.unValue syn
+                , (<$> mversion) $ \version -> HaddockR slug $ return $ concat
+                    [ toPathPiece $ E.unValue name
+                    , "-"
+                    , version
+                    ]
+                )
+            forceNotNull (E.Value Nothing) = Nothing
+            forceNotNull (E.Value (Just (Version v)))
+                | null v = Nothing
+                | otherwise = Just v
+        return (packages, packageListClipped)
 
 getStackageMetadataR :: SnapSlug -> Handler TypedContent
 getStackageMetadataR slug = do
-    Entity sid _ <- runDB $ getBy404 $ UniqueSnapshot slug
-    respondSourceDB typePlain $ do
-        sendChunkBS "Override packages\n"
-        sendChunkBS "=================\n"
-        stream sid True
-        sendChunkBS "\nPackages from Hackage\n"
-        sendChunkBS   "=====================\n"
-        stream sid False
+    (Entity sid _, msi) <- getStackage slug
+    respondSourceDB typePlain $
+        case msi of
+            Nothing -> do
+                sendChunkBS "Override packages\n"
+                sendChunkBS "=================\n"
+                stream sid True
+                sendChunkBS "\nPackages from Hackage\n"
+                sendChunkBS   "=====================\n"
+                stream sid False
+            Just si -> do
+                sendChunkBS "Packages from Hackage\n"
+                sendChunkBS "=====================\n"
+                forM_ (mapToList $ allPackageVersions si) $ \(name, version) -> do
+                    sendChunkText name
+                    sendChunkBS "-"
+                    sendChunkText version
+                    sendChunkBS "\n"
   where
     stream sid isOverwrite =
         selectSource
@@ -101,7 +152,7 @@ getStackageMetadataR slug = do
 
 getStackageCabalConfigR :: SnapSlug -> Handler TypedContent
 getStackageCabalConfigR slug = do
-    Entity sid _ <- runDB $ getBy404 $ UniqueSnapshot slug
+    (Entity sid _, msi) <- getStackage slug
     render <- getUrlRender
 
     mdownload <- lookupGetParam "download"
@@ -111,15 +162,30 @@ getStackageCabalConfigR slug = do
     mglobal <- lookupGetParam "global"
     let isGlobal = mglobal == Just "true"
 
-    respondSourceDB typePlain $ stream isGlobal render sid
+    respondSourceDB typePlain $
+        stream (maybe (Left sid) Right msi) $=
+        (if isGlobal then conduitGlobal else conduitLocal) render
   where
-    stream isGlobal render sid =
+    stream (Left sid) =
         selectSource
             [ PackageStackage ==. sid
             ]
             [ Asc PackageName'
             , Asc PackageVersion
-            ] $= (if isGlobal then conduitGlobal else conduitLocal) render
+            ] $= mapC (\(Entity _ p) ->
+                            ( toPathPiece $ packageName' p
+                            , case packageCore p of
+                                Just True -> Nothing
+                                _ -> Just $ toPathPiece $ packageVersion p
+                            ))
+    stream (Right SnapshotInfo {..}) = forM_ (mapToList m) $ \(name, mversion) ->
+        yield ( display name
+              , display <$> mversion
+              )
+      where
+        core = fmap (const Nothing) $ siCorePackages $ bpSystemInfo siPlan
+        noncore = fmap (Just . ppVersion) $ bpPackages siPlan
+        m = core ++ noncore
 
     conduitGlobal render = do
         headerGlobal render
@@ -149,28 +215,28 @@ getStackageCabalConfigR slug = do
         toBuilder (render $ SnapshotR slug StackageHomeR) ++
         toBuilder '\n'
 
-    constraint p
-        | Just True <- packageCore p = toBuilder $ asText " installed"
-        | otherwise = toBuilder (asText " ==") ++
-                      toBuilder (toPathPiece $ packageVersion p)
+    constraint Nothing = toBuilder $ asText " installed"
+    constraint (Just version) =
+                      toBuilder (asText " ==") ++
+                      toBuilder (toPathPiece version)
 
-    showPackageGlobal (Entity _ p) =
+    showPackageGlobal (name, mversion) =
         toBuilder (asText "constraint: ") ++
-        toBuilder (toPathPiece $ packageName' p) ++
-        constraint p ++
+        toBuilder (toPathPiece name) ++
+        constraint mversion ++
         toBuilder '\n'
 
     goFirst = do
         mx <- await
-        forM_ mx $ \(Entity _ p) -> yield $ Chunk $
+        forM_ mx $ \(name, mversion) -> yield $ Chunk $
             toBuilder (asText "constraints: ") ++
-            toBuilder (toPathPiece $ packageName' p) ++
-            constraint p
+            toBuilder (toPathPiece name) ++
+            constraint mversion
 
-    showPackageLocal (Entity _ p) =
+    showPackageLocal (name, mversion) =
         toBuilder (asText ",\n             ") ++
-        toBuilder (toPathPiece $ packageName' p) ++
-        constraint p
+        toBuilder (toPathPiece name) ++
+        constraint mversion
 
 yearMonthDay :: FormatTime t => t -> String
 yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d"
@@ -182,72 +248,51 @@ getOldStackageR ident pieces = do
         Nothing -> notFound
         Just route -> redirect (route :: Route App)
 
+-- | Just here for historical reasons, this functionality has been merged into
+-- the snapshot homepage.
 getSnapshotPackagesR :: SnapSlug -> Handler Html
-getSnapshotPackagesR slug = do
-    Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
-    defaultLayout $ do
-        setTitle $ toHtml $ "Package list for " ++ toPathPiece slug
-        cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
-            packages' <- handlerToWidget $ runDB $ E.select $ E.from $ \(u,m,p) -> do
-                E.where_ $
-                    (m E.^. MetadataName E.==. u E.^. UploadedName) E.&&.
-                    (m E.^. MetadataName E.==. p E.^. PackageName') E.&&.
-                    (p E.^. PackageStackage E.==. E.val sid)
-                E.orderBy [E.asc $ u E.^. UploadedName]
-                E.groupBy ( u E.^. UploadedName
-                          , m E.^. MetadataSynopsis
-                          )
-                return
-                    ( u E.^. UploadedName
-                    , m E.^. MetadataSynopsis
-                    , E.max_ $ E.case_
-                        [ ( p E.^. PackageHasHaddocks
-                          , p E.^. PackageVersion
-                          )
-                        ]
-                        (E.val (Version ""))
-                    )
-            let packages = flip map packages' $ \(name, syn, forceNotNull -> mversion) ->
-                    ( E.unValue name
-                    , mversion
-                    , strip $ E.unValue syn
-                    , (<$> mversion) $ \version -> HaddockR slug $ return $ concat
-                        [ toPathPiece $ E.unValue name
-                        , "-"
-                        , version
-                        ]
-                    )
-                forceNotNull (E.Value Nothing) = Nothing
-                forceNotNull (E.Value (Just (Version v)))
-                    | null v = Nothing
-                    | otherwise = Just v
-            $(widgetFile "package-list")
-  where strip x = fromMaybe x (stripSuffix "." x)
-        mback = Just (SnapshotR slug StackageHomeR, "Return to snapshot")
+getSnapshotPackagesR = getStackageHomeR
 
 getDocsR :: SnapSlug -> Handler Html
 getDocsR slug = do
-    Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
+    (Entity sid _stackage, msi) <- getStackage slug
     defaultLayout $ do
         setTitle $ toHtml $ "Module list for " ++ toPathPiece slug
         cachedWidget (20 * 60) ("module-list-" ++ toPathPiece slug) $ do
-            modules' <- handlerToWidget $ runDB $ E.select $ E.from $ \(d,m) -> do
-                E.where_ $
-                    (d E.^. DocsSnapshot E.==. E.val (Just sid)) E.&&.
-                    (d E.^. DocsId E.==. m E.^. ModuleDocs)
-                E.orderBy [ E.asc $ m E.^. ModuleName
-                          , E.asc $ d E.^. DocsName
-                          ]
-                return
-                    ( m E.^. ModuleName
-                    , m E.^. ModuleUrl
-                    , d E.^. DocsName
-                    , d E.^. DocsVersion
-                    )
-            let modules = flip map modules' $ \(name, url, package, version) ->
-                    ( E.unValue name
-                    , E.unValue url
-                    , E.unValue package
-                    , E.unValue version
-                    )
+            modules <- handlerToWidget $ maybe (getFromDB sid) convertYaml msi
             $(widgetFile "doc-list")
+  where
+    getFromDB sid = do
+        modules' <- runDB $ E.select $ E.from $ \(d,m) -> do
+            E.where_ $
+                (d E.^. DocsSnapshot E.==. E.val (Just sid)) E.&&.
+                (d E.^. DocsId E.==. m E.^. ModuleDocs)
+            E.orderBy [ E.asc $ m E.^. ModuleName
+                      , E.asc $ d E.^. DocsName
+                      ]
+            return
+                ( m E.^. ModuleName
+                , m E.^. ModuleUrl
+                , d E.^. DocsName
+                , d E.^. DocsVersion
+                )
+        return $ flip map modules' $ \(name, url, package, version) ->
+                ( E.unValue name
+                , E.unValue url
+                , E.unValue package
+                , E.unValue version
+                )
+
+    convertYaml :: SnapshotInfo -> Handler [(Text, Text, PackageName, Version)]
+    convertYaml SnapshotInfo {..} = do
+        render <- getUrlRender
+        return $ sortBy comp $ ($ []) $ execWriter $ do
+            forM_ (mapToList siDocMap) $ \(PackageName -> package, pd) -> do
+                let version = Version $ pdVersion pd
+                forM_ (mapToList $ pdModules pd) $ \(modname, path) -> do
+                    let url = render $ HaddockR
+                            slug
+                            path
+                    tell ((modname, url, package, version):)
+      where
+        comp (a, _, x, _) (b, _, y, _) = compare (a, x) (b, y)

Handler/UploadStackage.hs

@@ -139,6 +139,7 @@ putUploadStackageR = do
                         , stackageDesc = "No description provided"
                         , stackageHasHaddocks = False
                         , stackageSlug = baseSlug
+                        , stackageYaml = False
                         }
 
                 -- Evil lazy I/O thanks to tar package

Handler/UploadV2.hs

@@ -0,0 +1,212 @@
+module Handler.UploadV2
+    ( putUploadV2R
+    ) where
+
+import Import
+import Data.BlobStore
+import Control.Concurrent.Lifted (threadDelay)
+import Data.Slug (unSlug, mkSlug, SnapSlug (..))
+import Control.Monad.Trans.Resource (allocate)
+import System.Directory (removeFile, getTemporaryDirectory)
+import System.IO.Temp (openBinaryTempFile, withSystemTempDirectory, withSystemTempFile)
+import Crypto.Hash.Conduit (sinkHash)
+import Crypto.Hash (Digest, SHA1)
+import Data.Byteable (toBytes)
+import qualified Data.ByteString.Base16 as B16
+import System.Timeout.Lifted (timeout)
+import Control.Concurrent.Async (async, cancel, waitCatchSTM)
+import Yesod.Core.Types (HandlerT (..))
+import Stackage.ServerBundle
+import Stackage.BuildPlan
+import Stackage.BuildConstraints
+import Stackage.Prelude (display)
+import Filesystem (createTree)
+import Filesystem.Path (parent)
+import Data.Conduit.Process
+
+putUploadV2R :: Handler TypedContent
+putUploadV2R = do
+    uid <- requireAuthIdOrToken
+    user <- runDB $ get404 uid
+    extra <- getExtra
+    when (unSlug (userHandle user) `notMember` adminUsers extra)
+        $ permissionDenied "Only admins can upload V2 bundles"
+
+    tempDir <- liftIO getTemporaryDirectory
+    (_releaseKey, (bundleFP, bundleHOut)) <- allocate
+        (openBinaryTempFile tempDir "upload.stackage2")
+        (\(fp, h) -> hClose h `finally` removeFile fp)
+    digest <- rawRequestBody $$ getZipSink
+        (ZipSink (sinkHandle bundleHOut) *>
+         ZipSink sinkHash)
+    liftIO $ hClose bundleHOut
+
+    let digestBS = toBytes (digest :: Digest SHA1)
+        ident = PackageSetIdent $ decodeUtf8 $ B16.encode digestBS
+
+    mstackage <- runDB $ getBy $ UniqueStackage ident
+    when (isJust mstackage) $ invalidArgs ["Bundle already uploaded"]
+
+    status <- liftIO $ newTVarIO ""
+
+    let cont text = do
+            sendChunkBS "CONT: "
+            sendChunkText text
+            sendChunkBS "\n"
+            sendFlush
+
+    -- Grab the internal HandlerT state to perform magic
+    hd <- HandlerT return
+    worker <- fmap snd $ flip allocate cancel $ async $ flip unHandlerT hd
+            $ doUpload status uid ident (fpFromString bundleFP)
+
+    respondSource "text/plain" $ do
+        let displayStatus prev = do
+                memsg <- liftIO $ timeout 20000000 $ atomically $ (do
+                    msg <- readTVar status
+                    checkSTM (msg /= prev)
+                    return (Right msg)) <|> (Left <$> waitCatchSTM worker)
+                case memsg of
+                    Nothing -> do
+                        cont "Still working"
+                        displayStatus prev
+                    Just (Left (Left e)) -> do
+                        sendChunkText "FAILURE: "
+                        sendChunkText $ tshow e
+                        sendChunkText "\n"
+                    Just (Left (Right t)) -> do
+                        sendChunkText "SUCCESS: "
+                        sendChunkText t
+                        sendChunkText "\n"
+                    Just (Right t) -> do
+                        cont t
+                        displayStatus t
+        displayStatus ""
+
+doUpload :: TVar Text
+         -> UserId
+         -> PackageSetIdent
+         -> FilePath -- ^ temporary bundle file
+         -> Handler Text
+doUpload status uid ident bundleFP = do
+    say $ "Uploading to persistent storage with ident " ++ toPathPiece ident
+    sourceFile bundleFP $$ storeWrite (HaddockBundle ident)
+    threadDelay 1000000 -- FIXME remove
+
+    say $ "Unpacking bundle"
+    master <- getYesod
+    liftIO $ haddockUnpacker master True ident
+
+    SnapshotInfo {..} <- getSnapshotInfoByIdent ident
+
+    now <- liftIO getCurrentTime
+    let day = tshow $ utctDay now
+
+    let ghcVersion = display $ siGhcVersion $ bpSystemInfo siPlan
+        slug' =
+            case siType of
+                STNightly -> "nightly-" ++ day
+                STLTS major minor -> concat
+                    [ "lts-"
+                    , tshow major
+                    , "."
+                    , tshow minor
+                    ]
+        title =
+            case siType of
+                STNightly -> concat
+                    [ "Stackage Nightly "
+                    , day
+                    , ", GHC "
+                    , ghcVersion
+                    ]
+                STLTS major minor -> concat
+                    [ "LTS Haskell "
+                    , tshow major
+                    , "."
+                    , tshow minor
+                    , ", GHC "
+                    , ghcVersion
+                    ] 
+
+    slug <- SnapSlug <$> mkSlug slug'
+
+    say "Creating index tarball"
+    withSystemTempDirectory "buildindex.v2" $ \(fpFromString -> dir) -> do
+        files <- forM (mapToList $ fmap ppVersion $ bpPackages siPlan) $ \(name', version') -> do
+            let mpair = (,)
+                    <$> fromPathPiece (display name')
+                    <*> fromPathPiece (display version')
+            (name, version) <-
+                case mpair of
+                    Nothing -> error $ "Could not parse: " ++ show (name', version')
+                    Just pair -> return pair
+
+            msrc <- storeRead (HackageCabal name version)
+            src <-
+                case msrc of
+                    Nothing -> error $ "Cabal file not found for: " ++ show (name, version)
+                    Just src -> return src
+
+            let fp' =    fpFromText (toPathPiece name)
+                     </> fpFromText (toPathPiece version)
+                     </> fpFromText (concat
+                            [ toPathPiece name
+                            , "-"
+                            , toPathPiece version
+                            , ".cabal"
+                            ])
+            let fp = dir </> fp'
+
+            liftIO $ createTree $ parent fp
+            src $$ sinkFile fp
+            return $ fpToString fp'
+
+        withSystemTempFile "newindex.v2" $ \fp' h -> do
+            liftIO $ do
+                hClose h
+                let args = "cfz"
+                         : fp'
+                         : files
+                    cp = (proc "tar" args) { cwd = Just $ fpToString dir }
+                withCheckedProcess cp $ \ClosedStream Inherited Inherited ->
+                    return ()
+            sourceFile (fpFromString fp') $$ storeWrite (CabalIndex ident)
+
+    say $ "Attempting: " ++ tshow (slug, title)
+    sid <- runDB $ do
+        sid <- insert Stackage
+            { stackageUser = uid
+            , stackageIdent = ident
+            , stackageSlug = slug
+            , stackageUploaded = now
+            , stackageTitle = title
+            , stackageDesc = ""
+            , stackageHasHaddocks = True
+            , stackageYaml = True
+            }
+        case siType of
+            STNightly -> insert_ Nightly
+                { nightlyDay = utctDay now
+                , nightlyGhcVersion = ghcVersion
+                , nightlyStackage = sid
+                }
+            STLTS major minor -> insert_ Lts
+                { ltsMajor = major
+                , ltsMinor = minor
+                , ltsStackage = sid
+                }
+        return sid
+
+    say $ concat
+        [ "New snapshot with ID "
+        , toPathPiece sid
+        , " and slug "
+        , toPathPiece slug
+        , " created"
+        ]
+
+    render <- getUrlRender
+    return $ render $ SnapshotR slug StackageHomeR
+  where
+    say = atomically . writeTVar status

Import.hs

@@ -13,6 +13,11 @@ import Yesod.Auth as Import
 import Data.Slug (mkSlug)
 import Data.WebsiteContent as Import (WebsiteContent (..))
 import Data.Text.Read (decimal)
+import Data.Conduit.Zlib (ungzip)
+import System.IO (openBinaryFile, IOMode (ReadMode))
+import Data.Yaml (decodeEither')
+import Control.Monad.Trans.Resource (allocate)
+import Data.Slug (SnapSlug)
 
 requireAuthIdOrToken :: Handler UserId
 requireAuthIdOrToken = do
@@ -35,6 +40,80 @@ parseLtsPair t1 = do
     (y, "") <- either (const Nothing) Just $ decimal t3
     Just (x, y)
 
+getStackage :: SnapSlug -> Handler (Entity Stackage, Maybe SnapshotInfo)
+getStackage slug = do
+    ent@(Entity _ stackage) <- runDB $ getBy404 $ UniqueSnapshot slug
+    msi <-
+        if stackageYaml stackage
+            then Just <$> getSnapshotInfoByIdent (stackageIdent stackage)
+            else return Nothing
+    return (ent, msi)
+
+getSnapshotInfoByIdent :: PackageSetIdent -> Handler SnapshotInfo
+getSnapshotInfoByIdent ident = withCache $ do
+    dirs <- getDirs
+    let sourceDocFile rest = do
+            let rawfp = fpToString $ dirRawFp dirs ident rest
+                gzfp  = fpToString $ dirGzFp dirs ident rest
+            eres <- liftResourceT $ tryIO $ allocate (openBinaryFile rawfp ReadMode) hClose
+            case eres of
+                Left _ -> do
+                    (_, h) <- allocate (openBinaryFile gzfp ReadMode) hClose
+                    sourceHandle h $= ungzip
+                Right (_, h) -> sourceHandle h
+
+    let maxFileSize = 1024 * 1024 * 5
+        yaml :: FromJSON a => Text -> Handler a
+        yaml name = do
+            bs <- sourceDocFile [name] $$ takeCE maxFileSize =$ foldC
+            either throwM return $ decodeEither' bs
+
+    master <- getYesod
+    liftIO $ haddockUnpacker master False ident
+
+    siType <- yaml "build-type.yaml"
+    siPlan <- yaml "build-plan.yaml"
+    siDocMap <- yaml "docs-map.yaml"
+    return SnapshotInfo {..}
+  where
+    withCache inner = do
+        cacheRef <- snapshotInfoCache <$> getYesod
+        cache <- readIORef cacheRef
+        case lookup ident cache of
+            Just x -> return x
+            Nothing -> do
+                x <- inner
+                atomicModifyIORef' cacheRef $ \m ->
+                    (insertMap ident x m, x)
+
+data Dirs = Dirs
+    { dirRawRoot :: !FilePath
+    , dirGzRoot :: !FilePath
+    , dirCacheRoot :: !FilePath
+    , dirHoogleRoot :: !FilePath
+    }
+
+getDirs :: Handler Dirs
+getDirs = mkDirs . haddockRootDir <$> getYesod
+
+mkDirs :: FilePath -> Dirs
+mkDirs dir = Dirs
+    { dirRawRoot = dir </> "idents-raw"
+    , dirGzRoot = dir </> "idents-gz"
+    , dirCacheRoot = dir </> "cachedir"
+    , dirHoogleRoot = dir </> "hoogle"
+    }
+
+dirGzIdent, dirRawIdent, dirHoogleIdent :: Dirs -> PackageSetIdent -> FilePath
+dirGzIdent dirs ident = dirGzRoot dirs </> fpFromText (toPathPiece ident)
+dirRawIdent dirs ident = dirRawRoot dirs </> fpFromText (toPathPiece ident)
+dirHoogleIdent dirs ident = dirHoogleRoot dirs </> fpFromText (toPathPiece ident)
+
+dirGzFp, dirRawFp, dirHoogleFp :: Dirs -> PackageSetIdent -> [Text] -> FilePath
+dirGzFp dirs ident rest = dirGzIdent dirs ident </> mconcat (map fpFromText rest)
+dirRawFp dirs ident rest = dirRawIdent dirs ident </> mconcat (map fpFromText rest)
+dirHoogleFp dirs ident rest = dirHoogleIdent dirs ident </> mconcat (map fpFromText rest)
+
 requireDocs :: Entity Stackage -> Handler ()
 requireDocs stackageEnt = do
     master <- getYesod

cabal.config

@@ -691,7 +691,6 @@ constraints: abstract-deque ==0.3,
              Spock-worker ==0.2.1.3,
              spoon ==0.3.1,
              sqlite-simple ==0.4.8.0,
-             stackage ==0.3.1,
              stateref ==0.3,
              statestack ==0.2.0.3,
              statistics ==0.13.2.1,

config/models

@@ -23,6 +23,7 @@ Stackage
     title Text
     desc Text
     hasHaddocks Bool default=false
+    yaml Bool default=false
     UniqueStackage ident
     UniqueSnapshot slug
 

config/routes

@@ -52,5 +52,6 @@
 /older-releases OlderReleasesR GET
 
 /refresh-deprecated RefreshDeprecatedR GET
+/upload2 UploadV2R PUT
 /build-version BuildVersionR GET
 /package-counts PackageCountsR GET

stackage-server.cabal

@@ -1,4 +1,3 @@
--- Stackage snapshot: http://www.stackage.org/stackage/aecbf72b568a63e86a971311fee5475f076043cc
 name:              stackage-server
 version:           0.0.0
 cabal-version:     >= 1.8
@@ -50,6 +49,7 @@ library
                      Handler.Tag
                      Handler.BannedTags
                      Handler.RefreshDeprecated
+                     Handler.UploadV2
                      Handler.BuildVersion
                      Handler.PackageCounts
 
@@ -83,6 +83,7 @@ library
                 RecordWildCards
                 ScopedTypeVariables
                 BangPatterns
+                TupleSections
                 DeriveGeneric
 
     build-depends:
@@ -151,6 +152,8 @@ library
                  , formatting
                  , blaze-html
                  , haddock-library
+                 , async
+                 , stackage >= 0.4
                  , yesod-gitrepo >= 0.1.1
                  , hoogle
                  , spoon

templates/stackage-home.hamlet

@@ -4,11 +4,10 @@ $newline never
         #{stackageTitle stackage}
     <p>
         Published on #{yearMonthDay (stackageUploaded stackage)}
-        $if hasBundle
-           <span .separator>
-           <span>
-               <a href=@{SnapshotR slug StackageCabalConfigR}>
-                   \cabal.config
+        <span .separator>
+        <span>
+            <a href=@{SnapshotR slug StackageCabalConfigR}>
+                \cabal.config
     <h3>Setup guide
     <div class="accordion" id="accordion2">