Merge branch 'master' into course-visibility

CHANGELOG.md

@@ -2,6 +2,31 @@
 
 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.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)
+
+
+### Bug Fixes
+
+* **file-upload:** size limitation was inverted ([de53c80](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/de53c80))
+* **submission:** race condition allowed creating multiple subs ([02fc0d4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/02fc0d4))
+
+
+
 ### [18.2.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v18.2.0...v18.2.1) (2020-07-22)
 
 

models/files.model

@@ -5,4 +5,9 @@ FileContent
 
 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.1",
+  "version": "18.3.0",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

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

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 18.2.1
+version: 18.3.0
 
 dependencies:
   - base

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

@@ -204,10 +204,122 @@ submissionHelper tid ssh csh shn mcid = do
   msmid     <- traverse decrypt mcid
   actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
 
-  (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner, msubmission, corrector)  <- runDB $ do
+  let
-    csheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
+    getSheetInfo = do
-    maySubmit  <- (== Authorized) <$> evalAccessDB actionUrl True
+      csheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
-    isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
+      maySubmit  <- (== Authorized) <$> evalAccessDB actionUrl True
+      isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
+
+      case (msmid, sheetGrouping) of
+        (Nothing, Arbitrary maxBuddies) -> do
+          -- fetch buddies from previous submission in this course
+          buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+            E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
+            let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
+                  E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
+                  E.on (subUser        E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
+                  E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
+                  E.where_ $ E.just (subUser E.^. SubmissionUserUser) E.==. E.val muid
+                        E.&&. sheet   E.^.        SheetCourse E.==. E.val sheetCourse
+                  E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
+                  E.limit 1
+                  return $ submission E.^. SubmissionId
+            E.where_ $  submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
+                  E.&&. E.just (submissionUser E.^. SubmissionUserUser) E.!=. E.val muid
+            E.orderBy  [E.asc $ user E.^. UserEmail]
+            return $ user E.^. UserId
+          return ( csheet
+                 , buddies
+                   & map (Right . E.unValue)
+                   & Set.fromList
+                   & assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (maybe id (Set.insert . Right) muid) (not isLecturer))
+                   & fromMaybe Set.empty
+                 , []
+                 , maySubmit
+                 , isLecturer
+                 , not isLecturer
+                 , Nothing, Nothing
+                 )
+        (Nothing, RegisteredGroups) -> do
+          buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do
+            E.on . E.exists . E.from $ \submissionGroupUser ->
+              E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
+                   E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+            E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
+            E.where_ . E.exists . E.from $ \submissionGroupUser ->
+              E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
+                   E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+            E.where_ $ E.just (user E.^. UserId) E.!=. E.val muid
+            E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+              E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+              E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
+                   E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+
+            E.orderBy [E.asc $ user E.^. UserEmail]
+
+            return $ user E.^. UserId
+
+          return ( csheet
+                 , buddies
+                   & map (Right . E.unValue)
+                   & Set.fromList
+                 , []
+                 , maySubmit
+                 , isLecturer
+                 , not isLecturer
+                 , Nothing, Nothing
+                 )
+        (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing)
+        (Just smid, _) -> do
+          void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
+
+          sub@Submission{..} <- get404 smid
+          let shid' = submissionSheet
+          unless (shid == shid') $
+            invalidArgsI [MsgSubmissionWrongSheet]
+          -- fetch buddies from current submission
+          (Any isOwner, buddies) <- do
+            submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+              E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
+              E.where_ $  submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
+              E.orderBy  [E.asc $ user E.^. UserEmail]
+              return $ user E.^. UserId
+            let breakUserFromBuddies (E.Value userID)
+                  | muid == Just userID =  (Any True , mempty                      )
+                  | otherwise           =  (mempty   , Set.singleton $ Right userID)
+
+            invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)
+
+            return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors
+
+          lastEdits <- do
+              raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
+                E.on $ E.just (user E.^. UserId) E.==. submissionEdit E.^. SubmissionEditUser
+                E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
+                E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
+                -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
+                let userName = if isOwner || maySubmit
+                                then E.just $ user E.^. UserDisplayName
+                                else E.nothing
+                return (userName, submissionEdit E.^. SubmissionEditTime)
+              forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
+
+          corrector <- fmap join $ traverse getEntity submissionRatingBy
+
+          return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
+
+  -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
+  -- Therefore we do not restrict upload behaviour in any way in that case
+  ((res,formWidget'), formEnctype) <- do
+    (Entity _ Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo
+    runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
+  let formWidget = wrapForm' BtnHandIn formWidget' def
+        { formAction = Just $ SomeRoute actionUrl
+        , formEncoding = formEnctype
+        }
+
+  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
       E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
@@ -220,121 +332,13 @@ submissionHelper tid ssh csh shn mcid = do
         addMessageI Info MsgSubmissionAlreadyExists
         redirect $ CSubmissionR tid ssh csh shn cID SubShowR
       _other -> return ()
-  
-    case (msmid, sheetGrouping) of
-      (Nothing, Arbitrary maxBuddies) -> do
-        -- fetch buddies from previous submission in this course
-        buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
-          E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
-          let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
-                E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
-                E.on (subUser        E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
-                E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
-                E.where_ $ E.just (subUser E.^. SubmissionUserUser) E.==. E.val muid
-                      E.&&. sheet   E.^.        SheetCourse E.==. E.val sheetCourse
-                E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
-                E.limit 1
-                return $ submission E.^. SubmissionId
-          E.where_ $  submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
-                E.&&. E.just (submissionUser E.^. SubmissionUserUser) E.!=. E.val muid
-          E.orderBy  [E.asc $ user E.^. UserEmail]
-          return $ user E.^. UserId
-        return ( csheet
-               , buddies
-                 & map (Right . E.unValue)
-                 & Set.fromList
-                 & assertM' ((<= maxBuddies) . fromIntegral . Set.size . bool id (maybe id (Set.insert . Right) muid) (not isLecturer))
-                 & fromMaybe Set.empty
-               , []
-               , maySubmit
-               , isLecturer
-               , not isLecturer
-               , Nothing, Nothing
-               )
-      (Nothing, RegisteredGroups) -> do
-        buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do
-          E.on . E.exists . E.from $ \submissionGroupUser ->
-            E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
-                 E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
-          E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
-          E.where_ . E.exists . E.from $ \submissionGroupUser ->
-            E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
-                 E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
-          E.where_ $ E.just (user E.^. UserId) E.!=. E.val muid
-          E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
-            E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
-            E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
-                 E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
 
-          E.orderBy [E.asc $ user E.^. UserEmail]
+    when (    is _Nothing muid
-
+           && is _Nothing msubmission
-          return $ user E.^. UserId
+           && not isLecturer
-        
+         ) 
-        return ( csheet
+      notAuthenticated
-               , buddies
+    
-                 & map (Right . E.unValue)
-                 & Set.fromList
-               , []
-               , maySubmit
-               , isLecturer
-               , not isLecturer
-               , Nothing, Nothing
-               )
-      (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing)
-      (Just smid, _) -> do
-        void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
-
-        sub@Submission{..} <- get404 smid
-        let shid' = submissionSheet
-        unless (shid == shid') $
-          invalidArgsI [MsgSubmissionWrongSheet]
-        -- fetch buddies from current submission
-        (Any isOwner, buddies) <- do
-          submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
-            E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
-            E.where_ $  submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
-            E.orderBy  [E.asc $ user E.^. UserEmail]
-            return $ user E.^. UserId
-          let breakUserFromBuddies (E.Value userID)
-                | muid == Just userID =  (Any True , mempty                      )
-                | otherwise           =  (mempty   , Set.singleton $ Right userID)
-
-          invites <- sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)
-
-          return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors
-
-        lastEdits <- do
-            raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
-              E.on $ E.just (user E.^. UserId) E.==. submissionEdit E.^. SubmissionEditUser
-              E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
-              E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
-              -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
-              let userName = if isOwner || maySubmit
-                              then E.just $ user E.^. UserDisplayName
-                              else E.nothing
-              return (userName, submissionEdit E.^. SubmissionEditTime)
-            forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
-
-        corrector <- fmap join $ traverse getEntity submissionRatingBy
-  
-        return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
-
-  if | is _Nothing muid
-     , is _Nothing msubmission
-     , not isLecturer
-       -> notAuthenticated
-     | otherwise
-       -> return ()
-  
-  -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
-  -- Therefore we do not restrict upload behaviour in any way in that case
-  ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
-  let formWidget = wrapForm' BtnHandIn formWidget' def
-        { formAction = Just $ SomeRoute actionUrl
-        , formEncoding = formEnctype
-        }
-
-  mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
     -- Determine old submission users
     subUsersOld <- if
       | Just smid <- msmid -> Set.union
@@ -475,6 +479,8 @@ submissionHelper tid ssh csh shn mcid = do
         | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
     Nothing  -> return ()
 
+  (Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo
+
   showCorrection <- fmap (fromMaybe False) . for mcid $ \cid -> hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
 
   -- Maybe construct a table to display uploaded archive files

src/Handler/Utils/Form.hs

@@ -897,15 +897,16 @@ genericFileField mkOpts = Field{..}
 
     handleUpload :: FileField -> Maybe Text -> ConduitT File FileReference (YesodDB UniWorX) ()
     handleUpload FileField{fieldMaxFileSize} mIdent
-      =    C.filter (\File{..} -> maybe (const True) (<) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) fileContent)
+      =    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

@@ -900,7 +900,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
 

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

src/Jobs/Handler/Files.hs

@@ -37,9 +37,10 @@ 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
     ]
 
 
@@ -75,33 +76,28 @@ 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 (runDB . setSerializable) $ do
-        isReferenced <- lift . E.selectExists . E.where_ . E.any E.exists . fileReferences $ E.val fRef
+        alreadyInjected <- 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 <- (hoistMaybe =<<) . 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 $ (Sum 1, mempty) <$ insertUnique (FileContent fRef content)
-                        lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
-                      lift $ (mempty, Sum 1, mempty) <$ insert (FileContent fRef content)
-           | otherwise -> return (Sum 1, mempty, mempty)
       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|]
   when (inj > 0) $

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

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,17 +24,27 @@ 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{..}
@@ -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)

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}