Better URLs #37

URLs now look like /snapshot/2014-11-23-7.8hp-exc and similar.

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
+    runResourceT $
-        (Database.Persist.runPool dbconf (runMigration migrateAll) p)
+        flip runReaderT gen $
-        (messageLoggerSource foundation logger)
+        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"
@@ -315,3 +320,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)

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

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

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, putUploadHaddockR :: SnapSlug -> Handler Html
-getUploadHaddockR ident = do
+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 :: SnapSlug -> [Text] -> Handler ()
-getHaddockR ident rest = do
+getHaddockR slug rest = do
-    sanitize $ toPathPiece ident
+    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"

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
+                                  user ^. UserHandle ==. val fpcomplete &&.
-                               return (alias ^. AliasTarget))
+                                  alias ^. AliasTarget ==. stackage ^. StackageIdent
+                               return (stackage ^. StackageSlug))
         where selecting =
                   fmap (fmap unValue . listToMaybe) .
                   runDB .

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

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

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 :: SnapSlug -> Handler Html
-getStackageHomeR ident = do
+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 :: SnapSlug -> Handler TypedContent
-getStackageMetadataR ident = do
+getStackageMetadataR slug = do
-    Entity sid _ <- runDB $ getBy404 $ UniqueStackage ident
+    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 :: SnapSlug -> Handler TypedContent
-getStackageCabalConfigR ident = do
+getStackageCabalConfigR slug = do
-    Entity sid _ <- runDB $ getBy404 $ UniqueStackage ident
+    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)

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 :: SnapSlug -> Handler TypedContent
-getStackageIndexR ident = do
+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 :: SnapSlug -> Handler TypedContent
-getStackageBundleR ident = do
+getStackageBundleR slug = do
+    Entity _ stackage <- runDB $ getBy404 $ UniqueSnapshot slug
+    let ident = stackageIdent stackage
     msrc <- storeRead $ SnapshotBundle ident
     case msrc of
         Nothing -> notFound

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 :: SnapSlug -> PackageNameVersion -> Handler TypedContent
-getStackageSdistR ident (PackageNameVersion name version) = do
+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 <-

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
+                                slug <- runDB $ do
-                                    sid <- insert stackage
+                                    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

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.

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

config/routes

@@ -10,20 +10,24 @@
 /email/#EmailId EmailR DELETE
 /reset-token ResetTokenR POST
 /upload UploadStackageR GET PUT
-/upload-haddock/#PackageSetIdent UploadHaddockR GET PUT
+/upload-haddock/#SnapSlug UploadHaddockR GET PUT
-/stackage/#PackageSetIdent StackageHomeR GET
+
-/stackage/#PackageSetIdent/metadata StackageMetadataR GET
+/stackage/#PackageSetIdent/*Texts OldStackageR GET
-/stackage/#PackageSetIdent/cabal.config StackageCabalConfigR GET
+
-/stackage/#PackageSetIdent/00-index.tar.gz StackageIndexR GET
+/snapshot/#SnapSlug StackageHomeR GET
-/stackage/#PackageSetIdent/bundle StackageBundleR GET
+/snapshot/#SnapSlug/metadata StackageMetadataR GET
-/stackage/#PackageSetIdent/package/#PackageNameVersion StackageSdistR 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

templates/package.hamlet

@@ -111,16 +111,16 @@ $newline never
                            Package
                        <th>
                            Snapshot
-                   $forall (version, title, ident, hasHaddocks) <- packages
+                   $forall (version, title, slug, hasHaddocks) <- packages
                        <tr>
                            <td>
                                $if hasHaddocks
-                                 <a href=@{haddocksLink ident version}>
+                                 <a href=@{haddocksLink slug version}>
                                      Docs
                            <td>
                                #{version}
                            <td>
-                               <a href=@{StackageHomeR ident}>#{fromMaybe title $ stripSuffix ", exclusive" title}
+                               <a href=@{StackageHomeR slug}>#{fromMaybe title $ stripSuffix ", exclusive" title}
 
 <div .markdown-container .readme-container>
     <div .container>

templates/stackage-home.hamlet

@@ -7,28 +7,28 @@ $newline never
         $if hasBundle
            <span .separator>
            <span>
-               <a href=@{StackageMetadataR ident} title="View metadata on this snapshot, such as package versions">
+               <a href=@{StackageMetadataR slug} title="View metadata on this snapshot, such as package versions">
                    \Metadata
            <span .separator>
            <span>
-               <a href=@{StackageBundleR ident} title="This is useful for making modifications to an existing snapshot">
+               <a href=@{StackageBundleR slug} title="This is useful for making modifications to an existing snapshot">
                    \Bundle
            <span .separator>
            <span>
-               <a href=@{StackageCabalConfigR ident} title="If you want to stick with upstream Hackage but get a stable package set">
+               <a href=@{StackageCabalConfigR slug} title="If you want to stick with upstream Hackage but get a stable package set">
                    \cabal.config
            $if stackageHasHaddocks stackage
                <span .separator>
                <span>
-                   <a href=@{HaddockR ident []}>Haddocks
+                   <a href=@{HaddockR slug []}>Haddocks
     $if isOwner
         <p>
             You are the owner of this snapshot. You can #
-            <a href=@{UploadHaddockR ident}>upload haddocks#
+            <a href=@{UploadHaddockR slug}>upload haddocks#
             .
     <p>
         <pre>
-            remote-repo: stackage-#{ident}:@{StackageHomeR ident}
+            remote-repo: stackage-#{slug}:@{StackageHomeR slug}
     $maybe _ <- minclusive
         <p>
             <a href="https://github.com/fpco/stackage/wiki/Stackage-Server-FAQ#whats-the-difference-between-inclusive-and-exclusive-snapshots">What's the difference between inclusive and exclusive snapshots?</a>

templates/upload-haddock.hamlet

@@ -2,12 +2,12 @@
     <h1>Upload Haddocks
 
     <p>
-        <a href=@{StackageHomeR ident}>Return to snapshot
+        <a href=@{StackageHomeR slug}>Return to snapshot
 
     $if stackageHasHaddocks
         <div .alert .alert-warning>You have already uploaded Haddocks. Uploading against will delete the old contents.
 
-    <form method=POST action=@{UploadHaddockR ident}?_method=PUT enctype=#{enctype}>
+    <form method=POST action=@{UploadHaddockR slug}?_method=PUT enctype=#{enctype}>
         ^{widget}
         <div>
             <button .btn>Upload