diff --git a/Application.hs b/Application.hs index 222d9e1..4c508cf 100644 --- a/Application.hs +++ b/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" diff --git a/Foundation.hs b/Foundation.hs index 0e7389e..9120f6c 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/Progress.hs b/Handler/Progress.hs index fcbde35..a59f85b 100644 --- a/Handler/Progress.hs +++ b/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 - m <- readIORef $ progressMap app - case lookup key m of - Nothing -> notFound - Just (ProgressWorking text) -> defaultLayout $ do + UploadProgress text mdest <- runDB $ get404 key + case mdest of + Nothing -> defaultLayout $ do addHeader "Refresh" "1" setTitle "Working..." [whamlet|
#{text}|] - Just (ProgressDone text url) -> do + Just url -> do setMessage $ toHtml text redirect url diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index f997640..f1a8328 100644 --- a/Handler/UploadStackage.hs +++ b/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 updateHelper :: MonadBase IO m => Progress -> m () - updateHelper p = atomicModifyIORef (progressMap app) $ \m -> (insertMap key p m, ()) + let initProgress = UploadProgress "Upload starting" Nothing + key <- runDB $ insert initProgress + + -- 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) - done msg url = updateHelper (ProgressDone msg url) + update msg = updateHelper (UploadProgress msg Nothing) + 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 - done "Error creating index file" ProfileR + else done "Error creating index file" ProfileR addHeader "X-Stackage-Ident" $ toPathPiece ident redirect $ ProgressR key diff --git a/config/models b/config/models index 177b3d2..e4ddaf8 100644 --- a/config/models +++ b/config/models @@ -133,3 +133,7 @@ Suggested package PackageName insteadOf PackageName UniqueSuggested package insteadOf + +UploadProgress + message Text + dest Text Maybe diff --git a/config/routes b/config/routes index bcb98a4..18a1a3e 100644 --- a/config/routes +++ b/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 diff --git a/stackage-server.cabal b/stackage-server.cabal index 22b405e..805ead4 100644 --- a/stackage-server.cabal +++ b/stackage-server.cabal @@ -159,6 +159,7 @@ library , spoon , deepseq , deepseq-generics + , auto-update executable stackage-server if flag(library-only)