Framework for dynamic log settings & major jobs cleanup

config/settings.yml

@@ -25,9 +25,12 @@ job-cron-interval:  "_env:CRON_INTERVAL:60"
 job-stale-threshold: 300
 notification-rate-limit: 3600
 
-detailed-logging:  "_env:DETAILED_LOGGING:false"
+log-settings:
-should-log-all:    "_env:LOG_ALL:false"
+  log-detailed:      "_env:DETAILED_LOGGING:false"
-minimum-log-level: "_env:LOGLEVEL:warn"
+  log-all:           "_env:LOG_ALL:false"
+  log-minimum-level: "_env:LOGLEVEL:warn"
+
+# Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"
 

package.yaml

@@ -106,6 +106,7 @@ dependencies:
 - resourcet
 - postgresql-simple
 - word24
+- mmorph
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Application.hs

@@ -63,6 +63,10 @@ import Control.Monad.Trans.Resource
 
 import System.Log.FastLogger.Date
 import qualified Yesod.Core.Types as Yesod (Logger(..))
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Control.Lens ((&))
   
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
@@ -109,6 +113,8 @@ makeFoundation appSettings@(AppSettings{..}) = do
         recvChan <- dupTMChan chan
         return (chan, recvChan)
 
+    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
@@ -190,25 +196,38 @@ makeApplication foundation = liftIO $ do
     return $ logWare $ defaultMiddlewaresNoLogging appPlain
 
 makeLogWare :: MonadIO m => UniWorX -> m Middleware
-makeLogWare foundation = liftIO $
+makeLogWare app = do
-    mkRequestLogger def
+  logWareMap <- liftIO $ newTVarIO HashMap.empty
-        { outputFormat =
-            if appDetailedRequestLogging $ appSettings foundation
-                then Detailed True
-                else Apache
-                        (if appIpFromHeader $ appSettings foundation
-                            then FromFallback
-                            else FromSocket)
-        , destination = Logger $ loggerSet $ appLogger foundation
-        }
 
+  let
+    mkLogWare ls@LogSettings{..} = do
+      logWare <- mkRequestLogger def
+        { outputFormat = bool
+            (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
+            (Detailed True)
+            logDetailed
+        , destination = Logger . loggerSet $ appLogger app
+        }
+      atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
+      return logWare
+
+  void. liftIO $
+    mkLogWare =<< readTVarIO (appLogSettings app)
+
+  return $ \wai req fin -> do
+    lookupRes <- atomically $ do
+      ls <- readTVar $ appLogSettings app
+      existing <- HashMap.lookup ls <$> readTVar logWareMap
+      return $ maybe (Left ls) Right existing
+    logWare <- either mkLogWare return lookupRes
+    logWare wai req fin
 
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
-warpSettings foundation =
+warpSettings foundation = defaultSettings
-      setPort (appPort $ appSettings foundation)
+    & setPort (appPort $ appSettings foundation)
-    $ setHost (appHost $ appSettings foundation)
+    & setHost (appHost $ appSettings foundation)
-    $ setOnException (\_req e ->
+    & setOnException (\_req e ->
         when (defaultShouldDisplayException e) $ messageLoggerSource
             foundation
             (appLogger foundation)
@@ -216,7 +235,6 @@ warpSettings foundation =
             "yesod"
             LevelError
             (toLogStr $ "Exception from Warp: " ++ show e))
-      defaultSettings
 
 -- | For yesod devel, return the Warp settings and WAI Application.
 getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application)
@@ -232,9 +250,8 @@ getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSetting
 
 -- | main function for use by yesod devel
 develMain :: IO ()
-develMain = runResourceT $ do
+develMain = runResourceT $
-  app <- getApplicationDev
+  liftIO . develMainHelper . return =<< getApplicationDev
-  liftIO . develMainHelper $ return app
 
 -- | The @main@ function for an executable running this site.
 appMain :: MonadResourceBase m => m ()

src/Foundation.hs

@@ -123,6 +123,7 @@ data UniWorX = UniWorX
     , appSmtpPool    :: Maybe SMTPPool
     , appHttpManager :: Manager
     , appLogger      :: Logger
+    , appLogSettings :: TVar LogSettings
     , appCryptoIDKey :: CryptoIDKey
     , appInstanceID  :: InstanceId
     , appJobCtl      :: [TMChan JobCtl]
@@ -751,7 +752,10 @@ instance Yesod UniWorX where
 
     -- What messages should be logged. The following includes all messages when
     -- in development, and warnings and errors in production.
-    shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app)
+    shouldLog _ _ _ = error "Must use shouldLogIO"
+    shouldLogIO app _source level = do
+      LogSettings{..} <- readTVarIO $ appLogSettings app
+      return $ logAll || level >= logMinimumLevel
 
     makeLogger = return . appLogger
 

