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

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
Gregor Kleen 2018-11-09 13:57:32 +01:00
commit a056690151
7 changed files with 84 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -30,5 +30,4 @@ src/Handler/Course.SnapCustom.hs
/instance
.stack-work-*
.directory
tags
.vscode
tags

35
.vscode/tasks.json vendored Normal file
View File

@ -0,0 +1,35 @@
{
"version": "2.0.0",
"tasks": [
{
"label": "build",
"type": "shell",
"command": "./build.sh",
"group": {
"kind": "build",
"isDefault": true
},
"presentation": {
"echo": true,
"reveal": "silent",
"focus": false,
"panel": "dedicated",
"showReuseMessage": false
}
},
{
"label": "start",
"type": "shell",
"command": "./start.sh",
"group": "build",
"presentation": {
"echo": true,
"reveal": "silent",
"focus": false,
"panel": "dedicated",
"showReuseMessage": false
},
"problemMatcher": []
}
]
}

5
config/submission-blacklist
View File

@ -10,3 +10,8 @@ $# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt
$# Ignoriere rekursiv alle Dateien .DS_Store (Mac OS)
**/.DS_Store
$# Ignoriere VI-Style-Backup-Files
**/*~
$# Ignoriere Emacs-Style-Backup-Files
**/.#*#

2
messages/uniworx/de.msg
View File

@ -346,7 +346,7 @@ MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie kön
MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfristt für #{sheetName} in #{csh} abgelaufen
MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfrist für #{sheetName} in #{csh} abgelaufen
MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} Abgaben wurden Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
MailEditNotifications: Benachrichtigungen ein-/ausschalten

24
routes
View File

@ -10,20 +10,20 @@
-- Admins always have access to entities within their assigned schools.
--
-- Access Tags:
-- !free -- free for all
-- !lecturer -- lecturer for this course (or the school, if route is not connected to a course)
-- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
-- !registered -- participant for this course (no effect outside of courses)
-- !owner -- part of the group of owners of this submission
-- !capacity -- course this route is associated with has at least one unit of participant capacity
-- !free -- free for all
-- !lecturer -- lecturer for this course (or the school, if route is not connected to a course)
-- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
-- !registered -- participant for this course (no effect outside of courses)
-- !owner -- part of the group of owners of this submission
-- !capacity -- course this route is associated with has at least one unit of participant capacity
--
-- !materials -- only if course allows all materials to be free (no meaning outside of courses)
-- !time -- access depends on time somehow
-- !isRead -- only if it is read-only access (i.e. GET but not POST)
-- !isWrite -- only if it is write access (i.e. POST only) why needed???
--
-- !deprecated -- like free, but logs and gives a warning; entirely disabled in production
-- !materials -- only if course allows all materials to be free (no meaning outside of courses)
-- !time -- access depends on time somehow
-- !isRead -- only if it is read-only access (i.e. GET but not POST)
-- !isWrite -- only if it is write access (i.e. POST only) why needed???
--
-- !deprecated -- like free, but logs and gives a warning; entirely disabled in production
-- !development -- like free, but only for development builds
/static StaticR Static appStatic !free
/auth AuthR Auth getAuth !free

30
src/Handler/Sheet.hs
View File

@ -180,8 +180,7 @@ getSheetListR tid ssh csh = do
mkRoute = do
cid' <- mkCid
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
in protoCell & cellContents %~ (<* tell (sheetTypeSum sheetType submissionRatingPoints))
in anchorCellM mkRoute $(widgetFile "widgets/rating")
, sortable Nothing -- (Just "percent")
(i18nCell MsgRatingPercent)
$ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
@ -196,23 +195,7 @@ getSheetListR tid ssh csh = do
]
psValidator = def
& defaultSorting [("submission-since", SortAsc)]
------------------------------------------------------
-- ISSUE #223
-- The following line does not work; something is wrong with the tell in line 189 above.
-- (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
--
-- If fixed, remove the following workaround code:
SheetTypeSummary{..} <- do
rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
(_, table) <- dbTable psValidator $ DBTable
-- END ISSUE #223
-----------------------------------------------------
((), table) <- dbTable psValidator $ DBTable
{ dbtSQLQuery = sheetData
, dbtColonnade = sheetCol
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
@ -245,6 +228,15 @@ getSheetListR tid ssh csh = do
, dbtStyle = def
, dbtIdent = "sheets" :: Text
}
-- Collect summary over all Sheets, not just the ones shown due to pagination:
SheetTypeSummary{..} <- do
rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
defaultLayout $ do
$(widgetFile "sheetList")
$(widgetFile "widgets/sheetTypeSummary")

32
src/Handler/Submission.hs
View File

@ -47,22 +47,27 @@ import System.FilePath
-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsubmission $ \html -> do
let
fileUploadForm = case uploadMode of
NoUpload -> pure Nothing
(Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
flip (renderAForm FormStandard) html $ (,)
<$> fileUploadForm
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
| g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
])
<*> ( (:|)
-- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students)
<$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
| g <- [2..(fromIntegral groupNr)]
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
])
)
<* submitButton
where
(groupNr, editableBuddies)
| Arbitrary{..} <- grouping = (pred maxParticipants, True) -- pred to account for the person submitting
| Arbitrary{..} <- grouping = (maxParticipants, True)
| RegisteredGroups <- grouping = (fromIntegral $ length buddies, False)
| otherwise = (0, False)
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
@ -95,7 +100,7 @@ getSubmissionOwnR tid ssh csh shn = do
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
uid <- requireAuthId
(Entity uid userData) <- requireAuth
msmid <- traverse decrypt mcid
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
@ -141,7 +146,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
invalidArgsI [MsgSubmissionWrongSheet]
-- fetch buddies from current submission
(Any isOwner, buddies) <- do
submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
submitters <- 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]
@ -149,7 +154,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
let breakUserFromBuddies (E.Value userID, E.Value email)
| uid == userID = (Any True , [])
| otherwise = (Any False, [email])
return $ foldMap breakUserFromBuddies submittors
return $ foldMap breakUserFromBuddies submitters
lastEdits <- do
raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
@ -163,13 +168,14 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
return (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (csheet,buddies,lastEdits)
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
mCID <- runDBJobs $ do
res' <- case res of
FormMissing -> return FormMissing
(FormFailure failmsgs) -> return $ FormFailure failmsgs
(FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
(FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members
-- #227 Part II: no longer ignore submitter, if the user is lecturer or admin (allow lecturers to submit for their students)
(FormSuccess (mFiles,_submitter:|[])) -> return $ FormSuccess (mFiles,[]) -- Type change
(FormSuccess (mFiles,_submitter:|gEMails@(_:_))) -- Validate AdHoc Group Members
| Arbitrary{..} <- sheetGrouping -> do
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))