More WIP

Application.hs

@@ -68,6 +68,7 @@ import           Handler.CompressorStatus
 import           Handler.Tag
 import           Handler.BannedTags
 import           Handler.RefreshDeprecated
+import           Handler.UploadV2
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -198,6 +199,8 @@ makeFoundation useEcho conf = do
             loadWebsiteContent
 #endif
 
+    snapshotInfoCache' <- newIORef mempty
+
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App
             { settings = conf
@@ -215,6 +218,7 @@ makeFoundation useEcho conf = do
             , widgetCache = widgetCache'
             , compressorStatus = statusRef
             , websiteContent = websiteContent'
+            , snapshotInfoCache = snapshotInfoCache'
             }
 
     env <- getEnvironment

Foundation.hs

@@ -22,6 +22,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
@@ -47,6 +49,13 @@ data App = App
     , widgetCache :: !(IORef (HashMap Text (UTCTime, GWData (Route App))))
     , compressorStatus :: !(IORef Text)
     , websiteContent :: GitRepo WebsiteContent
+    , snapshotInfoCache :: !(IORef (HashMap PackageSetIdent SnapshotInfo))
+    }
+
+data SnapshotInfo = SnapshotInfo
+    { siType :: !SnapshotType
+    , siPlan :: !BuildPlan
+    , siDocMap :: !DocMap
     }
 
 type ForceUnpack = Bool
@@ -152,6 +161,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

@@ -202,30 +202,6 @@ gzipHash dirs suffix = do
     src = dirRawRoot dirs </> suffix
     dst = dirGzRoot dirs </> suffix
 
-data Dirs = Dirs
-    { dirRawRoot :: !FilePath
-    , dirGzRoot :: !FilePath
-    , dirCacheRoot :: !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"
-    }
-
-dirGzIdent, dirRawIdent :: Dirs -> PackageSetIdent -> FilePath
-dirGzIdent dirs ident = dirGzRoot dirs </> fpFromText (toPathPiece ident)
-dirRawIdent dirs ident = dirRawRoot dirs </> fpFromText (toPathPiece ident)
-
-dirGzFp, dirRawFp :: 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)
-
 dirCacheFp :: Dirs -> Digest SHA1 -> FilePath
 dirCacheFp dirs digest =
     dirCacheRoot dirs </> fpFromText x </> fpFromText y <.> "gz"

Handler/StackageHome.hs

@@ -6,12 +6,15 @@ 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)
 
 getStackageHomeR :: SnapSlug -> Handler Html
 getStackageHomeR slug = do
-    stackage <- runDB $ do
+    (Entity sid stackage, msi) <- getStackage slug
-        Entity _ stackage <- getBy404 $ UniqueSnapshot slug
-        return stackage
 
     hasBundle <- storeExists $ SnapshotBundle $ stackageIdent stackage
     let minclusive =
@@ -21,7 +24,7 @@ getStackageHomeR slug = do
                        then Just False
                        else Nothing
         base = maybe 0 (const 1) minclusive :: Int
-    Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
+
     defaultLayout $ do
         setTitle $ toHtml $ stackageTitle stackage
         cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
@@ -70,7 +73,7 @@ getStackageHomeR slug = do
 
 getStackageMetadataR :: SnapSlug -> Handler TypedContent
 getStackageMetadataR slug = do
-    Entity sid _ <- runDB $ getBy404 $ UniqueSnapshot slug
+    (Entity sid _, msi) <- getStackage slug
     respondSourceDB typePlain $ do
         sendChunkBS "Override packages\n"
         sendChunkBS "=================\n"
@@ -97,7 +100,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"
@@ -107,15 +110,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
@@ -145,28 +163,28 @@ getStackageCabalConfigR slug = do
         toBuilder (render $ SnapshotR slug StackageHomeR) ++
         toBuilder '\n'
 
