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/Cron.hs b/src/Cron.hs index 600eb873c..53a7a01b3 100644 --- a/src/Cron.hs +++ b/src/Cron.hs @@ -150,10 +150,11 @@ genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMa nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry -> Maybe UTCTime -- ^ Time of last execution of the job + -> NominalDiffTime -- ^ Scheduling precision -> UTCTime -- ^ Current time, used only for `CronCalendar` -> Cron -> CronNextMatch UTCTime -nextCronMatch tz mPrev now c@Cron{..} = case notAfter of +nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of MatchAsap -> MatchNone MatchAt ts | MatchAt ts' <- nextMatch @@ -183,7 +184,7 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of Just prevT -> case cronRepeat of CronRepeatOnChange - | not $ matchesCron tz Nothing prevT c + | not $ matchesCron tz Nothing prec prevT c -> let cutoffTime = addUTCTime cronRateLimit prevT in case execRef now False cronInitial of @@ -240,13 +241,14 @@ nextCronMatch tz mPrev now c@Cron{..} = case notAfter of matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry -> Maybe UTCTime -- ^ Previous execution of the job + -> NominalDiffTime -- ^ Scheduling precision -> UTCTime -- ^ "Current" time -> Cron -> Bool -- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron` -- specification @c@ should match @now@, under the assumption that the next -- check will occur no earlier than @now + prec@. -matchesCron tz mPrev now cron = case nextCronMatch tz mPrev now cron of +matchesCron tz mPrev prec now cron = case nextCronMatch tz mPrev prec now cron of MatchAsap -> True MatchNone -> False - MatchAt ts -> ts <= now + MatchAt ts -> ts <= addUTCTime prec now diff --git a/src/Foundation.hs b/src/Foundation.hs index 4960f292b..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 @@ -678,10 +678,10 @@ instance Yesod UniWorX where encrypted plaintextJson plaintext = do canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings - errKey <- getsYesod appErrorMsgKey if | shouldEncrypt , not canDecrypt -> do + errKey <- getsYesod appErrorMsgKey nonce <- liftIO SecretBox.newNonce let ciphertext = SecretBox.secretbox errKey nonce . Lazy.ByteString.toStrict $ encode plaintextJson encoded = decodeUtf8 . Base64.encode $ Saltine.encode nonce <> ciphertext @@ -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/Jobs.hs b/src/Jobs.hs index 50bb56e5d..45a5f74f6 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -207,7 +207,7 @@ execCrontab = evalStateT go HashMap.empty | otherwise = Just (jobCtl, t) where - t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron + t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) acc now cron waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool waitUntil crontabTV crontab nextTime = runResourceT $ do 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/templates/default-layout.lucius b/templates/default-layout.lucius index 1cdd12452..8deb58679 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -5,8 +5,9 @@ --color-success: #23d160; --color-info: #c4c4c4; --color-lightblack: #1A2A36; - --color-lightwhite: #FCFFFA; + --color-lightwhite: #fcfffa; --color-grey: #B1B5C0; + --color-grey-light: #f4f5f6; --color-font: #34303a; --color-fontsec: #5b5861; @@ -515,7 +516,7 @@ section { padding: 0 0 12px; margin: 0 0 12px; border-bottom: 1px solid #d3d3d3; - + } section:last-of-type { diff --git a/templates/widgets/pageactionprime.hamlet b/templates/widgets/pageactionprime.hamlet index 13aff9d10..624ec8e51 100644 --- a/templates/widgets/pageactionprime.hamlet +++ b/templates/widgets/pageactionprime.hamlet @@ -1,17 +1,16 @@ $newline never $if hasPageActions
-