haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-30 04:40:24 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Less lazy I/O (use tar command line tool)

Browse Source
This commit is contained in:
Michael Snoyman 2014-05-12 08:48:13 +03:00
parent 68f7abff47
commit 7e3abca045
4 changed files with 21 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Application.hs
View File

@ -134,7 +134,7 @@ makeFoundation conf = do
runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p runDB' = runResourceT . flip (Database.Persist.runPool dbconf) p
uploadHistory0 <- runDB' $ selectSource [] [] $$ sinkUploadHistory uploadHistory0 <- runDB' $ selectSource [] [] $$ sinkUploadHistory
UploadState uploadHistory newUploads <- loadCabalFiles uploadHistory0 UploadState uploadHistory newUploads <- loadCabalFiles uploadHistory0
runDB' $ mapM_ insert newUploads runDB' $ mapM_ insert_ newUploads
let views = let views =
[ ("pvp", viewPVP uploadHistory) [ ("pvp", viewPVP uploadHistory)
, ("no-bounds", viewNoBounds) , ("no-bounds", viewNoBounds)

2
Handler/Aliases.hs
View File

@ -10,7 +10,7 @@ putAliasesR = do
aliases <- mapM (parseAlias uid) $ lines aliasesText aliases <- mapM (parseAlias uid) $ lines aliasesText
runDB $ do runDB $ do
deleteWhere [AliasUser ==. uid] deleteWhere [AliasUser ==. uid]
mapM_ insert aliases mapM_ insert_ aliases
setMessage "Aliases updated" setMessage "Aliases updated"
redirect ProfileR redirect ProfileR

22
Handler/UploadStackage.hs
View File

@ -18,6 +18,8 @@ import Control.Monad.State.Strict (execStateT, get, put)
import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.GZip as GZip
import Control.Monad.Trans.Resource (unprotect, allocate) import Control.Monad.Trans.Resource (unprotect, allocate)
import System.Directory (removeFile, getTemporaryDirectory) import System.Directory (removeFile, getTemporaryDirectory)
import System.Process (runProcess, waitForProcess)
import System.Exit (ExitCode (ExitSuccess))
fileKey :: Text fileKey :: Text
fileKey = "stackage" fileKey = "stackage"
@ -81,12 +83,22 @@ putUploadStackageR = do
, lsFiles = mempty , lsFiles = mempty
, lsIdent = ident , lsIdent = ident
} }
entries <- liftIO $ Tar.pack dir $ map fpToString $ setToList files withSystemTempFile "newindex" $ \fp h -> do
let indexLBS = GZip.compress $ Tar.write entries ec <- liftIO $ do
sourceLazy indexLBS $$ storeWrite (CabalIndex ident) hClose h
runDB $ insert stackage let args = "cfz"
: fp
: map fpToString (setToList files)
ph <- runProcess "tar" args (Just dir) Nothing Nothing Nothing Nothing
waitForProcess ph
if ec == ExitSuccess
then do
sourceFile (fpFromString fp) $$ storeWrite (CabalIndex ident)
runDB $ insert stackage
done "Stackage created" $ StackageHomeR ident done "Stackage created" $ StackageHomeR ident
else do
done "Error creating index file" ProfileR
redirect $ ProgressR key redirect $ ProgressR key
where where

3
stackage-server.cabal
View File

@ -93,7 +93,7 @@ library
, fast-logger >= 2.1.4 && < 2.2 , fast-logger >= 2.1.4 && < 2.2
, wai >= 2.1 && < 2.2 , wai >= 2.1 && < 2.2
, wai-logger >= 2.1 && < 2.2 , wai-logger >= 2.1 && < 2.2
, classy-prelude-yesod >= 0.9 && < 0.9.1 , classy-prelude-yesod >= 0.9.2 && < 0.9.3
, mwc-random >= 0.13 && < 0.14 , mwc-random >= 0.13 && < 0.14
, mtl >= 2.1 && < 2.2 , mtl >= 2.1 && < 2.2
, blaze-markup >= 0.6 && < 0.7 , blaze-markup >= 0.6 && < 0.7
@ -119,6 +119,7 @@ library
, lifted-base , lifted-base
, mono-traversable , mono-traversable
, time , time
, process
executable stackage-server executable stackage-server
if flag(library-only) if flag(library-only)