diff --git a/Application.hs b/Application.hs index 3046e2b..8d2850f 100644 --- a/Application.hs +++ b/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. diff --git a/Foundation.hs b/Foundation.hs index dd23d2b..ad22829 100644 --- a/Foundation.hs +++ b/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 diff --git a/Handler/Progress.hs b/Handler/Progress.hs new file mode 100644 index 0000000..fcbde35 --- /dev/null +++ b/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|

#{text}|] + Just (ProgressDone text url) -> do + setMessage $ toHtml text + redirect url diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index c8d3583..c43202f 100644 --- a/Handler/UploadStackage.hs +++ b/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,38 +51,53 @@ putUploadStackageR = do mstackage <- runDB $ getBy $ UniqueStackage ident when (isJust mstackage) $ invalidArgs ["Stackage already exists"] - now <- liftIO getCurrentTime - let initial = Stackage - { stackageUser = uid - , stackageIdent = ident - , stackageUploaded = now - , stackageTitle = "Untitled Stackage" - , stackageDesc = "No description provided" - } + 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 - -- 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 - { lsRoot = fpFromString dir - , lsStackage = initial - , lsFiles = mempty - , lsIdent = ident - } - entries <- liftIO $ Tar.pack dir $ map fpToString $ setToList files - let indexLBS = GZip.compress $ Tar.write entries - sourceLazy indexLBS $$ storeWrite (CabalIndex ident) - runDB $ insert stackage - setMessage "Stackage created" - redirect $ StackageHomeR ident + update "Starting" + + forkHandler onExc $ do + now <- liftIO getCurrentTime + let initial = Stackage + { stackageUser = uid + , stackageIdent = ident + , stackageUploaded = now + , stackageTitle = "Untitled Stackage" + , stackageDesc = "No description provided" + } + + -- Evil lazy I/O thanks to tar package + lbs <- readFile $ fpFromString fp + withSystemTempDirectory "build00index." $ \dir -> do + LoopState _ stackage files _ <- execStateT (loop update (Tar.read lbs)) LoopState + { lsRoot = fpFromString dir + , lsStackage = initial + , lsFiles = mempty + , lsIdent = ident + } + entries <- liftIO $ Tar.pack dir $ map fpToString $ setToList files + let indexLBS = GZip.compress $ Tar.write entries + sourceLazy indexLBS $$ storeWrite (CabalIndex ident) + runDB $ insert stackage + + done "Stackage created" $ StackageHomeR ident + + redirect $ ProgressR key where - loop Tar.Done = return () - loop (Tar.Fail e) = throwM e - loop (Tar.Next entry entries) = do - addEntry entry - loop entries + loop _ Tar.Done = return () + loop _ (Tar.Fail e) = throwM e + loop update (Tar.Next entry entries) = do + addEntry update entry + loop update entries - addEntry entry = do + 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)] diff --git a/config/routes b/config/routes index 739e02b..0b31b81 100644 --- a/config/routes +++ b/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 diff --git a/stackage-server.cabal b/stackage-server.cabal index a6bbd9a..11840f8 100644 --- a/stackage-server.cabal +++ b/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