Merge branch '21-support-for-notifications-and-emails-in-general' into 'master'

Resolve "Support for Notifications and emails in general"

See merge request !81

.gitignore

@@ -29,6 +29,7 @@ uniworx.nix
 src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
 *.orig
+/instance
 .stack-work-*
 .directory
 tags

app/DevelMain.hs

@@ -33,13 +33,15 @@ module DevelMain where
 import Prelude
 import Application (getApplicationRepl, shutdownApp)
 
-import Control.Exception (finally)
+import Control.Monad.Catch (finally)
 import Control.Monad ((>=>))
 import Control.Concurrent
 import Data.IORef
 import Foreign.Store
 import Network.Wai.Handler.Warp
 import GHC.Word
+import Control.Monad.Trans.Resource
+import Control.Monad.IO.Class
 
 -- | Start or restart the server.
 -- newStore is from foreign-store.
@@ -71,13 +73,14 @@ update = do
     -- | Start the server in a separate thread.
     start :: MVar () -- ^ Written to when the thread is killed.
           -> IO ThreadId
-    start done = do
+    start done = runResourceT $ do
-        (port, site, app) <- getApplicationRepl
+      (port, site, app) <- getApplicationRepl
-        forkIO (finally (runSettings (setPort port defaultSettings) app)
+      resourceForkIO $ do
-                        -- Note that this implies concurrency
+        finally (liftIO $ runSettings (setPort port defaultSettings) app)
-                        -- between shutdownApp and the next app that is starting.
+          -- Note that this implies concurrency
-                        -- Normally this should be fine
+          -- between shutdownApp and the next app that is starting.
-                        (putMVar done () >> shutdownApp site))
+          -- Normally this should be fine
+          (liftIO $ putMVar done () >> shutdownApp site)
 
 -- | kill the server
 shutdown :: IO ()

config/keter_testworx.yml

@@ -31,9 +31,21 @@ stanzas:
       - DUMMY_LOGIN
       - DETAILED_LOGGING
       - LOG_ALL
+      - LOGLEVEL
+      - ALLOW_DEPRECATED
       - PWFILE
       - CRYPTOID_KEYFILE
       - IP_FROM_HEADER
+      - MAILFROM_NAME
+      - MAILFROM_EMAIL
+      - MAILOBJECT_DOMAIN
+      - SMTPHOST
+      - SMTPPORT
+      - SMTPSSL
+      - SMTPUSER
+      - SMTPPASS
+      - SMTPTIMEOUT
+      - SMTPLIMIT
 
 # Use the following to automatically copy your bundle upon creation via `yesod
 # keter`. Uses `scp` internally, so you can set it to a remote destination

config/keter_uni2work.yml

@@ -30,9 +30,22 @@ stanzas:
       - LDAPTIMEOUT
       - DETAILED_LOGGING
       - LOG_ALL
+      - LOGLEVEL
+      - ALLOW_DEPRECATED
       - PWFILE
       - CRYPTOID_KEYFILE
       - IP_FROM_HEADER
+      - MAILFROM_NAME
+      - MAILFROM_EMAIL
+      - MAILOBJECT_DOMAIN
+      - SMTPHOST
+      - SMTPPORT
+      - SMTPSSL
+      - SMTPUSER
+      - SMTPPASS
+      - SMTPTIMEOUT
+      - SMTPLIMIT
+
 
 # Use the following to automatically copy your bundle upon creation via `yesod
 # keter`. Uses `scp` internally, so you can set it to a remote destination

config/settings.yml

@@ -8,6 +8,19 @@ host:           "_env:HOST:*4" # any IPv4 host
 port:           "_env:PORT:3000"
 ip-from-header: "_env:IP_FROM_HEADER:false"
 approot:        "_env:APPROOT:http://localhost:3000"
+mail-from:
+  name:         "_env:MAILFROM_NAME:Uni2Work"
+  email:        "_env:MAILFROM_EMAIL:uniworx@localhost"
+mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
+mail-verp:
+  separator:    "+"
+  at-replacement: "="
+
+job-workers:        "_env:JOB_WORKERS:10"
+job-flush-interval: "_env:JOB_FLUSH:30"
+job-cron-interval:  "_env:CRON_INTERVAL:60"
+job-stale-threshold: 300
+notification-rate-limit: 3600
 
 detailed-logging:  "_env:DETAILED_LOGGING:false"
 should-log-all:    "_env:LOG_ALL:false"
@@ -44,6 +57,19 @@ ldap:
   scope:   "_env:LDAPSCOPE:WholeSubtree"
   timeout: "_env:LDAPTIMEOUT:5"
 
+smtp:
+  host:    "_env:SMTPHOST:"
+  port:    "_env:SMTPPORT:25"
+  ssl:     "_env:SMTPSSL:starttls"
+  auth:
+    type:  "login"
+    user:  "_env:SMTPUSER:"
+    pass:  "_env:SMTPPASS:"
+  pool:
+    stripes: "_env:SMTPSTRIPES:1"
+    timeout: "_env:SMTPTIMEOUT:20"
+    limit: "_env:SMTPLIMIT:10"
+
 user-defaults:
   max-favourites:   12
   theme:            Default
@@ -53,3 +79,4 @@ user-defaults:
   download-files:   false
 
 cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
+instance-idfile: "_env:INSTANCEID_FILE:instance"

db.hs

@@ -1,11 +1,12 @@
 #!/usr/bin/env stack
--- stack runghc
+-- stack runghc --package uniworx
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
 
 import "uniworx" Import hiding (Option(..))
 import "uniworx" Application (db, getAppDevSettings)
@@ -20,6 +21,8 @@ import System.IO (hPutStrLn, stderr)
 
 import qualified Data.ByteString as BS
 
+import Database.Persist.Sql (toSqlKey)
+
 import Data.Time
 
 
@@ -62,6 +65,8 @@ fillDb = do
   AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
   now <- liftIO getCurrentTime
   let
+    insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)
+    insert' = fmap (either entityKey id) . insertBy
     summer2017 = TermIdentifier 2017 Summer
     winter2017 = TermIdentifier 2017 Winter
     summer2018 = TermIdentifier 2018 Summer
@@ -78,6 +83,8 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["en"]
+    , userNotificationSettings = def
     }
   fhamann <- insert User
     { userIdent  = "felix.hamann@campus.lmu.de"
@@ -92,6 +99,8 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
+    , userNotificationSettings = def
     }
   jost <- insert User
     { userIdent  = "jost@tcs.ifi.lmu.de"
@@ -106,6 +115,8 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
+    , userNotificationSettings = def
     }
   void . insert $ User
     { userIdent  = "max@campus.lmu.de"
@@ -120,6 +131,8 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
+    , userNotificationSettings = def
     }
   void . insert $ User
     { userIdent  = "tester@campus.lmu.de"
@@ -134,8 +147,10 @@ fillDb = do
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
+    , userMailLanguages = MailLanguages ["de"]
+    , userNotificationSettings = def
     }
-  void . insert $ Term
+  void . repsert (TermKey summer2017) $ Term
     { termName     = summer2017
     , termStart    = fromGregorian 2017 04 09
     , termEnd      = fromGregorian 2017 07 14
@@ -144,7 +159,7 @@ fillDb = do
     , termLectureEnd   = fromGregorian 2018 07 14
     , termActive       = False
     }
-  void . insert $ Term
+  void . repsert (TermKey winter2017) $ Term
     { termName     = winter2017
     , termStart    = fromGregorian 2017 10 16
     , termEnd      = fromGregorian 2018 02 10
@@ -153,7 +168,7 @@ fillDb = do
     , termLectureEnd   = fromGregorian 2018 02 10
     , termActive       = True
     }
-  void . insert $ Term
+  void . repsert (TermKey summer2018) $ Term
     { termName     = summer2018
     , termStart    = fromGregorian 2018 04 09
     , termEnd      = fromGregorian 2018 07 14
@@ -162,22 +177,28 @@ fillDb = do
     , termLectureEnd   = fromGregorian 2018 07 14
     , termActive       = True
     }
-  ifi <- insert $ School "Institut für Informatik" "IfI"
+  ifi <- insert' $ School "Institut für Informatik" "IfI"
-  mi <- insert $ School "Institut für Mathematik" "MI"
+  mi <- insert' $ School "Institut für Mathematik" "MI"
-  void . insert $ UserAdmin gkleen ifi
+  void . insert' $ UserAdmin gkleen ifi
-  void . insert $ UserAdmin gkleen mi
+  void . insert' $ UserAdmin gkleen mi
-  void . insert $ UserAdmin fhamann ifi
+  void . insert' $ UserAdmin fhamann ifi
-  void . insert $ UserAdmin jost ifi
+  void . insert' $ UserAdmin jost ifi
-  void . insert $ UserAdmin jost mi
+  void . insert' $ UserAdmin jost mi
-  void . insert $ UserLecturer gkleen ifi
+  void . insert' $ UserLecturer gkleen ifi
-  void . insert $ UserLecturer fhamann ifi
+  void . insert' $ UserLecturer fhamann ifi
-  void . insert $ UserLecturer jost ifi
+  void . insert' $ UserLecturer jost ifi
-  sdBsc  <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor"  )
+  let
-  sdMst  <- insert $ StudyDegree 88 (Just "MSc") (Just "Master"    )
+    sdBsc = StudyDegreeKey' 82
-  sdInf  <- insert $ StudyTerms  79 (Just "Inf") (Just "Informatik")
+    sdMst = StudyDegreeKey' 88
-  sdMath <- insert $ StudyTerms 105 (Just "M"  ) (Just "Mathematik")
+  repsert sdBsc  $ StudyDegree 82 (Just "BSc") (Just "Bachelor"  )
+  repsert sdMst  $ StudyDegree 88 (Just "MSc") (Just "Master"    )
+  let
+    sdInf  = StudyTermsKey' 79
+    sdMath = StudyTermsKey' 105
+  repsert sdInf  $ StudyTerms  79 (Just "Inf") (Just "Informatik")
+  repsert sdMath $ StudyTerms 105 (Just "M"  ) (Just "Mathematik")
   -- FFP
