From c04686aad0dc52f45bc0bae606590a0cb68f4872 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 May 2015 20:23:09 +0300 Subject: [PATCH] Initial Stackge.Database --- Application.hs | 5 +++- Data/Slug.hs | 1 - Foundation.hs | 7 ++++- Handler/BuildPlan.hs | 4 +-- Handler/Download.hs | 4 +-- Handler/Haddock.hs | 4 +-- Handler/Hoogle.hs | 6 ++-- Handler/OldLinks.hs | 64 ++++++++++++++++++++++++++++++++++++---- Handler/StackageHome.hs | 10 +++---- Handler/StackageIndex.hs | 4 +-- Handler/StackageSdist.hs | 4 +-- Model.hs | 2 +- Stackage/Database.hs | 45 ++++++++++++++++++++++++++++ Types.hs | 9 ++++++ config/routes | 12 +++++--- stackage-server.cabal | 3 ++ 16 files changed, 152 insertions(+), 32 deletions(-) create mode 100644 Stackage/Database.hs diff --git a/Application.hs b/Application.hs index 67c62ed..512562f 100644 --- a/Application.hs +++ b/Application.hs @@ -12,7 +12,6 @@ import Control.Exception (catch) import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr) import Data.BlobStore (fileStore, cachedS3Store) import Data.WebsiteContent -import Data.Slug (SnapSlug (..), safeMakeSlug, HasGenIO) import Data.Streaming.Network (bindPortTCP) import Data.Time (diffUTCTime) import qualified Database.Esqueleto as E @@ -40,6 +39,7 @@ import System.IO (hSetBuffering, BufferMode (LineBuffering)) import qualified Data.ByteString as S import qualified Data.Text as T import System.Process (rawSystem) +import Stackage.Database (loadStackageDatabase) import qualified Echo @@ -165,6 +165,8 @@ makeFoundation useEcho conf = do threadDelay $ 1000 * 1000 * 60 * 20 grRefresh websiteContent' + stackageDatabase' <- liftIO $ loadStackageDatabase >>= newIORef + env <- getEnvironment let runDB' :: (MonadIO m, MonadBaseControl IO m) => SqlPersistT m a -> m a @@ -181,6 +183,7 @@ makeFoundation useEcho conf = do , genIO = gen , blobStore = blobStore' , websiteContent = websiteContent' + , stackageDatabase = stackageDatabase' } let urlRender' = yesodRender foundation (appRoot conf) diff --git a/Data/Slug.hs b/Data/Slug.hs index 7dead6d..56e6c5b 100644 --- a/Data/Slug.hs +++ b/Data/Slug.hs @@ -8,7 +8,6 @@ module Data.Slug , HasGenIO (..) , randomSlug , slugField - , SnapSlug (..) ) where import ClassyPrelude.Yesod diff --git a/Foundation.hs b/Foundation.hs index 1cf0100..8e06e68 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -2,7 +2,7 @@ module Foundation where import ClassyPrelude.Yesod import Data.BlobStore -import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug, SnapSlug) +import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug) import Data.WebsiteContent import qualified Database.Persist import Database.Persist.Sql (PersistentSqlException (Couldn'tGetSQLConnection)) @@ -21,6 +21,7 @@ import Yesod.Auth.GoogleEmail2 (authGoogleEmail) import Yesod.Core.Types (Logger) import Yesod.Default.Config import Yesod.GitRepo +import Stackage.Database -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -36,6 +37,7 @@ data App = App , genIO :: MWC.GenIO , blobStore :: BlobStore StoreKey , websiteContent :: GitRepo WebsiteContent + , stackageDatabase :: IORef StackageDatabase } instance HasBlobStore App StoreKey where @@ -272,3 +274,6 @@ getExtra = fmap (appExtra . settings) getYesod -- wiki: -- -- https://github.com/yesodweb/yesod/wiki/Sending-email + +getStackageDatabase :: Handler StackageDatabase +getStackageDatabase = getYesod >>= readIORef . stackageDatabase diff --git a/Handler/BuildPlan.hs b/Handler/BuildPlan.hs index acd0aad..16f68bc 100644 --- a/Handler/BuildPlan.hs +++ b/Handler/BuildPlan.hs @@ -2,11 +2,11 @@ module Handler.BuildPlan where import Import hiding (get, PackageName (..), Version (..), DList) -import Data.Slug (SnapSlug) import Stackage.Types import Stackage.BuildPlan +import Stackage.Database -getBuildPlanR :: SnapSlug -> Handler TypedContent +getBuildPlanR :: SnapName -> Handler TypedContent getBuildPlanR slug = do fullDeps <- (== Just "true") <$> lookupGetParam "full-deps" spec <- parseSnapshotSpec $ toPathPiece slug diff --git a/Handler/Download.hs b/Handler/Download.hs index 7b8a06f..9d4d418 100644 --- a/Handler/Download.hs +++ b/Handler/Download.hs @@ -7,9 +7,9 @@ module Handler.Download ) where import Import -import Data.Slug (SnapSlug) import Data.GhcLinks import Yesod.GitRepo (grContent) +import Stackage.Database executableFor :: SupportedArch -> StackageExecutable executableFor Win32 = StackageWindowsExecutable @@ -88,7 +88,7 @@ ghcMajorVersionText snapshot $ stackageGhcMajorVersion snapshot -} -getGhcMajorVersionR :: SnapSlug -> Handler Text +getGhcMajorVersionR :: SnapName -> Handler Text getGhcMajorVersionR _slug = do error "getGhcMajorVersionR" {- diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 100aa4a..3dd3896 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -10,7 +10,6 @@ import Data.BlobStore import qualified Data.ByteString.Base16 as B16 import Data.Byteable (toBytes) import Data.Conduit.Zlib (gzip) -import Data.Slug (SnapSlug, unSlug) import qualified Data.Text as T import qualified Data.Yaml as Y import Filesystem (isDirectory, createTree, isFile, rename, removeFile, removeDirectory) @@ -20,8 +19,9 @@ import Network.Mime (defaultMimeLookup) import System.IO (IOMode (ReadMode), withBinaryFile) import System.IO.Temp (withTempFile) import System.Posix.Files (createLink) +import Stackage.Database -getHaddockR :: SnapSlug -> [Text] -> Handler () +getHaddockR :: SnapName -> [Text] -> Handler () getHaddockR slug rest = redirect $ concat $ "http://haddock.stackage.org/" : toPathPiece slug diff --git a/Handler/Hoogle.hs b/Handler/Hoogle.hs index 666621f..2c86106 100644 --- a/Handler/Hoogle.hs +++ b/Handler/Hoogle.hs @@ -4,13 +4,13 @@ import Control.DeepSeq (NFData(..)) import Control.DeepSeq.Generics (genericRnf) import Control.Spoon (spoon) import Data.Data (Data (..)) -import Data.Slug (SnapSlug) import Data.Text.Read (decimal) import qualified Hoogle import Import import Text.Blaze.Html (preEscapedToHtml) +import Stackage.Database -getHoogleR :: SnapSlug -> Handler Html +getHoogleR :: SnapName -> Handler Html getHoogleR slug = do error "getHoogleR" {- FIXME @@ -54,7 +54,7 @@ getHoogleR slug = do $(widgetFile "hoogle") -} -getHoogleDatabaseR :: SnapSlug -> Handler Html +getHoogleDatabaseR :: SnapName -> Handler Html getHoogleDatabaseR slug = do error "getHoogleDatabaseR" {- diff --git a/Handler/OldLinks.hs b/Handler/OldLinks.hs index fdc9bec..f3c71bf 100644 --- a/Handler/OldLinks.hs +++ b/Handler/OldLinks.hs @@ -1,12 +1,64 @@ module Handler.OldLinks - ( getLtsR - , getNightlyR + ( getOldLtsR + , getOldLtsMajorR + , getOldNightlyR + , getOldSnapshotR ) where import Import +import Stackage.Database +import qualified Data.Text.Read as Reader -getLtsR :: [Text] -> Handler () -getLtsR foo = return () +data LtsSuffix = LSMajor !Int + | LSMinor !Int !Int -getNightlyR :: [Text] -> Handler () -getNightlyR foo = return () +parseLtsSuffix :: Text -> Maybe LtsSuffix +parseLtsSuffix t0 = do + Right (x, t1) <- Just $ Reader.decimal t0 + if null t1 + then return $ LSMajor x + else do + t2 <- stripPrefix "." t1 + Right (y, "") <- Just $ Reader.decimal t2 + return $ LSMinor x y + +getOldLtsR :: [Text] -> Handler () +getOldLtsR pieces = do + db <- getStackageDatabase + (x, y, pieces') <- case pieces of + t:ts | Just suffix <- parseLtsSuffix t -> do + (x, y) <- case suffix of + LSMajor x -> do + y <- newestLTSMajor db x >>= maybe notFound return + return (x, y) + LSMinor x y -> return (x, y) + return (x, y, ts) + _ -> do + (x, y) <- newestLTS db >>= maybe notFound return + return (x, y, pieces) + let name = concat ["lts-", tshow x, ".", tshow y] + redirect $ concatMap (cons '/') $ name : pieces' + +getOldLtsMajorR :: LtsMajor -> [Text] -> Handler () +getOldLtsMajorR (LtsMajor x) pieces = do + db <- getStackageDatabase + y <- newestLTSMajor db x >>= maybe notFound return + let name = concat ["lts-", tshow x, ".", tshow y] + redirect $ concatMap (cons '/') $ name : pieces + +getOldNightlyR :: [Text] -> Handler () +getOldNightlyR pieces = do + db <- getStackageDatabase + (day, pieces') <- case pieces of + t:ts | Just day <- fromPathPiece t -> return (day, ts) + _ -> do + day <- newestNightly db >>= maybe notFound return + return (day, pieces) + let name = "nightly-" ++ tshow day + redirect $ concatMap (cons '/') $ name : pieces' + +getOldSnapshotR :: Text -> [Text] -> Handler () +getOldSnapshotR t ts = + case fromPathPiece t :: Maybe SnapName of + Just _ -> redirect $ concatMap (cons '/') $ t : ts + Nothing -> notFound diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index df8f74a..d793b51 100644 --- a/Handler/StackageHome.hs +++ b/Handler/StackageHome.hs @@ -7,10 +7,10 @@ module Handler.StackageHome import Import import Data.Time (FormatTime) -import Data.Slug (SnapSlug) import qualified Database.Esqueleto as E +import Stackage.Database -getStackageHomeR :: SnapSlug -> Handler Html +getStackageHomeR :: SnapName -> Handler Html getStackageHomeR slug = do error "getStackageHomeR" {- @@ -70,7 +70,7 @@ getStackageHomeR slug = do where strip x = fromMaybe x (stripSuffix "." x) -} -getStackageCabalConfigR :: SnapSlug -> Handler TypedContent +getStackageCabalConfigR :: SnapName -> Handler TypedContent getStackageCabalConfigR slug = do error "getStackageCabalConfigR" {- @@ -156,7 +156,7 @@ getStackageCabalConfigR slug = do yearMonthDay :: FormatTime t => t -> String yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d" -getSnapshotPackagesR :: SnapSlug -> Handler Html +getSnapshotPackagesR :: SnapName -> Handler Html getSnapshotPackagesR slug = do error "getSnapshotPackagesR" {- @@ -201,7 +201,7 @@ getSnapshotPackagesR slug = do mback = Just (SnapshotR slug StackageHomeR, "Return to snapshot") -} -getDocsR :: SnapSlug -> Handler Html +getDocsR :: SnapName -> Handler Html getDocsR slug = do error "getDocsR" {- diff --git a/Handler/StackageIndex.hs b/Handler/StackageIndex.hs index 04eb353..49b5a45 100644 --- a/Handler/StackageIndex.hs +++ b/Handler/StackageIndex.hs @@ -2,9 +2,9 @@ module Handler.StackageIndex where import Import import Data.BlobStore -import Data.Slug (SnapSlug) +import Stackage.Database -getStackageIndexR :: SnapSlug -> Handler TypedContent +getStackageIndexR :: SnapName -> Handler TypedContent getStackageIndexR slug = do error "getStackageIndexR" {- diff --git a/Handler/StackageSdist.hs b/Handler/StackageSdist.hs index 3e3b020..d5b2563 100644 --- a/Handler/StackageSdist.hs +++ b/Handler/StackageSdist.hs @@ -4,9 +4,9 @@ module Handler.StackageSdist import Import import Data.BlobStore -import Data.Slug (SnapSlug) +import Stackage.Database -getStackageSdistR :: SnapSlug -> PackageNameVersion -> Handler TypedContent +getStackageSdistR :: SnapName -> PackageNameVersion -> Handler TypedContent getStackageSdistR slug (PNVTarball name version) = do error "getStackageSdistR" {- diff --git a/Model.hs b/Model.hs index 8df0423..778f791 100644 --- a/Model.hs +++ b/Model.hs @@ -2,7 +2,7 @@ module Model where import ClassyPrelude.Yesod import Database.Persist.Quasi -import Data.Slug (Slug, SnapSlug) +import Data.Slug (Slug) import Types -- You can define all of your database entities in the entities file. diff --git a/Stackage/Database.hs b/Stackage/Database.hs new file mode 100644 index 0000000..480bcde --- /dev/null +++ b/Stackage/Database.hs @@ -0,0 +1,45 @@ +module Stackage.Database + ( StackageDatabase + , SnapName (..) + , loadStackageDatabase + , newestLTS + , newestLTSMajor + , newestNightly + ) where + +import ClassyPrelude.Conduit +import Data.Time +import Web.PathPieces +import Data.Text.Read (decimal) + +data SnapName = SNLts !Int !Int + | SNNightly !Day + deriving (Eq, Read, Show) +instance PathPiece SnapName where + toPathPiece (SNLts x y) = concat ["lts-", tshow x, ".", tshow y] + toPathPiece (SNNightly d) = "nightly-" ++ tshow d + + fromPathPiece t0 = + nightly <|> lts + where + nightly = stripPrefix "nightly-" t0 >>= readMay + lts = do + t1 <- stripPrefix "lts-" t0 + Right (x, t2) <- Just $ decimal t1 + t3 <- stripPrefix "." t2 + Right (y, "") <- Just $ decimal t3 + return $ SNLts x y + +data StackageDatabase = StackageDatabase + +loadStackageDatabase :: IO StackageDatabase +loadStackageDatabase = return StackageDatabase + +newestLTS :: MonadIO m => StackageDatabase -> m (Maybe (Int, Int)) +newestLTS _ = return $ Just (2, 8) + +newestLTSMajor :: MonadIO m => StackageDatabase -> Int -> m (Maybe Int) +newestLTSMajor _ _ = return $ Just 7 + +newestNightly :: MonadIO m => StackageDatabase -> m (Maybe Day) +newestNightly _ = return $ Just $ fromGregorian 2015 4 3 diff --git a/Types.hs b/Types.hs index 6594170..3fc98fc 100644 --- a/Types.hs +++ b/Types.hs @@ -12,6 +12,15 @@ import qualified Data.Text.Lazy.Builder as Builder import qualified Data.Text.Lazy as LText import qualified Data.Text.Read as Reader +newtype LtsMajor = LtsMajor Int + deriving (Eq, Read, Show) +instance PathPiece LtsMajor where + toPathPiece (LtsMajor x) = "lts-" ++ tshow x + fromPathPiece t0 = do + t1 <- stripPrefix "lts-" t0 + Right (x, "") <- Just $ Reader.decimal t1 + Just $ LtsMajor x + newtype PackageName = PackageName { unPackageName :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString) instance PersistFieldSql PackageName where diff --git a/config/routes b/config/routes index cf3a864..ba04e4a 100644 --- a/config/routes +++ b/config/routes @@ -1,3 +1,5 @@ +!/#LtsMajor/*Texts OldLtsMajorR GET + /static StaticR Static getStatic /auth AuthR Auth getAuth /reload WebsiteContentR GitRepo-WebsiteContent websiteContent @@ -12,7 +14,9 @@ /email/#EmailId EmailR DELETE /reset-token ResetTokenR POST -/snapshot/#SnapSlug SnapshotR: +/snapshot/#Text/*Texts OldSnapshotR GET + +!/#SnapName SnapshotR: / StackageHomeR GET /cabal.config StackageCabalConfigR GET /00-index.tar.gz StackageIndexR GET @@ -25,7 +29,7 @@ /ghc-major-version GhcMajorVersionR GET /system SystemR GET -/haddock/#SnapSlug/*Texts HaddockR GET +/haddock/#SnapName/*Texts HaddockR GET /package/#PackageName PackageR GET /package/#PackageName/snapshots PackageSnapshotsR GET /package PackageListR GET @@ -37,8 +41,8 @@ /tag/#Slug TagR GET /banned-tags BannedTagsR GET PUT -/lts/*Texts LtsR GET -/nightly/*Texts NightlyR GET +/lts/*Texts OldLtsR GET +/nightly/*Texts OldNightlyR GET /authors AuthorsR GET /install InstallR GET diff --git a/stackage-server.cabal b/stackage-server.cabal index d145d6b..ad36c46 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -26,6 +26,7 @@ library Data.GhcLinks Data.WebsiteContent Types + Stackage.Database Handler.Home Handler.Snapshots Handler.Profile @@ -162,6 +163,8 @@ library , stackage-build-plan >= 0.1.1 , yesod-sitemap , streaming-commons + , classy-prelude-conduit + , path-pieces executable stackage-server if flag(library-only)