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

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"
 

messages/uniworx/de.msg

@@ -201,6 +201,7 @@ ProfileHeading: Benutzereinstellungen
 ProfileDataHeading: Gespeicherte Benutzerdaten
 ImpressumHeading: Impressum
 SystemMessageHeading: Uni2Work Statusmeldung
+SystemMessageListHeading: Uni2Work Statusmeldungen
 
 NumCourses n@Int64: #{display n} Kurse
 CloseAlert: Schliessen
@@ -258,6 +259,8 @@ RatingPercent: Erreicht
 RatingFiles: Korrigierte Dateien
 PointsNotPositive: Punktzahl darf nicht negativ sein
 RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
+ColumnRatingPointsDone: Punktzahl/Abgeschlossen
+Pseudonyms: Pseudonyme
 
 FileTitle: Dateiname
 FileModified: Letzte Änderung
@@ -385,15 +388,50 @@ SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt
 SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert:
 SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben:
 
+CorrGrade: Korrekturen eintragen
 
 UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht!
 
-HelpAnswer: Anfrage von 
+HelpAnswer: Antworten an
-HelpUser: Benutzeraccount Uni2Work
+HelpUser: Meinen Benutzeraccount
-HelpAnonymous: Anonym (Keine Antwort möglich)
+HelpAnonymous: Keine Antwort (Anonym)
-HelpEMail: E-Mail (ohne Login)
+HelpEMail: E-Mail
 HelpRequest: Supportanfrage / Verbesserungsvorschlag
 HelpProblemPage: Problematische Seite 
+HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
 
+SystemMessageFrom: Sichtbar ab
+SystemMessageTo: Sichtbar bis
+SystemMessageAuthenticatedOnly: Nur angemeldet
+SystemMessageSeverity: Schwere
+SystemMessageId: Id
+SystemMessageSummaryContent: Zusammenfassung / Inhalt
+SystemMessageSummary: Zusammenfassung
+SystemMessageContent: Inhalt
+SystemMessageLanguage: Sprache
 
-Dummy: TODO Message not defined!
+SystemMessageDelete: Löschen
+SystemMessageActivate: Sichtbar schalten
+SystemMessageDeactivate: Unsichtbar schalten
+SystemMessageTimestamp: Zeitpunkt
+
+SystemMessagesDeleted: System-Nachrichten gelöscht:
+SystemMessagesActivated: Aktivierungszeitpunkt folgender System-Nachrichten gesetzt:
+SystemMessagesDeactivated: Deaktivierungszeitpunkt folgender System-Nachrichten gesetzt:
+SystemMessageEmptySelection: Keine System-Nachrichten ausgewählt
+SystemMessageAdded sysMsgId@CryptoUUIDSystemMessage: System-Nachricht hinzugefügt: #{toPathPiece sysMsgId}
+SystemMessageEdit: Statusmeldung anpassen
+SystemMessageEditTranslations: Übersetzungen anpassen
+SystemMessageAddTranslation: Übersetzung hinzufügen
+
+SystemMessageEditSuccess: Statusmeldung angepasst.
+SystemMessageAddTranslationSuccess: Übersetzung hinzugefügt.
+SystemMessageEditTranslationSuccess: Übersetzung angepasst.
+SystemMessageDeleteTranslationSuccess: Übersetzung entfernt.
+
+MessageError: Fehler
+MessageWarning: Warnung
+MessageInfo: Information
+MessageSuccess: Erfolg
+
+InvalidLangFormat: Ungültiger Sprach-Code (RFC1766)

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.

routes

@@ -85,11 +85,13 @@
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
 
-/corrections  CorrectionsR GET POST !corrector !lecturer
+/submissions  CorrectionsR GET POST !corrector !lecturer
-/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
+/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer
-/corrections/create CorrectionsCreateR GET POST !corrector !lecturer
+/submissions/create CorrectionsCreateR GET POST !corrector !lecturer
+/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer
 
 
+/msgs                           MessageListR GET POST
 /msg/#{CryptoUUIDSystemMessage} MessageR      GET POST        !timeANDisReadANDauthentication
 
 

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/CryptoID.hs

@@ -40,6 +40,7 @@ decCryptoIDs [ ''SubmissionId
              , ''UserId
              , ''SheetId
              , ''SystemMessageId
+             , ''SystemMessageTranslationId
              ]
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

