Store progress info in database (fixes #78)

Application.hs

@@ -162,8 +162,6 @@ makeFoundation useEcho conf = do
     _ <- forkIO updateLoop
 
     gen <- MWC.createSystemRandom
-    progressMap' <- newIORef mempty
-    nextProgressKey' <- newIORef 0
 
     blobStore' <- loadBlobStore manager conf
 
@@ -198,8 +196,6 @@ makeFoundation useEcho conf = do
             , appLogger = logger
             , genIO = gen
             , blobStore = blobStore'
-            , progressMap = progressMap'
-            , nextProgressKey = nextProgressKey'
             , haddockRootDir = haddockRootDir'
             , appDocUnpacker = docUnpacker
             , widgetCache = widgetCache'
@@ -285,8 +281,6 @@ cabalLoaderMain = do
             , appLogger = error "appLogger"
             , genIO = error "genIO"
             , blobStore = bs
-            , progressMap = error "progressMap"
-            , nextProgressKey = error "nextProgressKey"
             , haddockRootDir = error "haddockRootDir"
             , appDocUnpacker = error "appDocUnpacker"
             , widgetCache = error "widgetCache"

Foundation.hs

@@ -37,8 +37,6 @@ data App = App
     , appLogger :: Logger
     , genIO :: MWC.GenIO
     , blobStore :: BlobStore StoreKey
-    , progressMap :: IORef (IntMap Progress)
-    , nextProgressKey :: IORef Int
     , haddockRootDir :: FilePath
     , appDocUnpacker :: DocUnpacker
     -- ^ We have a dedicated thread so that (1) we don't try to unpack too many

Handler/Progress.hs

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

Handler/UploadStackage.hs

@@ -20,6 +20,7 @@ import System.Directory (removeFile, getTemporaryDirectory)
 import System.Process (runProcess, waitForProcess)
 import System.Exit (ExitCode (ExitSuccess))
 import Data.Slug (mkSlug, SnapSlug (..), safeMakeSlug, unSlug)
+import Control.Debounce
 
 fileKey :: Text
 fileKey = "stackage"
@@ -78,12 +79,28 @@ putUploadStackageR = do
             when (isJust mstackage) $ invalidArgs ["Stackage already exists"]
 
             app <- getYesod
-            key <- atomicModifyIORef (nextProgressKey app) $ \i -> (i + 1, i + 1)
+            let initProgress = UploadProgress "Upload starting" Nothing
-            let updateHelper :: MonadBase IO m => Progress -> m ()
+            key <- runDB $ insert initProgress
-                updateHelper p = atomicModifyIORef (progressMap app) $ \m -> (insertMap key p m, ())
+
+            -- We don't want to be writing progress updates to the database too
+            -- frequently, so let's just do it once per second at most.
+            -- Debounce to the rescue!
+            statusRef <- newIORef initProgress
+            writeToDB <- liftIO $ mkDebounce defaultDebounceSettings
+                { debounceAction = do
+                    up <- readIORef statusRef
+                    runPool (persistConfig app) (replace key up) (connPool app)
+                }
+
+            let updateHelper :: MonadBase IO m => UploadProgress -> m ()
+                updateHelper p = do
+                    writeIORef statusRef p
+                    liftBase writeToDB
                 update :: MonadBase IO m => Text -> m ()
-                update msg = updateHelper (ProgressWorking msg)
+                update msg = updateHelper (UploadProgress msg Nothing)
-                done msg url = updateHelper (ProgressDone msg url)
+                done msg route = do
+                    render <- getUrlRender
+                    updateHelper (UploadProgress msg $ Just $ render route)
                 onExc e = done ("Exception occurred: " ++ tshow e) ProfileR
                 setAlias = do
                     forM_ (malias >>= mkSlug) $ \alias -> do
@@ -166,8 +183,7 @@ putUploadStackageR = do
                                     return slug
 
                                 done "Stackage created" $ SnapshotR slug StackageHomeR
-                            else do
+                            else done "Error creating index file" ProfileR
-                                done "Error creating index file" ProfileR
 
             addHeader "X-Stackage-Ident" $ toPathPiece ident
             redirect $ ProgressR key

config/models

@@ -133,3 +133,7 @@ Suggested
     package PackageName
     insteadOf PackageName
     UniqueSuggested package insteadOf
+
+UploadProgress
+    message Text
+    dest Text Maybe

config/routes

@@ -31,7 +31,7 @@
 /hackage-view/#HackageView/package/#PackageNameVersion HackageViewSdistR GET
 /aliases AliasesR PUT
 /alias/#Slug/#Slug/*Texts AliasR
-/progress/#Int ProgressR GET
+/progress/#UploadProgressId ProgressR GET
 /system SystemR GET
 /haddock/#SnapSlug/*Texts HaddockR GET
 /package/#PackageName PackageR GET

stackage-server.cabal

@@ -159,6 +159,7 @@ library
                  , spoon
                  , deepseq
                  , deepseq-generics
+                 , auto-update
 
 executable         stackage-server
     if flag(library-only)