diff --git a/Application.hs b/Application.hs index dd61140..1e9df82 100644 --- a/Application.hs +++ b/Application.hs @@ -13,6 +13,7 @@ import Control.Monad.Logger (runLoggingT, LoggingT, defaultLogStr) import Data.BlobStore (fileStore, storeWrite, cachedS3Store) import Data.Hackage import Data.Hackage.Views +import Data.Slug (SnapSlug (..), safeMakeSlug, HasGenIO) import Data.Time (diffUTCTime) import qualified Database.Esqueleto as E import qualified Database.Persist @@ -36,6 +37,7 @@ import System.Environment (getEnvironment) import Data.BlobStore (HasBlobStore (..), BlobStore) import System.IO (hSetBuffering, BufferMode (LineBuffering)) import qualified Data.ByteString as S +import qualified Data.Text as T import qualified Echo @@ -180,9 +182,12 @@ makeFoundation useEcho conf = do } -- Perform database migration using our application's logging settings. - runLoggingT - (Database.Persist.runPool dbconf (runMigration migrateAll) p) - (messageLoggerSource foundation logger) + runResourceT $ + flip runReaderT gen $ + flip runLoggingT (messageLoggerSource foundation logger) $ + flip (Database.Persist.runPool dbconf) p $ do + runMigration migrateAll + checkMigration 1 $ fixSnapSlugs env <- getEnvironment let updateDB = lookup "STACKAGE_CABAL_LOADER" env /= Just "0" @@ -321,3 +326,33 @@ getApplicationDev useEcho = loader = Yesod.Default.Config.loadConfig (configSettings Development) { csParseExtra = parseExtra } + +checkMigration :: MonadIO m + => Int + -> ReaderT SqlBackend m () + -> ReaderT SqlBackend m () +checkMigration num f = do + eres <- insertBy $ Migration num + case eres of + Left _ -> return () + Right _ -> f + +fixSnapSlugs :: (MonadResource m, HasGenIO env, MonadReader env m) + => ReaderT SqlBackend m () +fixSnapSlugs = + selectSource [] [Asc StackageUploaded] $$ mapM_C go + where + go (Entity sid Stackage {..}) = + loop (1 :: Int) + where + base = T.replace "haskell platform" "hp" + $ T.replace "stackage build for " "" + $ toLower stackageTitle + loop 50 = error "fixSnapSlugs can't find a good slug" + loop i = do + slug' <- lift $ safeMakeSlug base $ if i == 1 then False else True + let slug = SnapSlug slug' + ms <- getBy $ UniqueSnapshot slug + case ms of + Nothing -> update sid [StackageSlug =. slug] + Just _ -> loop (i + 1) diff --git a/Data/Slug.hs b/Data/Slug.hs index cc60ef3..b7726ab 100644 --- a/Data/Slug.hs +++ b/Data/Slug.hs @@ -8,6 +8,7 @@ module Data.Slug , HasGenIO (..) , randomSlug , slugField + , SnapSlug (..) ) where import ClassyPrelude.Yesod @@ -96,3 +97,9 @@ slugField = checkMMap go unSlug textField where go = return . either (Left . tshow) Right . mkSlug + +-- | Unique identifier for a snapshot. +newtype SnapSlug = SnapSlug { unSnapSlug :: Slug } + deriving (Show, Read, Eq, Typeable, PersistField, ToMarkup, PathPiece) +instance PersistFieldSql SnapSlug where + sqlType = sqlType . liftM unSnapSlug diff --git a/Foundation.hs b/Foundation.hs index 65ea1fe..73e6b49 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) +import Data.Slug (safeMakeSlug, HasGenIO (getGenIO), randomSlug, Slug, SnapSlug) import qualified Database.Persist import Model import qualified Settings diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs index 52f3128..29c537f 100644 --- a/Handler/Haddock.hs +++ b/Handler/Haddock.hs @@ -16,16 +16,24 @@ import qualified Data.ByteString.Base16 as B16 import Data.Byteable (toBytes) import Crypto.Hash (Digest, SHA1) import qualified Filesystem.Path.CurrentOS as F +import Data.Slug (SnapSlug) form :: Form FileInfo form = renderDivs $ areq fileField "tarball containing docs" { fsName = Just "tarball" } Nothing -getUploadHaddockR, putUploadHaddockR :: PackageSetIdent -> Handler Html -getUploadHaddockR ident = do +getUploadHaddockR, putUploadHaddockR :: SnapSlug -> Handler Html +getUploadHaddockR slug0 = do uid <- requireAuthIdOrToken - Entity sid Stackage {..} <- runDB $ getBy404 $ UniqueStackage ident + Entity sid Stackage {..} <- runDB $ do + -- Provide fallback for old URLs + ment <- getBy $ UniqueSnapshot slug0 + case ment of + Just ent -> return ent + Nothing -> getBy404 $ UniqueStackage $ PackageSetIdent $ toPathPiece slug0 + let ident = stackageIdent + slug = stackageSlug unless (uid == stackageUser) $ permissionDenied "You do not control this snapshot" ((res, widget), enctype) <- runFormPostNoToken form case res of @@ -35,16 +43,25 @@ getUploadHaddockR ident = do master <- getYesod void $ liftIO $ forkIO $ haddockUnpacker master True ident setMessage "Haddocks uploaded" - redirect $ StackageHomeR ident + redirect $ StackageHomeR slug _ -> defaultLayout $ do setTitle "Upload Haddocks" $(widgetFile "upload-haddock") putUploadHaddockR = getUploadHaddockR -getHaddockR :: PackageSetIdent -> [Text] -> Handler () -getHaddockR ident rest = do - sanitize $ toPathPiece ident +getHaddockR :: SnapSlug -> [Text] -> Handler () +getHaddockR slug rest = do + ident <- runDB $ do + ment <- getBy $ UniqueSnapshot slug + case ment of + Just ent -> return $ stackageIdent $ entityVal ent + Nothing -> do + Entity _ stackage <- getBy404 + $ UniqueStackage + $ PackageSetIdent + $ toPathPiece slug + redirectWith status301 $ HaddockR (stackageSlug stackage) rest mapM_ sanitize rest dirs <- getDirs -- (gzdir, rawdir) <- getHaddockDir ident master <- getYesod @@ -55,9 +72,9 @@ getHaddockR ident rest = do mime = defaultMimeLookup $ fpToText $ filename rawfp whenM (liftIO $ isDirectory rawfp) - $ redirect $ HaddockR ident $ rest ++ ["index.html"] + $ redirect $ HaddockR slug $ rest ++ ["index.html"] whenM (liftIO $ isDirectory gzfp) - $ redirect $ HaddockR ident $ rest ++ ["index.html"] + $ redirect $ HaddockR slug $ rest ++ ["index.html"] whenM (liftIO $ isFile gzfp) $ do addHeader "Content-Encoding" "gzip" diff --git a/Handler/Home.hs b/Handler/Home.hs index 7daaa40..0c63bc2 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -27,12 +27,13 @@ getHomeR = do linkFor name = do slug <- mkSlug name fpcomplete <- mkSlug "fpcomplete" - selecting (\(alias, user) -> + selecting (\(alias, user, stackage) -> do where_ $ alias ^. AliasName ==. val slug &&. alias ^. AliasUser ==. user ^. UserId &&. - user ^. UserHandle ==. val fpcomplete - return (alias ^. AliasTarget)) + user ^. UserHandle ==. val fpcomplete &&. + alias ^. AliasTarget ==. stackage ^. StackageIdent + return (stackage ^. StackageSlug)) where selecting = fmap (fmap unValue . listToMaybe) . runDB . diff --git a/Handler/Package.hs b/Handler/Package.hs index 5ac73c6..2887624 100644 --- a/Handler/Package.hs +++ b/Handler/Package.hs @@ -31,7 +31,7 @@ getPackageR pn = do E.orderBy [E.desc $ s ^. StackageUploaded] E.limit maxSnaps --selectList [PackageName' ==. pn] [LimitTo 10, Desc PackageStackage] - return (p ^. PackageVersion, s ^. StackageTitle, s ^. StackageIdent, s ^. StackageHasHaddocks) + return (p ^. PackageVersion, s ^. StackageTitle, s ^. StackageSlug, s ^. StackageHasHaddocks) nLikes <- count [LikePackage ==. pn] let getLiked uid = (>0) <$> count [LikePackage ==. pn, LikeVoter ==. uid] liked <- maybe (return False) getLiked muid diff --git a/Handler/Snapshots.hs b/Handler/Snapshots.hs index 067bc0d..f2cba77 100644 --- a/Handler/Snapshots.hs +++ b/Handler/Snapshots.hs @@ -23,7 +23,7 @@ getAllSnapshotsR = do E.on (stackage E.^. StackageUser E.==. user E.^. UserId) E.orderBy [E.desc $ stackage E.^. StackageUploaded] return - ( stackage E.^. StackageIdent + ( stackage E.^. StackageSlug , stackage E.^. StackageTitle , stackage E.^. StackageUploaded , user E.^. UserDisplay diff --git a/Handler/StackageHome.hs b/Handler/StackageHome.hs index e768675..bc0dd20 100644 --- a/Handler/StackageHome.hs +++ b/Handler/StackageHome.hs @@ -3,16 +3,17 @@ module Handler.StackageHome where import Data.BlobStore (storeExists) import Import import Data.Time (FormatTime) +import Data.Slug (SnapSlug) -getStackageHomeR :: PackageSetIdent -> Handler Html -getStackageHomeR ident = do +getStackageHomeR :: SnapSlug -> Handler Html +getStackageHomeR slug = do muid <- maybeAuthId stackage <- runDB $ do - Entity _ stackage <- getBy404 $ UniqueStackage ident + Entity _ stackage <- getBy404 $ UniqueSnapshot slug return stackage let isOwner = muid == Just (stackageUser stackage) - hasBundle <- storeExists $ SnapshotBundle ident + hasBundle <- storeExists $ SnapshotBundle $ stackageIdent stackage let minclusive = if "inclusive" `isSuffixOf` stackageTitle stackage then Just True @@ -24,9 +25,9 @@ getStackageHomeR ident = do setTitle $ toHtml $ stackageTitle stackage $(widgetFile "stackage-home") -getStackageMetadataR :: PackageSetIdent -> Handler TypedContent -getStackageMetadataR ident = do - Entity sid _ <- runDB $ getBy404 $ UniqueStackage ident +getStackageMetadataR :: SnapSlug -> Handler TypedContent +getStackageMetadataR slug = do + Entity sid _ <- runDB $ getBy404 $ UniqueSnapshot slug respondSourceDB typePlain $ do sendChunkBS "Override packages\n" sendChunkBS "=================\n" @@ -51,9 +52,9 @@ getStackageMetadataR ident = do , "\n" ] -getStackageCabalConfigR :: PackageSetIdent -> Handler TypedContent -getStackageCabalConfigR ident = do - Entity sid _ <- runDB $ getBy404 $ UniqueStackage ident +getStackageCabalConfigR :: SnapSlug -> Handler TypedContent +getStackageCabalConfigR slug = do + Entity sid _ <- runDB $ getBy404 $ UniqueSnapshot slug respondSourceDB typePlain $ stream sid where stream sid = @@ -81,3 +82,10 @@ getStackageCabalConfigR ident = do yearMonthDay :: FormatTime t => t -> String yearMonthDay = formatTime defaultTimeLocale "%Y-%m-%d" + +getOldStackageR :: PackageSetIdent -> [Text] -> Handler () +getOldStackageR ident pieces = do + Entity _ stackage <- runDB $ getBy404 $ UniqueStackage ident + case parseRoute ("snapshot" : toPathPiece (stackageSlug stackage) : pieces, []) of + Nothing -> notFound + Just route -> redirect (route :: Route App) diff --git a/Handler/StackageIndex.hs b/Handler/StackageIndex.hs index 38feeda..d5c558c 100644 --- a/Handler/StackageIndex.hs +++ b/Handler/StackageIndex.hs @@ -2,9 +2,12 @@ module Handler.StackageIndex where import Import import Data.BlobStore +import Data.Slug (SnapSlug) -getStackageIndexR :: PackageSetIdent -> Handler TypedContent -getStackageIndexR ident = do +getStackageIndexR :: SnapSlug -> Handler TypedContent +getStackageIndexR slug = do + Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug + let ident = stackageIdent stackage msrc <- storeRead $ CabalIndex ident case msrc of Nothing -> notFound @@ -14,8 +17,10 @@ getStackageIndexR ident = do neverExpires respondSource "application/x-gzip" $ mapOutput (Chunk . toBuilder) src -getStackageBundleR :: PackageSetIdent -> Handler TypedContent -getStackageBundleR ident = do +getStackageBundleR :: SnapSlug -> Handler TypedContent +getStackageBundleR slug = do + Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug + let ident = stackageIdent stackage msrc <- storeRead $ SnapshotBundle ident case msrc of Nothing -> notFound diff --git a/Handler/StackageSdist.hs b/Handler/StackageSdist.hs index c690c54..28c2d19 100644 --- a/Handler/StackageSdist.hs +++ b/Handler/StackageSdist.hs @@ -3,9 +3,12 @@ module Handler.StackageSdist where import Import import Data.BlobStore import Data.Hackage +import Data.Slug (SnapSlug) -getStackageSdistR :: PackageSetIdent -> PackageNameVersion -> Handler TypedContent -getStackageSdistR ident (PackageNameVersion name version) = do +getStackageSdistR :: SnapSlug -> PackageNameVersion -> Handler TypedContent +getStackageSdistR slug (PackageNameVersion name version) = do + Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug + let ident = stackageIdent stackage addDownload (Just ident) Nothing name version msrc1 <- storeRead (CustomSdist ident name version) msrc <- diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index cad802e..c5393d0 100644 --- a/Handler/UploadStackage.hs +++ b/Handler/UploadStackage.hs @@ -18,11 +18,14 @@ import Control.Monad.Trans.Resource (allocate) import System.Directory (removeFile, getTemporaryDirectory) import System.Process (runProcess, waitForProcess) import System.Exit (ExitCode (ExitSuccess)) -import Data.Slug (mkSlug) +import Data.Slug (mkSlug, SnapSlug (..), safeMakeSlug) fileKey :: Text fileKey = "stackage" +slugKey :: Text +slugKey = "slug" + getUploadStackageR :: Handler Html getUploadStackageR = do _ <- requireAuth @@ -34,6 +37,7 @@ putUploadStackageR :: Handler TypedContent putUploadStackageR = do uid <- requireAuthIdOrToken mfile <- lookupFile fileKey + mslug0 <- lookupPostParam slugKey case mfile of Nothing -> invalidArgs ["Upload missing"] Just file -> do @@ -75,6 +79,7 @@ putUploadStackageR = do forkHandler onExc $ do now <- liftIO getCurrentTime + baseSlug <- fmap SnapSlug $ mkSlug $ fromMaybe (tshow $ utctDay now) mslug0 let initial = Stackage { stackageUser = uid , stackageIdent = ident @@ -82,6 +87,7 @@ putUploadStackageR = do , stackageTitle = "Untitled Stackage" , stackageDesc = "No description provided" , stackageHasHaddocks = False + , stackageSlug = baseSlug } -- Evil lazy I/O thanks to tar package @@ -106,25 +112,27 @@ putUploadStackageR = do then do sourceFile (fpFromString fp') $$ storeWrite (CabalIndex ident) sourceFile (fpFromString fp) $$ gzip =$ storeWrite (SnapshotBundle ident) - runDB $ do - sid <- insert stackage + slug <- runDB $ do + slug <- getUniqueSlug $ stackageSlug stackage + sid <- insert stackage { stackageSlug = slug} forM_ contents $ \(name, version, overwrite) -> insert_ Package { packageStackage = sid , packageName' = name , packageVersion = version , packageOverwrite = overwrite } + return slug setAlias - done "Stackage created" $ StackageHomeR ident + done "Stackage created" $ StackageHomeR slug else do done "Error creating index file" ProfileR addHeader "X-Stackage-Ident" $ toPathPiece ident redirect $ ProgressR key where - loop _ Tar.Done = return () + loop update Tar.Done = update "Finished processing files" loop _ (Tar.Fail e) = throwM e loop update (Tar.Next entry entries) = do addEntry update entry @@ -147,6 +155,10 @@ putUploadStackageR = do , stackageDesc = desc } } + "slug" -> do + slug <- safeMakeSlug (decodeUtf8 $ toStrict lbs) False + ls <- get + put ls { lsStackage = (lsStackage ls) { stackageSlug = SnapSlug slug } } "hackage" -> forM_ (lines $ decodeUtf8 $ toStrict lbs) $ \line -> case parseName line of Just (name, version) -> do @@ -245,3 +257,31 @@ extractCabal lbs name version = , toPathPiece name , ".cabal" ] + +-- | Get a unique version of the given slug by appending random numbers to the +-- end. +getUniqueSlug :: MonadIO m => SnapSlug -> ReaderT SqlBackend m SnapSlug +getUniqueSlug base = + loop Nothing + where + loop msuffix = do + slug <- checkSlug $ addSuffix msuffix + ment <- getBy $ UniqueSnapshot slug + case ment of + Nothing -> return slug + Just _ -> + case msuffix of + Nothing -> loop $ Just (1 :: Int) + Just i + | i > 50 -> error "No unique slug found" + | otherwise -> loop $ Just $ i + 1 + + txt = toPathPiece base + + addSuffix Nothing = txt + addSuffix (Just i) = txt ++ pack ('-' : show i) + + checkSlug slug = + case fromPathPiece slug of + Nothing -> error $ "Invalid snapshot slug: " ++ unpack slug + Just s -> return s diff --git a/Model.hs b/Model.hs index 778f791..8df0423 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) +import Data.Slug (Slug, SnapSlug) import Types -- You can define all of your database entities in the entities file. diff --git a/config/models b/config/models index ada38e3..ab91d2b 100644 --- a/config/models +++ b/config/models @@ -18,11 +18,13 @@ Verkey Stackage user UserId ident PackageSetIdent + slug SnapSlug default="md5((random())::text)" uploaded UTCTime title Text desc Text hasHaddocks Bool default=false UniqueStackage ident + UniqueSnapshot slug Uploaded name PackageName @@ -88,3 +90,7 @@ Metadata BannedTag tag Slug UniqueBannedTag tag + +Migration + num Int + UniqueMigration num diff --git a/config/routes b/config/routes index 134e34c..39ac0db 100644 --- a/config/routes +++ b/config/routes @@ -10,20 +10,24 @@ /email/#EmailId EmailR DELETE /reset-token ResetTokenR POST /upload UploadStackageR GET PUT -/upload-haddock/#PackageSetIdent UploadHaddockR GET PUT -/stackage/#PackageSetIdent StackageHomeR GET -/stackage/#PackageSetIdent/metadata StackageMetadataR GET -/stackage/#PackageSetIdent/cabal.config StackageCabalConfigR GET -/stackage/#PackageSetIdent/00-index.tar.gz StackageIndexR GET -/stackage/#PackageSetIdent/bundle StackageBundleR GET -/stackage/#PackageSetIdent/package/#PackageNameVersion StackageSdistR GET +/upload-haddock/#SnapSlug UploadHaddockR GET PUT + +/stackage/#PackageSetIdent/*Texts OldStackageR GET + +/snapshot/#SnapSlug StackageHomeR GET +/snapshot/#SnapSlug/metadata StackageMetadataR GET +/snapshot/#SnapSlug/cabal.config StackageCabalConfigR GET +/snapshot/#SnapSlug/00-index.tar.gz StackageIndexR GET +/snapshot/#SnapSlug/bundle StackageBundleR GET +/snapshot/#SnapSlug/package/#PackageNameVersion StackageSdistR GET + /hackage-view/#HackageView/00-index.tar.gz HackageViewIndexR GET /hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET /aliases AliasesR PUT /alias/#Slug/#Slug/*Texts AliasR /progress/#Int ProgressR GET /system SystemR GET -/haddock/#PackageSetIdent/*Texts HaddockR GET +/haddock/#SnapSlug/*Texts HaddockR GET /package/#PackageName PackageR GET /package PackageListR GET /compressor-status CompressorStatusR GET diff --git a/templates/package.hamlet b/templates/package.hamlet index 3a1cf9a..fd8f26a 100644 --- a/templates/package.hamlet +++ b/templates/package.hamlet @@ -111,16 +111,16 @@ $newline never Package Snapshot - $forall (version, title, ident, hasHaddocks) <- packages + $forall (version, title, slug, hasHaddocks) <- packages $if hasHaddocks - + Docs #{version} - #{fromMaybe title $ stripSuffix ", exclusive" title} + #{fromMaybe title $ stripSuffix ", exclusive" title}
diff --git a/templates/stackage-home.hamlet b/templates/stackage-home.hamlet index ed49275..6bb68af 100644 --- a/templates/stackage-home.hamlet +++ b/templates/stackage-home.hamlet @@ -7,28 +7,28 @@ $newline never $if hasBundle - + \Metadata - + \Bundle - + \cabal.config $if stackageHasHaddocks stackage - Haddocks + Haddocks $if isOwner

You are the owner of this snapshot. You can # - upload haddocks# + upload haddocks# .

-            remote-repo: stackage-#{ident}:@{StackageHomeR ident}
+            remote-repo: stackage-#{slug}:@{StackageHomeR slug}
     $maybe _ <- minclusive
         

What's the difference between inclusive and exclusive snapshots? diff --git a/templates/upload-haddock.hamlet b/templates/upload-haddock.hamlet index 72cfdce..b3b57ee 100644 --- a/templates/upload-haddock.hamlet +++ b/templates/upload-haddock.hamlet @@ -2,12 +2,12 @@

Upload Haddocks

- Return to snapshot + Return to snapshot $if stackageHasHaddocks

You have already uploaded Haddocks. Uploading against will delete the old contents. -
+ ^{widget}