diff --git a/CHANGELOG.md b/CHANGELOG.md
index 2d80a63e2..ece61ece0 100644
--- a/CHANGELOG.md
+++ b/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)
diff --git a/models/files.model b/models/files.model
index eae0276d7..fcf0b3809 100644
--- a/models/files.model
+++ b/models/files.model
@@ -5,4 +5,9 @@ FileContent
SessionFile
content FileContentReference Maybe
- touched UTCTime
\ No newline at end of file
+ touched UTCTime
+
+FileLock
+ content FileContentReference
+ instance InstanceId
+ time UTCTime
\ No newline at end of file
diff --git a/package-lock.json b/package-lock.json
index e60ada17e..58a6f89bf 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "18.2.1",
+ "version": "18.3.0",
"lockfileVersion": 1,
"requires": true,
"dependencies": {
diff --git a/package.json b/package.json
index e0a8191c1..bf15ad329 100644
--- a/package.json
+++ b/package.json
@@ -1,6 +1,6 @@
{
"name": "uni2work",
- "version": "18.2.1",
+ "version": "18.3.0",
"description": "",
"keywords": [],
"author": "",
diff --git a/package.yaml b/package.yaml
index 0b8eb5b32..cfabb80ef 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
name: uniworx
-version: 18.2.1
+version: 18.3.0
dependencies:
- base
diff --git a/src/Application.hs b/src/Application.hs
index d6f72c080..65bdf4ea1 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -98,6 +98,8 @@ import qualified Web.ServerSession.Backend.Acid as Acid
import qualified Ldap.Client as Ldap (Host(Plain, Tls))
import qualified Network.Minio as Minio
+
+import Web.ServerSession.Core (StorageException(..))
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
@@ -433,7 +435,7 @@ warpSettings foundation = defaultSettings
& setHost (foundation ^. _appHost)
& setPort (foundation ^. _appPort)
& setOnException (\_req e ->
- when (defaultShouldDisplayException e) $ do
+ when (shouldDisplayException e) $ do
logger <- readTVarIO . snd $ appLogger foundation
messageLoggerSource
foundation
@@ -443,6 +445,16 @@ warpSettings foundation = defaultSettings
LevelError
(toLogStr $ "Exception from Warp: " ++ show e)
)
+ where
+ shouldDisplayException e = and
+ [ defaultShouldDisplayException e
+ , case fromException e of
+ Just (SessionDoesNotExist{} :: StorageException (MemcachedSqlStorage SessionMap)) -> False
+ _other -> True
+ , case fromException e of
+ Just (SessionDoesNotExist{} :: StorageException (AcidStorage SessionMap)) -> False
+ _other -> True
+ ]
getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs
index 0e52e4f13..dac6bd1fd 100644
--- a/src/Auth/LDAP.hs
+++ b/src/Auth/LDAP.hs
@@ -189,28 +189,33 @@ campusLogin pool mode = AuthPlugin{..}
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
case searchResults of
[Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
- | [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
+ | [principalName] <- nub $ fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
, Right credsIdent <- Text.decodeUtf8' principalName
- -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
- other -> return $ Left other
+ -> handleIf isInvalidCredentials (return . Left) $ do
+ Ldap.bind ldap (Ldap.Dn credsIdent) . Ldap.Password $ Text.encodeUtf8 campusPassword
+ return . Right $ Right (userDN, credsIdent)
+ other -> return . Right $ Left other
case ldapResult of
- Left err
- | LdapError (Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _)) <- err
- -> do
- $logDebugS apName "Invalid credentials"
- observeLoginOutcome apName LoginInvalidCredentials
- loginErrorMessageI LoginR Msg.InvalidLogin
- | otherwise -> do
- $logErrorS apName $ "Error during login: " <> tshow err
- observeLoginOutcome apName LoginError
- loginErrorMessageI LoginR Msg.AuthError
- Right (Right (userDN, credsIdent)) -> do
- observeLoginOutcome apName LoginSuccessful
- setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
- Right (Left searchResults) -> do
- $logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
+ Left err -> do
+ $logErrorS apName $ "Error during login: " <> tshow err
observeLoginOutcome apName LoginError
loginErrorMessageI LoginR Msg.AuthError
+ Right (Left _bindErr) -> do
+ $logDebugS apName "Invalid credentials"
+ observeLoginOutcome apName LoginInvalidCredentials
+ loginErrorMessageI LoginR Msg.InvalidLogin
+ Right (Right (Left searchResults))
+ | null searchResults -> do
+ $logDebugS apName "User not found"
+ observeLoginOutcome apName LoginInvalidCredentials
+ loginErrorMessageI LoginR Msg.InvalidLogin
+ | otherwise -> do
+ $logWarnS apName $ "Could not extract principal name: " <> tshow searchResults
+ observeLoginOutcome apName LoginError
+ loginErrorMessageI LoginR Msg.AuthError
+ Right (Right (Right (userDN, credsIdent))) -> do
+ observeLoginOutcome apName LoginSuccessful
+ setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
maybe (redirect $ tp LoginR) return resp
apDispatch _ [] = badMethod
@@ -228,3 +233,7 @@ campusLogin pool mode = AuthPlugin{..}
, formAnchor = Just "login--campus" :: Maybe Text
}
$(widgetFile "widgets/campus-login/campus-login-form")
+
+ isInvalidCredentials = \case
+ Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _ -> True
+ _other -> False
diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs
index c5229cbfb..73d898959 100644
--- a/src/Handler/Allocation/Application.hs
+++ b/src/Handler/Allocation/Application.hs
@@ -260,7 +260,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
if
| BtnAllocationApply <- afAction
, allowAction afAction
- -> runDB $ do
+ -> runDB . setSerializable $ do
haveOld <- exists [ CourseApplicationCourse ==. cid
, CourseApplicationUser ==. uid
, CourseApplicationAllocation ==. maId
@@ -291,7 +291,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
, allowAction afAction
, Just appId <- mAppId
- -> runDB $ do
+ -> runDB . setSerializable $ do
now <- liftIO getCurrentTime
changes <- if
diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs
index 5e0165a1c..66b9b3566 100644
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@@ -175,8 +175,9 @@ postCRegisterR tid ssh csh = do
formResult regResult $ \CourseRegisterForm{..} -> do
cTime <- liftIO getCurrentTime
let
+ doApplication = courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
mkApplication
- | courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
+ | doApplication
= void <$> do
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
appRes <- case appIds of
@@ -210,12 +211,12 @@ postCRegisterR tid ssh csh = do
]
case courseRegisterButton of
- BtnCourseRegister -> runDB $ do
+ BtnCourseRegister -> runDB . bool id setSerializable doApplication $ do
regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration
case regOk of
Nothing -> transactionUndo
Just _ -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
- BtnCourseDeregister -> runDB $ do
+ BtnCourseDeregister -> runDB . setSerializable $ do
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
deregisterParticipant uid cid
@@ -237,7 +238,7 @@ postCRegisterR tid ssh csh = do
when courseDeregisterNoShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
- BtnCourseApply -> runDB $ do
+ BtnCourseApply -> runDB . setSerializable $ do
regOk <- mkApplication
case regOk of
Nothing -> transactionUndo
diff --git a/src/Handler/Sheet/Pseudonym.hs b/src/Handler/Sheet/Pseudonym.hs
index b9c055fa6..f269ef18c 100644
--- a/src/Handler/Sheet/Pseudonym.hs
+++ b/src/Handler/Sheet/Pseudonym.hs
@@ -7,8 +7,6 @@ import Import
import Handler.Utils
-import Utils.Sql
-
data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs
index dc1b0141f..286481651 100644
--- a/src/Handler/Submission/Helper.hs
+++ b/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
- csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
- maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True
- isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
+ let
+ getSheetInfo = do
+ csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
+ 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]
-
- 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)
-
- 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
+ when ( is _Nothing muid
+ && is _Nothing msubmission
+ && not isLecturer
+ )
+ notAuthenticated
+
-- 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
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 0711da57e..0345765f8 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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) ->
- Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
+ whenIsJust mIdent $ \ident ->
+ modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
+ Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
_FileTitle :: Prism' Text FilePath
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 7af8f3d57..8d0a895cc 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/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
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index bbb67eb6b..25c1330b5 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -38,6 +38,7 @@ import Yesod.Core.Types.Instances as Import
import Utils as Import
import Utils.Frontend.I18n as Import
import Utils.DB as Import
+import Utils.Sql as Import
import Data.Fixed as Import
diff --git a/src/Jobs.hs b/src/Jobs.hs
index 5faf681e0..b917354f0 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -18,8 +18,6 @@ import Data.Aeson (fromJSON)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
-import Utils.Sql
-
import Control.Monad.Random (evalRand, mkStdGen, uniformMay)
import Cron
diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs
index b9817f649..7b144ae05 100644
--- a/src/Jobs/Handler/Files.hs
+++ b/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
- isReferenced <- lift . E.selectExists . E.where_ . E.any E.exists . fileReferences $ E.val fRef
- if | isReferenced -> do
- alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ]
- if | alreadyInjected -> return (mempty, mempty, Sum 1)
- | otherwise -> do
- content <- (hoistMaybe =<<) . runAppMinio . runMaybeT $ do
- objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions
- lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
- lift $ (mempty, Sum 1, mempty) <$ insert (FileContent fRef content)
- | otherwise -> return (Sum 1, mempty, mempty)
+ res <- hoist (runDB . setSerializable) $ do
+ alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ]
+ if | alreadyInjected -> return (mempty, Sum 1)
+ | otherwise -> do
+ content <- (hoistMaybe =<<) . runAppMinio . runMaybeT $ do
+ objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions
+ lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
+ lift $ (Sum 1, mempty) <$ insertUnique (FileContent fRef content)
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) $
diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs
index 5275304d7..045649ed1 100644
--- a/src/Jobs/Queue.hs
+++ b/src/Jobs/Queue.hs
@@ -11,7 +11,6 @@ module Jobs.Queue
import Import hiding ((<>))
-import Utils.Sql
import Jobs.Types
import Control.Monad.Writer.Class (MonadWriter(..))
diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs
index 6eed49d4b..e8c51dae7 100644
--- a/src/Utils/Failover.hs
+++ b/src/Utils/Failover.hs
@@ -161,9 +161,10 @@ withFailover' testTarget' f@Failover{..} mode detAcceptable act = withFailoverRe
$logErrorS "withFailover'" $ tshow (hashUnique alreadyTested) <> " recording failure for item " <> failoverLabel
atomically . modifyTVar failover $ \failover' -> if
| views (P.focus . _failoverReferences) (Set.member currentlyTesting) failover'
- -> fromMaybe failover' $ P.next failover'
+ -> fromMaybe (goFirst failover') $ P.next failover'
| otherwise
-> failover'
+ where goFirst l = maybe l goFirst $ P.previous l
$logDebugS "withFailover'" $ tshow (hashUnique alreadyTested) <> " using item " <> failoverLabel
res' <- handleAll (\err -> $logErrorS "withFailover'" (tshow (hashUnique alreadyTested) <> " exception during act or detAcceptable: " <> tshow err) >> recordFailure >> throwM err) $
diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs
index b9121904e..517c36034 100644
--- a/src/Utils/Files.hs
+++ b/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)
diff --git a/templates/mail/sheetHint.hamlet b/templates/mail/sheetHint.hamlet
index 621f15227..a20ded146 100644
--- a/templates/mail/sheetHint.hamlet
+++ b/templates/mail/sheetHint.hamlet
@@ -11,11 +11,11 @@ $newline never
}
- _{MsgMailSheetSolutionIntro (CI.original courseName) termDesc sheetName}
+ _{MsgMailSheetHintIntro (CI.original courseName) termDesc sheetName}
#{sheetName}
-
- _{MsgSheetSolution}
+
+ _{MsgSheetHint}
^{editNotifications}
diff --git a/templates/mail/sheetSolution.hamlet b/templates/mail/sheetSolution.hamlet
index a20ded146..621f15227 100644
--- a/templates/mail/sheetSolution.hamlet
+++ b/templates/mail/sheetSolution.hamlet
@@ -11,11 +11,11 @@ $newline never
}
- _{MsgMailSheetHintIntro (CI.original courseName) termDesc sheetName}
+ _{MsgMailSheetSolutionIntro (CI.original courseName) termDesc sheetName}
#{sheetName}
-
- _{MsgSheetHint}
+
+ _{MsgSheetSolution}
^{editNotifications}