haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-02-02 14:20:25 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Slightly improved logging

Browse Source
This commit is contained in:
Michael Snoyman 2014-11-17 14:22:06 +02:00
parent 48185bdf0e
commit 17c44751be
3 changed files with 14 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Application.hs
View File

@ -8,7 +8,7 @@ module Application
import qualified Aws import qualified Aws
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Monad.Logger (runLoggingT, LoggingT, runStdoutLoggingT) import Control.Monad.Logger (runLoggingT, LoggingT, runStdoutLoggingT, defaultLogStr, LogLevel (LevelDebug))
import Control.Monad.Reader (MonadReader (..)) import Control.Monad.Reader (MonadReader (..))
import Control.Monad.Reader (runReaderT, ReaderT) import Control.Monad.Reader (runReaderT, ReaderT)
import Control.Monad.Trans.Control import Control.Monad.Trans.Control
@ -220,7 +220,7 @@ cabalLoaderMain = do
manager <- newManager manager <- newManager
bs <- loadBlobStore manager conf bs <- loadBlobStore manager conf
hSetBuffering stdout LineBuffering hSetBuffering stdout LineBuffering
runStdoutLoggingT $ appLoadCabalFiles flip runLoggingT logFunc $ appLoadCabalFiles
CabalLoaderEnv CabalLoaderEnv
{ cleSettings = conf { cleSettings = conf
, cleBlobStore = bs , cleBlobStore = bs
@ -228,6 +228,10 @@ cabalLoaderMain = do
} }
dbconf dbconf
pool pool
where
logFunc loc src level str
| level > LevelDebug = hPutStrLn stdout $ fromLogStr $ defaultLogStr loc src level str
| otherwise = return ()
appLoadCabalFiles :: ( PersistConfig c appLoadCabalFiles :: ( PersistConfig c
, PersistConfigBackend c ~ SqlPersistT , PersistConfigBackend c ~ SqlPersistT
@ -254,7 +258,9 @@ appLoadCabalFiles env dbconf p = do
, m E.^. MetadataHash , m E.^. MetadataHash
) )
UploadState uploadHistory newUploads _ newMD <- loadCabalFiles uploadHistory0 metadata0 UploadState uploadHistory newUploads _ newMD <- loadCabalFiles uploadHistory0 metadata0
$logInfo "Inserting to new uploads"
runDB' $ mapM_ insert_ newUploads runDB' $ mapM_ insert_ newUploads
$logInfo "Updating metadatas"
runDB' $ forM_ newMD $ \x -> do runDB' $ forM_ newMD $ \x -> do
deleteBy $ UniqueMetadata $ metadataName x deleteBy $ UniqueMetadata $ metadataName x
insert_ x insert_ x

6
Data/Hackage.hs
View File

@ -75,7 +75,11 @@ loadCabalFiles uploadHistory0 metadata0 = (>>= runUploadState) $ flip execStateT
liftIO $ hClose handleOut liftIO $ hClose handleOut
withBinaryFile tempIndex ReadMode $ \handleIn -> do withBinaryFile tempIndex ReadMode $ \handleIn -> do
bss <- lazyConsume $ sourceHandle handleIn $= ungzip bss <- lazyConsume $ sourceHandle handleIn $= ungzip
tarSource (Tar.read $ fromChunks bss) $$ parMapMC 32 go =$ sinkNull -- FIXME parMapM_C tarSource (Tar.read $ fromChunks bss)
$$ parMapMC 32 go
=$ scanlC (\x _ -> x + 1) 0
=$ filterC ((== 0) . (`mod` 1000))
=$ mapM_C (\i -> $logInfo $ "Processing cabal file #" ++ tshow i)
where where
metadata1 = flip fmap metadata0 $ \(v, h) -> MetaSig metadata1 = flip fmap metadata0 $ \(v, h) -> MetaSig
v v

1
stackage-server.cabal
View File

@ -142,6 +142,7 @@ library
, unix , unix
, markdown , markdown
, formatting , formatting
, blaze-html
executable stackage-server executable stackage-server
if flag(library-only) if flag(library-only)