Better URLs #37

URLs now look like /snapshot/2014-11-23-7.8hp-exc and similar.
2026-01-12 12:18:29 +01:00 · 2014-11-23 12:36:20 +02:00 · 2014-11-23 12:36:20 +02:00 · a8911dbb3b
commit a8911dbb3b
parent e588f9e45c
17 changed files with 185 additions and 59 deletions
--- 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"
@ -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)
--- 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
--- 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
--- 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"
--- 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 .
--- 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
--- 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
--- 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)
--- 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
--- 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 <-
--- 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
--- 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.
--- 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
--- 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
--- a/templates/package.hamlet
+++ b/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>
--- a/templates/stackage-home.hamlet
+++ b/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>
--- a/templates/upload-haddock.hamlet
+++ b/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