From 431eb45a94b3b5beac101820e5b5a2c8564eaf89 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Nov 2018 19:11:28 +0100 Subject: [PATCH] Log to file during tests --- .gitignore | 3 ++- config/settings.yml | 8 +++--- config/test-settings.yml | 15 +++++------ src/Application.hs | 54 +++++++++++++++++++++++++++---------- src/Foundation.hs | 8 +++--- src/Model/Migration.hs | 6 ++--- src/Settings.hs | 16 +++++++++-- test/Database.hs | 2 ++ test/Handler/ProfileSpec.hs | 4 +-- test/TestImport.hs | 3 ++- 10 files changed, 81 insertions(+), 38 deletions(-) diff --git a/.gitignore b/.gitignore index bce03bdeb..b85a1c848 100644 --- a/.gitignore +++ b/.gitignore @@ -30,4 +30,5 @@ src/Handler/Course.SnapCustom.hs /instance .stack-work-* .directory -tags \ No newline at end of file +tags +test.log \ No newline at end of file diff --git a/config/settings.yml b/config/settings.yml index 60c1f2c33..f3243a773 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -29,9 +29,11 @@ notification-expiration: 259201 session-timeout: 7200 log-settings: - log-detailed: "_env:DETAILED_LOGGING:false" - log-all: "_env:LOG_ALL:false" - log-minimum-level: "_env:LOGLEVEL:warn" + detailed: "_env:DETAILED_LOGGING:false" + all: "_env:LOG_ALL:false" + minimum-level: "_env:LOGLEVEL:warn" + destination: "_env:LOGDEST:stderr" + # Debugging auth-dummy-login: "_env:DUMMY_LOGIN:false" diff --git a/config/test-settings.yml b/config/test-settings.yml index c6e5bf360..23f59aed5 100644 --- a/config/test-settings.yml +++ b/config/test-settings.yml @@ -1,11 +1,10 @@ database: - # NOTE: By design, this setting prevents the PGDATABASE environment variable - # from affecting test runs, so that we don't accidentally affect the - # production database during testing. If you're not concerned about that and - # would like to have environment variable overrides, you could instead use - # something like: - # - # database: "_env:PGDATABASE:uniworx_test" - database: uniworx_test + database: "_env:PGDATABASE_TEST:uniworx_test" + +log-settings: + detailed: true + all: true + minimum-level: "debug" + destination: "test.log" auth-dummy-login: true diff --git a/src/Application.hs b/src/Application.hs index e1fbfa575..b1f17147b 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -30,8 +30,9 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (..), OutputFormat (..), destination, mkRequestLogger, outputFormat) -import System.Log.FastLogger (defaultBufSize, newStderrLoggerSet, - toLogStr) +import System.Log.FastLogger ( defaultBufSize, newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet + , toLogStr, rmLoggerSet + ) import qualified Data.Map.Strict as Map @@ -61,7 +62,7 @@ import qualified Yesod.Core.Types as Yesod (Logger(..)) import qualified Data.HashMap.Strict as HashMap -import Control.Lens ((&)) +import Control.Lens import Data.Proxy @@ -100,10 +101,30 @@ makeFoundation appSettings@AppSettings{..} = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. appHttpManager <- newManager - appLogger <- liftIO $ do - tgetter <- newTimeCache "%Y-%m-%d %T %z" - loggerSet <- newStderrLoggerSet defaultBufSize - return $ Yesod.Logger loggerSet tgetter + appLogSettings <- liftIO $ newTVarIO appInitialLogSettings + + let + mkLogger LogSettings{..} = do + tgetter <- newTimeCache "%Y-%m-%d %T %z" + loggerSet <- case logDestination of + LogDestStderr -> newStderrLoggerSet defaultBufSize + LogDestStdout -> newStdoutLoggerSet defaultBufSize + LogDestFile{..} -> newFileLoggerSet defaultBufSize logDestFile + return $ Yesod.Logger loggerSet tgetter + mkLogger' = liftIO $ do + initialSettings <- readTVarIO appLogSettings + tVar <- newTVarIO =<< mkLogger initialSettings + let updateLogger prevSettings = do + newSettings <- atomically $ do + newSettings <- readTVar appLogSettings + guard $ newSettings /= prevSettings + return newSettings + oldLogger <- atomically . swapTVar tVar =<< mkLogger newSettings + rmLoggerSet $ loggerSet oldLogger + updateLogger newSettings + (tVar, ) <$> fork (updateLogger initialSettings) + appLogger <- over _2 fst <$> allocate mkLogger' (\(tVar, tId) -> killThread tId >> (readTVarIO tVar >>= rmLoggerSet . loggerSet)) + appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID @@ -111,8 +132,6 @@ makeFoundation appSettings@AppSettings{..} = do appJobCtl <- liftIO $ newTVarIO Map.empty appCronThread <- liftIO newEmptyTMVarIO - appLogSettings <- liftIO $ newTVarIO appInitialLogSettings - -- We need a log function to create a connection pool. We need a connection -- pool to create our foundation. And we need our foundation to get a -- logging function. To get out of this loop, we initially create a @@ -128,7 +147,9 @@ makeFoundation appSettings@AppSettings{..} = do (error "cryptoIDKey forced in tempFoundation") (error "sessionKey forced in tempFoundation") (error "errorMsgKey forced in tempFoundation") - logFunc = messageLoggerSource tempFoundation appLogger + logFunc loc src lvl str = do + f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger) + f loc src lvl str flip runLoggingT logFunc $ do $logDebugS "InstanceID" $ UUID.toText appInstanceID @@ -228,12 +249,13 @@ makeLogWare app = do let mkLogWare ls@LogSettings{..} = do + logger <- readTVarIO . snd $ appLogger app logWare <- mkRequestLogger def { outputFormat = bool (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app) (Detailed True) logDetailed - , destination = Logger . loggerSet $ appLogger app + , destination = Logger $ loggerSet logger } atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare return logWare @@ -255,9 +277,11 @@ warpSettings foundation = defaultSettings & setPort (appPort $ appSettings foundation) & setHost (appHost $ appSettings foundation) & setOnException (\_req e -> - when (defaultShouldDisplayException e) $ messageLoggerSource + when (defaultShouldDisplayException e) $ do + logger <- readTVarIO . snd $ appLogger foundation + messageLoggerSource foundation - (appLogger foundation) + logger $(qLocation >>= liftLoc) "yesod" LevelError @@ -322,7 +346,9 @@ getApplicationRepl = do return (getPort wsettings, foundation, app1) shutdownApp :: MonadIO m => UniWorX -> m () -shutdownApp = stopJobCtl +shutdownApp app = do + stopJobCtl app + release . fst $ appLogger app --------------------------------------------- diff --git a/src/Foundation.hs b/src/Foundation.hs index 4289cdaad..9b899765f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -104,7 +104,7 @@ data UniWorX = UniWorX , appConnPool :: ConnectionPool -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool , appHttpManager :: Manager - , appLogger :: Logger + , appLogger :: (ReleaseKey, TVar Logger) , appLogSettings :: TVar LogSettings , appCryptoIDKey :: CryptoIDKey , appInstanceID :: InstanceId @@ -757,7 +757,7 @@ instance Yesod UniWorX where LogSettings{..} <- readTVarIO $ appLogSettings app return $ logAll || level >= logMinimumLevel - makeLogger = return . appLogger + makeLogger = readTVarIO . snd . appLogger siteLayout :: Maybe Html -- ^ Optionally override `pageHeading` @@ -1694,7 +1694,9 @@ instance HasHttpManager UniWorX where getHttpManager = appHttpManager unsafeHandler :: UniWorX -> Handler a -> IO a -unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger +unsafeHandler f h = do + logger <- makeLogger f + Unsafe.fakeHandlerGetLogger (const logger) f h instance YesodMail UniWorX where diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index e38e55bb5..e84be6b9c 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -50,9 +50,9 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] deriving Show Eq Ord |] -migrateAll :: MonadIO m => ReaderT SqlBackend m () +migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () migrateAll = do - runMigration $ do + mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do -- Manual migrations to go to InitialVersion below: migrateEnableExtension "citext" @@ -69,7 +69,7 @@ migrateAll = do -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey Map.foldlWithKey doCustomMigration (return ()) missingMigrations - runMigration migrateAll' + mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' {- Confusion about quotes, from the PostgreSQL Manual: diff --git a/src/Settings.hs b/src/Settings.hs index b05ae3c5d..9b4e48541 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -114,11 +114,16 @@ data AppSettings = AppSettings data LogSettings = LogSettings { logAll, logDetailed :: Bool , logMinimumLevel :: LogLevel + , logDestination :: LogDestination } deriving (Show, Read, Generic, Eq, Ord) +data LogDestination = LogDestStderr | LogDestStdout | LogDestFile { logDestFile :: !FilePath } + deriving (Show, Read, Generic, Eq, Ord) + deriving instance Generic LogLevel instance Hashable LogLevel instance Hashable LogSettings +instance Hashable LogDestination data UserDefaultConf = UserDefaultConf { userDefaultTheme :: Theme @@ -178,12 +183,19 @@ data SmtpAuthConf = SmtpAuthConf } deriving (Show) deriveJSON defaultOptions - { fieldLabelModifier = intercalate "-" . map toLower . splitCamel + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , sumEncoding = UntaggedValue + , unwrapUnaryRecords = True + } ''LogDestination + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 } ''LogSettings deriveFromJSON defaultOptions ''Ldap.Scope deriveFromJSON defaultOptions - { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel + { fieldLabelModifier = camelToPathPiece' 2 } ''UserDefaultConf instance FromJSON LdapConf where diff --git a/test/Database.hs b/test/Database.hs index 8359210ce..0308a3dfa 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -12,6 +12,7 @@ import Data.Pool (destroyAllResources) import Database.Persist.Postgresql import Control.Monad.Logger +import Control.Monad.Trans.Resource import System.Console.GetOpt import System.Exit (exitWith, ExitCode(..)) @@ -50,6 +51,7 @@ main = do DBTruncate -> db $ do foundation <- getYesod stopJobCtl foundation + release . fst $ appLogger foundation liftIO . destroyAllResources $ appConnPool foundation truncateDb DBMigrate -> db $ return () diff --git a/test/Handler/ProfileSpec.hs b/test/Handler/ProfileSpec.hs index aaf7a0da5..5d34a831d 100644 --- a/test/Handler/ProfileSpec.hs +++ b/test/Handler/ProfileSpec.hs @@ -7,7 +7,6 @@ import TestImport import qualified Data.CaseInsensitive as CI import Yesod.Core.Handler (toTextUrl) -import Yesod.Core.Unsafe (fakeHandlerGetLogger) spec :: Spec spec = withApp $ do @@ -15,8 +14,7 @@ spec = withApp $ do it "asserts no access to my-account for anonymous users" $ do get ProfileR - app <- getTestYesod - loginText <- fakeHandlerGetLogger appLogger app (toTextUrl $ AuthR LoginR) + loginText <- runHandler . toTextUrl $ AuthR LoginR assertHeader "Location" $ encodeUtf8 loginText diff --git a/test/TestImport.hs b/test/TestImport.hs index 1ef954051..207a563fe 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -44,7 +44,8 @@ runDBWithApp app query = liftIO $ runSqlPersistMPool query (appConnPool app) runHandler :: Handler a -> YesodExample UniWorX a runHandler handler = do app <- getTestYesod - fakeHandlerGetLogger appLogger app handler + logger <- liftIO . readTVarIO . snd $ appLogger app + fakeHandlerGetLogger (const logger) app handler withApp :: YSpec UniWorX -> Spec