Log to file during tests

.gitignore

@@ -30,4 +30,5 @@ src/Handler/Course.SnapCustom.hs
 /instance
 .stack-work-*
 .directory
-tags
+tags
+test.log

config/settings.yml

@@ -29,9 +29,11 @@ notification-expiration: 259201
 session-timeout: 7200
 
 log-settings:
-  log-detailed:      "_env:DETAILED_LOGGING:false"
+  detailed:      "_env:DETAILED_LOGGING:false"
-  log-all:           "_env:LOG_ALL:false"
+  all:           "_env:LOG_ALL:false"
-  log-minimum-level: "_env:LOGLEVEL:warn"
+  minimum-level: "_env:LOGLEVEL:warn"
+  destination:   "_env:LOGDEST:stderr"
+
 
 # Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"

config/test-settings.yml

@@ -1,11 +1,10 @@
 database:
-  # NOTE: By design, this setting prevents the PGDATABASE environment variable
+  database: "_env:PGDATABASE_TEST:uniworx_test"
-  # from affecting test runs, so that we don't accidentally affect the
+
-  # production database during testing. If you're not concerned about that and
+log-settings:
-  # would like to have environment variable overrides, you could instead use
+  detailed:      true
-  # something like:
+  all:           true
-  #
+  minimum-level: "debug"
-  #   database: "_env:PGDATABASE:uniworx_test"
+  destination:   "test.log"
-  database: uniworx_test
 
 auth-dummy-login: true

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,
+import System.Log.FastLogger                ( defaultBufSize, newStderrLoggerSet, newStdoutLoggerSet, newFileLoggerSet
-                                             toLogStr)
+                                            , 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
+    appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
-      tgetter <- newTimeCache "%Y-%m-%d %T %z"
+
-      loggerSet <- newStderrLoggerSet defaultBufSize
+    let
-      return $ Yesod.Logger loggerSet tgetter
+      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
 
 
 ---------------------------------------------

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

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:

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

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 ()

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 <- runHandler . toTextUrl $ AuthR LoginR
-      loginText <- fakeHandlerGetLogger appLogger app (toTextUrl $ AuthR LoginR)
 
       assertHeader "Location" $ encodeUtf8 loginText
   

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