Some tweaks for automated doc uploads

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.

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)

Handler/UploadStackage.hs

@@ -32,17 +32,7 @@ getUploadStackageR = do
 
 putUploadStackageR :: Handler TypedContent
 putUploadStackageR = do
-    mtoken <- lookupHeader "authorization"
+    uid <- requireAuthIdOrToken
-    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
     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 ()

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