-    constraint p
+    constraint Nothing = toBuilder $ asText " installed"
-        | Just True <- packageCore p = toBuilder $ asText " installed"
+    constraint (Just version) =
-        | otherwise = toBuilder (asText " ==") ++
+                      toBuilder (asText " ==") ++
-                      toBuilder (toPathPiece $ packageVersion p)
+                      toBuilder (toPathPiece version)
 
-    showPackageGlobal (Entity _ p) =
+    showPackageGlobal (name, mversion) =
         toBuilder (asText "constraint: ") ++
-        toBuilder (toPathPiece $ packageName' p) ++
+        toBuilder (toPathPiece name) ++
-        constraint p ++
+        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) ++
+            toBuilder (toPathPiece name) ++
-            constraint p
+            constraint mversion
 
-    showPackageLocal (Entity _ p) =
+    showPackageLocal (name, mversion) =
         toBuilder (asText ",\n             ") ++
-        toBuilder (toPathPiece $ packageName' p) ++
+        toBuilder (toPathPiece name) ++
-        constraint p
+        constraint mversion
 
 yearMonthDay :: FormatTime t => t -> String
 yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d"
@@ -180,7 +198,7 @@ getOldStackageR ident pieces = do
 
 getSnapshotPackagesR :: SnapSlug -> Handler Html
 getSnapshotPackagesR slug = do
-    Entity sid _stackage <- runDB $ getBy404 $ UniqueSnapshot slug
+    (Entity sid _stackage, msi) <- getStackage slug
     defaultLayout $ do
         setTitle $ toHtml $ "Package list for " ++ toPathPiece slug
         cachedWidget (20 * 60) ("package-list-" ++ toPathPiece slug) $ do
@@ -223,27 +241,44 @@ getSnapshotPackagesR slug = do
 
 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
+            modules <- handlerToWidget $ maybe (getFromDB sid) convertYaml msi
-                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
-                    )
             $(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

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

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
@@ -34,3 +39,60 @@ parseLtsPair t1 = do
     t3 <- stripPrefix "." t2
     (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 = 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
+
+    siType <- yaml "build-type.yaml"
+    siPlan <- yaml "build-plan.yaml"
+    siDocMap <- yaml "docs-map.yaml"
+    return SnapshotInfo {..}
+
+data Dirs = Dirs
+    { dirRawRoot :: !FilePath
+    , dirGzRoot :: !FilePath
+    , dirCacheRoot :: !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"
+    }
+
+dirGzIdent, dirRawIdent :: Dirs -> PackageSetIdent -> FilePath
+dirGzIdent dirs ident = dirGzRoot dirs </> fpFromText (toPathPiece ident)
+dirRawIdent dirs ident = dirRawRoot dirs </> fpFromText (toPathPiece ident)
+
+dirGzFp, dirRawFp :: 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)

cabal.config

@@ -669,7 +669,6 @@ constraints: abstract-deque ==0.3,
              Spock ==0.7.5.1,
              spoon ==0.3.1,
              sqlite-simple ==0.4.8.0,
-             stackage ==0.2.1.3,
              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

@@ -53,3 +53,4 @@
 /older-releases OlderReleasesR GET
 
 /refresh-deprecated RefreshDeprecatedR GET
+/upload2 UploadV2R PUT

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
@@ -51,6 +50,7 @@ library
                      Handler.Tag
                      Handler.BannedTags
                      Handler.RefreshDeprecated
+                     Handler.UploadV2
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -150,6 +150,8 @@ library
                  , blaze-html
                  , haddock-library
                  , yesod-gitrepo
+                 , async
+                 , stackage >= 0.4
 
 executable         stackage-server
     if flag(library-only)

templates/doc-list.hamlet

@@ -1,6 +1,6 @@
 <h1>Module listing for #{toPathPiece slug}
 <p>
-    <a href=@{SnapshotR slug DocsR}>Return to snapshot
+    <a href=@{SnapshotR slug StackageHomeR}>Return to snapshot
 <ul>
     $forall (name, url, package, version) <- modules
         <li>

templates/stackage-home.hamlet

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