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 2019-06-04 10:32:29 +02:00
commit a5dcdaae0b
10 changed files with 237 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.vscode/tasks.json vendored
View File

@ -53,6 +53,11 @@
"type": "npm",
"script": "yesod:start",
"problemMatcher": []
},
{
"type": "npm",
"script": "start",
"problemMatcher": []
}
]
}

11
messages/uniworx/de.msg
View File

@ -17,7 +17,7 @@ BtnLecInvAccept: Annehmen
BtnLecInvDecline: Ablehnen
BtnCorrInvAccept: Annehmen
BtnCorrInvDecline: Ablehnen
BtnSubmissionsAssign: Abgaben automatisch zuteilen
Aborted: Abgebrochen
@ -33,6 +33,7 @@ GenericKey: Schlüssel
GenericShort: Kürzel
GenericIsNew: Neu
GenericHasConflict: Konflikt
GenericBack: Zurück
SummerTerm year@Integer: Sommersemester #{display year}
WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
@ -378,6 +379,7 @@ CorrDownload: Herunterladen
CorrUploadField: Korrekturen
CorrUpload: Korrekturen hochladen
CorrSetCorrector: Korrektor zuweisen
CorrSetCorrectorTooltip: Bereits verteilte Abgaben müssen zuerst Korrektor <Nichts> zugewiesen werden, bevor diese neu verteilt werden.
CorrAutoSetCorrector: Korrekturen verteilen
CorrDelete: Abgaben löschen
NatField name@Text: #{name} muss eine natürliche Zahl sein!
@ -396,7 +398,11 @@ SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem K
AssignSubmissionExceptionNoCorrectors: Es sind keine Korrektoren eingestellt
AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit Anteil ungleich Null eingestellt
AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden
NrSubmissionsTotal: Abgaben
NrSubmissionsUnassigned: Ohne Korrektor
NrCorrectors: Korrektoren
NrSubmissionsNewlyAssigned: Neu zugeteilt
NrSubmissionsNotAssigned: Nicht zugeteilt
CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
@ -822,6 +828,7 @@ MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsDownload: Offene Abgaben herunterladen
MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben online korrigieren
MenuCorrectionsAssign: Abgaben automatisch zuteilen
MenuAuthPreds: Authorisierungseinstellungen
MenuTutorialDelete: Tutorium löschen
MenuTutorialEdit: Tutorium editieren

4
routes
View File

@ -92,6 +92,7 @@
/communication CCommR GET POST
/notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access!
/subs CCorrectionsR GET POST
/subs/assigned CAssignR GET POST
/ex SheetListR GET !course-registered !materials !corrector
/ex/new SheetNewR GET POST
/ex/current SheetCurrentR GET !course-registered !materials !corrector
@ -103,10 +104,11 @@
/subs SSubsR GET POST -- for lecturer only
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions
!/subs/own SubmissionOwnR GET !free -- just redirect
!/subs/assign SAssignR GET POST !lecturerANDtime
/subs/#CryptoFileNameSubmission SubmissionR:
/ SubShowR GET POST !ownerANDtimeANDuser-submissions !ownerANDread !correctorANDread
/delete SubDelR GET POST !ownerANDtimeANDuser-submissions
/assign SAssignR GET POST !lecturerANDtime
/assign SubAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
/invite SInviteR GET POST !ownerANDtimeANDuser-submissions
!/#SubmissionFileType SubArchiveR GET !owner !corrector

67
src/Foundation.hs
View File