-  ffp <- insert Course
+  ffp <- insert' Course
     { courseName = "Fortgeschrittene Funktionale Programmierung"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -203,7 +224,7 @@ fillDb = do
   sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
   -- EIP
-  eip <- insert Course
+  eip <- insert' Course
     { courseName = "Einführung in die Programmierung"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -218,10 +239,10 @@ fillDb = do
     , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now eip
-  void . insert $ DegreeCourse eip sdBsc sdInf
+  void . insert' $ DegreeCourse eip sdBsc sdInf
-  void . insert $ Lecturer fhamann eip
+  void . insert' $ Lecturer fhamann eip
   -- interaction design
-  ixd <- insert Course
+  ixd <- insert' Course
     { courseName = "Interaction Design (User Experience Design I & II)"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -236,10 +257,10 @@ fillDb = do
     , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now ixd
-  void . insert $ DegreeCourse ixd sdBsc sdInf
+  void . insert' $ DegreeCourse ixd sdBsc sdInf
-  void . insert $ Lecturer fhamann ixd
+  void . insert' $ Lecturer fhamann ixd
   -- concept development
-  ux3 <- insert Course
+  ux3 <- insert' Course
     { courseName = "Concept Development (User Experience Design III)"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -254,10 +275,10 @@ fillDb = do
     , courseMaterialFree    = True
     }
   insert_ $ CourseEdit fhamann now ux3
-  void . insert $ DegreeCourse ux3 sdBsc sdInf
+  void . insert' $ DegreeCourse ux3 sdBsc sdInf
-  void . insert $ Lecturer fhamann ux3
+  void . insert' $ Lecturer fhamann ux3
   -- promo
-  pmo <- insert Course
+  pmo <- insert' Course
     { courseName = "Programmierung und Modellierung"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -298,7 +319,7 @@ fillDb = do
   void . insert $ SheetFile sh1 h103 SheetSolution
   void . insert $ SheetFile sh1 pdf10 SheetExercise
   -- datenbanksysteme
-  dbs <- insert Course
+  dbs <- insert' Course
     { courseName = "Datenbanksysteme"
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
@@ -313,7 +334,7 @@ fillDb = do
     , courseMaterialFree    = True
     }
   insert_ $ CourseEdit gkleen now dbs
-  void . insert $ DegreeCourse dbs sdBsc sdInf
+  void . insert' $ DegreeCourse dbs sdBsc sdInf
-  void . insert $ DegreeCourse dbs sdBsc sdMath
+  void . insert' $ DegreeCourse dbs sdBsc sdMath
-  void . insert $ Lecturer gkleen dbs
+  void . insert' $ Lecturer gkleen dbs
-  void . insert $ Lecturer jost   dbs
+  void . insert' $ Lecturer jost   dbs

ghci.sh

@@ -16,4 +16,4 @@ if [[ -d .stack-work-ghci ]]; then
     trap move-back EXIT
 fi
 
-stack ghci --flag uniworx:dev --flag uniworx:library-only
+stack ghci --flag uniworx:dev --flag uniworx:library-only ${@}

messages/uniworx/de.msg

@@ -245,6 +245,7 @@ RatingComment: Kommentar
 SubmissionUsers: Studenten
 Rating: Korrektur
 RatingPoints: Punkte
+RatingDone: Bewertung fertiggestellt
 RatingPercent: Erreicht
 RatingFiles: Korrigierte Dateien
 PointsNotPositive: Punktzahl darf nicht negativ sein
@@ -274,6 +275,7 @@ DateFormat: Datumsformat
 TimeFormat: Uhrzeitformat
 DownloadFiles: Dateien automatisch herunterladen
 DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
+NotificationSettings: Erwünschte Benachrichtigungen
 
 InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
 AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren
@@ -309,3 +311,47 @@ SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
 
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
+
+MailTestFormEmail: Email-Addresse
+MailTestFormLanguages: Spracheinstellungen
+
+MailTestSubject: Uni2Work Test-Email
+MailTestContent: Dies ist eine Test-Email versandt von Uni2Work. Von Ihrer Seite ist keine Handlung notwendig.
+MailTestDateTime: Test der Datumsformattierung:
+
+German: Deutsch
+GermanGermany: Deutsch (Deutschland)
+
+MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert
+MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert.
+
+MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
+MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
+
+MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
+MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Dia Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
+
+SheetTypeBonus: Bonus
+SheetTypeNormal: Normal
+SheetTypePass: Bestehen
+SheetTypeNotGraded: Keine Wertung
+
+SheetTypeBonus' maxPoints@Points: #{tshow maxPoints} Bonuspunkte
+SheetTypeNormal' maxPoints@Points: #{tshow maxPoints} Punkte
+SheetTypePass' maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
+SheetTypeNotGraded': Nicht gewertet
+
+SheetTypeMaxPoints: Maximalpunktzahl
+SheetTypePassingPoints: Notwendig zum Bestehen
+
+SheetGroupArbitrary: Arbiträre Gruppen
+SheetGroupRegisteredGroups: Registrierte Gruppen
+SheetGroupNoGroups: Keine Gruppenabgabe
+SheetGroupMaxGroupsize: Maximale Gruppengröße
+
+SheetFiles: Übungsblatt-Dateien
+
+NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
+NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
+NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
+NotificationTriggerSheetInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben

models

@@ -11,6 +11,8 @@ User json
     dateFormat     DateTimeFormat "default='%d.%m.%Y'"
     timeFormat     DateTimeFormat "default='%R'"
     downloadFiles  Bool default=false
+    mailLanguages  MailLanguages "default='[]'"
+    notificationSettings NotificationSettings
     UniqueAuthentication ident
     UniqueEmail email
     deriving Show
@@ -221,3 +223,15 @@ Exam
 --    -- CONTINUE HERE: Include rating in this table or separately?
 --    UniqueExamUser user   examId
 -- By default this file is used in Model.hs (which is imported by Foundation.hs)
+QueuedJob
+    content             Value
+    creationInstance    InstanceId
+    creationTime        UTCTime
+    lockInstance        InstanceId Maybe
+    lockTime            UTCTime Maybe
+    deriving Eq Read Show Generic Typeable
+CronLastExec
+    job                 Value
+    time                UTCTime
+    instance            InstanceId
+    UniqueCronLastExec job

package.yaml

@@ -77,6 +77,9 @@ dependencies:
 - parsec
 - uuid
 - exceptions
+- stm
+- stm-chans
+- stm-conduit
 - lens
 - MonadRandom
 - email-validate
@@ -92,6 +95,15 @@ dependencies:
 - universe-base
 - random-shuffle
 - th-abstraction
+- HaskellNet
+- HaskellNet-SSL
+- network
+- resource-pool
+- mime-mail
+- hashable
+- aeson-pretty
+- resourcet
+- postgresql-simple
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Application.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Application
     ( getApplicationDev, getAppDevSettings
@@ -13,6 +14,7 @@ module Application
     , makeFoundation
     , makeLogWare
     -- * for DevelMain
+    , foundationStoreNum
     , getApplicationRepl
     , shutdownApp
     -- * for GHCI
@@ -21,7 +23,7 @@ module Application
     , addPWEntry
     ) where
 
-import Control.Monad.Logger                 (liftLoc, runLoggingT)
+import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
 import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                              pgPoolSize, runSqlPool)
 import Import
@@ -38,12 +40,30 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
 import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
 
+import Foreign.Store
+
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+
+import System.Directory
+import System.FilePath
+
+import Jobs
+
 import qualified Data.Text.Encoding as Text
 import Yesod.Auth.Util.PasswordStore
 
-import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Yaml as Yaml
 
+import Network.HaskellNet.SSL hiding (Settings)
+import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
+import Data.Pool
+
+import Control.Monad.Trans.Resource
+
+import System.Log.FastLogger.Date
+import qualified Yesod.Core.Types as Yesod (Logger(..))
+  
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.Common
@@ -69,52 +89,107 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
 -- performs initialization and returns a foundation datatype value. This is also
 -- the place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
-makeFoundation :: AppSettings -> IO UniWorX
+makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
 makeFoundation appSettings@(AppSettings{..}) = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
-    appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
+    appLogger <- liftIO $ do
-    appStatic <-
+      tgetter <- newTimeCache "%Y-%m-%d %T %z"
-        (if appMutableStatic then staticDevel else static)
+      loggerSet <- newStdoutLoggerSet defaultBufSize
-        appStaticDir
+      return $ Yesod.Logger loggerSet tgetter
+    appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
 
     appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
+    appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile
+
+    (appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do
+        chan <- newBroadcastTMChan
+        recvChan <- dupTMChan chan
+        return (chan, recvChan)
 
     -- 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
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool = UniWorX {..}
         -- The UniWorX {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
-        tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
+        tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation")
         logFunc = messageLoggerSource tempFoundation appLogger
 
-    -- Create the database connection pool
+    flip runLoggingT logFunc $ do
-    pool <- flip runLoggingT logFunc $ createPostgresqlPool
+      $logDebugS "InstanceID" $ UUID.toText appInstanceID
+      -- $logDebugS "Configuration" $ tshow appSettings
+
+      smtpPool <- traverse createSmtpPool appSmtpConf
+
+      -- Create the database connection pool
+      sqlPool <- createPostgresqlPool
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
+    
+      -- Perform database migration using our application's logging settings.
+      migrateAll `runSqlPool` sqlPool
 
-    -- Perform database migration using our application's logging settings.
+      handleJobs recvChans $ mkFoundation sqlPool smtpPool
-    runLoggingT (runSqlPool migrateAll pool) logFunc
 
-    -- Return the foundation
+      -- Return the foundation
-    return $ mkFoundation pool
+      return $ mkFoundation sqlPool smtpPool
+
+readInstanceIDFile :: MonadIO m => FilePath -> m UUID
+readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
+  where
+    parseBS :: LBS.ByteString -> IO UUID
+    parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString
+    generateInstead :: IOException -> IO UUID
+    generateInstead e
+      | isDoesNotExistError e = do
+          createDirectoryIfMissing True $ takeDirectory idFile
+          instanceId <- UUID.nextRandom
+          LBS.writeFile idFile $ UUID.toByteString instanceId
+          return instanceId
+      | otherwise = throw e
+
+createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
+createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
+  logFunc <- askLoggerIO
+  let
+    withLogging :: LoggingT IO a -> IO a
+    withLogging = flip runLoggingT logFunc
+    
+    mkConnection = withLogging $ do
+      $logInfoS "SMTP" "Opening new connection"
+      liftIO mkConnection'
+    mkConnection'
+      | SmtpSslNone <- smtpSsl = connectSMTPPort smtpHost smtpPort
+      | SmtpSslSmtps <- smtpSsl = connectSMTPSSLWithSettings smtpHost $ defaultSettingsWithPort smtpPort
+      | SmtpSslStarttls <- smtpSsl = connectSMTPSTARTTLSWithSettings smtpHost $ defaultSettingsWithPort smtpPort
+    reapConnection conn = withLogging $ do
+      $logDebugS "SMTP" "Closing connection"
+      liftIO $ closeSMTP conn
+    applyAuth :: SmtpAuthConf -> SMTPConnection -> IO SMTPConnection
+    applyAuth SmtpAuthConf{..} conn = withLogging $ do
+      $logDebugS "SMTP" "Doing authentication"
+      authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn
+      when (not authSuccess) $ do
+        fail "SMTP authentication failed"
+      return conn
+  liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.
-makeApplication :: UniWorX -> IO Application
+makeApplication :: MonadIO m => UniWorX -> m Application
-makeApplication foundation = do
+makeApplication foundation = liftIO $ do
     logWare <- makeLogWare foundation
     -- Create the WAI application and apply middlewares
     appPlain <- toWaiAppPlain foundation
     return $ logWare $ defaultMiddlewaresNoLogging appPlain
 
-makeLogWare :: UniWorX -> IO Middleware
+makeLogWare :: MonadIO m => UniWorX -> m Middleware
-makeLogWare foundation =
+makeLogWare foundation = liftIO $
     mkRequestLogger def
         { outputFormat =
             if appDetailedRequestLogging $ appSettings foundation
@@ -143,26 +218,29 @@ warpSettings foundation =
       defaultSettings
 
 -- | For yesod devel, return the Warp settings and WAI Application.
-getApplicationDev :: IO (Settings, Application)
+getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application)
 getApplicationDev = do
     settings <- getAppDevSettings
     foundation <- makeFoundation settings
-    wsettings <- getDevSettings $ warpSettings foundation
+    wsettings <- liftIO . getDevSettings $ warpSettings foundation
     app <- makeApplication foundation
     return (wsettings, app)
 
-getAppDevSettings :: IO AppSettings
+getAppDevSettings :: MonadIO m => m AppSettings
-getAppDevSettings = loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
+getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
 
 -- | main function for use by yesod devel
 develMain :: IO ()
-develMain = develMainHelper getApplicationDev
+develMain = runResourceT $ do
+  app <- getApplicationDev
+  liftIO . develMainHelper $ return app
 
 -- | The @main@ function for an executable running this site.
-appMain :: IO ()
+appMain :: MonadResourceBase m => m ()
-appMain = do
+appMain = runResourceT $ do
     -- Get the settings from all relevant sources
-    settings <- loadYamlSettingsArgs
+    settings <- liftIO $
+      loadYamlSettingsArgs
         -- fall back to compile-time values, set to [] to require values at runtime
         [configSettingsYmlValue]
 
@@ -176,22 +254,31 @@ appMain = do
     app <- makeApplication foundation
 
     -- Run the application with Warp
-    runSettings (warpSettings foundation) app
+    liftIO $ runSettings (warpSettings foundation) app
 
 
 --------------------------------------------------------------
 -- Functions for DevelMain.hs (a way to run the app from GHCi)
 --------------------------------------------------------------
-getApplicationRepl :: IO (Int, UniWorX, Application)
+foundationStoreNum :: Word32
+foundationStoreNum = 2
+  
+getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
 getApplicationRepl = do
     settings <- getAppDevSettings
     foundation <- makeFoundation settings
-    wsettings <- getDevSettings $ warpSettings foundation
+    wsettings <- liftIO . getDevSettings $ warpSettings foundation
     app1 <- makeApplication foundation
+
+    let foundationStore = Store foundationStoreNum
+    liftIO $ deleteStore foundationStore
+    liftIO $ writeStore foundationStore foundation
+  
     return (getPort wsettings, foundation, app1)
 
-shutdownApp :: UniWorX -> IO ()
+shutdownApp :: MonadIO m => UniWorX -> m ()
-shutdownApp _ = return ()
+shutdownApp UniWorX{..} = do
+  liftIO . atomically $ mapM_ closeTMChan appJobCtl
 
 
 ---------------------------------------------
@@ -200,7 +287,7 @@ shutdownApp _ = return ()
 
 -- | Run a handler
 handler :: Handler a -> IO a
-handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h
+handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
 
 -- | Run DB queries
 db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
@@ -209,7 +296,7 @@ db = handler . runDB
 addPWEntry :: User
            -> Text {-^ Password -}
            -> IO ()
-addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do
+addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
   PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
   (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
   void $ insert User{..}

src/Cron.hs

@@ -0,0 +1,228 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , PatternGuards
+           , ViewPatterns
+           , DeriveFunctor
+           , TemplateHaskell
+           , NamedFieldPuns
+  #-}
+
+module Cron
+  ( CronNextMatch(..)
+  , nextCronMatch
+  , module Cron.Types
+  ) where
+
+import ClassyPrelude
+import Prelude (lcm)
+import Cron.Types
+
+import Data.Time
+import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid)
+import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate, fromWeekDateValid)
+import Data.Time.Zones
+
+import Numeric.Natural
+import Data.Ratio ((%))
+
+import qualified Data.Set as Set
+
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+
+import Utils.Lens.TH
+import Control.Lens
+
+  
+data CronDate = CronDate
+  { cdYear, cdWeekOfYear, cdDayOfYear
+  , cdMonth, cdWeekOfMonth, cdDayOfMonth
+  , cdDayOfWeek
+  , cdHour, cdMinute, cdSecond :: Natural
+  } deriving (Eq, Show, Read)
+
+makeLenses_ ''CronDate
+
+
+evalCronMatch :: CronMatch -> Natural -> Bool
+evalCronMatch CronMatchAny _ = True
+evalCronMatch CronMatchNone _ = False
+evalCronMatch (CronMatchSome set) x = Set.member x $ toNullable set
+evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0
+evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to
+evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x
+evalCronMatch (CronMatchUnion a b) x = evalCronMatch a x || evalCronMatch b x
+
+toCronDate :: LocalTime -> CronDate
+toCronDate LocalTime{..} = CronDate{..}
+  where
+    (fromInteger -> cdYear, fromIntegral -> cdMonth, fromIntegral -> cdDayOfMonth)
+      = toGregorian localDay
+    (_, fromIntegral -> cdDayOfYear)
+      = toOrdinalDate localDay
+    (_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
+      = toWeekDate localDay
+    cdWeekOfMonth = go 1 localDay
+      where
+        go :: Natural -> Day -> Natural
+        go n day
+          | dow /= 4  = go n $ fromWeekDate y w 4 -- According to ISO week of month is determined by Thursday
+          | m == m'   = go (succ n) day'
+          | otherwise = n
+          where
+            (y, w, dow) = toWeekDate day
+            day'
+              | w /= 0 = fromWeekDate y (pred w) dow
+              | otherwise = fromWeekDate (pred y) 53 dow
+            (_, m, _) = toGregorian day
+            (_, m', _) = toGregorian day'
+    TimeOfDay
+      { todHour = fromIntegral -> cdHour
+      , todMin = fromIntegral -> cdMinute
+      , todSec = round -> cdSecond
+      } = localTimeOfDay
+
+consistentCronDate :: CronDate -> Bool
+consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
+  gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth)
+  wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
+  guard $ gDay == wDay
+  oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear)
+  guard $ wDay == oDay
+  guard $ ((==) `on` cdWeekOfMonth) cd (toCronDate $ LocalTime wDay (error "TimeOfDay inspected in toCronDate"))
+  return True
+
+
+data CronNextMatch a = MatchAsap | MatchAt a | MatchNone
+  deriving (Eq, Ord, Show, Read, Functor)
+
+instance Applicative CronNextMatch where
+  pure = MatchAt
+  _ <*> MatchNone = MatchNone
+  MatchNone <*> _ = MatchNone
+  _ <*> MatchAsap = MatchAsap
+  MatchAsap <*> _ = MatchAsap
+  MatchAt f <*> MatchAt x = MatchAt $ f x
+
+instance Alternative CronNextMatch where
+  empty = MatchNone
+  x <|> MatchNone = x
+  MatchNone <|> x = x
+  _ <|> MatchAsap = MatchAsap
+  MatchAsap <|> _ = MatchAsap
+  (MatchAt a) <|> (MatchAt _) = MatchAt a
+  
+
+listToMatch :: [a] -> CronNextMatch a
+listToMatch [] = MatchNone
+listToMatch (t:_) = MatchAt t
+
+genMatch :: Int -- ^ Period
+         -> Bool -- ^ Modular
+         -> Natural -- ^ Start value
+         -> CronMatch
+         -> [Natural]
+genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..]
+genMatch _ _ _ CronMatchNone = []
+genMatch p m _ (CronMatchSome set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set
+genMatch p m st (CronMatchStep step) = do
+  start <- [st..st + step]
+  guard $ (start `mod` step) == 0
+  take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..]
+genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to]
+genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = []
+genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = []
+genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other
+genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other
+genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
+  = genMatch p m st . CronMatchStep $ lcm st1 st2
+genMatch p m st (CronMatchIntersect aGen bGen)
+  | [] <- as' = []
+  | (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen)
+  where
+    as' = genMatch p m st aGen
+    mergeAnd [] _ = []
+    mergeAnd _ [] = []
+    mergeAnd (a:as) (b:bs)
+      | a <  b = mergeAnd as (b:bs)
+      | a == b = a : mergeAnd as bs
+      | a >  b = mergeAnd (a:as) bs
+genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other
+genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other
+genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny
+genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny
+genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen)
+  where
+    merge [] bs = bs
+    merge as [] = as
+    merge (a:as) (b:bs)
+      | a <  b = a : merge as (b:bs)
+      | a == b = a : merge as bs
+      | a >  b = b : merge (a:as) bs
+
+nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
+              -> Maybe UTCTime -- ^ Time of last execution of the job
+              -> UTCTime -- ^ Current time, used only for `CronCalendar`
+              -> Cron
+              -> CronNextMatch UTCTime
+nextCronMatch tz mPrev now c@Cron{..}
+  | isNothing mPrev
+  = execRef now False cronInitial
+  | Just prevT <- mPrev
+  = case cronRepeat of
+      CronRepeatOnChange
+        | not $ matchesCron tz Nothing prevT c
+          -> let
+               cutoffTime = addUTCTime cronRateLimit prevT
+             in case execRef now False cronInitial of
+                  MatchAsap
+                    | now < cutoffTime -> MatchAt cutoffTime
+                  MatchAt ts 
+                    | ts < cutoffTime -> MatchAt cutoffTime
+                  other -> other
+      CronRepeatScheduled cronNext
+        -> case cronNext of
+             CronAsap
+               | addUTCTime cronRateLimit prevT <= now
+                 -> MatchAsap
+               | otherwise
+                 -> MatchAt $ addUTCTime cronRateLimit prevT
+             cronNext
+               -> execRef (addUTCTime cronRateLimit prevT) True cronNext
+      _other -> MatchNone
+  where
+    execRef ref wasExecd cronAbsolute = case cronAbsolute of
+      CronAsap -> MatchAsap
+      CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts }
+        | ref <= ts -> MatchAt ts
+        | not wasExecd -> MatchAsap
+        | otherwise -> MatchNone
+      CronCalendar{..} -> listToMatch $ do
+        let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
+        cronYear <- genMatch 400 False cdYear cronYear
+        cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
+        cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
+        cronMonth <- genMatch 12 True cdMonth cronMonth
+        cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
+        cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
+        cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
+        cronHour <- genMatch 24 True cdHour cronHour
+        cronMinute <- genMatch 60 True cdMinute cronMinute
+        cronSecond <- genMatch 60 True cdSecond cronSecond
+        guard $ consistentCronDate CronDate{..}
+        localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth)
+        let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond)
+        return $ localTimeToUTCTZ tz LocalTime{..}
+
+matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry
+            -> Maybe UTCTime -- ^ Previous execution of the job
+            -> UTCTime -- ^ "Current" time
+            -> Cron
+            -> Bool
+-- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron`
+--   specification @c@ should match @now@, under the assumption that the next
+--   check will occur no earlier than @now + prec@.
+matchesCron tz mPrev now cron = case nextCronMatch tz mPrev now cron of
+  MatchAsap -> True
+  MatchNone -> False
+  MatchAt ts -> ts <= now

src/Cron/Types.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , DuplicateRecordFields
+  #-}
+
+module Cron.Types
+  ( Cron(..), Crontab
+  , CronMatch(..)
+  , CronAbsolute(..)
+  , CronRepeat(..)
+  ) where
+
+import ClassyPrelude
+
+import Utils.Lens.TH
+
+import Data.Time 
+
+import Numeric.Natural
+
+import Data.HashMap.Strict (HashMap)
+  
+
+data CronMatch
+  = CronMatchAny
+  | CronMatchNone
+  | CronMatchSome (NonNull (Set Natural))
+  | CronMatchStep Natural
+  | CronMatchContiguous Natural Natural
+  | CronMatchIntersect CronMatch CronMatch
+  | CronMatchUnion CronMatch CronMatch
+  deriving (Eq, Show, Read)
+
+data CronAbsolute
+  = CronAsap
+  | CronTimestamp
+    { cronTimestamp :: LocalTime
+    }
+  | CronCalendar
+    { cronYear, cronWeekOfYear, cronDayOfYear
+    , cronMonth, cronWeekOfMonth, cronDayOfMonth
+    , cronDayOfWeek
+    , cronHour, cronMinute, cronSecond :: CronMatch
+    }
+  | CronNotScheduled
+  deriving (Eq, Show, Read)
+
+makeLenses_ ''CronAbsolute
+
+data CronRepeat
+  = CronRepeatOnChange
+  | CronRepeatScheduled CronAbsolute
+  | CronRepeatNever
+  deriving (Eq, Show, Read)
+
+data Cron = Cron
+  { cronInitial :: CronAbsolute
+  , cronRepeat :: CronRepeat
+  , cronRateLimit :: NominalDiffTime
+  }
+  deriving (Eq, Show)
+
+makeLenses_ ''Cron
+
+type Crontab a = HashMap a Cron

src/Data/Universe/Instances/Reverse/Hashable.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ScopedTypeVariables
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.Hashable
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Universe
+
+
+instance (Hashable a, Hashable b, Finite a) => Hashable (a -> b) where
+  hashWithSalt s f = s `hashWithSalt` [ (k, f k) | k <- universeF ]

src/Data/Universe/Instances/Reverse/JSON.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ScopedTypeVariables
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.JSON
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+
+import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HashMap
+import Data.HashMap.Strict ((!))
+
+import Data.Universe
+
+
+instance (Eq a, Hashable a, Finite a, ToJSON b, ToJSONKey a) => ToJSON (a -> b) where
+  toJSON f = toJSON $ HashMap.fromList [(k, f k) | k <- universeF]
+
+instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where
+  parseJSON val = do
+    vMap <- parseJSON val :: Parser (HashMap a b)
+    unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
+      fail "Not all required keys found"
+    return $ (vMap !)

src/Foundation.hs

@@ -20,12 +20,12 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 import Text.Jasmine         (minifym)
 
--- Used only when in "auth-dummy-login" setting is enabled.
 import Yesod.Auth.Message
 import Yesod.Auth.Dummy
 import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
+import Jobs.Types
 
 import qualified Network.Wai as W (requestMethod, pathInfo)
 
@@ -59,6 +59,7 @@ import qualified Data.Map as Map
 
 import Data.Monoid (Any(..))
 
+import Data.Pool
 
 import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
@@ -67,7 +68,7 @@ import qualified Database.Esqueleto as E
 
 import Control.Monad.Except (MonadError(..), runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
-import Control.Monad.Trans.Reader (runReader)
+import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..))
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Catch (handleAll)
@@ -88,6 +89,9 @@ import qualified Data.Yaml as Yaml
 
 import Text.Shakespeare.Text (st)
 
+import Yesod.Form.I18n.German
+import qualified Yesod.Auth.Message as Auth
+
 
 instance DisplayAble b => DisplayAble (E.CryptoID a b) where
   display = display . ciphertext
@@ -112,11 +116,16 @@ data UniWorX = UniWorX
     { appSettings    :: AppSettings
     , appStatic      :: Static -- ^ Settings for static file serving.
     , appConnPool    :: ConnectionPool -- ^ Database connection pool.
+    , appSmtpPool    :: Maybe SMTPPool
     , appHttpManager :: Manager
     , appLogger      :: Logger
     , appCryptoIDKey :: CryptoIDKey
+    , appInstanceID  :: InstanceId
+    , appJobCtl      :: [TMChan JobCtl]
     }
 
+type SMTPPool = Pool SMTPConnection
+
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers
@@ -135,6 +144,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes")
 type DB a = YesodDB UniWorX a
 type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
 type MsgRenderer = MsgRendererS UniWorX -- see Utils
+type MailM a = MailT (HandlerT UniWorX IO) a
 
 -- Pattern Synonyms for convenience
 pattern CSheetR tid ssh csh shn ptn
@@ -173,7 +183,7 @@ mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
 instance RenderMessage UniWorX FormMessage where
-    renderMessage _ _ = defaultFormMessage
+    renderMessage _ _  = germanFormMessage -- TODO
 
 instance RenderMessage UniWorX TermIdentifier where
   renderMessage foundation ls TermIdentifier{..} = case season of
@@ -182,10 +192,9 @@ instance RenderMessage UniWorX TermIdentifier where
     where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX StudyFieldType where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-    FieldPrimary -> renderMessage' MsgFieldPrimary
+    FieldPrimary -> MsgFieldPrimary
-    FieldSecondary -> renderMessage' MsgFieldSecondary
+    FieldSecondary -> MsgFieldSecondary
-    where renderMessage' = renderMessage foundation ls
 
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving (Eq, Ord, Read, Show)
@@ -200,27 +209,47 @@ instance RenderMessage UniWorX String where
   renderMessage f ls str = renderMessage f ls $ Text.pack str
 
 instance RenderMessage UniWorX SheetFileType where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      SheetExercise -> renderMessage' MsgSheetExercise
+      SheetExercise -> MsgSheetExercise
-      SheetHint     -> renderMessage' MsgSheetHint
+      SheetHint     -> MsgSheetHint
-      SheetSolution -> renderMessage' MsgSheetSolution
+      SheetSolution -> MsgSheetSolution
-      SheetMarking  -> renderMessage' MsgSheetMarking
+      SheetMarking  -> MsgSheetMarking
-    where renderMessage' = renderMessage foundation ls
 
 instance RenderMessage UniWorX CorrectorState where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      CorrectorNormal  -> renderMessage' MsgCorrectorNormal
+      CorrectorNormal  -> MsgCorrectorNormal
-      CorrectorMissing -> renderMessage' MsgCorrectorMissing
+      CorrectorMissing -> MsgCorrectorMissing
-      CorrectorExcused -> renderMessage' MsgCorrectorExcused
+      CorrectorExcused -> MsgCorrectorExcused
-    where renderMessage' = renderMessage foundation ls
 
 
 instance RenderMessage UniWorX Load where
-  renderMessage foundation ls = \case
+  renderMessage foundation ls = renderMessage foundation ls . \case
-      (Load {byTutorial=Nothing   , byProportion=p}) -> renderMessage' $ MsgCorByProportionOnly p
+      (Load {byTutorial=Nothing   , byProportion=p}) -> MsgCorByProportionOnly p
-      (Load {byTutorial=Just True , byProportion=p}) -> renderMessage' $ MsgCorByProportionIncludingTutorial p
+      (Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p
-      (Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p
+      (Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p
-    where renderMessage' = renderMessage foundation ls
+
+instance RenderMessage UniWorX SheetType where
+  renderMessage foundation ls = renderMessage foundation ls . \case
+      Bonus{..} -> MsgSheetTypeBonus' maxPoints
+      Normal{..} -> MsgSheetTypeNormal' maxPoints
+      Pass{..} -> MsgSheetTypePass' maxPoints passingPoints
+      NotGraded{} -> MsgSheetTypeNotGraded'
+
+newtype MsgLanguage = MsgLanguage Lang
+  deriving (Eq, Ord, Show, Read)
+instance RenderMessage UniWorX MsgLanguage where
+  renderMessage foundation ls (MsgLanguage lang)
+    | lang == "de-DE" = mr MsgGermanGermany
+    | "de" `isPrefixOf` lang = mr MsgGerman
+    where
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX NotificationTrigger where
+  renderMessage foundation ls = renderMessage foundation ls . \case
+    NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded
+    NTSubmissionRated -> MsgNotificationTriggerSubmissionRated
+    NTSheetActive -> MsgNotificationTriggerSheetActive
+    NTSheetInactive -> MsgNotificationTriggerSheetInactive
 
 
 instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
@@ -242,6 +271,22 @@ getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
 appTZ :: TZ
 appTZ = $(includeSystemTZ "Europe/Berlin")
 
+appLanguages :: ( MonadHandler m
+                , HandlerSite m ~ UniWorX
+                ) => m (OptionList Lang)
+-- ^ Authoritive list of supported Languages
+appLanguages = do
+  mr <- getsYesod renderMessage
+  let mkOption l = Option
+        { optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l)
+        , optionInternalValue = l
+        , optionExternalValue = l
+        }
+      langOptions = map mkOption
+        [ "de-DE"
+        ]
+  return $ mkOptionList langOptions
+
 
 -- Access Control
 data AccessPredicate
@@ -454,14 +499,14 @@ route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK
     attrsAND = map splitAND $ Set.toList $ routeAttrs r
     splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
 
-evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
+evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
-evalAccessDB r w = case route2ap r of
+evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of
   (APPure    p) -> lift $ runReader (p r w) <$> getMsgRenderer
   (APHandler p) -> lift $ p r w
   (APDB      p) -> p r w
 
-evalAccess :: Route UniWorX -> Bool -> Handler AuthResult
+evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
-evalAccess r w = case route2ap r of
+evalAccess r w = liftHandlerT $ case route2ap r of
   (APPure    p) -> runReader (p r w) <$> getMsgRenderer
   (APHandler p) -> p r w
   (APDB      p) -> runDB $ p r w
@@ -1223,12 +1268,14 @@ instance YesodAuth UniWorX where
 
           let
             newUser = User
-              { userMaxFavourites  = userDefaultMaxFavourites
+              { userMaxFavourites        = userDefaultMaxFavourites
-              , userTheme          = userDefaultTheme
+              , userTheme                = userDefaultTheme
-              , userDateTimeFormat = userDefaultDateTimeFormat
+              , userDateTimeFormat       = userDefaultDateTimeFormat
-              , userDateFormat     = userDefaultDateFormat
+              , userDateFormat           = userDefaultDateFormat
-              , userTimeFormat     = userDefaultTimeFormat
+              , userTimeFormat           = userDefaultTimeFormat
-              , userDownloadFiles  = userDefaultDownloadFiles
+              , userDownloadFiles        = userDefaultDownloadFiles
+              , userNotificationSettings = def
+              , userMailLanguages        = def
               , ..
               }
             userUpdate =  [ UserMatrikelnummer =. userMatrikelnummer
@@ -1271,6 +1318,8 @@ instance YesodAuth UniWorX where
 
     authHttpManager = getHttpManager
 
+    renderAuthMessage _ _ = Auth.germanMessage -- TODO
+
 instance YesodAuthPersist UniWorX
 
 -- Useful when writing code that is re-usable outside of the Handler context.
@@ -1283,6 +1332,25 @@ unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
 
+instance YesodMail UniWorX where
+  defaultFromAddress = getsYesod $ appMailFrom . appSettings
+  mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
+  mailVerp = getsYesod $ appMailVerp . appSettings
+  mailDateTZ = return appTZ
+  mailSmtp act = do
+    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
+    withResource pool act
+  mailT ctx mail = defMailT ctx $ do 
+    setMailObjectId
+    setDateCurrent
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+  
+    ret <- mail
+  
+    setMailSmtpData
+    return ret
+
+
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
   type MonadCryptoKey m = CryptoIDKey
   cryptoIDKey f = getsYesod appCryptoIDKey >>= f

src/Handler/Admin.hs

@@ -7,11 +7,13 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Handler.Admin where
 
 import Import
 import Handler.Utils
+import Jobs
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -20,6 +22,8 @@ import Handler.Utils
 
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
+import Database.Persist.Sql (fromSqlKey)
+
 -- import Colonnade hiding (fromMaybe)
 -- import Yesod.Colonnade
 
@@ -41,22 +45,54 @@ instance Button UniWorX CreateButton where
   cssClass CreateInf  = BCPrimary
 -- END Button needed here
 
+emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
+emailTestForm = (,)
+            <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
+            <*> ( MailContext
+                  <$> (MailLanguages <$> areq (reorderField appLanguages) (fslI MsgMailTestFormLanguages) Nothing)
+                  <*> (toMailDateTimeFormat
+                        <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
+                        <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
+                        <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
+                      )
+                )
+            <*  submitButton
+  where
+    toMailDateTimeFormat dt d t = \case
+      SelFormatDateTime -> dt
+      SelFormatDate -> d
+      SelFormatTime -> t
 
-getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
-getAdminTestR = do
-  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
-  defaultLayout $ do
-    -- setTitle "Uni2work Admin Testpage"
-    $(widgetFile "adminTest")
 
-postAdminTestR :: Handler Html
+getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
+getAdminTestR = postAdminTestR
 postAdminTestR = do
-  ((btnResult,_), _) <- runFormPost $ buttonForm
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton)
   case btnResult of
     (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
     (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
+    FormMissing -> return ()
     _other -> addMessage Warning "KEIN Knopf erkannt"
-  getAdminTestR
+
+  ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
+  case emailResult of 
+    (FormSuccess (email, ls)) -> do
+      jId <- runDB $ do
+        jId <- queueJob $ JobSendTestEmail email ls
+        addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
+        return jId
+      writeJobCtl $ JobCtlPerform jId
+    FormMissing -> return ()
+    (FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
+
+  let emailWidget' = [whamlet|
+        <form method=post action=@{AdminTestR} enctype=#{emailEnctype}>
+          ^{emailWidget}
+      |]
+  
+  defaultLayout $ do
+    -- setTitle "Uni2work Admin Testpage"
+    $(widgetFile "adminTest")
 
 
 getAdminUserR :: CryptoUUIDUser -> Handler Html

src/Handler/Corrections.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE MultiWayIf, LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -21,6 +20,7 @@ module Handler.Corrections where
 import Import
 -- import System.FilePath (takeFileName)
 
+import Jobs
 import Handler.Utils
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
@@ -189,44 +189,46 @@ makeCorrectionsTable whereClause colChoices psValidator = do
     { dbtSQLQuery
     , dbtColonnade = colChoices
     , dbtProj
-    , dbtSorting   = [ ( "term"
+    , dbtSorting   = Map.fromList
-                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
+      [ ( "term"
-                       )
+        , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
-                     , ( "course"
+        )
-                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
+      , ( "course"
-                       )
+        , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
-                     , ( "sheet"
+        )
-                       , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
+      , ( "sheet"
-                       )
+        , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
-                     , ( "corrector"
+        )
-                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
+      , ( "corrector"
-                       )
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
-                     , ( "rating"
+        )
-                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
+      , ( "rating"
-                       )
+        , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
-                     ]
+        )
-    , dbtFilter    = [ ( "term"
+      ]
-                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
+    , dbtFilter    = Map.fromList
-                           | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
+      [ ( "term"
-                           | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
+        , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
-                       )
+            | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
-                     , ( "course"
+            | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
-                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
+        )
-                           | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
+      , ( "course"
-                           | otherwise     -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
+        , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
-                       )
+            | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
-                     , ( "sheet"
+            | otherwise     -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
-                       , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
+        )
-                           | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
+      , ( "sheet"
-                           | otherwise     -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
+        , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
-                       )
+            | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
-                     , ( "corrector"
+            | otherwise     -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
-                       , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
+        )
-                           | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
+      , ( "corrector"
-                           | otherwise       -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
+        , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
-                                          E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
+            | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
-                       )
+            | otherwise       -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
-                     ]
+                           E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
+        )
+      ]
     , dbtStyle     = def
     , dbtIdent     = "corrections" :: Text
     }
@@ -248,12 +250,12 @@ data ActionCorrectionsData = CorrDownloadData
                            | CorrSetCorrectorData (Maybe UserId)
                            | CorrAutoSetCorrectorData SheetId
 
-correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
+correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
 correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
   tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
   ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
     ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
-    (actionRes, action) <- multiAction actions
+    (actionRes, action) <- multiAction actions Nothing
     return ((,) <$> actionRes <*> selectionRes, table <> action)
 
   Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
@@ -323,16 +325,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
     $(widgetFile "corrections")
 
 
-type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget))
+type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
   
 downloadAction :: ActionCorrections'
 downloadAction = ( CorrDownload
-                 , return (pure CorrDownloadData, Nothing)
+                 , pure CorrDownloadData
                  )
 
 assignAction :: Either CourseId SheetId -> ActionCorrections'
 assignAction selId = ( CorrSetCorrector
-                     , over (mapped._2) Just $ do
+                     , wFormToAForm $ do
                          correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
                            E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
                            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
@@ -346,14 +348,13 @@ assignAction selId = ( CorrSetCorrector
 
                          correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
 
-                         ($ mempty) . renderAForm FormStandard . wFormToAForm $ do
+                         cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
-                            cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
+                         fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
-                            fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
                      )
 
 autoAssignAction :: SheetId -> ActionCorrections'
 autoAssignAction shid = ( CorrAutoSetCorrector
-                        , return (pure $ CorrAutoSetCorrectorData shid, Nothing)
+                        , pure $ CorrAutoSetCorrectorData shid
                         )
 
 getCorrectionsR, postCorrectionsR :: Handler TypedContent
@@ -449,9 +450,12 @@ postCorrectionR tid ssh csh shn cid = do
   case results of
     [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
       let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
+          pointsForm = case sheetType of
+            NotGraded  -> bool Nothing (Just 0) <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
+            _otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints)
 
       ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,)
-        <$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints)
+        <$> pointsForm
         <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
         <* submitButton
 
@@ -463,11 +467,13 @@ postCorrectionR tid ssh csh shn cid = do
         FormMissing -> return ()
         FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
         FormSuccess (ratingPoints, ratingComment) -> do
-          runDB $ do
+          runDBJobs $ do
             uid <- liftHandlerT requireAuthId
             now <- liftIO getCurrentTime
 
-            let rated = isJust $ void ratingPoints <|> void ratingComment
+            let rated = isJust ratingPoints -- <|> void ratingComment -- Comment shouldn't cause rating
+
+            Submission{submissionRatingTime} <- getJust sub
           
             update sub [ SubmissionRatingBy      =. (uid <$ guard rated)
 -- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
@@ -478,6 +484,11 @@ postCorrectionR tid ssh csh shn cid = do
                        ]
 
             addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
+
+            when (rated && isNothing submissionRatingTime) $ do
+              $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
+              queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub 
+
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       case uploadResult of
@@ -486,7 +497,7 @@ postCorrectionR tid ssh csh shn cid = do
         FormSuccess fileSource -> do
           uid <- requireAuthId
           
-          runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
+          runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
 
           addMessageI Success MsgRatingFilesUpdated
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
@@ -521,7 +532,7 @@ postCorrectionsUploadR = do
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess files -> do
       uid <- requireAuthId
-      subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
+      subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
       if
         | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
         | otherwise -> do

src/Handler/Profile.hs

@@ -24,6 +24,8 @@ import Utils.Lens
 -- import Yesod.Colonnade
 import Data.Monoid (Any(..))
 import qualified Data.Map as Map
+import Data.Map ((!))
+import qualified Data.Set as Set
 -- import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
 -- import           Database.Esqueleto      ((^.))
@@ -37,6 +39,7 @@ data SettingsForm = SettingsForm
       , stgDate          :: DateTimeFormat
       , stgTime          :: DateTimeFormat
       , stgDownloadFiles :: Bool
+      , stgNotificationSettings :: NotificationSettings
       }
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
@@ -53,13 +56,30 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
       <*> areq checkBoxField (fslI MsgDownloadFiles
                                & setTooltip MsgDownloadFilesTip
                              ) (stgDownloadFiles <$> template)
+      <*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty)
       <*  submitButton
     return (result, widget) -- no validation required here
+  where
+    nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt ->
+      areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template)
+    nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX])
+    nsFieldView (res, fvInput) = do
+      mr <- getMessageRender
+      let fvLabel = toHtml $ mr MsgNotificationSettings
+          fvTooltip = mempty
+          fvRequired = True
+          fvErrors
+            | FormFailure (err:_) <- res = Just $ toHtml err
+            | otherwise = Nothing
+      fvId <- newIdent
+      return (res, pure FieldView{..})
+    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
 
 
 
-getProfileR :: Handler Html
+getProfileR, postProfileR :: Handler Html
-getProfileR = do
+getProfileR = postProfileR
+postProfileR = do
   (uid, User{..}) <- requireAuthPair
   let settingsTemplate = Just $ SettingsForm
         { stgMaxFavourties = userMaxFavourites
@@ -68,6 +88,7 @@ getProfileR = do
         , stgDate          = userDateFormat
         , stgTime          = userTimeFormat
         , stgDownloadFiles = userDownloadFiles
+        , stgNotificationSettings = userNotificationSettings
         }
   ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
   case res of
@@ -79,6 +100,7 @@ getProfileR = do
                       , UserDateFormat     =. stgDate
                       , UserTimeFormat     =. stgTime
                       , UserDownloadFiles  =. stgDownloadFiles
+                      , UserNotificationSettings =. stgNotificationSettings
                       ]
           when (stgMaxFavourties < userMaxFavourites) $ do
             -- prune Favourites to user-defined size
@@ -135,11 +157,6 @@ getProfileR = do
     $(widgetFile "profile")
     $(widgetFile "dsgvDisclaimer")
 
-postProfileR :: Handler Html
-postProfileR = do
-  -- TODO
-  getProfileR
-
 postProfileDataR  :: Handler Html
 postProfileDataR = do
   ((btnResult,_), _) <- runFormPost $ buttonForm

src/Handler/Sheet.hs

@@ -57,7 +57,7 @@ import qualified Data.Map as Map
 import Data.Map (Map, (!), (!?))
 import qualified Data.Map as Map
 
-import Data.Monoid (Sum(..))
+import Data.Monoid (Sum(..), Any(..))
 
 import Control.Lens
 -- import Utils.Lens
@@ -273,14 +273,14 @@ getSShowR tid ssh csh shn = do
         -- return desired columns
         return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
   let colonnadeFiles = widgetColonnade $ mconcat
-        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype
+        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
         , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName))
                                                            (\(E.Value fName,_,_) -> str2widget fName)
         , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
         ]
   let psValidator = def
         & defaultSorting [("type", SortAsc), ("path", SortAsc)]
-  ((), fileTable) <- dbTable psValidator $ DBTable
+  (Any hasFiles, fileTable) <- dbTable psValidator $ DBTable
     { dbtSQLQuery = fileData
     , dbtColonnade = colonnadeFiles
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }

src/Handler/Submission.hs

@@ -20,6 +20,8 @@ module Handler.Submission where
 
 import Import hiding (joinPath)
 
+import Jobs
+
 -- import Yesod.Form.Bootstrap3  
 
 import Handler.Utils
@@ -72,7 +74,7 @@ makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $
     flip (renderAForm FormStandard) html $ (,)
       <$> fileUpload
       <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
-                                    | g <- [1..(max groupNr $ length buddies)]             -- groupNr might have decreased meanwhile
+                                    | g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile
                                     | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
                                     ])
       <*  submitButton
@@ -178,7 +180,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
         return (csheet,buddies,lastEdits)
   ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
-  mCID <- runDB $ do
+  mCID <- runDBJobs $ do
     res' <- case res of
       (FormMissing )           -> return $ FormMissing
       (FormFailure failmsgs)   -> return $ FormFailure failmsgs
@@ -215,7 +217,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                   (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
                   (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
                   _other             -> mempty
-              , case length participants `compare` maxParticipants of
+              , case fromIntegral (length participants) `compare` maxParticipants of
                   LT -> mempty
                   _  -> pure $ mr MsgTooManyParticipants
               ]
@@ -232,8 +234,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
           smid <- case (mFiles, msmid) of
             (Nothing, Just smid)   -- no new files, existing submission partners updated
               -> return smid
-            (Just files, _)  -- new files
+            (Just files, _) -> -- new files
-              -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
+              runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
             (Nothing, Nothing) -- new submission, no file upload requested
               -> insert Submission
                   { submissionSheet = shid

src/Handler/Utils.hs

@@ -25,6 +25,7 @@ import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
 import Handler.Utils.Templates  as Handler.Utils
+import Handler.Utils.Mail       as Handler.Utils
 
 
 downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool

src/Handler/Utils/DateTime.hs

@@ -11,6 +11,7 @@ module Handler.Utils.DateTime
   , formatTime, formatTime', formatTimeW
   , getTimeLocale, getDateTimeFormat
   , validDateTimeFormats, dateTimeFormatOptions
+  , formatTimeMail
   , addOneWeek
   ) where
 
@@ -26,6 +27,8 @@ import qualified Data.Time.Format as Time
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import Mail
+
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
 
@@ -58,6 +61,9 @@ formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeForm
 formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
 formatTimeW s t = toWidget =<< formatTime s t
 
+formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
+formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
+
 getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
 getTimeLocale = getTimeLocale' <$> languages
 

src/Handler/Utils/Form.hs

@@ -25,7 +25,7 @@ import Handler.Utils.Templates
 import Handler.Utils.DateTime
 import qualified Data.Time as Time
 
-import Import
+import Import hiding (cons)
 import qualified Data.Char as Char
 import Data.String (IsString(..))
 
@@ -60,6 +60,10 @@ import Data.Scientific (Scientific)
 import Data.Ratio
 import Text.Read (readMaybe)
 
+import Data.Maybe (fromJust)
+
+import Utils.Lens
+
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
@@ -288,23 +292,122 @@ multiFileField permittedFiles' = Field{..}
       Right _ -> return ()
       Left  r -> yield r
 
-sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+data SheetType' = Bonus' | Normal' | Pass' | NotGraded'
-sheetTypeAFormReq d Nothing =
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
-  -- TODO, offer options to choose between Normal/Bonus/Pass
-  (Normal . toPoints) <$> areq (natField "Punkte") d Nothing
-sheetTypeAFormReq d (Just (Normal p)) =
-  -- TODO, offer options to choose between Normal/Bonus/Pass
-  (Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
-sheetTypeAFormReq d (Just (NotGraded)) = pure NotGraded
 
+instance Universe SheetType'
+instance Finite SheetType'
+
+$(return [])
+
+instance PathPiece SheetType' where
+  toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX SheetType' where
+  renderMessage f ls = \case
+    Bonus' -> render MsgSheetTypeBonus
+    Normal' -> render MsgSheetTypeNormal
+    Pass' -> render MsgSheetTypePass
+    NotGraded' -> render MsgSheetTypeNotGraded
+    where
+      render = renderMessage f ls
+
+data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+instance Universe SheetGroup'
+instance Finite SheetGroup'
+
+$(return [])
+
+instance PathPiece SheetGroup' where
+  toPathPiece = $(nullaryToPathPiece ''SheetGroup' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
+  fromPathPiece = finiteFromPathPiece
+
+instance RenderMessage UniWorX SheetGroup' where
+  renderMessage f ls = \case
+    Arbitrary' -> render MsgSheetGroupArbitrary
+    RegisteredGroups' -> render MsgSheetGroupRegisteredGroups
+    NoGroups' -> render MsgSheetGroupNoGroups
+    where
+      render = renderMessage f ls
+
+sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
+sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do
+  let
+    selOptions = Map.fromList
+      [ ( Bonus', Bonus <$> maxPointsReq )
+      , ( Normal', Normal <$> maxPointsReq )
+      , ( Pass', Pass
+          <$> maxPointsReq
+          <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template)
+        )
+      , ( NotGraded', pure NotGraded )
+      ]
+  (res, selView) <- multiAction selOptions (classify' <$> template)
+
+  fvId <- maybe newIdent return fsId
+  MsgRenderer mr <- getMsgRenderer
+
+  return (res,
+    [ FieldView
+      { fvLabel = toHtml $ mr fsLabel
+      , fvTooltip = toHtml . mr <$> fsTooltip
+      , fvId
+      , fvInput = selView
+      , fvErrors = case res of
+          FormFailure [e] -> Just $ toHtml e
+          _ -> Nothing
+      , fvRequired = True
+      }
+    ])
+
+  where
+    maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template)
+    
+    classify' :: SheetType -> SheetType'
+    classify' = \case
+      Bonus _ -> Bonus'
+      Normal _ -> Normal'
+      Pass _ _ -> Pass'
+      NotGraded -> NotGraded'
 
 sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
-sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
+sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
-  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
+  let
-  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
+    selOptions = Map.fromList
-sheetGroupAFormReq d _other = -- TODO
+      [ ( Arbitrary', Arbitrary
-  -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
+          <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
-  Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
+        )
+      , ( RegisteredGroups', pure RegisteredGroups )
+      , ( NoGroups', pure NoGroups )
+      ]
+  (res, selView) <- multiAction selOptions (classify' <$> template)
+
+  fvId <- maybe newIdent return fsId
+  MsgRenderer mr <- getMsgRenderer
+
+  return (res,
+    [ FieldView
+      { fvLabel = toHtml $ mr fsLabel
+      , fvTooltip = toHtml . mr <$> fsTooltip
+      , fvId
+      , fvInput = selView
+      , fvErrors = case res of
+          FormFailure [e] -> Just $ toHtml e
+          _ -> Nothing
+      , fvRequired = True
+      }
+    ])
+
+  where
+    classify' :: SheetGroup -> SheetGroup'
+    classify' = \case
+      Arbitrary _ -> Arbitrary'
+      RegisteredGroups -> RegisteredGroups'
+      NoGroups -> NoGroups'
+
 
 {-
 dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
@@ -416,15 +519,34 @@ aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m
         => Field m a -> FieldSettings site -> a -> AForm m a
 aforced field settings val = formToAForm $ second pure <$> mforced field settings val
 
+apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
+-- ^ Pseudo required
+apreq f fs mx = formToAForm $ do
+  mr <- getMessageRender
+  fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } ))) $ mopt f fs (Just <$> mx)
+
+wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
+wpreq f fs mx = mFormToWForm $ do
+  mr <- getMessageRender
+  fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } )) $ mopt f fs (Just <$> mx)
+
 multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
-            => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
+            => Map action (AForm (HandlerT UniWorX IO) a)
+            -> Maybe action
             -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
-multiAction acts = do
+multiAction acts defAction = do
   mr <- getMessageRender
   let
     options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
-  (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
+  (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
-  results <- sequence acts
+  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
-  let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
+  let mToWidget (_, []) = return Nothing
+      mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
+  widgets <- mapM mToWidget results
+  let actionWidgets = Map.foldrWithKey accWidget [] widgets
+      accWidget act Nothing = id
+      accWidget act (Just w) = cons $(widgetFile "widgets/multiAction")
       actionResults = Map.map fst results
   return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))

src/Handler/Utils/Mail.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE NoImplicitPrelude
+           , NamedFieldPuns
+           , TypeFamilies
+           , FlexibleContexts
+           , ViewPatterns
+           , LambdaCase
+  #-}
+
+module Handler.Utils.Mail
+  ( addRecipientsDB
+  , userMailT
+  , addFileDB
+  ) where
+
+import Import hiding ((.=))
+
+import Utils.Lens hiding (snoc)
+
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.ByteString.Lazy as LBS
+
+import qualified Data.Conduit.List as C
+
+import System.FilePath (takeBaseName)
+import Network.Mime (defaultMimeLookup)
+
+import Control.Monad.Trans.State (StateT)
+
+
+addRecipientsDB :: ( MonadMail m
+                   , MonadHandler m
+                   , HandlerSite m ~ UniWorX
+                   ) => [Filter User] -> m ()
+-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
+addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
+  where
+    addRecipient (Entity _ User{userEmail, userDisplayName}) = do
+      let addr = Address (Just userDisplayName) $ CI.original userEmail
+      _mailTo %= flip snoc addr
+
+userMailT :: ( MonadHandler m
+             , HandlerSite m ~ UniWorX
+             , MonadBaseControl IO m
+             , MonadLogger m
+             ) => UserId -> MailT m a -> m a
+userMailT uid mAct = do
+  User
+    { userEmail
+    , userDisplayName
+    , userMailLanguages
+    , userDateTimeFormat
+    , userDateFormat
+    , userTimeFormat
+    } <- liftHandlerT . runDB $ getJust uid
+  let
+    addr = Address (Just userDisplayName) $ CI.original userEmail
+    ctx = MailContext
+      { mcLanguages = userMailLanguages
+      , mcDateTimeFormat = \case
+          SelFormatDateTime -> userDateTimeFormat
+          SelFormatDate -> userDateFormat
+          SelFormatTime -> userTimeFormat
+      }
+  mailT ctx $ do
+    _mailTo .= pure addr
+    mAct
+
+addFileDB :: ( MonadMail m
+             , MonadHandler m
+             , HandlerSite m ~ UniWorX
+             ) => FileId -> m MailObjectId
+addFileDB fId = do
+  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
+  addPart $ do
+    _partType .= decodeUtf8 (defaultMimeLookup fileName)
+    _partEncoding .= Base64
+    _partFilename .= Just fileName
+    _partContent .= LBS.fromStrict fileContent
+    setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId

src/Handler/Utils/Submission.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiWayIf #-}
 
 
 module Handler.Utils.Submission
@@ -25,6 +26,7 @@ module Handler.Utils.Submission
   ) where
 
 import Import hiding ((.=), joinPath)
+import Jobs
 import Prelude (lcm)
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
@@ -38,7 +40,7 @@ import Control.Monad.RWS.Lazy (RWST)
 import qualified Control.Monad.Random as Rand
 import qualified System.Random.Shuffle as Rand (shuffleM)
 
-import Data.Maybe
+import Data.Maybe ()
 
 import qualified Data.List as List
 import Data.Set (Set)
@@ -279,6 +281,7 @@ submissionMultiArchive (Set.toList -> ids) = do
 data SubmissionSinkState = SubmissionSinkState
   { sinkSeenRating :: Any
   , sinkSubmissionTouched :: Any
+  , sinkSubmissionNotifyRating :: Any
   , sinkFilenames :: Set FilePath
   } deriving (Show, Eq, Generic, Typeable)
 
@@ -333,7 +336,7 @@ extractRatingsMsg = do
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId
                -> Bool -- ^ Is this a correction
-               -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
+               -> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId
 -- ^ Replace the currently saved files for the given submission (either
 --   corrected files or original ones, depending on arguments) with the supplied
 --   'SubmissionContent'.
@@ -365,7 +368,7 @@ sinkSubmission userId mExists isUpdate = do
 
     sinkSubmission' :: SubmissionId
                     -> Bool -- ^ Is this a correction
-                    -> Sink SubmissionContent (YesodDB UniWorX) ()
+                    -> Sink SubmissionContent (YesodJobDB UniWorX) ()
     sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
       Left file@(File{..}) -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
@@ -463,18 +466,21 @@ sinkSubmission userId mExists isUpdate = do
         -- The check whether the new version matches the underlying file is
         -- more lenient, considering only filename and -content.
 
-        touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) ()
+        touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
         touchSubmission = do
           alreadyTouched <- gets $ getAny . sinkSubmissionTouched
           when (not alreadyTouched) $ do
             now <- liftIO getCurrentTime
-            lift $ case isUpdate of
+            case isUpdate of
-              False -> insert_ $ SubmissionEdit userId now submissionId
+              False -> lift . insert_ $ SubmissionEdit userId now submissionId
-              True  -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+              True  -> do
-                        -- TODO: Should submissionRatingAssigned change here if userId changes?
+                Submission{submissionRatingTime} <- lift $ getJust submissionId
+                when (isNothing submissionRatingTime) $ tell mempty { sinkSubmissionNotifyRating = Any True }
+                lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+                -- TODO: Should submissionRatingAssigned change here if userId changes?
             tell $ mempty{ sinkSubmissionTouched = Any True }
 
-        finalize :: SubmissionSinkState -> YesodDB UniWorX ()
+        finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()
         finalize SubmissionSinkState{..} = do
           missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
             E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
@@ -509,13 +515,19 @@ sinkSubmission userId mExists isUpdate = do
                   update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
                   deleteCascade fileId
 
-          when (isUpdate && not (getAny sinkSeenRating)) $
+          if
-            update submissionId
+            | isUpdate
+            , not $ getAny sinkSeenRating
+              -> update submissionId
               [ SubmissionRatingTime =. Nothing
               , SubmissionRatingPoints =. Nothing
               , SubmissionRatingBy =. Nothing
               , SubmissionRatingComment =. Nothing
               ]
+            | isUpdate
+            , getAny sinkSubmissionNotifyRating
+              -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
+            | otherwise -> return ()
 
 data SubmissionMultiSinkException
   = SubmissionSinkException
@@ -529,7 +541,7 @@ instance Exception SubmissionMultiSinkException
 
 sinkMultiSubmission :: UserId
                     -> Bool {-^ Are these corrections -}
-                    -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
+                    -> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId)
                
 -- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
 --
@@ -543,8 +555,8 @@ sinkMultiSubmission userId isUpdate = do
          -> RWST
               ()
               _
-              (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
+              (Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId))
-              (YesodDB UniWorX)
+              (YesodJobDB UniWorX)
               ()
     feed sId val = do
       mSink <- gets $ Map.lookup sId
@@ -593,10 +605,10 @@ sinkMultiSubmission userId isUpdate = do
   when (not $ null ignored) $ do
     mr <- (toHtml .) <$> getMessageRender
     addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
-  fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
+  lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
     cID <- encrypt sId
     handle (throwM . SubmissionSinkException cID Nothing) $
-      void $ closeResumableSink sink
+      closeResumableSink sink
   where
     handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
     handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)

src/Import.hs

@@ -4,4 +4,3 @@ module Import
 
 import Foundation            as Import
 import Import.NoFoundation   as Import
-

src/Import/NoFoundation.hs

@@ -25,3 +25,13 @@ import Text.Lucius            as Import
 import Text.Shakespeare.Text  as Import hiding (text, stext)
 
 import Data.Universe          as Import
+import Data.Pool              as Import (Pool)
+import Network.HaskellNet.SMTP as Import (SMTPConnection)
+
+import Mail                   as Import
+
+import Data.Data              as Import (Data)
+import Data.Typeable          as Import (Typeable)
+import GHC.Generics           as Import (Generic)
+
+import Data.Hashable          as Import

src/Jobs.hs

@@ -0,0 +1,531 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , TemplateHaskell
+           , OverloadedStrings
+           , FlexibleContexts
+           , ViewPatterns
+           , TypeFamilies
+           , DeriveGeneric
+           , DeriveDataTypeable
+           , QuasiQuotes
+           , NamedFieldPuns
+           , MultiWayIf
+           , NumDecimals
+  #-}
+
+module Jobs
+  ( module Types
+  , writeJobCtl
+  , queueJob, queueJob'
+  , YesodJobDB
+  , runDBJobs, queueDBJob
+  , handleJobs
+  ) where
+
+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 Data.Conduit.TMChan
+import qualified Data.Conduit.List as C
+
+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 Data.Monoid (Last(..))
+import Data.Semigroup (Max(..))
+
+import Utils.Lens
+
+import Control.Monad.Random (evalRand, uniform, 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(..))
+import Control.Monad.Logger
+
+import Control.Monad.Random (MonadRandom(..), evalRand)
+
+import Data.Time.Clock
+import Data.Time.Zones
+
+import Control.Concurrent.STM (retry)
+
+import Database.PostgreSQL.Simple (sqlErrorHint)
+import Control.Monad.Catch (handleIf)
+
+  
+data JobQueueException = JInvalid QueuedJobId QueuedJob
+                       | JLocked QueuedJobId InstanceId UTCTime
+                       | JNonexistant QueuedJobId
+  deriving (Read, Show, Eq, Generic, Typeable)
+
+instance Exception JobQueueException
+
+
+handleJobs :: (MonadResource m, MonadIO m) => [TMChan JobCtl] -> UniWorX -> m ()
+-- | Read control commands from `appJobCtl` and address them as they come in
+--
+-- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
+-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
+handleJobs recvChans foundation@UniWorX{..} = do
+  jobCrontab <- liftIO $ newTVarIO HashMap.empty
+  jobConfirm <- liftIO $ newTVarIO HashMap.empty
+
+  forM_ (zip [1..] recvChans) $ \(n, chan) ->
+    let
+      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)
+
+  -- Start cron operation
+  void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread)
+  liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
+    writeJobCtlBlock JobCtlDetermineCrontab
+
+
+execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) ()
+-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
+--   seen, wait for the time of the next job and fire it
+execCrontab = flip evalStateT HashMap.empty . forever $ do
+  mapStateT (liftHandlerT . runDB . setSerializable) $ do
+    let
+      merge (Entity leId CronLastExec{..})
+        | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+        = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
+        | otherwise = lift $ delete leId
+    runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
+  
+  now <- liftIO getCurrentTime
+  (currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do
+    crontab <- liftBase . readTVar =<< asks jobCrontab
+    State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
+    prevExec <- State.get
+    case earliestJob prevExec crontab now of
+      Nothing -> liftBase retry
+      Just (_, MatchNone) -> liftBase retry
+      Just x -> return (crontab, x)
+
+  let doJob = do
+        mJid <- mapStateT (mapReaderT $ liftHandlerT . runDB . setSerializable) $ do
+          newCrontab <- lift . lift $ determineCrontab
+          if
+            | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
+              -> do
+                now <- liftIO $ getCurrentTime
+                instanceID <- getsYesod appInstanceID
+                State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
+                case jobCtl of
+                  JobCtlQueue job -> do
+                    lift . lift $ upsertBy
+                      (UniqueCronLastExec $ toJSON job)
+                      CronLastExec
+                        { cronLastExecJob = toJSON job
+                        , cronLastExecTime = now
+                        , cronLastExecInstance = instanceID
+                        }
+                      [ CronLastExecTime =. now ]
+                    Just <$> lift (lift $ queueJobUnsafe job)
+                  other -> Nothing <$ writeJobCtl other
+            | otherwise
+              -> lift . fmap (const Nothing) . mapReaderT (liftIO . atomically) $
+                   lift . flip writeTVar newCrontab =<< asks jobCrontab
+        maybe (return ()) (writeJobCtl . JobCtlPerform) mJid
+
+  case nextMatch of
+    MatchAsap -> doJob
+    MatchNone -> return ()
+    MatchAt nextTime -> do
+      JobContext{jobCrontab} <- ask
+      nextTime' <- applyJitter jobCtl nextTime
+      $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
+      logFunc <- askLoggerIO
+      whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
+        doJob
+  where
+    acc :: NominalDiffTime
+    acc = 1e-3
+
+    applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
+    applyJitter seed t = do
+      appInstance <- getsYesod appInstanceID
+      let
+        halfRange = truncate $ 0.5 / acc
+        diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
+      return $ addUTCTime diff t
+
+    earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
+    earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab
+      where
+        go (jobCtl, cron) mbPrev
+          | Just (_, t') <- mbPrev
+          , t' < t
+          = mbPrev
+          | otherwise
+          = Just (jobCtl, t)
+          where
+            t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron
+
+    waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
+    waitUntil crontabTV crontab nextTime = runResourceT $ do
+      diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
+      let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
+          waitTime'
+            | diffT < acc = "Done"
+            | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
+      $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
+      if
+        | diffT < acc -> return True
+        | otherwise   -> do
+            retVar <- liftIO newEmptyTMVarIO
+            void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread)
+            let
+              awaitDelayThread = False <$ takeTMVar retVar
+              awaitCrontabChange = do
+                crontab' <- readTVar crontabTV
+                True <$ guard (crontab /= crontab')
+            crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
+            bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
+
+
+handleJobs' :: Int -> Sink JobCtl (ReaderT JobContext Handler) ()
+handleJobs' wNum = C.mapM_ $ \jctl -> do
+  $logDebugS logIdent $ tshow jctl
+  resVars <- mapReaderT (liftIO . atomically) $
+    HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm)
+  res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl
+  sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars)
+  case res of
+    Just err
+      | not sentRes -> $logErrorS logIdent $ tshow err
+    _other -> return ()
+  where
+    logIdent = "Jobs #" <> tshow wNum
+    
+    handleQueueException :: MonadLogger m => JobQueueException -> m ()
+    handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
+    handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
+    handleQueueException (JLocked jId lInstance lTime)  = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
+
+    handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform)
+    handleCmd (JobCtlQueue job) = lift $ queueJob' job
+    handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
+      content <- case fromJSON queuedJobContent of
+        Aeson.Success c -> return c
+        Aeson.Error t -> do
+          $logErrorS logIdent $ "Aeson decoding error: " <> pack t
+          throwM $ JInvalid jId j
+      
+      $logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
+
+      performJob content
+
+      -- `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
+      -- $logDebugS logIdent $ tshow newCTab
+      mapReaderT (liftIO . atomically) $ 
+        lift . flip writeTVar newCTab =<< asks jobCrontab
+
+jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
+jLocked jId act = do
+  hasLock <- liftIO $ newTVarIO False
+
+  let
+    lock = runDB . setSerializable $ do
+      qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
+      instanceID <- getsYesod appInstanceID
+      threshold <- getsYesod $ appJobStaleThreshold . appSettings
+      now <- liftIO getCurrentTime
+      hadStale <- maybeT (return False) $ do
+        lockTime <- MaybeT $ return queuedJobLockTime
+        lockInstance <- MaybeT $ return queuedJobLockInstance
+        if
+          | lockInstance == instanceID
+          , diffUTCTime now lockTime >= threshold
+            -> return True
+          | otherwise
+            -> throwM $ JLocked jId lockInstance lockTime
+      when hadStale .
+        $logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
+      val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
+                           , QueuedJobLockTime =. Just now
+                           ]
+      liftIO . atomically $ writeTVar hasLock True
+      return val
+
+    unlock = whenM (liftIO . atomically $ readTVar hasLock) $
+      runDB . setSerializable $
+        update jId [ QueuedJobLockInstance =. Nothing
+                   , QueuedJobLockTime =. Nothing
+                   ]
+      
+  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
+
+setSerializable :: DB a -> DB a
+setSerializable act = setSerializable' (0 :: Integer)
+  where
+    act' = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
+
+    setSerializable' (min 10 -> logBackoff) =
+      handleIf
+        (\e -> sqlErrorHint e == "The transaction might succeed if retried.")
+        (\e -> $logWarnS "SQL" (tshow e) *> threadDelay (1e3 * 2 ^ logBackoff) *> setSerializable' (succ logBackoff))
+        act'
+
+pruneLastExecs :: Crontab JobCtl -> DB ()
+pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab
+  where
+    ensureCrontab (Entity leId CronLastExec{..})
+      | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
+      , HashMap.member (JobCtlQueue job) crontab
+      = return ()
+      | otherwise = delete leId
+        
+
+determineCrontab :: DB (Crontab JobCtl)
+-- ^ Extract all future jobs from the database (sheet deadlines, ...)
+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
+  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))

