fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into course-visibility

Browse Source
This commit is contained in:
Sarah Vaupel 2020-07-31 18:06:02 +02:00
commit 27d57fba32
21 changed files with 248 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
CHANGELOG.md
View File

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

7
models/files.model
View File

@ -5,4 +5,9 @@ FileContent
SessionFile
content FileContentReference Maybe
touched UTCTime
touched UTCTime
FileLock
content FileContentReference
instance InstanceId
time UTCTime

2
package-lock.json generated
View File

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

2
package.json
View File

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

2
package.yaml
View File

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

14
src/Application.hs
View File

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

45
src/Auth/LDAP.hs
View File

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

4
src/Handler/Allocation/Application.hs
View File

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

9
src/Handler/Course/Register.hs
View File

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

2
src/Handler/Sheet/Pseudonym.hs
View File

@ -7,8 +7,6 @@ import Import
import Handler.Utils
import Utils.Sql
data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)

242
src/Handler/Submission/Helper.hs
View File

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

11
src/Handler/Utils/Form.hs
View File

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

2
src/Handler/Utils/Submission.hs
View File

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

1
src/Import/NoModel.hs
View File

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

2
src/Jobs.hs
View File

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

30
src/Jobs/Handler/Files.hs
View File

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

1
src/Jobs/Queue.hs
View File

@ -11,7 +11,6 @@ module Jobs.Queue
import Import hiding ((<>))
import Utils.Sql
import Jobs.Types
import Control.Monad.Writer.Class (MonadWriter(..))

3
src/Utils/Failover.hs
View File

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

18
src/Utils/Files.hs
View File

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

6
templates/mail/sheetHint.hamlet
View File

@ -11,11 +11,11 @@ $newline never
}
<body>
<h1>
_{MsgMailSheetSolutionIntro (CI.original courseName) termDesc sheetName}
_{MsgMailSheetHintIntro (CI.original courseName) termDesc sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn (SZipR SheetSolution)}>
_{MsgSheetSolution}
<a href=@{CSheetR tid ssh csh shn (SZipR SheetHint)}>
_{MsgSheetHint}
^{editNotifications}

6
templates/mail/sheetSolution.hamlet
View File

@ -11,11 +11,11 @@ $newline never
}
<body>
<h1>
_{MsgMailSheetHintIntro (CI.original courseName) termDesc sheetName}
_{MsgMailSheetSolutionIntro (CI.original courseName) termDesc sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn (SZipR SheetHint)}>
_{MsgSheetHint}
<a href=@{CSheetR tid ssh csh shn (SZipR SheetSolution)}>
_{MsgSheetSolution}
^{editNotifications}