src/Import/NoFoundation.hs

@@ -3,7 +3,7 @@ module Import.NoFoundation
     ( module Import
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=))
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
@@ -37,3 +37,5 @@ import GHC.Generics           as Import (Generic)
 
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..))
+
+import Control.Monad.Morph    as Import (MFunctor(..))

src/Jobs.hs

@@ -14,19 +14,17 @@
 
 module Jobs
   ( module Types
-  , writeJobCtl
+  , module Jobs.Queue
-  , queueJob, queueJob'
-  , YesodJobDB
-  , runDBJobs, queueDBJob
   , handleJobs
   ) where
 
-import Import hiding ((.=), Proxy)
+import Import hiding (Proxy)
-import Handler.Utils.Mail
-import Handler.Utils.DateTime
 
 import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
 import Jobs.Types (JobCtl(JobCtlQueue))
+import Jobs.Queue
+import Jobs.TH
+import Jobs.Crontab
 
 import Data.Conduit.TMChan
 import qualified Data.Conduit.List as C
@@ -36,40 +34,25 @@ import qualified Data.Text.Lazy as LT
 import Data.Aeson (fromJSON, toJSON)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
-import Database.Persist.Sql (executeQQ, fromSqlKey, transactionSave)
+import Database.Persist.Sql (fromSqlKey)
 
-import Data.Monoid (Last(..))
 import Data.Semigroup (Max(..))
-import Data.Bitraversable
 
-import Utils.Lens
 import Utils.Sql
 
-import Control.Monad.Random (evalRand, uniform, mkStdGen)
+import Control.Monad.Random (evalRand, mkStdGen)
-
-import qualified Database.Esqueleto as E
-
-import qualified Data.CaseInsensitive as CI
-
-import Text.Shakespeare.Text
-import Text.Hamlet
 
 import Cron
 import qualified Data.HashMap.Strict as HashMap
 import Data.HashMap.Strict (HashMap)
 
-import qualified Data.Set as Set
-
-import Data.List.NonEmpty (NonEmpty, nonEmpty)
 import qualified Data.List.NonEmpty as NonEmpty
 
 import Data.Foldable (foldrM)
 
 import Control.Monad.Trans.Reader (mapReaderT)
-import Control.Monad.Trans.Writer (WriterT(..), execWriterT)
 import Control.Monad.Trans.State (StateT, evalStateT, mapStateT)
 import qualified Control.Monad.State.Class as State
-import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Reader.Class (MonadReader(..))
 import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)
 import Control.Monad.Trans.Maybe (MaybeT(..))
@@ -82,6 +65,13 @@ import Data.Time.Zones
 
 import Control.Concurrent.STM (retry)
 
+
+import Jobs.Handler.SendNotification
+import Jobs.Handler.SendTestEmail
+import Jobs.Handler.QueueNotification
+import Jobs.Handler.HelpRequest
+import Jobs.Handler.SetLogSettings
+
   
 data JobQueueException = JInvalid QueuedJobId QueuedJob
                        | JLocked QueuedJobId InstanceId UTCTime
@@ -105,7 +95,7 @@ handleJobs recvChans foundation@UniWorX{..} = do
       logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
       logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
       doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
-    in void $ allocate (liftIO doFork) (liftIO . killThread)
+    in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
 
   -- Start cron operation
   void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread)
@@ -135,9 +125,8 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
       Just (_, MatchNone) -> liftBase retry
       Just x -> return (crontab, x)
 
-  let doJob = do
+  let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
-        mJid <- mapStateT (mapReaderT $ liftHandlerT . runDB . setSerializable) $ do
+          newCrontab <- lift . lift . hoist lift $ determineCrontab'
-          newCrontab <- lift . lift $ determineCrontab
           if
             | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
               -> do
