From ef9e5cc7cebf60b1d147509611807203ca8fceb2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 26 Dec 2014 16:13:08 +0200 Subject: [PATCH] More WIP --- Application.hs | 4 ++ Foundation.hs | 10 +++ Handler/Haddock.hs | 24 ------- Handler/StackageHome.hs | 121 +++++++++++++++++++++------------ Handler/UploadStackage.hs | 1 + Import.hs | 62 +++++++++++++++++ cabal.config | 1 - config/models | 1 + config/routes | 1 + stackage-server.cabal | 4 +- templates/doc-list.hamlet | 2 +- templates/stackage-home.hamlet | 9 ++- 12 files changed, 165 insertions(+), 75 deletions(-) diff --git a/Application.hs b/Application.hs index ac30d9a..b3dc6cd 100644 --- 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 diff --git a/Foundation.hs b/Foundation.hs index d9b574c..e93fa37 100644 --- 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 diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index ab6b94d..ebfe746 100644 --- 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" diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index 1da0082..255887e 100644 --- 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) diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index f997640..6897a3c 100644 --- 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 diff --git a/Import.hs b/Import.hs index 9a53b4d..f1089ef 100644 --- 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) diff --git a/cabal.config b/cabal.config index 915451a..e266890 100644 --- 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, diff --git a/config/models b/config/models index 177b3d2..260db48 100644 --- 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 diff --git a/config/routes b/config/routes index 6bd1d22..3bad7df 100644 --- a/config/routes +++ b/config/routes @@ -53,3 +53,4 @@ /older-releases OlderReleasesR GET /refresh-deprecated RefreshDeprecatedR GET +/upload2 UploadV2R PUT diff --git a/stackage-server.cabal b/stackage-server.cabal index a4a0b0d..2a85af7 100644 --- 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) diff --git a/templates/doc-list.hamlet b/templates/doc-list.hamlet index fd61584..2b13d13 100644 --- a/templates/doc-list.hamlet +++ b/templates/doc-list.hamlet @@ -1,6 +1,6 @@

Module listing for #{toPathPiece slug}

- Return to snapshot + Return to snapshot