src/Foundation.hs

@@ -85,7 +85,7 @@ import Utils.Form
 import Utils.Lens
 import Utils.SystemMessage
 
-import Data.Aeson hiding (Error)
+import Data.Aeson hiding (Error, Success)
 import Data.Aeson.TH
 import qualified Data.Yaml as Yaml
 
@@ -123,6 +123,7 @@ data UniWorX = UniWorX
     , appSmtpPool    :: Maybe SMTPPool
     , appHttpManager :: Manager
     , appLogger      :: Logger
+    , appLogSettings :: TVar LogSettings
     , appCryptoIDKey :: CryptoIDKey
     , appInstanceID  :: InstanceId
     , appJobCtl      :: [TMChan JobCtl]
@@ -260,6 +261,13 @@ instance RenderMessage UniWorX NotificationTrigger where
 instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
   renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
 
+instance RenderMessage UniWorX MessageClass where
+  renderMessage f ls = renderMessage f ls . \case
+    Error -> MsgMessageError
+    Warning -> MsgMessageWarning
+    Info -> MsgMessageInfo
+    Success -> MsgMessageSuccess
+
 
 data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
@@ -751,7 +759,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
 
@@ -823,6 +834,12 @@ instance YesodBreadcrumbs UniWorX where
   -- Others
   breadcrumb (CorrectionsR)       = return ("Korrekturen", Just HomeR)
   breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
+  breadcrumb (MessageR _) = do
+    mayList <- (== Authorized) <$> evalAccess MessageListR False
+    return $ if
+      | mayList   -> ("Statusmeldung", Just MessageListR)
+      | otherwise -> ("Statusmeldung", Just HomeR)
+  breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR)
   breadcrumb  _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
 
 submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
@@ -938,6 +955,13 @@ pageActions (HomeR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "System-Nachrichten"
+      , menuItemIcon = Nothing
+      , menuItemRoute = MessageListR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (ProfileR) =
   [ PageActionPrime $ MenuItem
@@ -1118,6 +1142,35 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
       }
   ]
 pageActions (CorrectionsR) =
+  [ PageActionPrime $ MenuItem
+      { menuItemLabel = "Korrekturen hochladen"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CorrectionsUploadR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Abgaben erstellen"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CorrectionsCreateR
+      , menuItemModal = True
+      , menuItemAccessCallback' = runDB $ do
+          uid <- liftHandlerT requireAuthId
+          [E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
+            E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+            E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
+            return E.countRows
+          return $ (count :: Int) /= 0
+      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Korrekturen eintragen"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CorrectionsGradeR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
+pageActions (CorrectionsGradeR) =
   [ PageActionPrime $ MenuItem
       { menuItemLabel = "Korrekturen hochladen"
       , menuItemIcon = Nothing
@@ -1233,8 +1286,12 @@ pageHeading CorrectionsUploadR
   = Just $ i18nHeading MsgCorrUpload
 pageHeading CorrectionsCreateR
   = Just $ i18nHeading MsgCorrCreate
+pageHeading CorrectionsGradeR
+  = Just $ i18nHeading MsgCorrGrade
 pageHeading (MessageR _)
   = Just $ i18nHeading MsgSystemMessageHeading
+pageHeading MessageListR
+  = Just $ i18nHeading MsgSystemMessageListHeading
 
 -- TODO: add headings for more single course- and single term-pages
 pageHeading _

src/Handler/Corrections.hs

@@ -69,6 +69,8 @@ import qualified Data.CaseInsensitive as CI
 import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
 import Control.Monad.Writer.Class (MonadWriter(..))
 
+import Control.Monad.Trans.RWS (RWST)
+
 import Control.Monad.Trans.State (State, StateT(..), runState)
 import qualified Control.Monad.State.Class as State
 
@@ -90,8 +92,11 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
 sheetIs :: Key Sheet -> CorrectionsWhere
 sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
 
+submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
+submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
 
-type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User)
+
+type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
 
 colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colTerm = sortable (Just "term") (i18nCell MsgTerm)
@@ -143,13 +148,15 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
   tid = course ^. _3
   ssh = course ^. _4
   link cid = CourseR tid ssh csh $ CUserR cid
-  cell = listCell (Map.toList users) $ \(userId, User{..}) -> do
+  cell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
-    anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname)
+    anchorCellM (link <$> encrypt userId) $ case mPseudo of
+      Nothing -> nameWidget userDisplayName userSurname
+      Just p  -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|]
   in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
 
 colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
-  cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
+  cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
   in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
   
 colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
@@ -171,13 +178,31 @@ colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
 colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
   maybe mempty timeCell submissionRatingTime
 
+colPseudonyms :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
+    lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo ->
+      cell [whamlet|#{review pseudonymText pseudo}|]
+  in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+
+colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), a))))
+colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone & cellTooltip MsgRatingPointsDone) $ formCell
+  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
+  (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
+      NotGraded -> over (_1.mapped) ((_1 .~) . fmap Left) . over _2 fvInput <$> mopt checkBoxField "" (Just . Just $ isJust submissionRatingPoints)
+      _other -> over (_1.mapped) ((_1 .~) . fmap Right) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints)
+  )
+
+colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Text))))
+colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
+  (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
+  (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_2 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
 
 
 type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
             
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
-                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
-makeCorrectionsTable whereClause colChoices psValidator = do
+makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
   let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
       dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
         E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
@@ -191,18 +216,20 @@ makeCorrectionsTable whereClause colChoices psValidator = do
                     )
         return (submission, sheet, crse, corrector)
       dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
-      dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
+      dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
-        submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+        submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
+          E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
+           E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
           E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
           E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
           E.orderBy [E.asc $ user E.^. UserId]
-          return user
+          return (user, pseudonym E.?. SheetPseudonymPseudonym)
         let
-          submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors
+          submittorMap = foldr (\((Entity userId user, E.Value pseudo)) -> Map.insert userId (user, pseudo)) Map.empty submittors
-        return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
+        dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
   dbTable psValidator $ DBTable
     { dbtSQLQuery
-    , dbtColonnade = colChoices
+    , dbtColonnade
     , dbtProj
     , dbtSorting   = Map.fromList
       [ ( "term"
@@ -220,6 +247,9 @@ makeCorrectionsTable whereClause colChoices psValidator = do
       , ( "rating"
         , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
         )
+      , ( "ratingtime"
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime
+        )
       ]
     , dbtFilter    = Map.fromList
       [ ( "term"
@@ -267,7 +297,7 @@ data ActionCorrectionsData = CorrDownloadData
 
 correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
 correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
-  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
+  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
   ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
     ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
     (actionRes, action) <- multiAction actions Nothing
@@ -383,6 +413,7 @@ postCorrectionsR = do
         , colTerm
         , colCourse
         , colSheet
+        , colPseudonyms
         , colSubmissionLink
         , colAssigned
         , colRating
@@ -591,6 +622,7 @@ postCorrectionsCreateR = do
     FormMissing -> return ()
     FormFailure errs -> forM_ errs $ addMessage Error . toHtml
     FormSuccess (sid, pss) -> do
+      now <- liftIO getCurrentTime
       runDB $ do
         Sheet{..} <- get404 sid
         (sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
@@ -632,6 +664,7 @@ postCorrectionsCreateR = do
             | otherwise
               -> do
                 subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
                 insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
                     { submissionUserUser = sheetPseudonymUser
                     , submissionUserSubmission = subId
@@ -644,12 +677,14 @@ postCorrectionsCreateR = do
             case (groups :: [E.Value SubmissionGroupId]) of
               [x] -> do
                 subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
                 insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
                     { submissionUserUser = sheetPseudonymUser
                     , submissionUserSubmission = subId
                     }
               [] -> do
                 subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
                 insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
                     { submissionUserUser = sheetPseudonymUser
                     , submissionUserSubmission = subId
@@ -660,17 +695,20 @@ postCorrectionsCreateR = do
             | [SheetPseudonym{sheetPseudonymUser}] <- spGroup
               -> do
                 subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
                 insert_ SubmissionUser
                   { submissionUserUser = sheetPseudonymUser
                   , submissionUserSubmission = subId
                   }
             | otherwise -> do
                 subId <- insert submission
+                void . insert $ SubmissionEdit uid now subId
                 insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
                     { submissionUserUser = sheetPseudonymUser
                     , submissionUserSubmission = subId
                     }               
                 addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
+      redirect CorrectionsGradeR
                 
   
   defaultLayout $ do
@@ -690,3 +728,51 @@ postCorrectionsCreateR = do
              []    -> return $ Right valid
     textFromList :: [[Pseudonym]] -> Textarea
     textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText))
+
+getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
+getCorrectionsGradeR = postCorrectionsGradeR
+postCorrectionsGradeR = do
+  uid <- requireAuthId
+  let whereClause = ratedBy uid
+      displayColumns = mconcat -- should match getSSubsR for consistent UX
+        [ dbRow
+        , colTerm
+        , colCourse
+        , colSheet
+        , colPseudonyms
+        , colSubmissionLink
+        , colRated
+        , colPointsField
+        , colCommentField
+        ] -- Continue here
+      psValidator = def
+        & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Maybe (Either Bool Points), Maybe Text)))
+      unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } -> (bool (Right <$> submissionRatingPoints) (Just . Left $ isJust submissionRatingPoints) $ sheetType == NotGraded, submissionRatingComment)
+  
+  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
+    cID <- encrypt subId
+    void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
+    return i
+  (((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm
+
+  case tableRes of
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    FormSuccess resMap -> do
+      now <- liftIO getCurrentTime
+      subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (mPoints, mComment)) -> do
+        let mPoints' = either (bool Nothing $ return 0) return =<< mPoints
+        Submission{..} <- get404 subId
+        if
+          | submissionRatingPoints /= mPoints' || submissionRatingComment /= mComment
+            -> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints'
+                                          , SubmissionRatingComment =. mComment
+                                          , SubmissionRatingBy =. Just uid
+                                          , SubmissionRatingTime =. now <$ (void mPoints' <|> void mComment)
+                                          ]
+          | otherwise -> return $ Nothing
+      subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
+      unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
+
+  defaultLayout $ do
+    $(widgetFile "corrections-grade")

src/Handler/Home.hs

@@ -117,10 +117,10 @@ homeAnonymous = do
     , dbtStyle     = def
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
-  let features = $(widgetFile "featureList")
+  -- let features = $(widgetFile "featureList")
-  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
+  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
   defaultLayout $ do
-    $(widgetFile "dsgvDisclaimer")
+    -- $(widgetFile "dsgvDisclaimer")
     $(widgetFile "home")
 
 homeUser :: Key User -> Handler Html
@@ -218,11 +218,11 @@ homeUser uid = do
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
-  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
+  -- addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
   defaultLayout $ do
     -- setTitle "Willkommen zum Uni2work Test!"
     $(widgetFile "homeUser")
-    $(widgetFile "dsgvDisclaimer")
+    -- $(widgetFile "dsgvDisclaimer")
 
 
 getVersionR :: Handler TypedContent

src/Handler/SystemMessage.hs

@@ -1,12 +1,39 @@
 {-# LANGUAGE NoImplicitPrelude
            , RecordWildCards
            , TemplateHaskell
+           , NamedFieldPuns
+           , RecordWildCards
+           , OverloadedStrings
+           , TypeFamilies
+           , ViewPatterns
+           , FlexibleContexts
+           , LambdaCase
+           , MultiParamTypeClasses
   #-}
 
 module Handler.SystemMessage where
 
 import Import
 
+import qualified Data.Map.Lazy as Map
+import qualified Data.Text as Text
+
+import qualified Data.Set as Set
+
+import qualified Data.List.NonEmpty as NonEmpty
+
+import Handler.Utils
+
+import Utils.Lens
+
+  
+htmlField' :: Field (HandlerT UniWorX IO) Html
+htmlField' = htmlField
+  { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
+  }
+
+ 
+
 getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
 getMessageR = postMessageR
 postMessageR cID = do
@@ -15,5 +42,202 @@ postMessageR cID = do
   let (summary, content) = case translation of
         Nothing -> (systemMessageSummary, systemMessageContent)
         Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
+
+  let
+    mkForm :: Handler (((FormResult SystemMessage, Widget), Enctype), Map Lang ((FormResult (Entity SystemMessageTranslation, [Maybe BtnSubmitDelete]), Widget), Enctype), ((FormResult SystemMessageTranslation, Widget), Enctype))
+    mkForm = do
+      modifyRes'@((modifyRes, _), _) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard
+        $ SystemMessage
+          <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
+          <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
+          <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
+          <*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
+          <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage)
+          <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent)
+          <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageSummary)
+          <* submitButton
+
+      ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
+      let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts
+
+      modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
+        cID' <- encrypt tId
+        runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
+          $ (,)
+          <$> ( fmap (Entity tId) $ SystemMessageTranslation
+                <$> pure systemMessageTranslationMessage
+                <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
+                <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
+                <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
+              )
+          <*> combinedButtonField (universeF :: [BtnSubmitDelete])
+
+      let modifyTranss = Map.map (view $ _1._1) modifyTranss'
+
+      addTransRes'@((addTransRes, _), _) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard
+        $ SystemMessageTranslation
+          <$> pure smId
+          <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
+          <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
+          <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
+          <* submitButton
+
+      formResult modifyRes $ \SystemMessage{..} -> do
+        runDB $ update smId
+          [ SystemMessageFrom =. systemMessageFrom
+          , SystemMessageTo =. systemMessageTo
+          , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
+          , SystemMessageSeverity =. systemMessageSeverity
+          , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
+          , SystemMessageContent =. systemMessageContent
+          , SystemMessageSummary =. systemMessageSummary
+          ]
+        addMessageI Success MsgSystemMessageEditSuccess
+        redirect $ MessageR cID
+
+      formResult addTransRes $ \smt -> do
+        runDB . void . insert $ smt
+        addMessageI Success MsgSystemMessageAddTranslationSuccess
+        redirect $ MessageR cID
+
+      forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of
+        [BtnDelete'] -> do
+          runDB $ delete tId
+          addMessageI Success MsgSystemMessageDeleteTranslationSuccess
+          redirect $ MessageR cID
+        _other -> do
+          runDB $ update tId
+            [ SystemMessageTranslationLanguage =. systemMessageTranslationLanguage
+            , SystemMessageTranslationContent =. systemMessageTranslationContent
+            , SystemMessageTranslationSummary =. systemMessageTranslationSummary
+            ]
+          addMessageI Success MsgSystemMessageEditTranslationSuccess
+          redirect $ MessageR cID
+  
+      return (modifyRes', modifyTranss', addTransRes')
+
+  maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
+  forms <- traverse (const mkForm) $ () <$ guard maySubmit
+  
   defaultLayout $ do
     $(widgetFile "system-message")
+
+
+type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation)
+
+data ActionSystemMessage = SMDelete | SMActivate | SMDeactivate
+  deriving (Eq, Ord, Enum, Bounded, Show, Read)
+instance Universe ActionSystemMessage
+instance Finite ActionSystemMessage
+$(return [])
+instance PathPiece ActionSystemMessage where
+  toPathPiece = $(nullaryToPathPiece ''ActionSystemMessage [ Text.intercalate "-" . drop 1 . splitCamel ])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX ActionSystemMessage where
+  renderMessage m ls = renderMessage m ls . \case
+    SMDelete -> MsgSystemMessageDelete
+    SMActivate -> MsgSystemMessageActivate
+    SMDeactivate -> MsgSystemMessageDeactivate
+
+data ActionSystemMessageData = SMDDelete
+                             | SMDActivate (Maybe UTCTime)
+                             | SMDDeactivate (Maybe UTCTime)
+  deriving (Eq, Show, Read)
+
+getMessageListR, postMessageListR :: Handler Html
+getMessageListR = postMessageListR
+postMessageListR = do
+  let
+    dbtSQLQuery = return
+    dbtColonnade = mconcat
+      [ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
+      , dbRow
+      , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (toWidget . tshow . ciphertext)
+      , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
+      , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
+      , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
+      , sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
+      , sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let
+          (summary, content) = case smT of
+              Nothing -> (systemMessageSummary, systemMessageContent)
+              Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
+            in cell . toWidget $ fromMaybe content summary
+      ]
+    dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
+      Just (_, smT) <- lift $ getSystemMessage appLanguages smId
+      return $ DBRow
+        { dbrOutput = (smE, smT)
+        , ..
+        }
+    psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
+  tableForm <- dbTable psValidator $ DBTable
+    { dbtSQLQuery
+    , dbtColonnade
+    , dbtProj
+    , dbtSorting = Map.fromList
+      [ -- TODO: from, to, authenticated, severity
+      ]
+    , dbtFilter = Map.fromList
+      [
+      ]
+    , dbtStyle = def
+    , dbtIdent = "messages" :: Text
+    }
+  ((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
+    ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
+    now <- liftIO $ getCurrentTime
+    let actions = Map.fromList
+          [ (SMDelete, pure SMDDelete)
+          , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
+          , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
+          ]
+    (actionRes, action) <- multiAction actions (Just SMActivate)
+    $logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
+    return ((,) <$> actionRes <*> selectionRes, table <> action)
+
+  case tableRes of
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    FormSuccess (SMDDelete, selection)
+      | not $ null selection -> do
+          selection' <- traverse decrypt $ Set.toList selection
+          runDB $ deleteCascadeWhere [ SystemMessageId <-. selection' ]
+          $(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet")
+          redirect MessageListR
+    FormSuccess (SMDActivate ts, selection)
+      | not $ null selection -> do
+          selection' <- traverse decrypt $ Set.toList selection
+          runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ]
+          $(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet")
+          redirect MessageListR
+    FormSuccess (SMDDeactivate ts, selection)
+      | not $ null selection -> do
+          selection' <- traverse decrypt $ Set.toList selection
+          runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ]
+          $(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet")
+          redirect MessageListR
+    FormSuccess (_, selection)
+      | null selection -> addMessageI Error MsgSystemMessageEmptySelection
+
+  ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
+    <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
+    <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
+    <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
+    <*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) Nothing
+    <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages)
+    <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
+    <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
+    <* submitButton
+
+  case addRes of
+    FormMissing -> return ()
+    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
+    FormSuccess sysMsg -> do
+      sId <- runDB $ insert sysMsg
+      cID <- encrypt sId :: Handler CryptoUUIDSystemMessage
+      addMessageI Success $ MsgSystemMessageAdded cID
+      redirect $ MessageR cID
+
+  defaultLayout $ do
+    $(widgetFile "system-message-list")

src/Handler/Utils/Form.hs

@@ -108,6 +108,25 @@ instance Button UniWorX AdminHijackUserButton where
 
   cssClass BtnHijack = BCDefault
 
+data BtnSubmitDelete = BtnSubmit' | BtnDelete'
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance Universe BtnSubmitDelete
+instance Finite BtnSubmitDelete
+
+instance Button UniWorX BtnSubmitDelete where
+  label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|]
+  label BtnDelete' = [whamlet|_{MsgBtnDelete}|]
+
+  cssClass BtnSubmit' = BCPrimary
+  cssClass BtnDelete' = BCDanger
+
+$(return [])
+
+instance PathPiece BtnSubmitDelete where
+  toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ])
+  fromPathPiece = finiteFromPathPiece
+
 
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
 -- data LinkButton = LinkButton (Route UniWorX)
@@ -471,6 +490,11 @@ utcTimeField = Field
         (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
         Nothing -> Left MsgInvalidDateTimeFormat
 
+langField :: Bool -- ^ Only allow values from `appLanguages`
+          -> Field (HandlerT UniWorX IO) Lang
+langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
+langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
+
 
 fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
 fsm = bfs -- TODO: get rid of Bootstrap

src/Handler/Utils/Table/Pagination.hs

@@ -35,7 +35,7 @@ module Handler.Utils.Table.Pagination
   , widgetColonnade, formColonnade, dbColonnade
   , cell, textCell, stringCell, i18nCell
   , anchorCell, anchorCell', anchorCellM, anchorCellM'
-  , tickmarkCell
+  , tickmarkCell, cellTooltip
   , listCell
   , formCell, DBFormResult, getDBFormResult
   , dbRow, dbSelect
@@ -339,8 +339,8 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   
   -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
   --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
-  dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent
+  dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
-  dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf
+  dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> form csrf
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
   -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
   -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
@@ -499,6 +499,15 @@ tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
 tickmarkCell True  = textCell (tickmark :: Text)
 tickmarkCell False = mempty
 
+cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
+cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt)
+  where
+    tipWdgt = [whamlet|
+        <div .js-tooltip>
+          <div .tooltip__handle>
+          <div .tooltip__content>_{msg}
+      |]
+
 
 anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
 anchorCell = anchorCellM . return

src/Import/NoFoundation.hs

@@ -1,9 +1,10 @@
 {-# LANGUAGE CPP #-}
 module Import.NoFoundation
     ( module Import
+    , MForm
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import
@@ -37,3 +38,10 @@ 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(..))
+
+
+import Control.Monad.Trans.RWS (RWST)
+
+type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m

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/Form.hs

@@ -15,7 +15,7 @@
 
 module Utils.Form where
 
-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (addMessage)
 import Settings
 
 import qualified Text.Blaze.Internal as Blaze (null)
@@ -33,6 +33,10 @@ import Data.List ((!!))
 
 import Web.PathPieces
 
+import Data.UUID
+
+import Utils.Message
+
 -------------------
 -- Form Renderer --
 -------------------
@@ -150,8 +154,22 @@ noValidate = addAttr "formnovalidate" ""
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
+data FormIdentifier
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+  = FIDcourse
+  | FIDsheet
+  | FIDsubmission
+  | FIDsettings
+  | FIDcorrectors
+  | FIDcorrectorTable
+  | FIDcorrection
+  | FIDcorrectionsUpload
+  | FIDcorrectionUpload
+  | FIDSystemMessageAdd
+  | FIDSystemMessageTable
+  | FIDSystemMessageModify
+  | FIDSystemMessageModifyTranslation UUID
+  | FIDSystemMessageAddTranslation
+  deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
   fromPathPiece = readFromPathPiece
@@ -260,3 +278,12 @@ reorderField optList = Field{..}
         nums = map (id &&& withNum theId) [1..length olOptions]
         withNum t n = tshow n <> "." <> t
       $(widgetFile "widgets/permutation")
+
+---------------------
+-- Form evaluation --
+---------------------
+
+formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
+formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml
+formResult  FormMissing       _ = return ()
+formResult (FormSuccess res)  f = f res

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)

src/index.md

@@ -103,6 +103,43 @@ Jobs
     
 Jobs.Types
   : `Job`, `Notification`, `JobCtl` Types of Jobs
+  
+Cron.Types
+  : Datentypen zur Spezifikation von Intervallen zu denen Jobs ausgeführt werden
+    können:
+  
+    `Cron`, `CronMatch`, `CronAbsolute`, `CronRepeat`, `Crontab`
+    
+Cron
+  : Seiteneffektfreie Berechnungen auf Typen aus `Cron.Types`: `nextCronMatch`
+  
+Jobs.Queue
+  : Funktionen zum _anstoßen_ von Jobs und zur Kommunikation mit den
+    Worker-Threads
+  
+    `writeJobCtl` schickt Nachricht an einen pseudo-Zufälligen worker-thread der
+    lokalen Instanz
+    
+    `queueJob` und `queueJob'` schreiben neue Jobs in die Instanz-übergreifende
+    Job-Queue, `queueJob'` stößt außerdem einen lokalen worker-thread an sich
+    des Jobs anzunehmen
+    
+    `runDBJobs` ersetzt `runDB` und erlaubt `queueDBJob` zu
+    benutzen. `queueDBJob` schreibt einen Job in die Queue; am Ende stößt
+    `runDBJobs` lokale worker-threads für alle mit `queueDBJobs` eingetragenen
+    Jobs an.
+    
+Jobs.TH
+  : Templatehaskell für den dispatch mechanismus für `Jobs`
+  
+Jobs.Crontab
+  : Generiert `Crontab JobCtl` aus der Datenbank (sammelt alle in den Daten aus
+    der Datenbank impliziten Jobs (notifications zu bestimmten zeiten,
+    aufräumaktionen, ...) ein)
+    
+Jobs.Handler.**
+  : Via `Jobs.TH` delegiert `Jobs` das Interpretieren und Ausführen eines Werts
+    aus `Jobs.Types` an einen dieser Handler
 
 Mail
   : Monadically constructing MIME emails

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/corrections-grade.hamlet

@@ -0,0 +1,5 @@
+<div .container>
+  <form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
+    ^{table}
+    <button type=submit>
+      _{MsgBtnSubmit}

templates/help.hamlet

@@ -1,5 +1,4 @@
-
+_{MsgHelpIntroduction}
-Bitte beschreiben Sie Ihr Problem:
 
 <form method=post action=@{HelpR} enctype=#{formEnctype}>
    ^{formWidget}

templates/home.hamlet

@@ -1,11 +1,5 @@
 <div .container>
-
+  <h2>
-  <h1>
     Kurse mit offener Registrierung
   <div .container>
     ^{courseTable}
-
-  <h3>
-    Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
-
-  ^{features}

templates/homeUser.hamlet

@@ -1,13 +1,10 @@
 <div .container>
-  <h3>
+  <h2>
-    Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
-
-<div .container>
-  <h1>
     Anstehende Übungsblätter
   <div .container>
     ^{sheetTable}
 
+<!--
 <div .container>
   <h1>
     Anstehende Klausuren
@@ -17,3 +14,4 @@
   <h1>
     Anstehende Kursanmeldungen
   TODO
+-->

templates/mail/support.hamlet

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

templates/messages/systemMessagesDeleted.hamlet

@@ -0,0 +1,6 @@
+_{MsgSystemMessagesDeleted}
+
+<ul>
+  $forall sel <- selection
+    <li style="white-space: nowrap">
+      #{toPathPiece sel}

templates/messages/systemMessagesSetFrom.hamlet

@@ -0,0 +1,6 @@
+_{MsgSystemMessagesActivated}
+
+<ul>
+  $forall sel <- selection
+    <li style="white-space: nowrap">
+      #{toPathPiece sel}

templates/messages/systemMessagesSetTo.hamlet

@@ -0,0 +1,6 @@
+_{MsgSystemMessagesDeactivated}
+
+<ul>
+  $forall sel <- selection
+    <li style="white-space: nowrap">
+      #{toPathPiece sel}

templates/standalone/modal.lucius

@@ -16,11 +16,13 @@
   overflow: auto;
   opacity: 0;
   transition: all .15s ease;
+  pointer-events: none;
 
   &.modal--open {
     opacity: 1;
     z-index: 200;
     transform: translate(-50%, -50%) scale(1, 1);
+    pointer-events: all;
   }
 }
 

templates/submission.hamlet

@@ -13,7 +13,7 @@ $maybe cID <- mcid
         <p>
           _{MsgSubmissionNoUploadExpected}
 
-    $if not (null lastEdits)
+    $if maySubmit && not (null lastEdits)
       <h3>_{MsgLastEdits}
       <ul>
         $forall (mbName,time) <- lastEdits

templates/system-message-list.hamlet

@@ -0,0 +1,9 @@
+<section>
+  <form method=post action=@{MessageListR} encytpe=#{tableEncoding}>
+    ^{tableView}
+    <button type=submit>
+      _{MsgBtnSubmit}
+
+<section>
+  <form method=post action=@{MessageListR} enctype=#{addEncoding}>
+    ^{addView}

templates/system-message.hamlet

@@ -4,3 +4,21 @@
       #{summary'}
   <p>
     #{content}
+
+$maybe (((_, modifyView), modifyEnctype), modifyTranss, ((_, addTransView), addTransEnctype)) <- forms
+  <section>
+    <h2>_{MsgSystemMessageEdit}
+    <form method=post action=@{MessageR cID} enctype=#{modifyEnctype}>
+      ^{modifyView}
+
+  <section>
+    <h2>_{MsgSystemMessageAddTranslation}
+    <form method=post action=@{MessageR cID} enctype=#{addTransEnctype}>
+      ^{addTransView}
+  
+  $if not (null modifyTranss)
+    <section>
+      <h2>_{MsgSystemMessageEditTranslations}
+      $forall ((_, transView), transEnctype) <- modifyTranss
+        <form method=post action=@{MessageR cID} enctype=#{transEnctype}>
+          ^{transView}

templates/versionHistory.hamlet

@@ -10,11 +10,11 @@
       Bekannte Bugs
     <ul>
       <li>
-        Umlaute in Benutzernamen werden durch externes LDAP-Plugin entfernt
+        Login ist u.U. anders als im alten System, z.B. <span style="font-family:monospace">@campus.lmu.de</span> statt <span style="font-family:monospace">@lmu.de</span>
       <li>
-        Auswahlbox "alle markieren" fehlt noch
+        Favicon ist default des Frameworks
       <li>
-        Tabellen über mehrere Seiten müssen vor Seitenwechsel manuell sortiert werden
+        Format von Bewertungsdateien ist provisorisch
 
   <section>
     <h2>
@@ -26,7 +26,7 @@
     <h2>
       Impressum
 
-    <ul>
+    <ul style="list-style-type: none">
       <li>
         Dr Steffen Jost
       <li>