From 4cbf301051a9faa345d8ef098e89cad1aa5d9187 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 20 Oct 2014 15:43:23 +0300
Subject: [PATCH] Some tweaks for automated doc uploads

---
 Foundation.hs             |  2 +-
 Handler/Haddock.hs        |  4 ++--
 Handler/UploadStackage.hs | 13 ++-----------
 Import.hs                 | 15 +++++++++++++++
 4 files changed, 20 insertions(+), 14 deletions(-)

diff --git a/Foundation.hs b/Foundation.hs
index 99bcdf0..4af727a 100644
--- a/Foundation.hs
+++ b/Foundation.hs
@@ -142,7 +142,7 @@ instance Yesod App where
     makeLogger = return . appLogger
 
     maximumContentLength _ (Just UploadStackageR) = Just 50000000
-    maximumContentLength _ (Just UploadHaddockR{}) = Just 50000000
+    maximumContentLength _ (Just UploadHaddockR{}) = Just 100000000
     maximumContentLength _ _ = Just 2000000
 
 -- How to run database actions.
diff --git a/Handler/Haddock.hs b/Handler/Haddock.hs
index 9028d67..fff8035 100644
--- a/Handler/Haddock.hs
+++ b/Handler/Haddock.hs
@@ -18,10 +18,10 @@ form = renderDivs $ areq fileField "tarball containing docs"
 
 getUploadHaddockR, putUploadHaddockR :: PackageSetIdent -> Handler Html
 getUploadHaddockR ident = do
-    uid <- requireAuthId
+    uid <- requireAuthIdOrToken
     Entity sid Stackage {..} <- runDB $ getBy404 $ UniqueStackage ident
     unless (uid == stackageUser) $ permissionDenied "You do not control this snapshot"
-    ((res, widget), enctype) <- runFormPost form
+    ((res, widget), enctype) <- runFormPostNoToken form
     case res of
         FormSuccess fileInfo -> do
             fileSource fileInfo $$ storeWrite (HaddockBundle ident)
diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs
index 0292265..cad802e 100644
--- a/Handler/UploadStackage.hs
+++ b/Handler/UploadStackage.hs
@@ -32,17 +32,7 @@ getUploadStackageR = do
 
 putUploadStackageR :: Handler TypedContent
 putUploadStackageR = do
-    mtoken <- lookupHeader "authorization"
-    uid <- case decodeUtf8 <$> mtoken of
-        Nothing -> requireAuthId
-        Just token -> do
-            case mkSlug token of
-                Nothing -> invalidArgs ["Invalid token: " ++ token]
-                Just token' -> do
-                    muser <- runDB $ getBy $ UniqueToken token'
-                    case muser of
-                        Nothing -> invalidArgs ["Unknown token: " ++ token]
-                        Just (Entity uid _) -> return uid
+    uid <- requireAuthIdOrToken
     mfile <- lookupFile fileKey
     case mfile of
         Nothing -> invalidArgs ["Upload missing"]
@@ -131,6 +121,7 @@ putUploadStackageR = do
                             else do
                                 done "Error creating index file" ProfileR
 
+            addHeader "X-Stackage-Ident" $ toPathPiece ident
             redirect $ ProgressR key
   where
     loop _ Tar.Done = return ()
diff --git a/Import.hs b/Import.hs
index 14959dd..b2570d4 100644
--- a/Import.hs
+++ b/Import.hs
@@ -10,8 +10,23 @@ import Settings.Development as Import
 import Settings.StaticFiles as Import
 import Types as Import
 import Yesod.Auth as Import
+import Data.Slug (mkSlug)
 
 getHaddockDir :: PackageSetIdent -> Handler FilePath
 getHaddockDir ident = do
     master <- getYesod
     return $ haddockRootDir master </> fpFromText (toPathPiece ident)
+
+requireAuthIdOrToken :: Handler UserId
+requireAuthIdOrToken = do
+    mtoken <- lookupHeader "authorization"
+    case decodeUtf8 <$> mtoken of
+        Nothing -> requireAuthId
+        Just token -> do
+            case mkSlug token of
+                Nothing -> invalidArgs ["Invalid token: " ++ token]
+                Just token' -> do
+                    muser <- runDB $ getBy $ UniqueToken token'
+                    case muser of
+                        Nothing -> invalidArgs ["Unknown token: " ++ token]
+                        Just (Entity uid _) -> return uid