src/Jobs/Types.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE TemplateHaskell
+           , NoImplicitPrelude
+           , DeriveGeneric
+           , DeriveDataTypeable
+  #-}
+
+module Jobs.Types
+  ( Job(..), Notification(..)
+  , JobCtl(..)
+  , JobContext(..)
+  ) where
+
+import Import.NoFoundation
+
+import Data.Aeson (defaultOptions, Options(..), SumEncoding(..))
+import Data.Aeson.TH (deriveJSON)
+
+import Data.List.NonEmpty (NonEmpty)
+
+
+data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
+         | JobSendTestEmail { jEmail :: Text, jMailContext :: MailContext }
+         | JobQueueNotification { jNotification :: Notification }
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
+                  | NotificationSheetActive { nSheet :: SheetId }
+                  | NotificationSheetInactive { nSheet :: SheetId }
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+
+instance Hashable Job
+instance Hashable Notification
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "job" "data"
+  } ''Job
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "notification" "data"
+  } ''Notification
+
+
+data JobCtl = JobCtlFlush
+            | JobCtlPerform QueuedJobId
+            | JobCtlDetermineCrontab
+            | JobCtlQueue Job
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Hashable JobCtl
+
+
+data JobContext = JobContext
+  { jobCrontab :: TVar (Crontab JobCtl)
+  , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
+  }

src/Mail.hs

@@ -0,0 +1,479 @@
+{-# LANGUAGE NoImplicitPrelude
+           , GeneralizedNewtypeDeriving
+           , DerivingStrategies
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , UndecidableInstances
+           , DeriveGeneric
+           , TemplateHaskell
+           , OverloadedStrings
+           , RecordWildCards
+           , FlexibleContexts
+           , TypeFamilies
+           , ViewPatterns
+           , NamedFieldPuns
+           , MultiWayIf
+           , QuasiQuotes
+           , RankNTypes
+           , ScopedTypeVariables
+           , DeriveDataTypeable
+  #-}
+
+module Mail
+  ( -- * Structured MIME emails
+    module Network.Mail.Mime
+    -- * MailT
+  , MailT, defMailT
+  , MailSmtpData(..), MailContext(..), MailLanguages(..)
+  , MonadMail(..)
+  , getMailMessageRender, getMailMsgRenderer
+    -- * YesodMail
+  , VerpMode(..)
+  , YesodMail(..)
+  , MailException(..)
+    -- * Monadically constructing Mail
+  , PrioritisedAlternatives
+  , ToMailPart(..)
+  , addAlternatives, provideAlternative, providePreferredAlternative
+  , addPart
+  , MonadHeader(..)
+  , MailHeader
+  , MailObjectId
+  , replaceMailHeader, addMailHeader, removeMailHeader
+  , replaceMailHeaderI, addMailHeaderI
+  , setSubjectI, setMailObjectId, setMailObjectId'
+  , setDateCurrent
+  , setMailSmtpData
+  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
+  , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
+  ) where
+
+import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
+import qualified ClassyPrelude.Yesod as Yesod (getMessageRender)
+
+import Network.Mail.Mime hiding (addPart, addAttachment)
+import qualified Network.Mail.Mime as Mime (addPart)
+
+import Data.Monoid (Last(..))
+import Control.Monad.Trans.RWS (RWST(..), execRWST)
+import Control.Monad.Trans.State (StateT(..), execStateT, State, mapStateT)
+import Control.Monad.Trans.Writer (execWriter, Writer)
+import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify)
+import Control.Monad.Fail
+
+import GHC.Generics (Generic)
+import Generics.Deriving.Monoid (memptydefault, mappenddefault)
+
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import Data.Data (Data)
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import qualified Data.Text as Text
+
+import qualified Data.Foldable as Foldable
+
+import Data.Hashable
+
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Builder as LTB
+import qualified Data.ByteString.Lazy as LBS
+
+import Utils (MsgRendererS(..))
+import Utils.Lens.TH
+import Control.Lens
+
+import Text.Blaze.Renderer.Utf8
+
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import Data.UUID.Cryptographic.ImplicitNamespace
+
+import Data.Binary (Binary)
+
+import GHC.TypeLits (KnownSymbol)
+
+import Network.BSD (getHostName)
+
+import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
+import Data.Time.LocalTime (ZonedTime(..))
+import Data.Time.Format
+
+import Network.HaskellNet.SMTP (SMTPConnection)
+import qualified Network.HaskellNet.SMTP as SMTP
+
+import qualified Text.Hamlet as Hamlet (Translate)
+import qualified Text.Shakespeare as Shakespeare (RenderUrl)
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+import Data.Aeson (Options(..))
+import Data.Aeson.TH
+import Utils (MsgRendererS(..))
+import Utils.PathPiece (splitCamel)
+import Utils.DateTime
+
+import Data.Universe.Instances.Reverse ()
+import Data.Universe.Instances.Reverse.JSON ()
+import Data.Universe.Instances.Reverse.Hashable ()
+
+makeLenses_ ''Mail
+makeLenses_ ''Part
+
+
+newtype MailT m a = MailT { unMailT :: RWST MailContext MailSmtpData Mail m a }
+  deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
+                   , MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
+                   , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext
+                   )
+
+instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
+  type MonadCryptoKey (MailT m) = CryptoIDKey
+  cryptoIDKey f = lift (cryptoIDKey return) >>= f
+
+data MailSmtpData = MailSmtpData
+  { smtpEnvelopeFrom :: Last Text
+  , smtpRecipients :: Set Text
+  } deriving (Eq, Ord, Show, Read, Generic)
+
+instance Monoid (MailSmtpData) where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+  deriving newtype (FromJSON, ToJSON)
+
+instance Default MailLanguages where
+  def = MailLanguages []
+
+instance Hashable MailLanguages
+
+data MailContext = MailContext
+  { mcLanguages :: MailLanguages
+  , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''MailContext
+
+instance Hashable MailContext
+
+makeLenses_ ''MailContext
+
+class (MonadHandler m, MonadState Mail m) => MonadMail m where
+  askMailLanguages :: m MailLanguages
+  askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
+  tellMailSmtpData :: MailSmtpData -> m ()
+
+instance MonadHandler m => MonadMail (MailT m) where
+  askMailLanguages = view _mcLanguages
+  askMailDateTimeFormat = (view _mcDateTimeFormat ??)
+  tellMailSmtpData = tell
+
+data VerpMode = VerpNone
+              | Verp { verpSeparator, verpAtReplacement :: Char }
+  deriving (Eq, Show, Read)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , sumEncoding = UntaggedValue
+  } ''VerpMode
+
+getMailMessageRender :: ( MonadMail m
+                        , HandlerSite m ~ site
+                        , RenderMessage site msg
+                        ) => m (msg -> Text)
+getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
+
+getMailMsgRenderer :: forall site m.
+                      ( MonadMail m
+                      , HandlerSite m ~ site
+                      ) => m (MsgRendererS site)
+getMailMsgRenderer = do
+  mr <- getMailMessageRender
+  return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text)
+
+
+data MailException = MailNotAvailable
+                   | MailNoSenderSpecified
+                   | MailNoRecipientsSpecified
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Exception MailException
+  
+
+class Yesod site => YesodMail site where
+  defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
+  defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
+
+  mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
+  mailObjectIdDomain = pack <$> liftIO getHostName
+
+  mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ
+  mailDateTZ = return utcTZ
+
+  mailSmtp :: ( MonadHandler m
+              , HandlerSite m ~ site
+              , MonadBaseControl IO m
+              ) => (SMTPConnection -> m a) -> m a
+  mailSmtp _ = throwM MailNotAvailable
+
+  mailVerp :: ( MonadHandler m
+              , HandlerSite m ~ site
+              ) => m VerpMode
+  mailVerp = return VerpNone
+
+  mailT :: ( MonadHandler m
+           , HandlerSite m ~ site
+           , MonadBaseControl IO m
+           , MonadLogger m
+           ) => MailContext -> MailT m a -> m a
+  mailT = defMailT
+
+  defaultMailLayout :: ( MonadHandler m
+                       , HandlerSite m ~ site
+                       ) => WidgetT site IO () -> m Html
+  defaultMailLayout wgt = do
+    PageContent{..} <- liftHandlerT $ widgetToPageContent wgt
+    msgs <- getMessages
+    withUrlRenderer [hamlet|
+      $newline never
+      $doctype 5
+      <html>
+        <head>
+          <title>#{pageTitle}
+          ^{pageHead}
+        <body>
+          $forall (status, msg) <- msgs
+            <p class="message #{status}">#{msg}
+        ^{pageBody}
+    |]
+
+defMailT :: ( MonadHandler m
+            , YesodMail (HandlerSite m)
+            , MonadBaseControl IO m
+            , MonadLogger m
+            ) => MailContext
+              -> MailT m a
+              -> m a
+defMailT ls (MailT mail) = do
+  fromAddress <- defaultFromAddress
+  (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress)
+  mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
+  $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
+  ret <$ case smtpData of
+    MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
+    MailSmtpData{ smtpRecipients }
+      | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
+    MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
+                , smtpRecipients = (map unpack . toList -> recipients)
+                } -> mailSmtp $ \conn -> do
+      $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
+      liftIO $ SMTP.sendMail
+        returnPath
+        recipients
+        mail'
+        conn
+
+
+data PrioritisedAlternatives m = PrioritisedAlternatives
+  { preferredAlternative :: Last (m Part)
+  , otherAlternatives :: Seq (m Part)
+  } deriving (Generic)
+
+instance Monoid (PrioritisedAlternatives m) where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+class YesodMail site => ToMailPart site a where
+  type MailPartReturn site a :: *
+  type MailPartReturn site a = ()
+  toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
+
+instance YesodMail site => ToMailPart site (StateT Part (HandlerT site IO) a) where
+  type MailPartReturn site (StateT Part (HandlerT site IO) a) = a
+  toMailPart = mapStateT liftHandlerT
+
+instance YesodMail site => ToMailPart site LT.Text where
+  toMailPart text = do
+    _partType .= "text/plain; charset=utf-8"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= encodeUtf8 text
+
+instance YesodMail site => ToMailPart site Text where
+  toMailPart = toMailPart . LT.fromStrict
+
+instance YesodMail site => ToMailPart site LTB.Builder where
+  toMailPart = toMailPart . LTB.toLazyText
+
+instance YesodMail site => ToMailPart site Html where
+  toMailPart html = do
+    _partType .= "text/html; charset=utf-8"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= renderMarkup html
+
+instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
+  type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
+  toMailPart act = do
+    mr <- lift getMailMessageRender
+    toMailPart $ act (toHtml . mr)
+
+instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where
+  type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a
+  toMailPart act = do
+    mr <- lift getMailMsgRenderer
+    toMailPart $ act mr
+
+instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where
+  type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a
+  toMailPart act = do
+    ur <- getUrlRenderParams
+    toMailPart $ act ur
+
+instance YesodMail site => ToMailPart site Aeson.Value where
+  toMailPart val = do
+    _partType .= "application/json; charset=utf-8"
+    _partEncoding .= QuotedPrintableText
+    _partContent .= Aeson.encodePretty val
+
+
+addAlternatives :: (MonadMail m)
+                => Writer (PrioritisedAlternatives m) ()
+                -> m ()
+addAlternatives provided = do
+  let PrioritisedAlternatives{..} = execWriter provided
+  alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
+  modify $ Mime.addPart alternatives
+
+provideAlternative, providePreferredAlternative
+  :: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
+  => a
+  -> Writer (PrioritisedAlternatives m) ()
+provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
+providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
+
+addPart :: ( MonadMail m
+           , HandlerSite m ~ site
+           , ToMailPart site a
+           ) => a -> m (MailPartReturn site a)
+addPart part = do
+  (ret, part') <- runStateT (toMailPart part) initialPart
+  modify . Mime.addPart $ pure part'
+  return ret
+
+initialPart :: Part
+initialPart = Part
+  { partType = "text/plain"
+  , partEncoding = None
+  , partFilename = Nothing
+  , partHeaders = []
+  , partContent = mempty
+  }
+
+
+class MonadHandler m => MonadHeader m where
+  modifyHeaders :: (Headers -> Headers) -> m ()
+  objectIdHeader :: m MailHeader
+
+instance MonadHandler m => MonadHeader (MailT m) where
+  modifyHeaders f = MailT . modify $ over _mailHeaders f
+  objectIdHeader = return "Message-ID"
+
+instance MonadHandler m => MonadHeader (StateT Part m) where
+  modifyHeaders f = _partHeaders %= f
+  objectIdHeader = return "Content-ID"
+
+
+type MailHeader = ByteString
+type MailObjectId = Text
+
+
+replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m ()
+replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC
+
+addMailHeader :: MonadHeader m => MailHeader -> Text -> m ()
+addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c)
+
+removeMailHeader :: MonadHeader m => MailHeader -> m ()
+removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders
+
+
+replaceMailHeaderI :: ( RenderMessage site msg
+                      , MonadMail m
+                      , HandlerSite m ~ site
+                      , MonadHeader m
+                      ) => MailHeader -> msg -> m ()
+replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg
+  
+addMailHeaderI :: ( RenderMessage site msg
+                  , MonadMail m
+                  , HandlerSite m ~ site
+                  , MonadHeader m
+                  ) => MailHeader -> msg -> m ()
+addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> pure msg)
+
+
+setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
+setSubjectI = replaceMailHeaderI "Subject"
+
+setMailObjectUUID :: ( MonadHeader m
+                     , YesodMail (HandlerSite m)
+                     ) => UUID -> m MailObjectId
+setMailObjectUUID uuid = do
+  domain <- mailObjectIdDomain
+  oidHeader <- objectIdHeader
+  let objectId = UUID.toText uuid <> "@" <> domain
+  replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
+  return objectId
+
+setMailObjectId :: ( MonadHeader m
+                   , YesodMail (HandlerSite m)
+                   ) => m MailObjectId
+setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
+
+setMailObjectId' :: ( MonadHeader m
+                    , YesodMail (HandlerSite m)
+                    , MonadCrypto m
+                    , HasCryptoUUID plain m
+                    , MonadCryptoKey m ~ CryptoIDKey
+                    , KnownSymbol (CryptoIDNamespace UUID plain)
+                    , Binary plain
+                    ) => plain -> m MailObjectId
+setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
+
+
+setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
+setDateCurrent = do
+  now <- liftIO getCurrentTime
+  tz <- mailDateTZ
+  let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz now) (timeZoneForUTCTime tz now)
+  replaceMailHeader "Date" . Just $ pack timeStr
+
+
+setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
+setMailSmtpData = do
+  Address _ from <- use _mailFrom
+  recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
+
+  tell $ mempty { smtpRecipients = recps }
+
+  verpMode <- mailVerp
+  if
+    | Verp{..} <- verpMode
+    , [recp] <- Set.toList recps
+    -> let doVerp (Text.breakOn "@" -> (user, domain)) recp = mconcat
+             [ user
+             , Text.singleton verpSeparator
+             , Text.replace "@" (Text.singleton verpAtReplacement) recp
+             , domain
+             ]
+        in tell $ mempty { smtpEnvelopeFrom = Last . Just $ doVerp from recp }
+    | otherwise
+    -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }

src/Model.hs

@@ -7,6 +7,8 @@
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 
@@ -14,6 +16,7 @@
 module Model
   ( module Model
   , module Model.Types
+  , module Cron.Types
   ) where
 
 import ClassyPrelude.Yesod
@@ -21,7 +24,10 @@ import Database.Persist.Quasi
 -- import Data.Time
 -- import Data.ByteString
 import Model.Types
-import Data.Aeson.TH
+import Cron.Types
+
+import Data.Aeson (Value)
+import Data.Aeson.TH (deriveJSON, defaultOptions)
 
 import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive.Instances ()
@@ -35,7 +41,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
 
 -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
 deriving instance Eq (Unique Course)
-
+  
 data PWEntry = PWEntry
   { pwUser :: User
   , pwHash :: Text

src/Model/Migration.hs

@@ -189,6 +189,13 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
+    , whenM (tableExists "user") $ do
+        [executeQQ|
+          ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null;
+          UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
+        |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -5,16 +5,23 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
 {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
-module Model.Types where
+module Model.Types
+  ( module Model.Types
+  , module Numeric.Natural
+  , module Mail
+  , module Utils.DateTime
+  ) where
 
 import ClassyPrelude
 import Utils
 import Control.Lens
+import Utils.Lens.TH
 
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -26,6 +33,8 @@ import Data.Universe
 import Data.Universe.Helpers
 import Data.UUID.Types
 
+import Data.Default
+
 import Text.Read (readMaybe)
 
 import Database.Persist.TH hiding (derivePersistFieldJSON)
@@ -40,20 +49,32 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Lens as Text
 
+import qualified Data.HashMap.Strict as HashMap
+
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import Data.CaseInsensitive.Instances ()
 
 import Yesod.Core.Dispatch (PathPiece(..))
-import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
+import Data.Aeson.Types (toJSONKeyText)
 import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
 
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 import Data.Typeable (Typeable)
 
+import Data.Universe.Instances.Reverse ()
+
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
+import Mail (MailLanguages(..))
+import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
+
+import Numeric.Natural
+
 
 instance PathPiece UUID where
   fromPathPiece = Data.UUID.Types.fromString . unpack
@@ -108,6 +129,8 @@ instance DisplayAble SheetType where
 deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON ''SheetType
 
+makeLenses_ ''SheetType
+
 data SheetTypeSummary = SheetTypeSummary
   { sumBonusPoints  :: Sum Points
   , sumNormalPoints :: Sum Points
@@ -130,13 +153,15 @@ sheetTypeSum (NotGraded,  _       ) = mempty { numNotGraded = Sum 1 }
 
 
 data SheetGroup
-  = Arbitrary { maxParticipants :: Int }
+  = Arbitrary { maxParticipants :: Natural }
   | RegisteredGroups
   | NoGroups
   deriving (Show, Read, Eq)
 deriveJSON defaultOptions ''SheetGroup
 derivePersistFieldJSON ''SheetGroup
 
+makeLenses_ ''SheetGroup
+
 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "SheetFileType"
@@ -332,7 +357,7 @@ instance PathPiece TermIdentifier where
   toPathPiece = termToText
 
 instance ToJSON TermIdentifier where
-  toJSON = String . termToText
+  toJSON = Aeson.String . termToText
 
 instance FromJSON TermIdentifier where
   parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
@@ -355,6 +380,16 @@ data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded)
 derivePersistField "StudyFieldType"
 
+instance PersistField UUID where
+  toPersistValue = PersistDbSpecific . toASCIIBytes
+  fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ fromText t
+  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
+  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
+  fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
+
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"
+
 instance DisplayAble StudyFieldType
 
 data Theme
@@ -391,12 +426,6 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
     fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
     toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
 
-newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
-  deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
-
-data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
-  deriving (Eq, Ord, Read, Show, Enum, Bounded)
-
 
 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
@@ -429,14 +458,76 @@ deriveJSON defaultOptions
 
 derivePersistFieldJSON ''AuthenticationMode
 
-  
+
+derivePersistFieldJSON ''Value
+
+
+-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
+--
+-- Could maybe be replaced with `Structure Notification` in the long term
+data NotificationTrigger = NTSubmissionRatedGraded
+                         | NTSubmissionRated
+                         | NTSheetActive
+                         | NTSheetInactive
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+
+instance Universe NotificationTrigger
+instance Finite NotificationTrigger
+
+instance Hashable NotificationTrigger
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  } ''NotificationTrigger
+
+instance ToJSONKey NotificationTrigger where
+  toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
+
+instance FromJSONKey NotificationTrigger where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
+
+
+newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
+  deriving (Generic, Typeable)
+  deriving newtype (Eq, Ord, Read, Show)
+
+instance Default NotificationSettings where
+  def = NotificationSettings $ \case
+    NTSubmissionRatedGraded -> True
+    NTSubmissionRated -> False
+    NTSheetActive -> True
+    NTSheetInactive -> True
+
+instance ToJSON NotificationSettings where
+  toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
+
+instance FromJSON NotificationSettings where
+  parseJSON = withObject "NotificationSettings" $ \o -> do
+    o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
+    return . NotificationSettings $ \n -> case HashMap.lookup n o' of
+      Nothing -> notificationAllowed def n
+      Just b  -> b
+
+derivePersistFieldJSON ''NotificationSettings
+
+
+instance ToBackendKey SqlBackend record => Hashable (Key record) where
+  hashWithSalt s key = s `hashWithSalt` fromSqlKey key
+
+
+derivePersistFieldJSON ''MailLanguages
+
+
 -- Type synonyms
 
+type Email           = Text
+
 type SchoolName      = CI Text
 type SchoolShorthand = CI Text
 type CourseName      = CI Text
 type CourseShorthand = CI Text
 type SheetName       = CI Text
-type UserEmail       = CI Text
+type UserEmail       = CI Email
 
 type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
+type InstanceId      = UUID

src/Model/Types/JSON.hs

@@ -50,7 +50,7 @@ derivePersistFieldJSON n = do
       ]
     , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
       [ funD (mkName "sqlType")
-        [ clause [wildP] (normalB [e|SqlOther "json"|]) []
+        [ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
         ]
       ]
     ]

src/Settings.hs

@@ -1,9 +1,12 @@
-{-# LANGUAGE CPP               #-}
+{-# LANGUAGE CPP                #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE NoImplicitPrelude  #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE RecordWildCards    #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TemplateHaskell    #-}
-{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE MultiWayIf         #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -- | Settings are centralized, as much as possible, into this file. This
 -- includes database connection settings, static file locations, etc.
@@ -15,7 +18,7 @@ module Settings where
 import           ClassyPrelude.Yesod
 import qualified Control.Exception           as Exception
 import           Data.Aeson                  (Result (..), fromJSON, withObject,
-                                              (.!=), (.:?))
+                                              (.!=), (.:?), withScientific)
 import qualified Data.Aeson.Types as Aeson
 import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
@@ -29,6 +32,12 @@ import           Yesod.Default.Util          (WidgetFileSettings,
                                               widgetFileReload)
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
+import Data.Time (NominalDiffTime)
+
+import Data.Scientific (toBoundedInteger)
+import Data.Word (Word16)
+
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
@@ -39,6 +48,13 @@ import Control.Lens
 import Data.Maybe (fromJust)
 import qualified Data.Char as Char
 
+import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
+import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
+
+import Network.Mail.Mime (Address)
+
+import Mail (VerpMode)
+
 import Model
 
 -- | Runtime settings to configure this application. These settings can be
@@ -51,6 +67,8 @@ data AppSettings = AppSettings
     -- ^ Configuration settings for accessing the database.
     , appLdapConf               :: Maybe LdapConf
     -- ^ Configuration settings for accessing the LDAP-directory
+    , appSmtpConf               :: Maybe SmtpConf
+    -- ^ Configuration settings for accessing a SMTP Mailserver
     , appRoot                   :: Maybe Text
     -- ^ Base for all generated URLs. If @Nothing@, determined
     -- from the request headers.
@@ -61,6 +79,14 @@ data AppSettings = AppSettings
     , appIpFromHeader           :: Bool
     -- ^ Get the IP address from the header when logging. Useful when sitting
     -- behind a reverse proxy.
+    , appMailFrom               :: Address
+    , appMailObjectDomain       :: Text
+    , appMailVerp               :: VerpMode
+    , appJobWorkers             :: Int
+    , appJobFlushInterval       :: Maybe NominalDiffTime
+    , appJobCronInterval        :: NominalDiffTime
+    , appJobStaleThreshold      :: NominalDiffTime
+    , appNotificationRateLimit  :: NominalDiffTime
 
     , appDetailedRequestLogging :: Bool
     -- ^ Use detailed request logging system
@@ -82,20 +108,24 @@ data AppSettings = AppSettings
     , appAuthPWHash             :: PWHashConf
 
     , appCryptoIDKeyFile        :: FilePath
-    }
+    , appInstanceIDFile         :: Maybe FilePath
+    } deriving (Show)
   
 data UserDefaultConf = UserDefaultConf
   { userDefaultTheme :: Theme
   , userDefaultMaxFavourites :: Int
   , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
   , userDefaultDownloadFiles :: Bool
-  }
+  } deriving (Show)
  
 data PWHashConf = PWHashConf
   { pwHashAlgorithm :: PWHashAlgorithm
   , pwHashStrength :: Int
   }
 
+instance Show PWHashConf where
+  show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }"
+
 instance FromJSON PWHashConf where
   parseJSON = withObject "PWHashConf" $ \o -> do
     pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text)
@@ -113,8 +143,31 @@ data LdapConf = LdapConf
   , ldapBase :: Ldap.Dn
   , ldapScope :: Ldap.Scope
   , ldapTimeout :: Int32
-  }
+  } deriving (Show)
  
+data SmtpConf = SmtpConf
+  { smtpHost :: HaskellNet.HostName
+  , smtpPort :: HaskellNet.PortNumber
+  , smtpAuth :: Maybe SmtpAuthConf
+  , smtpSsl  :: SmtpSslMode
+  , smtpPool :: ResourcePoolConf
+  } deriving (Show)
+
+data ResourcePoolConf = ResourcePoolConf
+  { poolStripes :: Int
+  , poolTimeout :: NominalDiffTime
+  , poolLimit :: Int
+  } deriving (Show)
+
+data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls
+  deriving (Show)
+
+data SmtpAuthConf = SmtpAuthConf
+  { smtpAuthType :: HaskellNet.AuthType
+  , smtpAuthUsername :: HaskellNet.UserName
+  , smtpAuthPassword :: HaskellNet.Password
+  } deriving (Show)
+
 deriveFromJSON defaultOptions ''Ldap.Scope
 deriveFromJSON defaultOptions
   { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
@@ -139,6 +192,12 @@ instance FromJSON LdapConf where
         ldapTimeout <- o .: "timeout"
         return LdapConf{..}
 
+deriveFromJSON
+  defaultOptions
+    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    }
+  ''ResourcePoolConf
+
 deriveFromJSON
   defaultOptions
     { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
@@ -146,6 +205,52 @@ deriveFromJSON
     }
   ''LogLevel
 
+instance FromJSON HaskellNet.PortNumber where
+  parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of
+    Just int -> return $ fromIntegral (int :: Word16)
+    Nothing -> fail "Expected whole number of plausible size to denote port"
+
+deriveFromJSON
+  defaultOptions
+    { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack
+    , allNullaryToStringTag = True
+    }
+  ''HaskellNet.AuthType
+
+instance FromJSON SmtpConf where
+  parseJSON = withObject "SmtpConf" $ \o -> do
+    smtpHost <- o .: "host"
+    smtpPort <- o .: "port"
+    smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth"
+    smtpSsl <- o .: "ssl"
+    smtpPool <- o .: "pool"
+    return SmtpConf{..}
+
+deriveFromJSON
+  defaultOptions
+    { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+    , allNullaryToStringTag = True
+    }
+  ''SmtpSslMode
+
+deriveFromJSON
+  defaultOptions
+    { fieldLabelModifier = let
+                             nameMap "username" = "user"
+                             nameMap "password" = "pass"
+                             nameMap x = x
+                           in nameMap . intercalate "-" . map toLower . drop 2 . splitCamel
+    }
+  ''SmtpAuthConf
+
+deriveFromJSON
+  defaultOptions
+    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+    }
+  ''Address
+
+
+
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -160,11 +265,22 @@ instance FromJSON AppSettings where
               Ldap.Tls host _ -> not $ null host
               Ldap.Plain host -> not $ null host
         appLdapConf               <- assertM nonEmptyHost <$> o .:? "ldap"
+        appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"
         appIpFromHeader           <- o .: "ip-from-header"
 
+        appMailFrom               <- o .: "mail-from"
+        appMailObjectDomain       <- o .: "mail-object-domain"
+        appMailVerp               <- o .: "mail-verp"
+
+        appJobWorkers             <- o .:  "job-workers"
+        appJobFlushInterval       <- o .:? "job-flush-interval"
+        appJobCronInterval        <- o .:  "job-cron-interval"
+        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"
@@ -178,6 +294,7 @@ instance FromJSON AppSettings where
         appAuthPWHash             <- o .:  "auth-pw-hash"
 
         appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
+        appInstanceIDFile         <- o .:? "instance-idfile"
 
         return AppSettings {..}
 

src/Utils/DateTime.hs

@@ -2,7 +2,12 @@
            , TemplateHaskell
            , QuasiQuotes
            , StandaloneDeriving
+           , DerivingStrategies
            , DeriveLift
+           , DeriveDataTypeable
+           , DeriveGeneric
+           , GeneralizedNewtypeDeriving
+           , OverloadedStrings
   #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -10,6 +15,8 @@ module Utils.DateTime
   ( timeLocaleMap
   , TimeLocale(..)
   , currentYear
+  , DateTimeFormat(..)
+  , SelDateTimeFormat(..)
   , module Data.Time.Zones
   , module Data.Time.Zones.TH
   ) where
@@ -25,6 +32,18 @@ import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
 import Instances.TH.Lift ()
 
+import Data.Data (Data)
+import Data.Typeable (Typeable)
+import Data.Universe
+
+import Database.Persist.Sql (PersistField, PersistFieldSql)
+
+import Data.Aeson.Types (toJSONKeyText)
+import Data.Aeson
+import Data.Aeson.TH
+
+import Utils.PathPiece
+
 deriving instance Lift TimeZone
 deriving instance Lift TimeLocale
 
@@ -63,3 +82,26 @@ currentYear = do
   now <- runIO getCurrentTime
   let (year, _, _) = toGregorian $ utctDay now
   [e|year|]
