Merge branch 'master' into feat/customized-exercises

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)
 
 

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
 

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

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

models/files.model

@@ -1,8 +1,14 @@
 FileContent
-    hash            FileContentReference
+    hash              FileContentReference
-    content         ByteString
+    content           ByteString
-    Primary         hash
+    unreferencedSince UTCTime Maybe
+    Primary           hash
 
 SessionFile
     content         FileContentReference Maybe
-    touched         UTCTime
+    touched         UTCTime
+
+FileLock
+    content         FileContentReference
+    instance        InstanceId
+    time            UTCTime

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "18.2.2",
+  "version": "18.5.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "18.2.2",
+  "version": "18.5.0",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 18.2.2
+version: 18.5.0
 
 dependencies:
   - base

routes

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

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

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)
+              -> handleIf isInvalidCredentials (return . Left) $ do
-            other -> return $ Left other
+                   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
+          Left err -> do
-            | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
+            $logErrorS apName $ "Error during login: " <> tshow 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
             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

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'

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

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
 

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

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)

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

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}
+    |]

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
+    mapWriterT runDBJobs $ do
-      jId <- queueJob $ JobSendTestEmail email ls
+      lift . queueDBJob $ JobSendTestEmail email ls
-      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
+      tell . pure $ Message Success [shamlet|Email-test gestartet|] (Just IconEmail)
-      return jId
-    runReaderT (writeJobCtl $ JobCtlPerform jId) =<< getYesod
     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

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

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

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)

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

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)

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) ->
+          whenIsJust mIdent $ \ident ->
-            Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
+            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

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

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)

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

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
+  now <- liftIO getCurrentTime
-  Sum n <- runConduit $    getCandidates
+  interval <- fmap (fmap $ max 0) . getsYesod $ view _appPruneUnreferencedFiles
-                        .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
+  keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles
-                        .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64)
+
-                        .| C.map (view $ _1 . _Value)
+  E.update $ \fileContent -> do
-                        .| C.mapM (\fRef -> Sum <$> deleteWhereCount [FileContentHash ==. fRef])
+    let isReferenced = E.any E.exists . fileReferences $ fileContent E.^. FileContentHash
-                        .| C.fold
+        now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now
-  $logInfoS "PruneUnreferencedFiles" [st|Deleted #{n} unreferenced files|]
+        shouldBe = E.bool (E.just . E.maybe now' (E.min now') $ fileContent E.^. FileContentUnreferencedSince) E.nothing isReferenced 
-  where
+    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
+      res <- hoist (startEvalMemoT . hoistStateCache (runDB . setSerializable)) $ do
-        isReferenced <- lift . E.selectExists . E.where_ . E.any E.exists . fileReferences $ E.val fRef
+        alreadyInjected <- lift . lift $ exists [ FileContentHash ==. fRef ]
-        if | isReferenced -> do
+        if | alreadyInjected -> return (mempty, Sum 1)
-               alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ]
+           | otherwise -> do
-               if | alreadyInjected -> return (mempty, mempty, Sum 1)
+               content <- flip memo obj $ \obj' -> hoistMaybeM . runAppMinio . runMaybeT $ do
-                  | otherwise -> do
+                 objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj' Minio.defaultGetObjectOptions
-                      content <- (hoistMaybe =<<) . runAppMinio  . runMaybeT $ do
+                 lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
-                        objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions
+
-                        lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
+               fmap ((, mempty) . Sum) . lift. lift . E.insertSelectCount $
-                      lift $ (mempty, Sum 1, mempty) <$ insert (FileContent fRef content)
+                 let isReferenced = E.any E.exists $ fileReferences (E.val fRef)
-           | otherwise -> return (Sum 1, mempty, mempty)
+                     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|]

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
+  doQueue <- fmap not . and2M (return $ jobNoQueueSame job) $ exists [ QueuedJobContent ==. toJSON job ]
-  insert QueuedJob
+  
-    { queuedJobContent = toJSON job
+  if
-    , queuedJobLockInstance = Nothing
+    | doQueue -> Just <$> do
-    , queuedJobLockTime = Nothing
+        queuedJobCreationTime <- liftIO getCurrentTime
-    , ..
+        queuedJobCreationInstance <- getsYesod appInstanceID
-    }
+        insert QueuedJob
-  -- We should not immediately notify a worker; instead wait for the transaction to finish first
+          { queuedJobContent = toJSON job
-  -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
+          , queuedJobLockInstance = Nothing
-  -- return jId
+          , 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
+queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . maybe Set.empty Set.singleton
-queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . 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

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

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

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"

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

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)
 

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

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)

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

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)}>
+      <a href=@{CSheetR tid ssh csh shn (SZipR SheetHint)}>
-        _{MsgSheetSolution}
+        _{MsgSheetHint}
     ^{editNotifications}

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)}>
+      <a href=@{CSheetR tid ssh csh shn (SZipR SheetSolution)}>
-        _{MsgSheetHint}
+        _{MsgSheetSolution}
     ^{editNotifications}