Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

.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"
-  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"

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

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

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

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

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

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

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 {

templates/widgets/pageactionprime.hamlet

@@ -1,17 +1,16 @@
 $newline never
 $if hasPageActions
   <div .page-nav-prime>
-    <ul .pagenav__list>
-      $forall (MenuItem{menuItemLabel, menuItemType, menuItemModal}, menuIdent, route) <- menuTypes
-        $case menuItemType
-          $of PageActionPrime
-            <li .pagenav__list-item>
-              $if menuItemModal
-                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
-              <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
-          $of PageActionSecondary
-            <li .pagenav__list-item>
-              $if menuItemModal
-                <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
-              <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
-          $of _
+    $forall (MenuItem{menuItemLabel, menuItemType, menuItemModal}, menuIdent, route) <- menuTypes
+      $case menuItemType
+        $of PageActionPrime
+          <div .pagenav__list-item>
+            $if menuItemModal
+              <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
+            <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
+        $of PageActionSecondary
+          <div .pagenav__list-item>
+            $if menuItemModal
+              <div .modal.js-modal #modal-#{menuIdent} data-trigger=#{menuIdent} data-closeable data-dynamic>
+            <a .pagenav__link-wrapper href=#{route} ##{menuIdent}>_{SomeMessage menuItemLabel}
+        $of _

templates/widgets/pageactionprime.lucius

@@ -1,19 +1,10 @@
 .page-nav-prime {
-  margin: 4px 0 13px;
-  border-left: 2px solid #c3c3c3;
-  padding-left: 10px;
-}
-
-.pagenav__list {
-  display: block;
-  margin-left: 0;
+  margin: 10px 0 20px;
+  background-color: var(--color-grey-light);
 }
 
 .pagenav__list-item {
   display: inline-block;
-
-  &:not(:last-child) {
-    margin-right: 7px;
-    padding-right: 7px;
-  }
+  padding: 15px;
+  box-shadow: 0 0 2px 0 rgba(0, 0, 0, 0.1);
 }

test/CronSpec.hs

@@ -21,7 +21,7 @@ sampleCron :: Natural -> Cron -> [UTCTime]
 sampleCron n = go n baseTime Nothing
   where
     go 0 _ _ _ = []
-    go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
+    go (pred -> n') t mPrev cron = case nextCronMatch utcTZ mPrev 0 t cron of
       MatchAsap -> t : go n' t (Just t) cron
       MatchAt t' -> t' : go n' t' (Just t') cron
       MatchNone -> []

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