Fix upload-haddock to work with old-style PackageSetIdents

Handler/Haddock.hs

@@ -23,15 +23,17 @@ form = renderDivs $ areq fileField "tarball containing docs"
     { fsName = Just "tarball"
     } Nothing
 
-getUploadHaddockR, putUploadHaddockR :: SnapSlug -> Handler Html
+getUploadHaddockR, putUploadHaddockR :: Text -> Handler Html
 getUploadHaddockR slug0 = do
     uid <- requireAuthIdOrToken
     Entity sid Stackage {..} <- runDB $ do
         -- Provide fallback for old URLs
-        ment <- getBy $ UniqueSnapshot slug0
+        ment <- getBy $ UniqueStackage $ PackageSetIdent slug0
         case ment of
             Just ent -> return ent
-            Nothing -> getBy404 $ UniqueStackage $ PackageSetIdent $ toPathPiece slug0
+            Nothing -> do
+                slug <- maybe notFound return $ fromPathPiece slug0
+                getBy404 $ UniqueSnapshot slug
     let ident = stackageIdent
         slug = stackageSlug
     unless (uid == stackageUser) $ permissionDenied "You do not control this snapshot"

config/routes

@@ -10,7 +10,7 @@
 /email/#EmailId EmailR DELETE
 /reset-token ResetTokenR POST
 /upload UploadStackageR GET PUT
-/upload-haddock/#SnapSlug UploadHaddockR GET PUT
+/upload-haddock/#Text UploadHaddockR GET PUT
 
 /stackage/#PackageSetIdent/*Texts OldStackageR GET
 

templates/stackage-home.hamlet

@@ -24,7 +24,7 @@ $newline never
     $if isOwner
         <p>
             You are the owner of this snapshot. You can #
-            <a href=@{UploadHaddockR slug}>upload haddocks#
+            <a href=@{UploadHaddockR $ toPathPiece slug}>upload haddocks#
             .
     <p>
         <pre>

templates/upload-haddock.hamlet

@@ -7,7 +7,7 @@
     $if stackageHasHaddocks
         <div .alert .alert-warning>You have already uploaded Haddocks. Uploading against will delete the old contents.
 
-    <form method=POST action=@{UploadHaddockR slug}?_method=PUT enctype=#{enctype}>
+    <form method=POST action=@{UploadHaddockR $ toPathPiece slug}?_method=PUT enctype=#{enctype}>
         ^{widget}
         <div>
             <button .btn>Upload