+
+
+newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
+  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
+  deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
+
+instance Hashable DateTimeFormat
+
+data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
+
+instance Universe SelDateTimeFormat
+instance Finite SelDateTimeFormat
+instance Hashable SelDateTimeFormat
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+  } ''SelDateTimeFormat
+
+instance ToJSONKey SelDateTimeFormat where
+  toJSONKey = toJSONKeyText $ \v -> let String txt = toJSON v in txt
+instance FromJSONKey SelDateTimeFormat where
+  fromJSONKey = FromJSONKeyTextParser $ parseJSON . String

src/Utils/Form.hs

@@ -9,6 +9,8 @@
            , FlexibleContexts
            , NamedFieldPuns
            , ScopedTypeVariables
+           , MultiWayIf
+           , RecordWildCards
 #-}
 
 module Utils.Form where
@@ -23,6 +25,12 @@ import qualified Data.Char as Char
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
+import Data.Map.Lazy ((!))
+import qualified Data.Map.Lazy as Map
+import qualified Data.Set as Set
+
+import Data.List ((!!))
+
 import Web.PathPieces
 
 -------------------
@@ -135,6 +143,9 @@ addDatalist field mValues = field
       |]
   }
 
+noValidate :: FieldSettings site -> FieldSettings site
+noValidate = addAttr "formnovalidate" ""
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
@@ -216,3 +227,36 @@ ciField :: ( Textual t
            , RenderMessage (HandlerSite m) FormMessage
            ) => Field m (CI t)
 ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField
+
+reorderField :: ( MonadHandler m
+                , HandlerSite m ~ site
+                , Eq a
+                , Show a
+                ) => HandlerT site IO (OptionList a) -> Field m [a] 
+-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result)
+reorderField optList = Field{..}
+  where
+    fieldEnctype = UrlEncoded
+    fieldParse [] _ = return $ Right Nothing
+    fieldParse optlist _ = do
+      OptionList{..} <- liftHandlerT optList
+      let
+        olNum = fromIntegral $ length olOptions
+        selOptions = Map.fromList $ do
+          i <- [1..olNum]
+          (readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist
+          guard $ i == n
+          Just val <- return . olReadExternal $ pack extVal
+          return (i, val)
+      return $ if
+        | Map.keysSet selOptions == Set.fromList [1..olNum]
+          -> Right . Just $ map (selOptions !) [1..fromIntegral olNum]
+        | otherwise
+          -> Left "Not a valid permutation"
+    fieldView theId name attrs val isReq = do
+      OptionList{..} <- liftHandlerT optList
+      let
+        isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue
+        nums = map (id &&& withNum theId) [1..length olOptions]
+        withNum t n = tshow n <> "." <> t
+      $(widgetFile "widgets/permutation")

src/Utils/Message.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 
 module Utils.Message
@@ -13,7 +14,7 @@ import Data.Universe
 import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
 
 import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
-import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html)
+import ClassyPrelude.Yesod hiding (addMessage, addMessageI)
 
 
 data MessageClass = Error | Warning | Info | Success

src/Utils/TH.hs

@@ -1,11 +1,13 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Utils.TH where
 -- Common Utility Functions that require TemplateHaskell
 
 -- import Data.Char
 
+import Prelude
 import Language.Haskell.TH
 -- import Control.Monad
 -- import Control.Monad.Trans.Class

src/index.md

@@ -96,3 +96,13 @@ CryptoID
   
 Model.Migration
   : Manuelle Datenbank-Migration
+
+Jobs
+  : `handleJobs` worker thread handling background jobs
+    `JobQueueException`
+    
+Jobs.Types
+  : `Job`, `Notification`, `JobCtl` Types of Jobs
+
+Mail
+  : Monadically constructing MIME emails

templates/adminTest.hamlet

@@ -34,3 +34,5 @@
       Modals:
       ^{modal "Klick mich für Ajax-Test" (Left UsersR)}
       ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
+    <li>
+      ^{modal "Email-Test" (Right emailWidget')}

templates/correction-user.cassius

@@ -0,0 +1,3 @@
+.comment
+  white-space: pre-wrap
+  font-family: monospace

templates/correction-user.hamlet

@@ -36,4 +36,4 @@
     $maybe comment <- ratingComment
       <tr .table__row>
         <th .table__th>_{MsgRatingComment}
-        <td .table__td style="white-space: pre;">#{comment}
+        <td .table__td .comment>#{comment}

templates/correction.hamlet

@@ -1,11 +1,10 @@
-^{userCorrection}
+<section>
+  ^{userCorrection}
 
-<hr>
+<section> 
-  
+  <form method=post enctype=#{corrEncoding}>
-<form method=post enctype=#{corrEncoding}>
+    ^{corrForm}
-  ^{corrForm}
 
-<hr>
+<section>
-  
+  <form method=post enctype=#{uploadEncoding}>
-<form method=post enctype=#{uploadEncoding}>
+    ^{uploadForm}
-  ^{uploadForm}

templates/default-layout.lucius

@@ -185,6 +185,10 @@ h4 {
   p {
     margin: 10px 0;
   }
+
+  p:last-child {
+    margin: 10px 0 0;
+  }
 }
 
 .logged-in {
@@ -309,6 +313,10 @@ input[type="button"].btn-info:hover,
   width: 100%;
 }
 
+.table:only-child {
+    margin: 0;
+}
+
 .table--striped {
 
   .table__row:not(.no-stripe):nth-child(even) {
@@ -502,3 +510,17 @@ input[type="button"].btn-info:hover,
     padding-right: 15px;
   }
 }
+
+section {
+    padding: 0 0 12px;
+    margin: 0 0 12px;
+    border-bottom: 1px solid #d3d3d3;
+    
+}
+
+section:last-of-type {
+    padding: 0;
+    margin: 0;
+    border-bottom: none;
+}
+

templates/mail/sheetActive.hamlet

@@ -0,0 +1,17 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailSheetActiveIntro (CI.original courseName) termDesc sheetName}
+    <p>
+      <a href=@{CSheetR tid ssh csh shn SShowR}>
+        #{sheetName}

templates/mail/sheetInactive.hamlet

@@ -0,0 +1,17 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{MsgMailSheetInactiveIntro (CI.original courseName) termDesc sheetName}
+    <p>
+      <a href=@{CSheetR tid ssh csh shn SShowR}>
+        #{sheetName}

templates/mail/submissionRated.hamlet

@@ -0,0 +1,65 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+
+      .comment {
+        white-space: pre-wrap;
+        font-family: monospace;
+      }
+  <body>
+    <h1>
+      _{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc}
+    <dl>
+      <dt>
+        _{MsgSubmission}
+      <dd>
+        <a href=@{CSubmissionR tid ssh csh shn csid SubShowR}>
+          #{display csid}
+      $maybe User{..} <- corrector
+        <dt>
+          _{MsgRatingBy}
+        <dd>
+          #{display userDisplayName}
+      $maybe time <- submissionRatingTime'
+        <dt>
+          _{MsgRatingTime}
+        <dd>
+          #{time}
+      $maybe points <- submissionRatingPoints
+        $case sheetType
+          $of Bonus{..}
+            <dt>
+              _{MsgAchievedBonusPoints}
+            <dd>
+              _{MsgAchievedOf points maxPoints}
+          $of Normal{..}
+            <dt>
+              _{MsgAchievedNormalPoints}
+            <dd>
+              _{MsgAchievedOf points maxPoints}
+          $of Pass{..}
+            <dt>
+              _{MsgPassedResult}
+            <dd>
+              $if points >= passingPoints
+                _{MsgPassed}
+              $else
+                _{MsgNotPassed}
+            <dt>
+              _{MsgAchievedPassPoints}
+            <dd>
+              _{MsgPassAchievedOf points passingPoints maxPoints}
+          $of NotGraded
+      $maybe comment <- submissionRatingComment
+        <dt>
+          _{MsgRatingComment}
+        <dd .comment>
+          #{comment}

templates/mail/submissionRated.txt

@@ -0,0 +1 @@
+#{mr (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)}

templates/sheetShow.hamlet

@@ -1,33 +1,32 @@
-<div .container>
+$newline never
-  $maybe descr <- sheetDescription sheet
+$maybe descr <- sheetDescription sheet
-    <h2 #description>Hinweise
+  <section>
-    <p> #{descr}
+    <h2 #description>_{MsgSheetDescription}
+    <p>
+      #{descr}
 
-  <h3>Bewertung
+$maybe marking <- sheetMarkingText sheet
-  <p>
+  <section>
-    #{display $ sheetType sheet}
+    <h2>_{MsgSheetMarking}
-
-  $maybe marking <- sheetMarkingText sheet
     <p>
       #{marking}
 
-  <p>
+<section>
-    Download und Abgabe freigeschaltet ab
+  <dl .deflist>
-    #{sheetFrom}
+    <dt .deflist__dt>_{MsgSheetActiveFrom}
+    <dd .deflist__dd>#{sheetFrom}
+    <dt .deflist__dt>_{MsgSheetActiveTo}
+    <dd .deflist__dd>#{sheetTo}
+    $maybe hints <- hintsFrom <* guard hasHints
+      <dt .deflist__dt>_{MsgSheetHintFrom}
+      <dd .deflist__dd>#{hints}
+    $maybe solution <- solutionFrom <* guard hasSolution
+      <dt .deflist__dt>_{MsgSheetSolutionFrom}
+      <dd .deflist__dd>#{solution}
+    <dt .deflist__dt>_{MsgSheetType}
+    <dd .deflist__dd>_{sheetType sheet}
 
-  <p>
+$if hasFiles
-    Abgabe bis
+  <section>
-    #{sheetTo}
+    <h2>_{MsgSheetFiles}
-
+    ^{fileTable}
-  $maybe hints <- hintsFrom <* guard hasHints
-    <p>
-      Hinweise ab
-      #{hints}
-
-  $maybe solution <- solutionFrom <* guard hasSolution
-    <p>
-      Lösung ab
-      #{solution}
-
-  <h2>Dateien
-  ^{fileTable}

templates/widgets/form.julius

@@ -36,7 +36,6 @@
   };
 
   window.utils.interactiveFieldset = function(form, fieldSets) {
-
     var fields = fieldSets.map(function(fs) {
       return {
         fieldSet: fs,

templates/widgets/form.lucius

@@ -1,10 +1,3 @@
-.hidden {
-  visibility: hidden;
-  height: 0;
-  opacity: 0;
-}
-
-
 fieldset {
   border: 0;
   margin: 20px 0 30px;
@@ -13,3 +6,14 @@ fieldset {
     display: none;
   }
 }
+
+.form-group__input > fieldset {
+  margin-bottom: 0;
+}
+
+.hidden {
+  visibility: hidden;
+  height: 0;
+  opacity: 0;
+  margin: 0;
+}

templates/widgets/permutation.hamlet

@@ -0,0 +1,7 @@
+$newline never
+<ul ##{theId}>
+  $forall (n, selId) <- nums
+    <li>
+      <select ##{selId} name=#{name} :isReq:required *{attrs}>
+        $forall opt <- olOptions
+          <option value=#{withNum (optionExternalValue opt) n} :isSel n opt:selected>#{optionDisplay opt}

templates/widgets/permutation.lucius

@@ -0,0 +1,3 @@
+##{theId} {
+    list-style-type: none;
+}

test.sh

@@ -0,0 +1,14 @@
+#!/usr/bin/env bash
+
+move-back() {
+    mv -v .stack-work .stack-work-test
+    [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
+}
+
+if [[ -d .stack-work-test ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
+    mv -v .stack-work-test .stack-work
+    trap move-back EXIT
+fi
+
+stack test --flag uniworx:dev --flag uniworx:library-only ${@}

test/CronSpec.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module CronSpec where
+
+import TestImport
+
+import Cron
+import Numeric.Natural
+
+import Data.Time
+import Data.Time.Clock.System
+import Data.Time.Zones
+
+import Data.List (iterate)
+
+
+baseTime :: UTCTime
+baseTime = UTCTime (addDays 58400 systemEpochDay) 50000
+
+
+sampleCron :: Natural -> Cron -> [UTCTime]
+sampleCron n = go n baseTime Nothing
+  where
+    go 0 _ _ _ = []
+    go n t mPrev cron = case nextCronMatch utcTZ mPrev t cron of
+      MatchAsap -> t : go (pred n) t (Just t) cron
+      MatchAt t' -> t' : go (pred n) t' (Just t') cron
+      MatchNone -> []
+
+
+spec :: Spec
+spec = do
+  describe "Cron" $ do
+    it "generates correct example series" . mapM_ seriesExample $ 
+      [ (Cron CronAsap Nothing CronScheduleBefore, [baseTime])
+      , (Cron CronAsap (Just $ CronPeriod 10 CronAsap) CronScheduleBefore, iterate (addUTCTime 10) baseTime)
+      ]
+
+seriesExample :: (Cron, [UTCTime]) -> Expectation
+seriesExample (cron, res) = example $ sampleCron 10 cron `shouldBe` take 10 res

test/Handler/ProfileSpec.hs

@@ -4,6 +4,8 @@ module Handler.ProfileSpec (spec) where
 
 import TestImport
 
+import qualified Data.CaseInsensitive as CI
+
 spec :: Spec
 spec = withApp $ do
 
@@ -13,16 +15,16 @@ spec = withApp $ do
             statusIs 403
 
         it "asserts access to my-account for authenticated users" $ do
-            userEntity <- createUser "dummy" "foo"
+            userEntity <- createUser "foo"
             authenticateAs userEntity
 
             get ProfileR
             statusIs 200
 
         it "asserts user's information is shown" $ do
-            userEntity <- createUser "dummy" "bar"
+            userEntity <- createUser "bar"
             authenticateAs userEntity
 
             get ProfileR
             let (Entity _ user) = userEntity
-            htmlAnyContain ".username" . unpack $ userIdent user
+            htmlAnyContain ".username" . unpack . CI.original $ userIdent user

test/TestImport.hs

@@ -25,6 +25,13 @@ import Test.QuickCheck.Gen   as X
 import Data.Default          as X
 import Test.QuickCheck.Instances as X
 
+
+import Settings
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+
 runDB :: SqlPersistM a -> YesodExample UniWorX a
 runDB query = do
     app <- getTestYesod
@@ -79,12 +86,24 @@ authenticateAs :: Entity User -> YesodExample UniWorX ()
 authenticateAs (Entity _ User{..}) = do
     request $ do
         setMethod "POST"
-        addPostParam "ident" $ userPlugin <> ":" <> userIdent
+        addPostParam "ident" $ CI.original userIdent
         setUrl $ AuthR $ PluginR "dummy" []
 
 -- | Create a user.  The dummy email entry helps to confirm that foreign-key
 -- checking is switched off in wipeDB for those database backends which need it.
-createUser :: Text -> Text -> YesodExample UniWorX (Entity User)
+createUser :: CI Text -> YesodExample UniWorX (Entity User)
-createUser userPlugin userIdent = runDB $ insertEntity User{..}
+createUser userIdent = do
-  where
+  UserDefaultConf{..} <- appUserDefaults . appSettings <$> getTestYesod
-    userMatrikelnummer = "DummyMatrikelnummer"
+  let
+    userMatrikelnummer = Nothing
+    userAuthentication = AuthLDAP
+    userEmail = "dummy@example.invalid"
+    userDisplayName = "Dummy Example"
+    userSurname = "Example"
+    userTheme = userDefaultTheme
+    userMaxFavourites = userDefaultMaxFavourites
+    userDateTimeFormat = userDefaultDateTimeFormat
+    userDateFormat = userDefaultDateFormat
+    userTimeFormat = userDefaultTimeFormat
+    userDownloadFiles = userDefaultDownloadFiles
+  runDB $ insertEntity User{..}