Do uploads in background

Application.hs

@@ -45,6 +45,7 @@ import Handler.HackageViewIndex
 import Handler.HackageViewSdist
 import Handler.Aliases
 import Handler.Alias
+import Handler.Progress
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -100,6 +101,8 @@ makeFoundation conf = do
     _ <- forkIO updateLoop
 
     gen <- MWC.createSystemRandom
+    progressMap' <- newIORef mempty
+    nextProgressKey' <- newIORef 0
 
     let logger = Yesod.Core.Types.Logger loggerSet' getter
         foundation = App
@@ -113,6 +116,8 @@ makeFoundation conf = do
             , blobStore =
                 case storeConfig $ appExtra conf of
                     BSCFile root -> fileStore root
+            , progressMap = progressMap'
+            , nextProgressKey = nextProgressKey'
             }
 
     -- Perform database migration using our application's logging settings.

Foundation.hs

@@ -33,8 +33,13 @@ data App = App
     , appLogger :: Logger
     , genIO :: !MWC.GenIO
     , blobStore :: !(BlobStore StoreKey)
+    , progressMap :: !(IORef (IntMap Progress))
+    , nextProgressKey :: !(IORef Int)
     }
 
+data Progress = ProgressWorking !Text
+              | ProgressDone !Text !(Route App)
+
 instance HasBlobStore App StoreKey where
     getBlobStore = blobStore
 
@@ -56,6 +61,8 @@ instance HasHackageRoot App where
 -- explanation for this split.
 mkYesodData "App" $(parseRoutesFile "config/routes")
 
+deriving instance Show Progress
+
 type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
 
 -- Please see the documentation for the Yesod typeclass. There are a number

Handler/Progress.hs

@@ -0,0 +1,17 @@
+module Handler.Progress where
+
+import Import
+
+getProgressR :: Int -> Handler Html
+getProgressR key = do
+    app <- getYesod
+    m <- readIORef $ progressMap app
+    case lookup key m of
+        Nothing -> notFound
+        Just (ProgressWorking text) -> defaultLayout $ do
+            addHeader "Refresh" "1"
+            setTitle "Working..."
+            [whamlet|<p>#{text}|]
+        Just (ProgressDone text url) -> do
+            setMessage $ toHtml text
+            redirect url

Handler/UploadStackage.hs

@@ -1,7 +1,7 @@
 module Handler.UploadStackage where
 
 import Import hiding (catch, get)
-import System.IO.Temp (withSystemTempFile, withSystemTempDirectory)
+import System.IO.Temp (withSystemTempFile, withSystemTempDirectory, openBinaryTempFile)
 import Crypto.Hash.Conduit (sinkHash)
 import Control.Monad.Catch (MonadCatch (..))
 import Crypto.Hash (Digest, SHA1)
@@ -16,6 +16,8 @@ import Data.BlobStore
 import Filesystem (createTree)
 import Control.Monad.State.Strict (execStateT, get, put)
 import qualified Codec.Compression.GZip as GZip
+import Control.Monad.Trans.Resource (unprotect, allocate)
+import System.Directory (removeFile, getTemporaryDirectory)
 
 fileKey :: Text
 fileKey = "stackage"
@@ -33,10 +35,15 @@ putUploadStackageR = do
     mfile <- lookupFile fileKey
     case mfile of
         Nothing -> invalidArgs ["Upload missing"]
-        Just file -> withSystemTempFile "upload-stackage." $ \fp handleOut -> do
+        Just file -> do
+            tempDir <- liftIO getTemporaryDirectory
+            (releaseKey, (fp, handleOut)) <- allocate
+                (openBinaryTempFile tempDir "upload-stackage.")
+                (\(fp, h) -> hClose h `finally` removeFile fp)
             digest <- fileSource file
                    $$ getZipSink (ZipSink sinkHash <* ZipSink (ungzip =$ sinkHandle handleOut))
             liftIO $ hClose handleOut
+
             let bs = toBytes (digest :: Digest SHA1)
                 ident = PackageSetIdent $ decodeUtf8 $ B16.encode bs
 
@@ -44,6 +51,18 @@ putUploadStackageR = do
             mstackage <- runDB $ getBy $ UniqueStackage ident
             when (isJust mstackage) $ invalidArgs ["Stackage already exists"]
 
+            app <- getYesod
+            key <- atomicModifyIORef (nextProgressKey app) $ \i -> (i + 1, i + 1)
+            let updateHelper :: MonadBase IO m => Progress -> m ()
+                updateHelper p = atomicModifyIORef (progressMap app) $ \m -> (insertMap key p m, ())
+                update :: MonadBase IO m => Text -> m ()
+                update msg = updateHelper (ProgressWorking msg)
+                done msg url = updateHelper (ProgressDone msg url)
+                onExc e = done ("Exception occurred: " ++ tshow e) ProfileR
+
+            update "Starting"
+
+            forkHandler onExc $ do
                 now <- liftIO getCurrentTime
                 let initial = Stackage
                         { stackageUser = uid
@@ -56,7 +75,7 @@ putUploadStackageR = do
                 -- Evil lazy I/O thanks to tar package
                 lbs <- readFile $ fpFromString fp
                 withSystemTempDirectory "build00index." $ \dir -> do
-                LoopState _ stackage files _ <- execStateT (loop (Tar.read lbs)) LoopState
+                    LoopState _ stackage files _ <- execStateT (loop update (Tar.read lbs)) LoopState
                         { lsRoot = fpFromString dir
                         , lsStackage = initial
                         , lsFiles = mempty
@@ -66,16 +85,19 @@ putUploadStackageR = do
                     let indexLBS = GZip.compress $ Tar.write entries
                     sourceLazy indexLBS $$ storeWrite (CabalIndex ident)
                     runDB $ insert stackage
-                setMessage "Stackage created"
-                redirect $ StackageHomeR ident
-  where
-    loop Tar.Done = return ()
-    loop (Tar.Fail e) = throwM e
-    loop (Tar.Next entry entries) = do
-        addEntry entry
-        loop entries
 
-    addEntry entry = do
+                    done "Stackage created" $ StackageHomeR ident
+
+            redirect $ ProgressR key
+  where
+    loop _ Tar.Done = return ()
+    loop _ (Tar.Fail e) = throwM e
+    loop update (Tar.Next entry entries) = do
+        addEntry update entry
+        loop update entries
+
+    addEntry update entry = do
+        update $ "Processing file: " ++ pack (Tar.entryPath entry)
         case Tar.entryContent entry of
             Tar.NormalFile lbs _ ->
                 case filename $ fpFromString $ Tar.entryPath entry of
@@ -95,6 +117,12 @@ putUploadStackageR = do
                         case parseName line of
                             Just (name, version) -> do
                                 $logDebug $ "hackage: " ++ tshow (name, version)
+                                update $ concat
+                                    [ "Adding Hackage package: "
+                                    , toPathPiece name
+                                    , "-"
+                                    , toPathPiece version
+                                    ]
                                 msrc <- storeRead (HackageCabal name version)
                                 case msrc of
                                     Nothing -> invalidArgs ["Unknown Hackage name/version: " ++ tshow (name, version)]

config/routes

@@ -16,3 +16,4 @@
 /hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET
 /aliases AliasesR PUT
 /alias/#Slug/#Slug/*Texts AliasR
+/progress/#Int ProgressR GET

stackage-server.cabal

@@ -36,6 +36,7 @@ library
                      Handler.HackageViewSdist
                      Handler.Aliases
                      Handler.Alias
+                     Handler.Progress
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT