Merge branch 'master' into feat/customized-exercises

2020-08-04 10:07:36 +02:00 · 2020-08-04 10:07:36 +02:00 · c4c952ebc1
commit c4c952ebc1
parent 9ee44aa2f1 1d956a5fdc
40 changed files with 516 additions and 161 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -2,6 +2,54 @@

 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.

+## [18.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.4.0...v18.5.0) (2020-08-03)
+
+
+### Bug Fixes
+
+* **jobs:** queue certain jobs at most once ([1be9716](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1be9716))
+
+
+### Features
+
+* admin-crontab-r ([460c133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/460c133))
+
+
+
+## [18.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.3.0...v18.4.0) (2020-08-02)
+
+
+### Bug Fixes
+
+* **migration:** make index migration truly idempotent ([7a17535](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7a17535))
+* weird sql casting ([eb9c676](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/eb9c676))
+* **set-serializable:** logging limit ([60be62b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/60be62b))
+* better concurrency behaviour ([a0392dd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a0392dd))
+* suppress exceptions relating to expired sessions ([d47d6aa](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d47d6aa))
+
+
+### Features
+
+* migrate indexes ([dfe68d5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dfe68d5))
+* **files:** safer file deletion ([88a9239](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88a9239))
+
+
+
+## [18.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.2.2...v18.3.0) (2020-07-28)
+
+
+### Bug Fixes
+
+* **campus-auth:** properly handle login failures ([ec42d83](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ec42d83))
+* correct (switch) sheetHint and sheetSolution mail templates ([d6f0d28](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d6f0d28))
+
+
+### Features
+
+* **failover:** treat alternatives cyclically ([9213b75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9213b75))
+
+
+
 ### [18.2.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.2.1...v18.2.2) (2020-07-23)


--- a/config/settings.yml
+++ b/config/settings.yml
@ -35,7 +35,8 @@ bearer-expiration: 604800
 bearer-encoding: HS256
 maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
 session-files-expire: 3600
-prune-unreferenced-files: 600
+prune-unreferenced-files: 28800
+keep-unreferenced-files: 86400
 health-check-interval:
  matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
  http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"
@ -61,6 +62,7 @@ log-settings:
  all:           "_env:LOG_ALL:false"
  minimum-level: "_env:LOGLEVEL:warn"
  destination:   "_env:LOGDEST:stderr"
+  serializable-transaction-retry-limit: 2

 ip-retention-time: 1209600

--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@ -1342,6 +1342,7 @@ MenuAllocationAccept: Platzvergabe akzeptieren
 MenuFaq: FAQ
 MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen
 MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen
+MenuAdminCrontab: Crontab

 BreadcrumbSubmissionFile: Datei
 BreadcrumbSubmissionUserInvite: Einladung zur Abgabe
@ -1415,6 +1416,7 @@ BreadcrumbMessageHide: Verstecken
 BreadcrumbFaq: FAQ
 BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen
 BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen
+BreadcrumbAdminCrontab: Crontab

 ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}
 ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn}
@ -2683,4 +2685,7 @@ PersonalisedSheetFilesDownloadAnonymous: Anonymisiert
 PersonalisedSheetFilesDownloadSurnames: Mit Nachnamen
 PersonalisedSheetFilesDownloadMatriculations: Mit Matrikelnummern
 PersonalisedSheetFilesDownloadGroups: Mit festen Abgabegruppen
-CoursePersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-personalisierte_dateien
+CoursePersonalisedSheetFilesArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-personalisierte_dateien
+AdminCrontabNotGenerated: (Noch) keine Crontab generiert
+CronMatchAsap: ASAP
+CronMatchNone: Nie
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@ -1340,6 +1340,7 @@ MenuAllocationPriorities: Central priorities
 MenuAllocationCompute: Compute allocation
 MenuAllocationAccept: Accept allocation
 MenuFaq: FAQ
+MenuAdminCrontab: Crontab

 BreadcrumbSubmissionFile: File
 BreadcrumbSubmissionUserInvite: Invitation to participate in a submission
@ -1411,6 +1412,7 @@ BreadcrumbAllocationCompute: Compute allocation
 BreadcrumbAllocationAccept: Accept allocation
 BreadcrumbMessageHide: Hide
 BreadcrumbFaq: FAQ
+BreadcrumbAdminCrontab: Crontab

 ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn}
 ExternalExamGrades coursen examn: Exam achievements: #{coursen}, #{examn}
@ -2665,3 +2667,7 @@ SubmissionDoneByFile: According to correction file
 SubmissionDoneAlways: Always
 CorrUploadSubmissionDoneMode: Rating finished
 CorrUploadSubmissionDoneModeTip: Should uploaded corrections be marked as finished? The rating is only visible to the submittors and considered for any exam bonuses if it is finished.
+
+AdminCrontabNotGenerated: Crontab not (yet) generated
+CronMatchAsap: ASAP
+CronMatchNone: Never
--- a/models/files.model
+++ b/models/files.model
@ -1,8 +1,14 @@
 FileContent
-    hash            FileContentReference
-    content         ByteString
-    Primary         hash
+    hash              FileContentReference
+    content           ByteString
+    unreferencedSince UTCTime Maybe
+    Primary           hash

 SessionFile
    content         FileContentReference Maybe
-    touched         UTCTime
+    touched         UTCTime
+
+FileLock
+    content         FileContentReference
+    instance        InstanceId
+    time            UTCTime
--- a/package-lock.json
+++ b/package-lock.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "18.2.2",
+  "version": "18.5.0",
  "lockfileVersion": 1,
  "requires": true,
  "dependencies": {
--- a/package.json
+++ b/package.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "18.2.2",
+  "version": "18.5.0",
  "description": "",
  "keywords": [],
  "author": "",
--- a/package.yaml
+++ b/package.yaml
@ -1,5 +1,5 @@
 name:    uniworx
-version: 18.2.2
+version: 18.5.0

 dependencies:
  - base
--- a/1
+++ b/1
@ -56,6 +56,7 @@
 /admin/test                   AdminTestR       GET POST
 /admin/errMsg                 AdminErrMsgR     GET POST
 /admin/tokens                 AdminTokensR     GET POST
+/admin/crontab                AdminCrontabR    GET

 /health                       HealthR          GET             !free
 /instance                     InstanceR        GET             !free
--- a/src/Application.hs
+++ b/src/Application.hs
@ -98,6 +98,8 @@ import qualified Web.ServerSession.Backend.Acid as Acid
 import qualified Ldap.Client as Ldap (Host(Plain, Tls))

 import qualified Network.Minio as Minio
+  
+import Web.ServerSession.Core (StorageException(..))

 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
@ -433,7 +435,7 @@ warpSettings foundation = defaultSettings
    & setHost (foundation ^. _appHost)
    & setPort (foundation ^. _appPort)
    & setOnException (\_req e ->
-        when (defaultShouldDisplayException e) $ do
+        when (shouldDisplayException e) $ do
          logger <- readTVarIO . snd $ appLogger foundation
          messageLoggerSource
            foundation
@ -443,6 +445,16 @@ warpSettings foundation = defaultSettings
            LevelError
            (toLogStr $ "Exception from Warp: " ++ show e)
                     )
+  where
+    shouldDisplayException e = and
+      [ defaultShouldDisplayException e
+      , case fromException e of
+          Just (SessionDoesNotExist{} :: StorageException (MemcachedSqlStorage SessionMap)) -> False
+          _other -> True
+      , case fromException e of
+          Just (SessionDoesNotExist{} :: StorageException (AcidStorage SessionMap)) -> False
+          _other -> True
+      ]
                           

 getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@ -189,28 +189,33 @@ campusLogin pool mode = AuthPlugin{..}
          searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
          case searchResults of
            [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
-              | [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
+              | [principalName] <- nub $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
              , Right credsIdent <- Text.decodeUtf8' principalName
-              -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
-            other -> return $ Left other
+              -> handleIf isInvalidCredentials (return . Left) $ do
+                   Ldap.bind ldap (Ldap.Dn credsIdent) . Ldap.Password $ Text.encodeUtf8 campusPassword
+                   return . Right $ Right (userDN, credsIdent)
+            other -> return . Right $ Left other
        case ldapResult of
-          Left err
-            | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
-              -> do
-                $logDebugS apName "Invalid credentials"
-                observeLoginOutcome apName LoginInvalidCredentials
-                loginErrorMessageI LoginR Msg.InvalidLogin
-            | otherwise -> do
-                $logErrorS apName $ "Error during login: " <> tshow err
-                observeLoginOutcome apName LoginError
-                loginErrorMessageI LoginR Msg.AuthError
-          Right (Right (userDN, credsIdent)) -> do
-            observeLoginOutcome apName LoginSuccessful
-            setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
-          Right (Left searchResults) -> do
-            $logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
+          Left err -> do
+            $logErrorS apName $ "Error during login: " <> tshow err
            observeLoginOutcome apName LoginError
            loginErrorMessageI LoginR Msg.AuthError
+          Right (Left _bindErr) -> do
+            $logDebugS apName "Invalid credentials"
+            observeLoginOutcome apName LoginInvalidCredentials
+            loginErrorMessageI LoginR Msg.InvalidLogin
+          Right (Right (Left searchResults))
+            | null searchResults -> do
+              $logDebugS apName "User not found"
+              observeLoginOutcome apName LoginInvalidCredentials
+              loginErrorMessageI LoginR Msg.InvalidLogin
+            | otherwise -> do
+                $logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
+                observeLoginOutcome apName LoginError
+                loginErrorMessageI LoginR Msg.AuthError
+          Right (Right (Right (userDN, credsIdent))) -> do
+            observeLoginOutcome apName LoginSuccessful
+            setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]

      maybe (redirect $ tp LoginR) return resp
    apDispatch _ [] = badMethod
@ -228,3 +233,7 @@ campusLogin pool mode = AuthPlugin{..}
            , formAnchor = Just "login--campus" :: Maybe Text
            }
      $(widgetFile "widgets/campus-login/campus-login-form")
+
+    isInvalidCredentials = \case
+      Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _ -> True
+      _other -> False
--- a/src/Control/Monad/Trans/Memo/StateCache/Instances.hs
+++ b/src/Control/Monad/Trans/Memo/StateCache/Instances.hs
@ -0,0 +1,50 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Control.Monad.Trans.Memo.StateCache.Instances
+  ( hoistStateCache
+  ) where
+
+import ClassyPrelude hiding (handle)
+import Yesod.Core
+import Control.Monad.Logger (MonadLoggerIO)
+import Control.Monad.Trans.Memo.StateCache
+import Control.Monad.Catch
+
+
+instance MonadResource m => MonadResource (StateCache c m) where
+  liftResourceT = lift . liftResourceT
+
+instance MonadLogger m => MonadLogger (StateCache c m)
+instance MonadLoggerIO m => MonadLoggerIO (StateCache c m)
+  
+instance MonadHandler m => MonadHandler (StateCache c m) where
+  type HandlerSite (StateCache c m) = HandlerSite m
+  type SubHandlerSite (StateCache c m) = SubHandlerSite m
+
+  liftHandler = lift . liftHandler
+  liftSubHandler = lift . liftSubHandler
+
+instance MonadWidget m => MonadWidget (StateCache c m) where
+  liftWidget = lift . liftWidget
+
+instance MonadThrow m => MonadThrow (StateCache c m) where
+  throwM = lift . throwM
+
+-- | Rolls back modifications to state in failing section
+instance MonadCatch m => MonadCatch (StateCache c m) where
+  catch m h = do
+    s <- container
+    (x, s') <- lift . handle (flip runStateCache s . h) $ runStateCache m s
+    x <$ setContainer s'
+
+hoistStateCache :: forall m n c b.
+                   Monad n
+                => (forall a. m a -> n a)
+                -> (StateCache c m b -> StateCache c n b)
+-- ^ Morally identical to `Control.Monad.Morph.hoist`
+--
+-- Due to limited exports from `Control.Monad.Trans.Memo.StateCache` we incur a @Monad n@ constraint which `Control.Monad.Morph.hoist` does not account for
+hoistStateCache nat m = do
+  s <- container
+  (x, s') <- lift . nat $ runStateCache m s
+  x <$ setContainer s'
--- a/src/Cron.hs
+++ b/src/Cron.hs
@ -1,6 +1,6 @@
 module Cron
  ( evalCronMatch
-  , CronNextMatch(..)
+  , CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone
  , nextCronMatch
  , module Cron.Types
  ) where
@ -84,6 +84,8 @@ consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
 data CronNextMatch a = MatchAsap | MatchAt a | MatchNone
  deriving (Eq, Ord, Show, Read, Functor)

+makePrisms ''CronNextMatch
+
 instance Applicative CronNextMatch where
  pure = MatchAt
  _ <*> MatchNone = MatchNone
--- a/src/Database/Esqueleto/Utils.hs
+++ b/src/Database/Esqueleto/Utils.hs
@ -17,7 +17,9 @@ module Database.Esqueleto.Utils
  , selectExists, selectNotExists
  , SqlHashable
  , sha256
-  , maybe, unsafeCoalesce
+  , maybe, maybeEq, unsafeCoalesce
+  , bool
+  , max, min
  , SqlProject(..)
  , (->.)
  , fromSqlKey
@ -27,7 +29,7 @@ module Database.Esqueleto.Utils
  ) where


-import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe)
+import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust, maybe, bool, max, min)
 import Data.Universe
 import qualified Data.Set as Set
 import qualified Data.List as List
@ -240,6 +242,45 @@ maybe onNothing onJust val = E.case_
      (onJust $ E.veryUnsafeCoerceSqlExprValue val)
  ]
  (E.else_ onNothing)
+  
+infix 4 `maybeEq`
+
+maybeEq :: PersistField a
+        => E.SqlExpr (E.Value (Maybe a))
+        -> E.SqlExpr (E.Value (Maybe a))
+        -> E.SqlExpr (E.Value Bool)
+-- ^ `E.==.` but treat `E.nothing` as identical
+maybeEq a b = E.case_
+  [ E.when_
+      (E.isNothing a)
+    E.then_
+      (E.isNothing b)
+  , E.when_
+      (E.isNothing b)
+    E.then_
+      false -- (E.isNothing a)
+  ]
+  (E.else_ $ a E.==. b)
+
+bool :: PersistField a
+     => E.SqlExpr (E.Value a)
+     -> E.SqlExpr (E.Value a)
+     -> E.SqlExpr (E.Value Bool)
+     -> E.SqlExpr (E.Value a)
+bool onFalse onTrue val = E.case_
+  [ E.when_
+      val
+    E.then_
+      onTrue
+  ]
+  (E.else_ onFalse)
+
+max, min :: PersistField a
+         => E.SqlExpr (E.Value a)
+         -> E.SqlExpr (E.Value a)
+         -> E.SqlExpr (E.Value a)
+max a b = bool a b $ b E.>. a
+min a b = bool a b $ b E.<. a

 unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlExpr (E.Value a)
 unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce
@ -257,6 +298,8 @@ instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.E
  sqlProject = (E.?.)
  unSqlProject _ _ = Just

+infixl 8 ->.
+
 (->.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value b)
 (->.) expr t = E.unsafeSqlBinOp "->" expr $ E.val t

--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@ -2362,6 +2362,7 @@ instance YesodBreadcrumbs UniWorX where
  breadcrumb AdminTestR       = i18nCrumb MsgMenuAdminTest        $ Just AdminR
  breadcrumb AdminErrMsgR     = i18nCrumb MsgMenuAdminErrMsg      $ Just AdminR
  breadcrumb AdminTokensR     = i18nCrumb MsgMenuAdminTokens      $ Just AdminR
+  breadcrumb AdminCrontabR    = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
  
  breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
  breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
@ -2852,6 +2853,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
              , navQuick'      = mempty
              , navForceActive = False
              }
+          , NavLink
+              { navLabel       = MsgMenuAdminCrontab
+              , navRoute       = AdminCrontabR
+              , navAccess'     = return True
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }
          , NavLink
              { navLabel       = MsgMenuAdminTest
              , navRoute       = AdminTestR
--- a/src/Foundation/Type.hs
+++ b/src/Foundation/Type.hs
@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE UndecidableInstances #-}
+
 module Foundation.Type
  ( UniWorX(..)
  , SomeSessionStorage(..)
@ -68,3 +71,6 @@ instance HasAppSettings UniWorX where
  appSettings = _appSettings'
 instance HasCookieSettings RegisteredCookie UniWorX where
  getCookieSettings = appCookieSettings . appSettings'
+
+instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
+  readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@ -10,6 +10,7 @@ import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
 import Handler.Admin.StudyFeatures as Handler.Admin
 import Handler.Admin.Tokens as Handler.Admin
+import Handler.Admin.Crontab as Handler.Admin


 getAdminR :: Handler Html
--- a/src/Handler/Admin/Crontab.hs
+++ b/src/Handler/Admin/Crontab.hs
@ -0,0 +1,44 @@
+module Handler.Admin.Crontab
+  ( getAdminCrontabR
+  ) where
+
+import Import
+import Jobs
+import Handler.Utils.DateTime
+
+import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
+
+
+getAdminCrontabR :: Handler Html
+getAdminCrontabR = do
+  jState <- getsYesod appJobState
+  mCrontab' <- atomically . runMaybeT $ do
+    JobState{jobCurrentCrontab} <- MaybeT $ tryReadTMVar jState
+    MaybeT $ readTVar jobCurrentCrontab
+
+  let mCrontab = mCrontab' <&> _2 %~ filter (hasn't $ _1 . _MatchNone)
+
+  siteLayoutMsg MsgMenuAdminCrontab $ do
+    setTitleI MsgMenuAdminCrontab
+    [whamlet|
+      $newline never
+      $maybe (genTime, crontab) <- mCrontab
+        <p>
+          ^{formatTimeW SelFormatDateTime genTime}
+        <table .table .table--striped .table--hover>
+          $forall (match, job) <- crontab
+            <tr .table__row>
+              <td .table__td>
+                $case match
+                  $of MatchAsap
+                    _{MsgCronMatchAsap}
+                  $of MatchNone
+                    _{MsgCronMatchNone}
+                  $of MatchAt t
+                    ^{formatTimeW SelFormatDateTime t}
+              <td .table__td>
+                <pre>
+                  #{encodePrettyToTextBuilder job}
+      $nothing
+        _{MsgAdminCrontabNotGenerated}
+    |]
--- a/src/Handler/Admin/Test.hs
+++ b/src/Handler/Admin/Test.hs
@ -86,11 +86,9 @@ postAdminTestR = do

  ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
  formResultModal emailResult AdminTestR $ \(email, ls) -> do
-    jId <- mapWriterT runDB $ do
-      jId <- queueJob $ JobSendTestEmail email ls
-      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
-      return jId
-    runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
+    mapWriterT runDBJobs $ do
+      lift . queueDBJob $ JobSendTestEmail email ls
+      tell . pure $ Message Success [shamlet|Email-test gestartet|] (Just IconEmail)
    addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`

  let emailWidget' = wrapForm emailWidget def
--- a/src/Handler/Allocation/Application.hs
+++ b/src/Handler/Allocation/Application.hs
@ -260,7 +260,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
    if
      | BtnAllocationApply <- afAction
      , allowAction afAction
-        -> runDB $ do
+        -> runDB . setSerializable $ do
          haveOld <- exists [ CourseApplicationCourse     ==. cid
                            , CourseApplicationUser       ==. uid
                            , CourseApplicationAllocation ==. maId
@ -291,7 +291,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
      | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
      , allowAction afAction
      , Just appId <- mAppId
-        -> runDB $ do
+        -> runDB . setSerializable $ do
          now <- liftIO getCurrentTime

          changes <- if
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@ -175,8 +175,9 @@ postCRegisterR tid ssh csh = do
  formResult regResult $ \CourseRegisterForm{..} -> do
    cTime <- liftIO getCurrentTime
    let
+      doApplication = courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
      mkApplication
-        | courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
+        | doApplication
        = void <$> do
            appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
            appRes <- case appIds of
@ -210,12 +211,12 @@ postCRegisterR tid ssh csh = do
          ]

    case courseRegisterButton of
-      BtnCourseRegister -> runDB $ do
+      BtnCourseRegister -> runDB . bool id setSerializable doApplication $ do
        regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration
        case regOk of
          Nothing -> transactionUndo
          Just _  -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
-      BtnCourseDeregister -> runDB $ do
+      BtnCourseDeregister -> runDB . setSerializable $ do
        part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
        forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
          deregisterParticipant uid cid
@ -237,7 +238,7 @@ postCRegisterR tid ssh csh = do
            when courseDeregisterNoShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow

        addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
-      BtnCourseApply -> runDB $ do
+      BtnCourseApply -> runDB . setSerializable $ do
        regOk <- mkApplication
        case regOk of
          Nothing -> transactionUndo
--- a/src/Handler/Sheet/Pseudonym.hs
+++ b/src/Handler/Sheet/Pseudonym.hs
@ -7,8 +7,6 @@ import Import

 import Handler.Utils

-import Utils.Sql
-

 data ButtonGeneratePseudonym = BtnGenerate
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
--- a/src/Handler/Submission/Helper.hs
+++ b/src/Handler/Submission/Helper.hs
@ -318,7 +318,7 @@ submissionHelper tid ssh csh shn mcid = do
        , formEncoding = formEnctype
        }

-  mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
+  mCID <- fmap join . msgSubmissionErrors . runDBJobs . setSerializable $ do
    (Entity shid Sheet{..}, _, _, _, isLecturer, _, msubmission, _) <- hoist lift getSheetInfo

    submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

 module Handler.Utils.Exam
  ( fetchExamAux
@ -519,7 +519,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
                   )
    postprocess result = (resultAscList, resultUsers)
      where
-        resultAscList = pad . Map.fromListWith Set.union . accRes (pure <$> Set.lookupMin rangeAlphabet) $ (\r -> traceShow (over (traverse . _2 . traverse . traverse) CI.original r) r) result
+        resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
          where
            accRes _ [] = []
            accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -899,13 +899,14 @@ genericFileField mkOpts = Field{..}
    handleUpload FileField{fieldMaxFileSize} mIdent
      =    C.filter (\File{..} -> maybe (const True) (>) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) fileContent)
        .| sinkFiles
-        .| maybe (C.map id) mkSessionFile mIdent
+        .| C.mapM mkSessionFile
      where
-        mkSessionFile ident = C.mapM $ \fRef@FileReference{..} -> fRef <$ do
+        mkSessionFile fRef@FileReference{..} = fRef <$ do
          now <- liftIO getCurrentTime
          sfId <- insert $ SessionFile fileReferenceContent now
-          modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
-            Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
+          whenIsJust mIdent $ \ident ->
+            modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
+              Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old

  
    _FileTitle :: Prism' Text FilePath
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@ -904,7 +904,7 @@ submissionDeleteRoute drRecords = DeleteRoute
          subUsers <- selectList [SubmissionUserSubmission ==. subId] []
          if
            | length subUsers >= 1
-            , maybe False (flip any subUsers . (. submissionUserUser . entityVal) . (==)) uid
+            , maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
              -> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
            | otherwise
              -> return Nothing
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@ -38,6 +38,7 @@ import Yesod.Core.Types.Instances as Import
 import Utils                  as Import
 import Utils.Frontend.I18n    as Import
 import Utils.DB               as Import
+import Utils.Sql              as Import

 import Data.Fixed             as Import

@ -165,6 +166,7 @@ import Crypto.Random.Instances as Import ()
 import Network.Minio.Instances as Import ()
 import System.Clock.Instances as Import ()
 import Data.Word.Word24.Instances as Import ()
+import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache)

 import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512)
 import Crypto.Random as Import (ChaChaDRG, Seed)
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@ -18,8 +18,6 @@ import Data.Aeson (fromJSON)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson

-import Utils.Sql
-
 import Control.Monad.Random (evalRand, mkStdGen, uniformMay)

 import Cron
@ -100,6 +98,7 @@ handleJobs foundation@UniWorX{..}
      jobCrontab <- liftIO $ newTVarIO HashMap.empty
      jobConfirm <- liftIO $ newTVarIO HashMap.empty
      jobShutdown <- liftIO newEmptyTMVarIO
+      jobCurrentCrontab <- liftIO $ newTVarIO Nothing
      atomically $ putTMVar appJobState JobState
        { jobContext = JobContext{..}
        , ..
@ -112,12 +111,12 @@ manageCrontab :: forall m.
              => UniWorX -> (forall a. m a -> m a) -> m ()
 manageCrontab foundation@UniWorX{..} unmask = do
  ch <- allocateLinkedAsync $ do
-    context <- atomically . fmap jobContext $ readTMVar appJobState
+    jState <- atomically $ readTMVar appJobState
    liftIO . unsafeHandler foundation . void $ do
      atomically . assertM_ (not . Map.null . jobWorkers) $ readTMVar appJobState
      runReaderT ?? foundation $
        writeJobCtlBlock JobCtlDetermineCrontab
-      void $ evalRWST (forever execCrontab) context HashMap.empty
+      void $ evalRWST (forever execCrontab) jState HashMap.empty

  let awaitTermination = guardM $
        readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
@ -255,7 +254,7 @@ stopJobCtl UniWorX{appJobState} = do
      , jobCron jSt'
      ] ++ workers

-execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
+execCrontab :: RWST JobState () (HashMap JobCtl (Max UTCTime)) (HandlerFor UniWorX) ()
 -- ^ 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 = do
@ -279,7 +278,7 @@ execCrontab = do
  refT <- liftIO getCurrentTime
  settings <- getsYesod appSettings'
  (currentCrontab, (jobCtl, nextMatch), currentState) <- mapRWST (liftIO . atomically) $ do
-    crontab <- liftBase . readTVar =<< asks jobCrontab
+    crontab <- liftBase . readTVar =<< asks (jobCrontab . jobContext)

    State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
    prevExec <- State.get
@ -291,13 +290,16 @@ execCrontab = do
  do
    lastTimes <- State.get
    now <- liftIO getCurrentTime
-    $logDebugS "Crontab" . intercalate "\n" . map tshow . sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
+    let currentCrontab' = sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
+    crontabTVar <- asks jobCurrentCrontab
+    atomically . writeTVar crontabTVar $ Just (now, currentCrontab')
+    $logDebugS "Crontab" . intercalate "\n" $ "Current crontab:" : map tshow currentCrontab'

  let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do
        newCrontab <- lift $ hoist lift determineCrontab'
        when (newCrontab /= currentCrontab) $ 
          mapRWST (liftIO . atomically) $
-            liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
+            liftBase . void . flip swapTVar newCrontab =<< asks (jobCrontab . jobContext)

        mergeState
        newState <- State.get
@ -318,11 +320,11 @@ execCrontab = do
    MatchAsap -> doJob
    MatchNone -> return ()
    MatchAt nextTime -> do
-      JobContext{jobCrontab} <- ask
+      crontab <- asks $ jobCrontab . jobContext
      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')
+      whenM (liftIO . flip runLoggingT logFunc $ waitUntil crontab currentCrontab nextTime')
        doJob

  where
--- a/src/Jobs/Handler/Files.hs
+++ b/src/Jobs/Handler/Files.hs
@ -10,6 +10,7 @@ import Database.Persist.Sql (deleteWhereCount)

 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlCastAs)

 import qualified Data.Conduit.Combinators as C
 import qualified Data.Conduit.List as C (mapMaybe)
@ -20,6 +21,8 @@ import qualified Network.Minio as Minio
 import qualified Crypto.Hash as Crypto
 import qualified Data.ByteString.Base64.URL as Base64

+import Control.Monad.Memo (startEvalMemoT, memo)
+

 dispatchJobPruneSessionFiles :: JobHandler UniWorX
 dispatchJobPruneSessionFiles = JobHandlerAtomic  . hoist lift $ do
@ -37,35 +40,49 @@ fileReferences (E.just -> fHash)
    , E.from $ \newsFile  -> E.where_ $ newsFile  E.^. CourseNewsFileContent           E.==. fHash
    , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileContent                E.==. fHash
    , E.from $ \appInstr  -> E.where_ $ appInstr  E.^. CourseAppInstructionFileContent E.==. fHash
-    , E.from $ \matching  -> E.where_ $ E.just (matching  E.^. AllocationMatchingLog)  E.==. fHash
+    , E.from $ \matching  -> E.where_ $ E.just (matching E.^. AllocationMatchingLog)   E.==. fHash
    , E.from $ \subFile   -> E.where_ $ subFile   E.^. SubmissionFileContent           E.==. fHash
    , E.from $ \sessFile  -> E.where_ $ sessFile  E.^. SessionFileContent              E.==. fHash
+    , E.from $ \lock      -> E.where_ $ E.just (lock E.^. FileLockContent)             E.==. fHash
    ]


    
 dispatchJobPruneUnreferencedFiles :: JobHandler UniWorX
 dispatchJobPruneUnreferencedFiles = JobHandlerAtomic . hoist lift $ do
-  interval <- getsYesod $ view _appPruneUnreferencedFiles
-  Sum n <- runConduit $    getCandidates
-                        .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
-                        .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64)
-                        .| C.map (view $ _1 . _Value)
-                        .| C.mapM (\fRef -> Sum <$> deleteWhereCount [FileContentHash ==. fRef])
-                        .| C.fold
-  $logInfoS "PruneUnreferencedFiles" [st|Deleted #{n} unreferenced files|]
-  where
+  now <- liftIO getCurrentTime
+  interval <- fmap (fmap $ max 0) . getsYesod $ view _appPruneUnreferencedFiles
+  keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles
+
+  E.update $ \fileContent -> do
+    let isReferenced = E.any E.exists . fileReferences $ fileContent E.^. FileContentHash
+        now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now
+        shouldBe = E.bool (E.just . E.maybe now' (E.min now') $ fileContent E.^. FileContentUnreferencedSince) E.nothing isReferenced 
+    E.set fileContent [ FileContentUnreferencedSince E.=. shouldBe ]
+
+  let
    getCandidates = E.selectSource . E.from $ \fileContent -> do
-      E.where_ . E.not_ . E.any E.exists $ fileReferences (fileContent E.^. FileContentHash)
+      E.where_ . E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) $ fileContent E.^. FileContentUnreferencedSince 
      return ( fileContent E.^. FileContentHash
             , E.length_ $ fileContent E.^. FileContentContent
             )
+  
+  Sum deleted <- runConduit $
+       getCandidates
+    .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
+    .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64)
+    .| C.map (view $ _1 . _Value)
+    .| C.mapM (\fRef -> Sum <$> deleteWhereCount [FileContentHash ==. fRef])
+    .| C.fold
+  when (deleted > 0) $
+    $logInfoS "PruneUnreferencedFiles" [st|Deleted #{deleted} long-unreferenced files|]


 dispatchJobInjectFiles :: JobHandler UniWorX
 dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
  uploadBucket <- getsYesod $ view _appUploadCacheBucket
  interval <- getsYesod $ view _appInjectFiles
+  now <- liftIO getCurrentTime

  let
    extractReference (Minio.ListItemObject oi)
@ -75,34 +92,33 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
    extractReference _ = Nothing
    
    injectOrDelete :: (Minio.Object, FileContentReference)
-                   -> Handler (Sum Int64, Sum Int64, Sum Int64) -- ^ Deleted, Injected, Existed
+                   -> Handler (Sum Int64, Sum Int64) -- ^ Injected, Already existed
    injectOrDelete (obj, fRef) = maybeT (return mempty) $ do
-      res <- hoist runDB $ do
-        isReferenced <- lift . E.selectExists . E.where_ . E.any E.exists . fileReferences $ E.val fRef
-        if | isReferenced -> do
-               alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ]
-               if | alreadyInjected -> return (mempty, mempty, Sum 1)
-                  | otherwise -> do
-                      content <- (hoistMaybe =<<) . runAppMinio  . runMaybeT $ do
-                        objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions
-                        lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
-                      lift $ (mempty, Sum 1, mempty) <$ insert (FileContent fRef content)
-           | otherwise -> return (Sum 1, mempty, mempty)
+      res <- hoist (startEvalMemoT . hoistStateCache (runDB . setSerializable)) $ do
+        alreadyInjected <- lift . lift $ exists [ FileContentHash ==. fRef ]
+        if | alreadyInjected -> return (mempty, Sum 1)
+           | otherwise -> do
+               content <- flip memo obj $ \obj' -> hoistMaybeM . runAppMinio . runMaybeT $ do
+                 objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj' Minio.defaultGetObjectOptions
+                 lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
+
+               fmap ((, mempty) . Sum) . lift. lift . E.insertSelectCount $
+                 let isReferenced = E.any E.exists $ fileReferences (E.val fRef)
+                     now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now
+                  in return $ FileContent E.<# E.val fRef E.<&> E.val content E.<&> E.bool (E.just now') E.nothing isReferenced
      runAppMinio . maybeT (return ()) . catchIfMaybeT minioIsDoesNotExist $ Minio.removeObject uploadBucket obj 
      return res

-  (Sum del, Sum inj, Sum exc) <-
+  (Sum inj, Sum exc) <-
    runConduit $ transPipe runAppMinio (Minio.listObjects uploadBucket Nothing True)
              .| C.mapMaybe extractReference
              .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
-              .| transPipe (lift . runDB) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize)
+              .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize)
              .| C.map (over _1 Minio.oiObject)
              .| transPipe lift (C.mapM injectOrDelete)
              .| C.fold

-  when (del > 0) $
-    $logInfoS "InjectFiles" [st|Deleted #{del} unreferenced files from upload cache|]
  when (exc > 0) $
-    $logInfoS "InjectFiles" [st|Deleted #{exc} files from upload cache because they were already referenced|]
+    $logInfoS "InjectFiles" [st|Deleted #{exc} files from upload cache because they were already injected|]
  when (inj > 0) $
    $logInfoS "InjectFiles" [st|Injected #{inj} files from upload cache into database|]
--- a/src/Jobs/Queue.hs
+++ b/src/Jobs/Queue.hs
@ -11,7 +11,6 @@ module Jobs.Queue

 import Import hiding ((<>))

-import Utils.Sql
 import Jobs.Types

 import Control.Monad.Writer.Class (MonadWriter(..))
@ -81,22 +80,28 @@ writeJobCtlBlock :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -
 -- | Pass an instruction to the `Job`-Workers and block until it was acted upon
 writeJobCtlBlock = writeJobCtlBlock' writeJobCtl

-queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX QueuedJobId
+queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX (Maybe QueuedJobId)
 queueJobUnsafe queuedJobWriteLastExec job = do
  $logInfoS "queueJob" $ tshow job
-  queuedJobCreationTime <- liftIO getCurrentTime
-  queuedJobCreationInstance <- getsYesod appInstanceID
-  insert QueuedJob
-    { queuedJobContent = toJSON job
-    , 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
+  
+  doQueue <- fmap not . and2M (return $ jobNoQueueSame job) $ exists [ QueuedJobContent ==. toJSON job ]
+  
+  if
+    | doQueue -> Just <$> do
+        queuedJobCreationTime <- liftIO getCurrentTime
+        queuedJobCreationInstance <- getsYesod appInstanceID
+        insert QueuedJob
+          { queuedJobContent = toJSON job
+          , 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
+    | otherwise -> return Nothing

-queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
+queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m (Maybe QueuedJobId)
 -- ^ Queue a job for later execution
 --
 -- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`)
