Initial Stackge.Database

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)

Data/Slug.hs

@@ -8,7 +8,6 @@ module Data.Slug
     , HasGenIO (..)
     , randomSlug
     , slugField
-    , SnapSlug (..)
     ) where
 
 import ClassyPrelude.Yesod

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

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

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"
   {-

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

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"
     {-

Handler/OldLinks.hs

@@ -1,12 +1,64 @@
 module Handler.OldLinks
-    ( getLtsR
+    ( getOldLtsR
-    , getNightlyR
+    , getOldLtsMajorR
+    , getOldNightlyR
+    , getOldSnapshotR
     ) where
 
 import Import
+import Stackage.Database
+import qualified Data.Text.Read as Reader
 
-getLtsR :: [Text] -> Handler ()
+data LtsSuffix = LSMajor !Int
-getLtsR foo = return ()
+               | LSMinor !Int !Int
 
-getNightlyR :: [Text] -> Handler ()
+parseLtsSuffix :: Text -> Maybe LtsSuffix
-getNightlyR foo = return ()
+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

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"
     {-

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"
     {-

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"
     {-

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.

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

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

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
+/lts/*Texts OldLtsR GET
-/nightly/*Texts NightlyR GET
+/nightly/*Texts OldNightlyR GET
 
 /authors AuthorsR GET
 /install InstallR GET

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)