@ -676,10 +676,11 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom
SZipR _ -> mzero
-- Submissions
SubmissionNewR -> guard active
SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
SubmissionR _ _ -> guard active
_ -> return ()
SubmissionNewR -> guard active
SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler
SubmissionR _ SubAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
SubmissionR _ _ -> guard active
_ -> return ()
return Authorized
@ -966,7 +967,7 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf
let
authVarSpecificity = authTagSpecificity `on` plVar
authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'
authTagIsInactive = not . authTagIsActive
evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
@ -1426,6 +1427,7 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh CInviteR) = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh CAssignR) = return ("Zuteilen" , Just $ CourseR tid ssh csh CCorrectionsR)
breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CourseR tid ssh csh SheetCurrentR) = return ("Aktuelles Blatt", Just $ CourseR tid ssh csh SheetListR)
@ -1439,10 +1441,11 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR)
breadcrumb (CTutorialR tid ssh csh tutn TCommR) = return ("Mitteilung", Just $ CTutorialR tid ssh csh tutn TUsersR)
breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten" , Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen" , Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben" , Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SAssignR) = return ("Zuteilen" , Just $ CSheetR tid ssh csh shn SSubsR)
breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
@ -1607,7 +1610,7 @@ pageActions :: Route UniWorX -> [MenuItem]
pageActions (HomeR) =
[
MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgInfoLecturerTitle
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute InfoLecturerR
@ -1914,6 +1917,16 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemAccessCallback' = return True
}
]
pageActions (CourseR tid ssh csh CCorrectionsR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
]
pageActions (CourseR tid ssh csh SheetListR) =
[ MenuItem
{ menuItemType = PageActionPrime
@ -1943,6 +1956,14 @@ pageActions (CourseR tid ssh csh SheetListR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsOwn
@ -2112,6 +2133,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetEdit
@ -2139,6 +2168,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
]
pageActions (CSheetR tid ssh csh shn SSubsR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissionNew
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectors
, menuItemIcon = Nothing
@ -2146,11 +2183,11 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissionNew
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
@ -2168,7 +2205,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
{ menuItemType = PageActionPrime
, menuItemLabel = MsgCorrectorAssignTitle
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SAssignR
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR
, menuItemModal = True
, menuItemAccessCallback' = return True
}

103
src/Handler/Corrections.hs
View File

@ -528,7 +528,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
E.where_ $ submission E.^. SubmissionId E.==. E.val sId
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName)
cID <- encrypt sId
let route = CSubmissionR tid ssh csh shn cID SAssignR
let route = CSubmissionR tid ssh csh shn cID SubAssignR
(== Authorized) <$> evalAccessDB route True
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
@ -555,7 +555,7 @@ assignAction selId = ( CorrSetCorrector
correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey
cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector) Nothing
cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector & setTooltip MsgCorrSetCorrectorTooltip) Nothing
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
)
@ -1015,38 +1015,73 @@ postCorrectionsGradeR = do
$(widgetFile "corrections-grade")
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
data ButtonSubmissionsAssign = BtnSubmissionsAssign
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonSubmissionsAssign
instance Finite ButtonSubmissionsAssign
nullaryPathPiece ''ButtonSubmissionsAssign camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
instance Button UniWorX ButtonSubmissionsAssign where
btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
-- | Gather info about corrector assignment per sheet
data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int }
getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAssignR = postCAssignR
postCAssignR tid ssh csh = do
shids <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
assignHandler tid ssh csh shids
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSAssignR = postSAssignR
postSAssignR tid ssh csh shn cID = do
let actionUrl = CSubmissionR tid ssh csh shn cID SAssignR
sId <- decrypt cID
(currentCorrector, sheetCorrectors) <- runDB $ do
Submission{submissionRatingBy, submissionSheet} <- get404 sId
sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
userCorrector <- traverse getJustEntity submissionRatingBy
return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)
$logDebugS "SAssignR" $ tshow currentCorrector
let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $
aopt correctorField (fslI MsgCorrector) (Just currentCorrector)
formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
now <- liftIO getCurrentTime
update sId [ SubmissionRatingBy =. mbUserId
, SubmissionRatingAssigned =. (now <$ mbUserId)
]
addMessageI Success MsgCorrectorUpdated
redirect actionUrl
let corrForm = wrapForm' BtnSave corrForm' def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = corrEncoding
, formSubmit = FormDualSubmit
}
defaultLayout $ do
setTitleI MsgCorrectorAssignTitle
$(widgetFile "submission-assign")
postSAssignR tid ssh csh shn = do
shid <- runDB $ fetchSheetId tid ssh csh shn
assignHandler tid ssh csh [shid]
assignHandler :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html
assignHandler tid ssh csh rawSids = do
-- gather data
openSubs <- runDB $ (\f -> foldM f Map.empty rawSids) $
\acc sid -> maybeT (return acc) $ do
Just Sheet{sheetName=saiName} <- lift $ get sid
guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh saiName SAssignR -- we must check, whether the submission is already closed and thus assignable
saiUnassignedNr <- lift $ count [SubmissionSheet ==. sid, SubmissionRatingBy ==. Nothing]
guard $ 0 < saiUnassignedNr -- only consider sheets with unassigned submissions
saiSubmissionNr <- lift $ count [SubmissionSheet ==. sid]
saiCorrectorNr <- lift $ count [SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal]
-- guard $ saiCorrectorNr > 0 -- COMMENTED OUT BECAUSE we should show sheets without possible correctors to inform the user about these problematic sheets
return $ Map.insert sid SubAssignInfo{..} acc
let sids = Map.keys openSubs
linkBack <- simpleLinkI (SomeMessage MsgGenericBack) <$> case sids of
[sid] -> do Sheet{sheetName} <- runDB $ getJust sid
return $ CSheetR tid ssh csh sheetName SSubsR
_ -> return $ CourseR tid ssh csh CCorrectionsR
-- process form
currentRoute <- getCurrentRoute
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm FIDAssignSubmissions buttonForm
assignmentStatus <- case btnResult of
FormSuccess BtnSubmissionsAssign -> do -- Button was pressed, assign and report
-- Assign submissions
runDB $ (\f -> foldM f Map.empty sids) $
\acc sid -> flip (Map.insert sid) acc <$> assignSubmissions sid Nothing
-- Too much important information for an alert. Display proper info page instead
other -> do
formFailure2Alerts other -- show possible allerts
return Map.empty -- no assignments performed
let btnForm = wrapForm btnWdgt def
{ formAction = SomeRoute <$> currentRoute
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
headingShort = MsgMenuCorrectionsAssign
headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
siteLayoutMsg headingShort $ do
setTitleI headingLong
$(widgetFile "corrections-assign")
if null sids || not (null assignmentStatus)
then linkBack -- TODO: convenience link might be unnecessary: either via breadcrumb or closing model. Remove, if modal works fine. Otherwise change to PrimaryAction?
else btnForm

35
src/Handler/Submission.hs
View File

@ -364,7 +364,7 @@ submissionHelper tid ssh csh shn mcid = do
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
-- @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 (Set.insert $ Right uid) isOwner buddies
((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
let formWidget = wrapForm' BtnHandIn formWidget' def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype
@ -611,3 +611,36 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions
addMessageI Info MsgNoOpenSubmissions
redirect CorrectionsR
submissionMultiArchive $ Set.fromList subs
getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubAssignR = postSubAssignR
postSubAssignR tid ssh csh shn cID = do
let actionUrl = CSubmissionR tid ssh csh shn cID SubAssignR
sId <- decrypt cID
(currentCorrector, sheetCorrectors) <- runDB $ do
Submission{submissionRatingBy, submissionSheet} <- get404 sId
sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
userCorrector <- traverse getJustEntity submissionRatingBy
return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)
$logDebugS "SubAssignR" $ tshow currentCorrector
let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $
aopt correctorField (fslI MsgCorrector) (Just currentCorrector)
formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
now <- liftIO getCurrentTime
update sId [ SubmissionRatingBy =. mbUserId
, SubmissionRatingAssigned =. (now <$ mbUserId)
]
addMessageI Success MsgCorrectorUpdated
redirect actionUrl
let corrForm = wrapForm' BtnSave corrForm' def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = corrEncoding
, formSubmit = FormSubmit
}
defaultLayout $ do
setTitleI MsgCorrectorAssignTitle
$(widgetFile "submission-assign")

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

@ -53,7 +53,6 @@ import Text.Hamlet (ihamletFile)
import qualified Control.Monad.Catch as E (Handler(..))
data AssignSubmissionException = NoCorrectors
| NoCorrectorsByProportion
| SubmissionsNotFound (NonNull (Set SubmissionId))

7
src/Utils.hs
View File

@ -355,7 +355,14 @@ floorToDigits :: (RealFrac a, Integral b) => b -> a -> a
floorToDigits d x = fromInteger (floor $ x * prec) / prec
where prec = 10^d
-- | Integral division, but rounded upwards.
ceilingDiv :: Integral a => a -> a -> a
ceilingDiv d n = (d+n-1) `div` n
-- | Integral division, rounded to custom digit; convenience function for hamlets
roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c
roundDiv digits numerator denominator
= roundToDigits digits $ fromIntegral numerator / fromIntegral denominator
------------
-- Monoid --

7
src/Utils/Form.hs
View File

@ -189,6 +189,7 @@ data FormIdentifier
| FIDAdminDemo
| FIDUserDelete
| FIDCommunication
| FIDAssignSubmissions
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@ -606,6 +607,10 @@ formFailure errs' = do
mr <- getMessageRender
return . FormFailure $ map mr errs'
-- | Turn form errors into alerts, but otherwise do nothing at all
formFailure2Alerts :: MonadHandler m => FormResult a -> m ()
formFailure2Alerts = flip formResult $ const $ return ()
-- | Turns errors into alerts, ignores missing forms and applies processing function
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x
@ -668,7 +673,7 @@ aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
writer ((a, ints, enctype), vs)
infixl 4 `fmapAForm`
fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints

52
templates/corrections-assign.hamlet Normal file
View File

@ -0,0 +1,52 @@
$# Display a table showing the result of the corrector assignment for possibly several sheets
$# Expected variables"
$# sids :: list of SheetId
$# openSubs :: Map from SheetId to SubAssignInfo, a datatype collecting info about open submissions
$# assignmentStatus :: Map from SheetId to (Set SubmissionId, Set SubmisionId), i.e. assigned submissions and unassigned submissions for that sheet
$if null sids
<p>
_{MsgSheetNoOldUnassigned}
$else
<div .scrolltable>
<table .table .table--striped>
<tr .table__row .table__row--head>
<th .table__th>
_{MsgSheet}
<th .table__th>
_{MsgNrSubmissionsTotal}
<th .table__th>
_{MsgNrSubmissionsUnassigned}
<th .table__th>
_{MsgNrCorrectors}
$# Header-Styling indicates, whether assignment was attempted or not.
$with hasAssignment <- not (Map.null assignmentStatus)
<th :hasAssignment:.table__th>
_{MsgNrSubmissionsNewlyAssigned}
<th :hasAssignment:.table__th>
_{MsgNrSubmissionsNotAssigned}
$forall sid <- sids
$case Map.lookup sid openSubs
$of Nothing
<!-- Empty table row; should not occur. -->
$of Just SubAssignInfo{saiName, saiSubmissionNr, saiUnassignedNr, saiCorrectorNr}
<tr .table__row>
<td .table__td>
#{saiName}
<td .table__td>
#{show saiSubmissionNr}
<td .table__td>
#{show saiUnassignedNr}
<td .table__td>
#{show saiCorrectorNr}
$case Map.lookup sid assignmentStatus
$of Nothing
<td .table__td>
<!-- no newly assigned submission for this sheet -->
<td .table__td>
<!-- no newly unassigned submission for this sheet -->
$of Just (assigned,unassigned)
<td .table__td>
#{show (Set.size assigned)}
<td .table__td>
#{show (Set.size unassigned)}