@ -106,15 +111,15 @@ queueJob' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m
 -- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
 queueJob' job = do
  app <- getYesod
-  queueJob job >>= flip runReaderT app . writeJobCtl . JobCtlPerform
+  queueJob job >>= maybe (return ()) (flip runReaderT app . writeJobCtl . JobCtlPerform)

 -- | Slightly modified Version of `DB` for `runDBJobs`
 type JobDB = YesodJobDB UniWorX

 queueDBJob, queueDBJobCron :: Job -> YesodJobDB UniWorX ()
 -- | Queue a job as part of a database transaction and execute it after the transaction succeeds
-queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . Set.singleton
-queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . Set.singleton
+queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . maybe Set.empty Set.singleton
+queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . maybe Set.empty Set.singleton

 sinkDBJobs :: ConduitT Job Void (YesodJobDB UniWorX) ()
 -- | Queue many jobs as part of a database transaction and execute them after the transaction passes
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@ -17,6 +17,8 @@ module Jobs.Types
  , showWorkerId, newWorkerId
  , JobQueue, jqInsert, jqDequeue
  , JobPriority(..), prioritiseJob
+  , jobNoQueueSame
+  , module Cron
  ) where

 import Import.NoFoundation hiding (Unique, state)
@ -37,6 +39,8 @@ import Utils.Metrics (withJobWorkerStateLbls)

 import qualified Prometheus (Label4)

+import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
+

 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
         | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
@ -233,6 +237,19 @@ prioritiseJob (JobCtlGenerateHealthReport _)  = JobPrioRealtime
 prioritiseJob  JobCtlDetermineCrontab         = JobPrioRealtime
 prioritiseJob  _                              = JobPrioBatch

+jobNoQueueSame :: Job -> Bool
+jobNoQueueSame = \case
+  JobSendPasswordReset{}       -> True
+  JobTruncateTransactionLog{}  -> True
+  JobPruneInvitations{}        -> True
+  JobDeleteTransactionLogIPs{} -> True
+  JobSynchroniseLdapUser{}     -> True
+  JobChangeUserDisplayEmail{}  -> True
+  JobPruneSessionFiles{}       -> True
+  JobPruneUnreferencedFiles{}  -> True
+  JobInjectFiles{}             -> True
+  _                            -> False
+

 newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue JobPriority JobCtl }
  deriving (Eq, Ord, Read, Show)
@ -254,6 +271,7 @@ data JobState = JobState
  , jobPoolManager :: Async ()
  , jobCron :: Async ()
  , jobShutdown :: TMVar ()
+  , jobCurrentCrontab :: TVar (Maybe (UTCTime, [(CronNextMatch UTCTime, JobCtl)]))
  }

 jobWorkerNames :: JobState -> Set JobWorkerId
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@ -71,6 +71,7 @@ migrateAll' :: Migration
 migrateAll' = sequence_
  [ migrateUniWorX
  , migrateMemcachedSqlStorage
+  , migrateManual
  ]

 migrateAll :: ( MonadLogger m
@ -137,6 +138,35 @@ getMissingMigrations = do
  appliedMigrations <- selectKeysList [] []
  return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations

+
+migrateManual :: Migration
+migrateManual = do
+  mapM_ (uncurry addIndex)
+    [ ("course_application_file_content",     "CREATE INDEX course_application_file_content ON course_application_file (content)"        )
+    , ("material_file_content",               "CREATE INDEX material_file_content ON material_file (content)"                            )
+    , ("course_news_file_content",            "CREATE INDEX course_news_file_content ON course_news_file (content)"                      )
+    , ("sheet_file_content",                  "CREATE INDEX sheet_file_content ON sheet_file (content)"                                  )
+    , ("course_app_instruction_file_content", "CREATE INDEX course_app_instruction_file_content ON course_app_instruction_file (content)")
+    , ("allocation_matching_log",             "CREATE INDEX allocation_matching_log ON allocation_matching (log)"                        )
+    , ("submission_file_content",             "CREATE INDEX submission_file_content ON submission_file (content)"                        )
+    , ("session_file_content",                "CREATE INDEX session_file_content ON session_file (content)"                              )
+    , ("file_lock_content",                   "CREATE INDEX file_lock_content ON file_lock (content)"                                    )
+    , ("user_lower_display_email",            "CREATE INDEX user_lower_display_email ON \"user\" (lower(display_email))"                 )
+    , ("user_lower_email",                    "CREATE INDEX user_lower_email ON \"user\" (lower(email))"                                 )
+    , ("user_lower_ident",                    "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))"                                 )
+    , ("submission_sheet",                    "CREATE INDEX submission_sheet ON submission (sheet)"                                      )
+    , ("submission_edit_submission",          "CREATE INDEX submission_edit_submission ON submission_edit (submission)"                  )
+    ]
+  where
+    addIndex :: Text -> Sql -> Migration
+    addIndex ixName ixDef = do
+      res <- lift $ lift [sqlQQ|SELECT EXISTS (SELECT 1 FROM pg_indexes WHERE schemaname = current_schema() AND indexname = #{ixName})|]
+      alreadyDefined <- case res of
+        [Single e] -> return e
+        _other -> return True
+      unless alreadyDefined $ addMigration False ixDef
+
+
 {-
  Confusion about quotes, from the PostgreSQL Manual:
    Single quotes for string constants, double quotes for table/column names.
@ -145,7 +175,6 @@ getMissingMigrations = do
                  #{anything} (escaped as value);
 -}

-
 customMigrations :: forall m.
                    MonadResource m
                 => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
--- a/src/Settings.hs
+++ b/src/Settings.hs
@ -11,6 +11,7 @@ module Settings
  , module Settings.Cluster
  , module Settings.Mime
  , module Settings.Cookies
+  , module Settings.Log
  ) where

 import           Import.NoModel
@ -53,6 +54,7 @@ import Model
 import Settings.Cluster
 import Settings.Mime
 import Settings.Cookies
+import Settings.Log

 import qualified System.FilePath as FilePath

@ -139,6 +141,7 @@ data AppSettings = AppSettings

    , appSessionFilesExpire     :: NominalDiffTime
    , appPruneUnreferencedFiles :: Maybe NominalDiffTime
+    , appKeepUnreferencedFiles  :: NominalDiffTime

    , appInitialLogSettings     :: LogSettings

@ -190,23 +193,6 @@ newtype ServerSessionSettings
 instance Show ServerSessionSettings where
  showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"

-data LogSettings = LogSettings
-  { logAll, logDetailed :: Bool
-  , logMinimumLevel :: LogLevel
-  , logDestination :: LogDestination
-  } deriving (Show, Read, Generic, Eq, Ord)
-
-data LogDestination = LogDestStderr | LogDestStdout | LogDestFile { logDestFile :: !FilePath }
-  deriving (Show, Read, Generic, Eq, Ord)
-
-deriving instance Generic LogLevel
-instance Hashable LogLevel
-instance NFData LogLevel
-instance Hashable LogSettings
-instance NFData LogSettings
-instance Hashable LogDestination
-instance NFData LogDestination
-
 data UserDefaultConf = UserDefaultConf
  { userDefaultTheme :: Theme
  , userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int
@ -308,17 +294,6 @@ deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
  } ''TokenBucketConf

-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 2
-  , fieldLabelModifier = camelToPathPiece' 2
-  , sumEncoding = UntaggedValue
-  , unwrapUnaryRecords = True
-  } ''LogDestination
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''LogSettings
-
 deriveFromJSON defaultOptions ''Ldap.Scope
 deriveFromJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
@ -351,13 +326,6 @@ deriveFromJSON
    }
  ''ResourcePoolConf

-deriveJSON
-  defaultOptions
-    { constructorTagModifier = camelToPathPiece' 1
-    , sumEncoding = UntaggedValue
-    }
-  ''LogLevel
-
 instance FromJSON HaskellNet.PortNumber where
  parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of
    Just int -> return $ fromIntegral (int :: Word16)
@ -504,6 +472,7 @@ instance FromJSON AppSettings where

        appSessionFilesExpire     <- o .:  "session-files-expire"
        appPruneUnreferencedFiles <- o .:? "prune-unreferenced-files"
+        appKeepUnreferencedFiles  <- o .:? "keep-unreferenced-files" .!= 0
        appInjectFiles            <- o .:? "inject-files"

        appMaximumContentLength   <- o .: "maximum-content-length"
--- a/src/Settings/Log.hs
+++ b/src/Settings/Log.hs
@ -0,0 +1,52 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Settings.Log
+  ( LogSettings(..)
+  , LogDestination(..)
+  , LogLevel(..)
+  , ReadLogSettings(..)
+  ) where
+
+import ClassyPrelude.Yesod
+import Numeric.Natural
+
+import Data.Aeson.TH
+import Utils.PathPiece
+
+
+data LogSettings = LogSettings
+  { logAll, logDetailed :: Bool
+  , logMinimumLevel :: LogLevel
+  , logDestination :: LogDestination
+  , logSerializableTransactionRetryLimit :: Maybe Natural
+  } deriving (Show, Read, Generic, Eq, Ord)
+
+data LogDestination = LogDestStderr | LogDestStdout | LogDestFile { logDestFile :: !FilePath }
+  deriving (Show, Read, Generic, Eq, Ord)
+
+deriving instance Generic LogLevel
+instance Hashable LogLevel
+instance NFData LogLevel
+instance Hashable LogSettings
+instance NFData LogSettings
+instance Hashable LogDestination
+instance NFData LogDestination
+  
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , sumEncoding = UntaggedValue
+  } ''LogLevel
+  
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  , sumEncoding = UntaggedValue
+  , unwrapUnaryRecords = True
+  } ''LogDestination
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''LogSettings
+
+class ReadLogSettings m where
+  readLogSettings :: m LogSettings
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -569,6 +569,9 @@ hoistMaybe :: MonadPlus m => Maybe a -> m a
 -- ^ `hoist` regarding `Maybe` as if identical to @MaybeT Identity@
 hoistMaybe = maybe mzero return

+hoistMaybeM :: MonadPlus m => m (Maybe a) -> m a
+hoistMaybeM = (=<<) hoistMaybe
+
 catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
 catchIfMaybeT p act = catchIf p (lift act) (const mzero)

--- a/src/Utils/Failover.hs
+++ b/src/Utils/Failover.hs
@ -161,9 +161,10 @@ withFailover' testTarget' f@Failover{..} mode detAcceptable act = withFailoverRe
            $logErrorS "withFailover'" $ tshow (hashUnique alreadyTested) <> " recording failure for item " <> failoverLabel
            atomically . modifyTVar failover $ \failover' -> if
              | views (P.focus . _failoverReferences) (Set.member currentlyTesting) failover'
-                -> fromMaybe failover' $ P.next failover'
+                -> fromMaybe (goFirst failover') $ P.next failover'
              | otherwise
                -> failover'
+            where goFirst l = maybe l goFirst $ P.previous l

        $logDebugS "withFailover'" $ tshow (hashUnique alreadyTested) <> " using item " <> failoverLabel
        res' <- handleAll (\err -> $logErrorS "withFailover'" (tshow (hashUnique alreadyTested) <> " exception during act or detAcceptable: " <> tshow err) >> recordFailure >> throwM err) $
--- a/src/Utils/Files.hs
+++ b/src/Utils/Files.hs
@ -24,20 +24,30 @@ import Control.Monad.State.Class (modify)

 import Database.Persist.Sql (deleteWhereCount)

+import Control.Monad.Trans.Resource (allocate)

-sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
+
+sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
 sinkFiles = C.mapM sinkFile
  
-sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => File -> SqlPersistT m FileReference
+sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File -> SqlPersistT m FileReference
 sinkFile File{ fileContent = Nothing, .. } = return FileReference
  { fileReferenceContent  = Nothing
  , fileReferenceTitle    = fileTitle
  , fileReferenceModified = fileModified
  }
 sinkFile File{ fileContent = Just fileContentContent, .. } = do
+  void . withUnliftIO $ \UnliftIO{..} ->
+    let takeLock = do
+          fileLockTime <- liftIO getCurrentTime
+          fileLockInstance <- getsYesod appInstanceID
+          insert FileLock{ fileLockContent = fileContentHash, .. }
+        releaseLock lId = liftHandler . runDB $ (withReaderT projectBackend $ setSerializable (delete lId :: SqlPersistT (HandlerFor UniWorX) ()) :: YesodDB UniWorX ())
+     in unliftIO $ allocate (unliftIO takeLock) (unliftIO . releaseLock)
+  
  inDB <- exists [ FileContentHash ==. fileContentHash ]
  
-  let sinkFileDB = unless inDB $ repsert (FileContentKey fileContentHash) FileContent{..}
+  let sinkFileDB = unless inDB $ repsert (FileContentKey fileContentHash) FileContent{ fileContentUnreferencedSince = Nothing, .. }
  maybeT sinkFileDB $ do
    let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
    uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
@ -60,10 +70,10 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do
    fileContentHash = Crypto.hash fileContentContent
        

-sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
+sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
 sinkFiles' = C.mapM $ uncurry sinkFile'

-sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
+sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
 sinkFile' file residual = do
  reference <- sinkFile file
  return $ _FileReference # (reference, residual)
--- a/src/Utils/Sql.hs
+++ b/src/Utils/Sql.hs
@ -3,6 +3,8 @@ module Utils.Sql
  ) where

 import ClassyPrelude.Yesod
+import Numeric.Natural
+import Settings.Log

 import Database.PostgreSQL.Simple (SqlError)
 import Database.PostgreSQL.Simple.Errors (isSerializationError)
@ -16,23 +18,27 @@ import Control.Retry
 import Control.Lens ((&))


-setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
+setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => SqlPersistT m a -> SqlPersistT m a
 setSerializable = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6
  
-setSerializable' :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => RetryPolicyM (ReaderT SqlBackend m) -> ReaderT SqlBackend m a -> ReaderT SqlBackend m a
+setSerializable' :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => RetryPolicyM (SqlPersistT m) -> SqlPersistT m a -> ReaderT SqlBackend m a
 setSerializable' policy act = do
+  LogSettings{logSerializableTransactionRetryLimit} <- readLogSettings
  didCommit <- newTVarIO False
-  recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry logRetry) $ act' didCommit
+  recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry (logRetry logSerializableTransactionRetryLimit)) $ act' didCommit
  where
    suggestRetry :: SqlError -> ReaderT SqlBackend m Bool
    suggestRetry = return . isSerializationError
  
-    logRetry :: Bool -- ^ Will retry
+    logRetry :: Maybe Natural
+             -> Bool -- ^ Will retry
             -> SqlError
             -> RetryStatus
             -> ReaderT SqlBackend m ()
-    logRetry shouldRetry@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
-    logRetry shouldRetry@True  err status = $logDebugS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
+    logRetry _ shouldRetry@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
+    logRetry (Just limit) shouldRetry err status
+      | fromIntegral limit <= rsIterNumber status = $logInfoS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
+    logRetry _ shouldRetry err status = $logDebugS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status

    act' :: TVar Bool -> RetryStatus -> ReaderT SqlBackend m a
    act' didCommit RetryStatus{..} = do
--- a/templates/mail/sheetHint.hamlet
+++ b/templates/mail/sheetHint.hamlet
@ -11,11 +11,11 @@ $newline never
      }
  <body>
    <h1>
-      _{MsgMailSheetSolutionIntro (CI.original courseName) termDesc sheetName}
+      _{MsgMailSheetHintIntro (CI.original courseName) termDesc sheetName}
    <p>
      <a href=@{CSheetR tid ssh csh shn SShowR}>
        #{sheetName}
    <p>
-      <a href=@{CSheetR tid ssh csh shn (SZipR SheetSolution)}>
-        _{MsgSheetSolution}
+      <a href=@{CSheetR tid ssh csh shn (SZipR SheetHint)}>
+        _{MsgSheetHint}
    ^{editNotifications}
--- a/templates/mail/sheetSolution.hamlet
+++ b/templates/mail/sheetSolution.hamlet
@ -11,11 +11,11 @@ $newline never
      }
  <body>
    <h1>
-      _{MsgMailSheetHintIntro (CI.original courseName) termDesc sheetName}
+      _{MsgMailSheetSolutionIntro (CI.original courseName) termDesc sheetName}
    <p>
      <a href=@{CSheetR tid ssh csh shn SShowR}>
        #{sheetName}
    <p>
-      <a href=@{CSheetR tid ssh csh shn (SZipR SheetHint)}>
-        _{MsgSheetHint}
+      <a href=@{CSheetR tid ssh csh shn (SZipR SheetSolution)}>
+        _{MsgSheetSolution}
    ^{editNotifications}