@@ -154,12 +143,11 @@ execCrontab = flip evalStateT HashMap.empty . forever $ do
                         , cronLastExecInstance = instanceID
                         }
                       [ CronLastExecTime =. now ]
-                    Just <$> lift (lift $ queueJobUnsafe job)
+                    lift . lift $ queueDBJob job
-                  other -> Nothing <$ writeJobCtl other
+                  other -> writeJobCtl other
             | otherwise
-              -> lift . fmap (const Nothing) . mapReaderT (liftIO . atomically) $
+              -> lift . mapReaderT (liftIO . atomically) $
                    lift . flip writeTVar newCrontab =<< asks jobCrontab
-        maybe (return ()) (writeJobCtl . JobCtlPerform) mJid
 
   case nextMatch of
     MatchAsap -> doJob
@@ -252,7 +240,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
       -- `performJob` is expected to throw an exception if it detects that the job was not done
       runDB $ delete jId
     handleCmd JobCtlDetermineCrontab = do
-      newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab
+      newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
       -- $logDebugS logIdent $ tshow newCTab
       mapReaderT (liftIO . atomically) $ 
         lift . flip writeTVar newCTab =<< asks jobCrontab
@@ -292,57 +280,6 @@ jLocked jId act = do
       
   bracket lock (const unlock) act
 
-writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
-writeJobCtl cmd = do
-  tid <- liftIO myThreadId
-  chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
-  liftIO . atomically $ writeTMChan chan cmd
-
-writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
-writeJobCtlBlock cmd = do
-  getResVar <- asks jobConfirm
-  resVar <- liftIO . atomically $ do
-    var <- newEmptyTMVar
-    modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var)
-    return var
-  lift $ writeJobCtl cmd
-  let
-    removeResVar = HashMap.update (nonEmpty . NonEmpty.filter (/= resVar)) cmd 
-  mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
-  maybe (return ()) throwM mExc
-
-queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
-queueJobUnsafe job = do
-  now <- liftIO getCurrentTime
-  self <- getsYesod appInstanceID
-  insert QueuedJob
-    { queuedJobContent = toJSON job
-    , queuedJobCreationInstance = self
-    , queuedJobCreationTime = now
-    , queuedJobLockInstance = Nothing
-    , queuedJobLockTime = Nothing
-    }
-  -- We should not immediately notify a worker; instead wait for the transaction to finish first
-  -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
-  -- return jId
-
-queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
-queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
-
-queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
--- ^ `queueJob` followed by `JobCtlPerform`
-queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
-
-type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
-
-queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
-queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
-
-runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
-runDBJobs act = do
-  (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
-  forM_ jIds $ writeJobCtl . JobCtlPerform
-  return ret
 
 pruneLastExecs :: Crontab JobCtl -> DB ()
 pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab
@@ -352,181 +289,10 @@ pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCronta
       , HashMap.member (JobCtlQueue job) crontab
       = return ()
       | otherwise = delete leId
-        
 
-determineCrontab :: DB (Crontab JobCtl)
+determineCrontab' :: DB (Crontab JobCtl)
--- ^ Extract all future jobs from the database (sheet deadlines, ...)
+determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab
-determineCrontab = (\ct -> ct <$ pruneLastExecs ct) <=< execWriterT $ do
-  AppSettings{..} <- getsYesod appSettings
-
-  case appJobFlushInterval of
-    Just interval -> tell $ HashMap.singleton
-      JobCtlFlush
-      Cron
-        { cronInitial = CronAsap
-        , cronRepeat = CronRepeatScheduled CronAsap
-        , cronRateLimit = interval
-        }
-    Nothing -> return ()
-
-  now <- liftIO getCurrentTime
-  tell $ HashMap.singleton
-    JobCtlDetermineCrontab
-    Cron
-      { cronInitial = CronAsap
-      , cronRepeat = CronRepeatScheduled CronAsap
-      , cronRateLimit = appJobCronInterval
-      }
-
-  let
-    sheetJobs (Entity nSheet Sheet{..}) = do
-      tell $ HashMap.singleton
-        (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
-        Cron
-          { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
-          , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
-          , cronRateLimit = appNotificationRateLimit
-          }
-      tell $ HashMap.singleton
-        (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
-        Cron
-          { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
-          , cronRepeat = CronRepeatOnChange
-          , cronRateLimit = appNotificationRateLimit
-          }
-  runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
-
-
-determineNotificationCandidates :: Notification -> DB [Entity User]
-determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
-  E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
-  E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
-  return user
-determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
-  E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
-  E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
-  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
-  return user
-determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
-  E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
-  E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
-  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
-  return user
-
-classifyNotification :: Notification -> DB NotificationTrigger
-classifyNotification NotificationSubmissionRated{..} = do
-  Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
-  return $ case sheetType of
-    NotGraded -> NTSubmissionRated
-    _other -> NTSubmissionRatedGraded
-classifyNotification NotificationSheetActive{} = return NTSheetActive
-classifyNotification NotificationSheetInactive{} = return NTSheetInactive
 
 
 performJob :: Job -> HandlerT UniWorX IO ()
-performJob JobQueueNotification{jNotification} = do
+performJob = $(dispatchTH ''Job)
-  jIds <- runDB. setSerializable $ do
-    candidates <- determineNotificationCandidates jNotification
-    nClass <- classifyNotification jNotification
-    mapM (queueJobUnsafe . flip JobSendNotification jNotification) $ do
-      Entity uid User{userNotificationSettings} <- candidates
-      guard $ notificationAllowed userNotificationSettings nClass
-      return uid
-  forM_ jIds $ writeJobCtl . JobCtlPerform
-performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, jRecipient } = userMailT jRecipient $ do
-  (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do
-    submission@Submission{submissionRatingBy} <- getJust nSubmission
-    sheet <- belongsToJust submissionSheet submission
-    course <- belongsToJust sheetCourse sheet
-    corrector <- traverse getJust submissionRatingBy
-    return (course, sheet, submission, corrector)
-  setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
-
-  csid <- encrypt nSubmission
-  MsgRenderer mr <- getMailMsgRenderer
-  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
-  submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
-  let tid = courseTerm
-      ssh = courseSchool
-      csh = courseShorthand
-      shn = sheetName
-
-  -- TODO: provide convienience template-haskell for `addAlternatives`
-  addAlternatives $ do
-    provideAlternative $ Aeson.object
-      [ "submission" Aeson..= ciphertext csid
-      , "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints)
-      , "submission-rating-comment" Aeson..= submissionRatingComment
-      , "submission-rating-time" Aeson..= submissionRatingTime
-      , "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
-      , "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType)
-      , "sheet-name" Aeson..= sheetName
-      , "sheet-type" Aeson..= sheetType
-      , "course-name" Aeson..= courseName
-      , "course-shorthand" Aeson..= courseShorthand
-      , "course-term" Aeson..= courseTerm
-      , "course-school" Aeson..= courseSchool
-      ]
-    -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
-    providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
-performJob JobSendNotification{ jNotification = NotificationSheetActive{..}, jRecipient } = userMailT jRecipient $ do
-  (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
-    sheet <- getJust nSheet
-    course <- belongsToJust sheetCourse sheet
-    return (course, sheet)
-  setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
-
-  MsgRenderer mr <- getMailMsgRenderer
-  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
-      tid = courseTerm
-      ssh = courseSchool
-      csh = courseShorthand
-      shn = sheetName
-
-  addAlternatives $ do
-    providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
-performJob JobSendNotification{ jNotification = NotificationSheetInactive{..}, jRecipient } = userMailT jRecipient $ do
-  (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
-    sheet <- getJust nSheet
-    course <- belongsToJust sheetCourse sheet
-    return (course, sheet)
-  setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
-
-  MsgRenderer mr <- getMailMsgRenderer
-  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
-      tid = courseTerm
-      ssh = courseSchool
-      csh = courseShorthand
-      shn = sheetName
-
-  addAlternatives $ do
-    providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
-performJob JobSendTestEmail{..} = mailT jMailContext $ do
-  _mailTo .= [Address Nothing jEmail]
-  setSubjectI MsgMailTestSubject
-  now <- liftIO getCurrentTime
-  nDT <- formatTimeMail SelFormatDateTime now
-  nD <- formatTimeMail SelFormatDate now
-  nT <- formatTimeMail SelFormatTime now
-  addPart $ \(MsgRenderer mr) -> ([text|
-    #{mr MsgMailTestContent}
-
-    #{mr MsgMailTestDateTime}
-      * #{nDT}
-      * #{nD}
-      * #{nT}
-    |] :: TextUrl (Route UniWorX))
-performJob JobHelpRequest{..} = do
-  supportAddress <- getsYesod $ appMailSupport . appSettings
-  userInfo <- bitraverse return (runDB . getEntity) jSender
-  let userAddress = either (fmap $ Address Nothing)
-                           (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
-                           userInfo
-  mailT def $ do
-    _mailTo .= [supportAddress]
-    whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
-    setSubjectI MsgMailSubjectSupport
-    setDate jRequestTime
-    rtime <- formatTimeMail SelFormatDateTime jRequestTime
-    addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
-

src/Jobs/Crontab.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , FlexibleContexts
+  #-}
+
+module Jobs.Crontab
+  ( determineCrontab
+  ) where
+
+import Import
+
+import qualified Data.HashMap.Strict as HashMap
+import Jobs.Types
+
+import Data.Time
+import Data.Time.Zones
+
+import Control.Monad.Trans.Writer (execWriterT)
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+import qualified Data.Conduit.List as C
+
+
+determineCrontab :: DB (Crontab JobCtl)
+-- ^ Extract all future jobs from the database (sheet deadlines, ...)
+determineCrontab = execWriterT $ do
+  AppSettings{..} <- getsYesod appSettings
+
+  case appJobFlushInterval of
+    Just interval -> tell $ HashMap.singleton
+      JobCtlFlush
+      Cron
+        { cronInitial = CronAsap
+        , cronRepeat = CronRepeatScheduled CronAsap
+        , cronRateLimit = interval
+        }
+    Nothing -> return ()
+
+  tell $ HashMap.singleton
+    JobCtlDetermineCrontab
+    Cron
+      { cronInitial = CronAsap
+      , cronRepeat = CronRepeatScheduled CronAsap
+      , cronRateLimit = appJobCronInterval
+      }
+
+  let
+    sheetJobs (Entity nSheet Sheet{..}) = do
+      tell $ HashMap.singleton
+        (JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
+        Cron
+          { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
+          , cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
+          , cronRateLimit = appNotificationRateLimit
+          }
+      tell $ HashMap.singleton
+        (JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
+        Cron
+          { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
+          , cronRepeat = CronRepeatOnChange
+          , cronRateLimit = appNotificationRateLimit
+          }
+  runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs

src/Jobs/Handler/HelpRequest.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , RecordWildCards
+           , OverloadedStrings
+  #-}
+
+module Jobs.Handler.HelpRequest
+  ( dispatchJobHelpRequest
+  ) where
+
+import Import hiding ((.=))
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+import Handler.Utils.DateTime
+
+import Utils.Lens
+
+import Data.Bitraversable
+  
+
+dispatchJobHelpRequest :: Either (Maybe Email) UserId
+                       -> UTCTime
+                       -> Text -- ^ Help Request
+                       -> Maybe Text -- ^ Referer
+                       -> Handler ()
+dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
+  supportAddress <- getsYesod $ appMailSupport . appSettings
+  userInfo <- bitraverse return (runDB . getEntity) jSender
+  let userAddress = either (fmap $ Address Nothing)
+                           (fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
+                           userInfo
+  mailT def $ do
+    _mailTo .= [supportAddress]
+    whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
+    setSubjectI MsgMailSubjectSupport
+    setDate jRequestTime
+    rtime <- formatTimeMail SelFormatDateTime jRequestTime
+    addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/QueueNotification.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+  #-}
+
+module Jobs.Handler.QueueNotification
+  ( dispatchJobQueueNotification
+  ) where
+
+import Import
+
+import Jobs.Types
+
+import qualified Database.Esqueleto as E
+import Utils.Sql
+import Jobs.Queue
+
+
+dispatchJobQueueNotification :: Notification -> Handler ()
+dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
+  candidates <- hoist lift $ determineNotificationCandidates jNotification
+  nClass <- hoist lift $ classifyNotification jNotification
+  mapM_ (queueDBJob . flip JobSendNotification jNotification) $ do
+    Entity uid User{userNotificationSettings} <- candidates
+    guard $ notificationAllowed userNotificationSettings nClass
+    return uid
+
+  
+determineNotificationCandidates :: Notification -> DB [Entity User]
+determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
+  E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
+  E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
+  return user
+determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
+  E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
+  E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+  return user
+determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
+  E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
+  E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+  E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
+  return user
+
+classifyNotification :: Notification -> DB NotificationTrigger
+classifyNotification NotificationSubmissionRated{..} = do
+  Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
+  return $ case sheetType of
+    NotGraded -> NTSubmissionRated
+    _other -> NTSubmissionRatedGraded
+classifyNotification NotificationSheetActive{} = return NTSheetActive
+classifyNotification NotificationSheetInactive{} = return NTSheetInactive
+
+

src/Jobs/Handler/SendNotification.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+  #-}
+
+module Jobs.Handler.SendNotification
+  ( dispatchJobSendNotification
+  ) where
+
+import Import
+
+import Jobs.TH
+import Jobs.Types
+
+
+import Jobs.Handler.SendNotification.SubmissionRated
+import Jobs.Handler.SendNotification.SheetActive
+import Jobs.Handler.SendNotification.SheetInactive
+
+
+dispatchJobSendNotification :: UserId -> Notification -> Handler ()
+dispatchJobSendNotification jRecipient jNotification = $(dispatchTH ''Notification) jNotification jRecipient

src/Jobs/Handler/SendNotification/SheetActive.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , TemplateHaskell
+           , OverloadedStrings
+  #-}
+
+module Jobs.Handler.SendNotification.SheetActive
+  ( dispatchNotificationSheetActive
+  ) where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationSheetActive :: SheetId -> UserId -> Handler ()
+dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
+  (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
+    sheet <- getJust nSheet
+    course <- belongsToJust sheetCourse sheet
+    return (course, sheet)
+  setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
+
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+      tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      shn = sheetName
+
+  addAlternatives $ do
+    providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/SheetInactive.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , TemplateHaskell
+           , OverloadedStrings
+  #-}
+
+module Jobs.Handler.SendNotification.SheetInactive
+  ( dispatchNotificationSheetInactive
+  ) where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
+dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
+  (Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
+    sheet <- getJust nSheet
+    course <- belongsToJust sheetCourse sheet
+    return (course, sheet)
+  setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
+
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+      tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      shn = sheetName
+
+  addAlternatives $ do
+    providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/SubmissionRated.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , TemplateHaskell
+           , OverloadedStrings
+  #-}
+
+module Jobs.Handler.SendNotification.SubmissionRated
+  ( dispatchNotificationSubmissionRated
+  ) where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils.DateTime
+import Handler.Utils.Mail
+
+import Text.Hamlet
+import qualified Data.Aeson as Aeson
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler ()
+dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do
+  (Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do
+    submission@Submission{submissionRatingBy} <- getJust nSubmission
+    sheet <- belongsToJust submissionSheet submission
+    course <- belongsToJust sheetCourse sheet
+    corrector <- traverse getJust submissionRatingBy
+    return (course, sheet, submission, corrector)
+  setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
+
+  csid <- encrypt nSubmission
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+  submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
+  let tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      shn = sheetName
+
+  -- TODO: provide convienience template-haskell for `addAlternatives`
+  addAlternatives $ do
+    provideAlternative $ Aeson.object
+      [ "submission" Aeson..= ciphertext csid
+      , "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints)
+      , "submission-rating-comment" Aeson..= submissionRatingComment
+      , "submission-rating-time" Aeson..= submissionRatingTime
+      , "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
+      , "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType)
+      , "sheet-name" Aeson..= sheetName
+      , "sheet-type" Aeson..= sheetType
+      , "course-name" Aeson..= courseName
+      , "course-shorthand" Aeson..= courseShorthand
+      , "course-term" Aeson..= courseTerm
+      , "course-school" Aeson..= courseSchool
+      ]
+    -- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
+    providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendTestEmail.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , NamedFieldPuns
+           , QuasiQuotes
+  #-}
+
+module Jobs.Handler.SendTestEmail
+  ( dispatchJobSendTestEmail
+  ) where
+
+import Import hiding ((.=))
+
+import Handler.Utils.DateTime
+
+import Text.Shakespeare.Text
+
+import Utils.Lens
+
+dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
+dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
+  _mailTo .= [Address Nothing jEmail]
+  setSubjectI MsgMailTestSubject
+  now <- liftIO getCurrentTime
+  nDT <- formatTimeMail SelFormatDateTime now
+  nD <- formatTimeMail SelFormatDate now
+  nT <- formatTimeMail SelFormatTime now
+  addPart $ \(MsgRenderer mr) -> ([text|
+    #{mr MsgMailTestContent}
+
+    #{mr MsgMailTestDateTime}
+      * #{nDT}
+      * #{nD}
+      * #{nT}
+    |] :: TextUrl (Route UniWorX))

src/Jobs/Handler/SetLogSettings.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE NoImplicitPrelude
+  #-}
+
+module Jobs.Handler.SetLogSettings
+  ( dispatchJobSetLogSettings
+  ) where
+
+import Import
+
+dispatchJobSetLogSettings :: InstanceId -> LogSettings -> Handler ()
+dispatchJobSetLogSettings jInstance jLogSettings = do
+  instanceId <- getsYesod appInstanceID
+  unless (instanceId == jInstance) $ fail "Incorrect instance"
+  lSettings <- getsYesod appLogSettings
+  atomically $ writeTVar lSettings jLogSettings

src/Jobs/Queue.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TypeFamilies
+  #-}
+
+module Jobs.Queue
+  ( writeJobCtl, writeJobCtlBlock
+  , queueJob, queueJob'
+  , YesodJobDB
+  , runDBJobs, queueDBJob
+  ) where
+
+import Import
+
+import Utils.Sql
+import Jobs.Types
+
+import Control.Monad.Trans.Writer (WriterT, runWriterT)
+import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
+
+import qualified Data.Set as Set
+import qualified Data.List.NonEmpty as NonEmpty
+import qualified Data.HashMap.Strict as HashMap
+
+import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform)
+
+
+writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
+writeJobCtl cmd = do
+  tid <- liftIO myThreadId
+  chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
+  liftIO . atomically $ writeTMChan chan cmd
+
+writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
+writeJobCtlBlock cmd = do
+  getResVar <- asks jobConfirm
+  resVar <- liftIO . atomically $ do
+    var <- newEmptyTMVar
+    modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var)
+    return var
+  lift $ writeJobCtl cmd
+  let
+    removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd 
+  mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
+  maybe (return ()) throwM mExc
+
+queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
+queueJobUnsafe job = do
+  now <- liftIO getCurrentTime
+  self <- getsYesod appInstanceID
+  insert QueuedJob
+    { queuedJobContent = toJSON job
+    , queuedJobCreationInstance = self
+    , queuedJobCreationTime = now
+    , queuedJobLockInstance = Nothing
+    , queuedJobLockTime = Nothing
+    }
+  -- We should not immediately notify a worker; instead wait for the transaction to finish first
+  -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
+  -- return jId
+
+queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
+queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
+
+queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
+-- ^ `queueJob` followed by `JobCtlPerform`
+queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
+
+type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
+
+queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
+queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
+
+runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
+runDBJobs act = do
+  (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
+  forM_ jIds $ writeJobCtl . JobCtlPerform
+  return ret
+
+
+

src/Jobs/TH.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , QuasiQuotes
+           , RecordWildCards
+  #-}
+
+module Jobs.TH
+  ( dispatchTH
+  ) where
+
+import ClassyPrelude
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+
+import Data.List (foldl)
+
+
+dispatchTH :: Name -- ^ Datatype to pattern match
+           -> ExpQ
+dispatchTH dType = do
+  DatatypeInfo{..} <- reifyDatatype dType
+  let
+    matches = map mkMatch datatypeCons
+    mkMatch ConstructorInfo{..} = do
+      pats <- forM constructorFields $ \_ -> newName "x"
+      let fName = mkName $ "dispatch" <> nameBase constructorName
+      match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
+  lamCaseE matches

src/Jobs/Types.hs

@@ -24,6 +24,7 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
          | JobHelpRequest { jSender :: Either (Maybe Email) UserId
                           , jRequestTime :: UTCTime
                           , jHelpRequest :: Text, jReferer :: Maybe Text }
+         | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }

src/Settings.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiWayIf         #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -- | Settings are centralized, as much as possible, into this file. This
@@ -89,10 +90,8 @@ data AppSettings = AppSettings
     , appJobStaleThreshold      :: NominalDiffTime
     , appNotificationRateLimit  :: NominalDiffTime
 
-    , appDetailedRequestLogging :: Bool
+    , appInitialLogSettings     :: LogSettings
-    -- ^ Use detailed request logging system
+
-    , appShouldLogAll           :: Bool
-    -- ^ Should all log messages be displayed?
     , appReloadTemplates        :: Bool
     -- ^ Use the reload version of templates
     , appMutableStatic          :: Bool
@@ -103,7 +102,6 @@ data AppSettings = AppSettings
     -- ^ Indicate if auth dummy login should be enabled.
     , appAllowDeprecated        :: Bool
     -- ^ Indicate if deprecated routes are accessible for everyone
-    , appMinimumLogLevel        :: LogLevel
 
     , appUserDefaults           :: UserDefaultConf
     , appAuthPWHash             :: PWHashConf
@@ -111,7 +109,16 @@ data AppSettings = AppSettings
     , appCryptoIDKeyFile        :: FilePath
     , appInstanceIDFile         :: Maybe FilePath
     } deriving (Show)
-  
+
+data LogSettings = LogSettings
+  { logAll, logDetailed :: Bool
+  , logMinimumLevel :: LogLevel
+  } deriving (Show, Read, Generic, Eq, Ord)
+
+deriving instance Generic LogLevel
+instance Hashable LogLevel
+instance Hashable LogSettings
+
 data UserDefaultConf = UserDefaultConf
   { userDefaultTheme :: Theme
   , userDefaultMaxFavourites :: Int
@@ -169,6 +176,10 @@ data SmtpAuthConf = SmtpAuthConf
   , smtpAuthPassword :: HaskellNet.Password
   } deriving (Show)
 
+deriveJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . splitCamel
+  } ''LogSettings
+  
 deriveFromJSON defaultOptions ''Ldap.Scope
 deriveFromJSON defaultOptions
   { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
@@ -199,7 +210,7 @@ deriveFromJSON
     }
   ''ResourcePoolConf
 
-deriveFromJSON
+deriveJSON
   defaultOptions
     { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
     , sumEncoding = UntaggedValue
@@ -283,15 +294,14 @@ instance FromJSON AppSettings where
         appJobStaleThreshold      <- o .:  "job-stale-threshold"
         appNotificationRateLimit  <- o .:  "notification-rate-limit"
 
-        appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
-        appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
-        appMinimumLogLevel        <- o .:  "minimum-log-level"
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
         appAuthDummyLogin         <- o .:? "auth-dummy-login" .!= defaultDev
         appAllowDeprecated        <- o .:? "allow-deprecated" .!= defaultDev
 
+        appInitialLogSettings     <- o .:  "log-settings"
+
         appUserDefaults           <- o .:  "user-defaults"
         appAuthPWHash             <- o .:  "auth-pw-hash"
 

src/Utils/Sql.hs

@@ -32,6 +32,7 @@ setSerializable act = setSerializable' (0 :: Integer)
               delay :: NominalDiffTime
               delay = 1e-3 * 2 ^ logBackoff
             $logWarnS "Sql" $ tshow (delay, e)
+            transactionUndo
             threadDelay . round $ delay * 1e6
             setSerializable' (succ logBackoff)
         )

src/Utils/SystemMessage.hs

@@ -5,7 +5,6 @@
 module Utils.SystemMessage where
 
 import Import.NoFoundation
-import Utils
 
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.List (findIndex)

start.sh

@@ -3,6 +3,7 @@
 unset HOST
 export DETAILED_LOGGING=true
 export LOG_ALL=true
+export LOGLEVEL=info
 export DUMMY_LOGIN=true
 export ALLOW_DEPRECATED=true
 export PWFILE=users.yml

templates/mail/support.hamlet

@@ -25,5 +25,5 @@ $newline never
             <dd> #{lang}
       <dt> Zeit
       <dd> #{rtime}
-    <p>
+    <p style="white-space: pre">
       #{jHelpRequest}