More WIP

2026-01-12 04:08:29 +01:00 · 2014-12-26 16:13:08 +02:00 · 2014-12-26 16:13:08 +02:00 · ef9e5cc7ce
commit ef9e5cc7ce
parent 7672603fcb
12 changed files with 165 additions and 75 deletions
--- a/Application.hs
+++ b/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
--- a/Foundation.hs
+++ b/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
--- a/Handler/Haddock.hs
+++ b/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"
--- a/Handler/StackageHome.hs
+++ b/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 _ stackage <- getBy404 $ UniqueSnapshot slug
-        return stackage
+    (Entity sid stackage, msi) <- getStackage slug

    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
-        | 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"
@ -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
-                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)
--- a/Handler/UploadStackage.hs
+++ b/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
--- a/Import.hs
+++ b/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)
--- a/cabal.config
+++ b/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,
--- a/config/models
+++ b/config/models
@ -23,6 +23,7 @@ Stackage
    title Text
    desc Text
    hasHaddocks Bool default=false
+    yaml Bool default=false
    UniqueStackage ident
    UniqueSnapshot slug

--- a/config/routes
+++ b/config/routes
@ -53,3 +53,4 @@
 /older-releases OlderReleasesR GET

 /refresh-deprecated RefreshDeprecatedR GET
+/upload2 UploadV2R PUT
--- a/stackage-server.cabal
+++ b/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)
--- a/templates/doc-list.hamlet
+++ b/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>
--- a/templates/stackage-home.hamlet
+++ b/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">