diff --git a/.vscode/tasks.json b/.vscode/tasks.json index a2b36e1b4..1c0b71c32 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -58,6 +58,11 @@ "type": "npm", "script": "start", "problemMatcher": [] + }, + { + "type": "npm", + "script": "frontend:lint", + "problemMatcher": [] } ] } \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5415d7578..570730adf 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -394,14 +394,21 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden: SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt! + +CorrectionSheets: Übersicht Korrekturen nach Blättern +CorrectionCorrectors: Übersicht Korrekturen nach Korrektoren 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 +NrSubmittorsTotal: Abgebende NrSubmissionsTotal: Abgaben NrSubmissionsUnassigned: Ohne Korrektor +NoCorrectorAssigned: Ohne Korrektor NrCorrectors: Korrektoren NrSubmissionsNewlyAssigned: Neu zugeteilt NrSubmissionsNotAssigned: Nicht zugeteilt +NrSubmissionsNotCorrected: Unkorrigiert +CorrectionTime: Korrekturdauer (Min/Avg/Max) CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert: NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden. @@ -971,7 +978,7 @@ TutorialDelete: Löschen CourseTutorials: Übungen -ParticipantsN n@Int: Teilnehmer +ParticipantsN n@Int: #{tshow n} Teilnehmer TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen? TutorialDeleted: Tutorium gelöscht @@ -1007,6 +1014,7 @@ HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden w HealthSMTPConnect: SMTP-Server kann erreicht werden HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus +CourseParticipants n@Int: Derzeit #{tshow n} angemeldete Kursteilnehmer CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} diff --git a/models/sheets b/models/sheets index f8d21a6c2..138b50bf1 100644 --- a/models/sheets +++ b/models/sheets @@ -4,7 +4,7 @@ Sheet -- exercise sheet for a given course description Html Maybe type SheetType -- Does it count towards overall course grade? grouping SheetGroup -- May participants submit in groups of certain sizes? - markingText Html Maybe -- Instructions for correctors, included in marking templates + markingText Html Maybe -- Instructons for correctors, included in marking templates visibleFrom UTCTime Maybe -- Invisible to enrolled participants before activeFrom UTCTime -- Download of questions and submission is permitted afterwards activeTo UTCTime -- Submission is only permitted before diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index b865ee96e..0e2f70e21 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -5,6 +5,7 @@ import Import import Jobs import Handler.Utils +import Handler.Utils.Corrections import Handler.Utils.Submission import Handler.Utils.Table.Cells import Handler.Utils.SheetType @@ -13,11 +14,11 @@ import Handler.Utils.Delete import Utils.Lens -import Data.List (nub) +import Data.List as List (nub, foldl, foldr) import Data.Set (Set) import qualified Data.Set as Set -import Data.Map (Map, (!)) -import qualified Data.Map as Map +import Data.Map.Strict (Map, (!)) +import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI @@ -250,7 +251,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] return (user, pseudonym E.?. SheetPseudonymPseudonym) let - submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors + submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap) dbTable psValidator DBTable { dbtSQLQuery @@ -1035,7 +1036,7 @@ embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id instance Button UniWorX ButtonSubmissionsAssign where btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary] --- | Gather info about corrector assignment per sheet +-- | DEPRECATED use CorrectorInfo instead. Gather info about corrector assignment per sheet data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int } getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -1092,3 +1093,134 @@ assignHandler tid ssh csh rawSids = do 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 + +assignHandler' :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html +assignHandler' tid ssh csh _rawSids = do + -- gather data + (nrParticipants, groupsPossible, infoMap, correctorMap) <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + nrParticipants <- count [CourseParticipantCourse ==. cid] + + sheetList <- selectList [SheetCourse ==. cid] [Asc SheetName] + let sheets = entities2map sheetList + sheetIds = Map.keys sheets + groupsPossible :: Bool + groupsPossible = + let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups + in List.foldr foldFun False sheetList + + correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do + E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId + E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds + return (corrector, user) + let correctorMap :: Map UserId (SheetCorrector,User) + correctorMap = foldl (\m (Entity _ corr, Entity uid user)-> Map.insert uid (corr,user) m) Map.empty correctors + + submissions <- E.select . E.from $ \submission -> do + E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds + let numSubmittors = E.sub_select . E.from $ \subUser -> do + E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission + return E.countRows + return (submission, numSubmittors) + -- prepare map + let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) + infoMap = List.foldl (flip buildS) emptySheets submissions + + -- ensure that all sheets are shown, including those without any submissions + emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) Map.empty m) Map.empty sheetIds + + buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) + buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m = + let shnm = sheetName $ sheets ! submissionSheet + corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned + cinf = Map.singleton submissionRatingBy $ CorrectionInfo + { ciSubmittors = fromIntegral nrSbmtrs + , ciSubmissions = 1 + , ciAssigned = maybe 0 (const 1) submissionRatingBy + , ciCorrected = maybe 0 (const 1) submissionRatingTime + , ciCorrector = submissionRatingBy + , ciMin = corTime + , ciTot = corTime + , ciMax = corTime + } + in Map.insertWith (Map.unionWith (<>)) shnm cinf m + return (nrParticipants, groupsPossible, infoMap, correctorMap) + + let -- create aggregate maps + sheetMap :: Map SheetName CorrectionInfo + sheetMap = Map.map fold infoMap + corrMap :: Map (Maybe UserId) CorrectionInfo + corrMap = Map.unionsWith (<>) $ Map.elems infoMap + sheetNames = Map.keys infoMap + let -- whamlet convenience functions + showCorrector :: Maybe UserId -> Widget + showCorrector (Just uid) + | Just (_,User{..}) <- Map.lookup uid correctorMap + = nameEmailWidget userEmail userDisplayName userSurname + showCorrector _ = [whamlet|_{MsgNoCorrectorAssigned}|] + showDiffDays :: Maybe NominalDiffTime -> Text + showDiffDays = foldMap formatDiffDays + showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text + showAvgsDays Nothing _ = mempty + showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n + let headingShort = MsgMenuCorrectionsAssign + headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign + siteLayoutMsg headingShort $ do + setTitleI headingLong + -- TODO: Move whamlet into separate Widget-File, once completed + [whamlet| +
+

_{MsgCorrectionSheets} + _{MsgCourseParticipants nrParticipants} + + + +
_{MsgSheet} + $if groupsPossible + _{MsgNrSubmittorsTotal} + _{MsgNrSubmissionsTotal} + _{MsgNrSubmissionsNotAssigned} + _{MsgNrSubmissionsNotCorrected} + _{MsgCorrectionTime} + $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- Map.toList sheetMap +
^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)} + $if groupsPossible + #{ciSubmittors} + #{ciSubmissions} + #{ciSubmissions - ciAssigned} + #{ciSubmissions - ciCorrected} + #{showDiffDays ciMin} + #{showAvgsDays ciTot ciCorrected} + #{showDiffDays ciMax} +
+

_{MsgCorrectionCorrectors} + + + +
_{MsgCorrector} + _{MsgNrSubmissionsTotal} + _{MsgNrSubmissionsNotCorrected} + _{MsgCorrectionTime} + $forall shn <- sheetNames + #{shn} + $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap +
^{showCorrector ciCorrector} + #{ciSubmissions} + #{ciSubmissions - ciCorrected} + #{showDiffDays ciMin} + #{showAvgsDays ciTot ciCorrected} + #{showDiffDays ciMax} + $forall shn <- sheetNames + $maybe smap <- Map.lookup shn infoMap + $maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- Map.lookup ciCorrector smap + #{ciAssigned} + #{ciAssigned - ciCorrected} + #{showAvgsDays ciTot ciCorrected} + $nothing + + $nothing + + |] + + + diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 2a98110c1..caeeb11c1 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -136,7 +136,7 @@ postTDeleteR tid ssh csh tutn = do return E.countRows return (course, tutorial, participants :: E.SqlExpr (E.Value Int)) , drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) -> - return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (#{tshow ps} _{MsgParticipantsN ps})|] + return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|] , drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) -> return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|] , drCaption = SomeMessage MsgTutorialDeleteQuestion @@ -199,7 +199,7 @@ postTCommR tid ssh csh tutn = do [E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser -> E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid - + isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False diff --git a/src/Handler/Utils/Corrections.hs b/src/Handler/Utils/Corrections.hs new file mode 100644 index 000000000..ca5d433d7 --- /dev/null +++ b/src/Handler/Utils/Corrections.hs @@ -0,0 +1,45 @@ +module Handler.Utils.Corrections where + +import Import + + +-- CorrectionInfo has seeming redundancies, but these are useful for aggregation +-- INVARIANT: isJust ciTot `implies` ciCorrected > 0 +data CorrectionInfo = CorrectionInfo + { ciSubmittors, ciSubmissions, ciAssigned, ciCorrected :: Integer + , ciCorrector :: Maybe UserId + , ciTot, ciMin, ciMax :: Maybe NominalDiffTime + } + +instance Semigroup CorrectionInfo where + corrA <> corrB = + assert (isJust (ciTot corrA) `implies` (ciCorrected corrA > 0)) $ + assert (isJust (ciTot corrB) `implies` (ciCorrected corrB > 0)) + CorrectionInfo + { ciSubmittors = ciSubmittors `mergeWith` (+) + , ciSubmissions = ciSubmissions `mergeWith` (+) + , ciAssigned = ciAssigned `mergeWith` (+) + , ciCorrected = ciCorrected `mergeWith` (+) + , ciCorrector = ciCorrector `mergeWith` keepEqual + , ciTot = ciTot `mergeWith` ignoreNothing (+) + , ciMin = ciMin `mergeWith` ignoreNothing min + , ciMax = ciMax `mergeWith` ignoreNothing max + } + where + mergeWith :: (CorrectionInfo -> a) -> (a -> a -> c) -> c + mergeWith prj f = on f prj corrA corrB + + keepEqual (Just x) (Just y) | x==y = Just x + keepEqual _ _ = Nothing + +instance Monoid CorrectionInfo where + mappend = (<>) + mempty = CorrectionInfo { ciSubmittors = 0 + , ciSubmissions = 0 + , ciAssigned = 0 + , ciCorrected = 0 + , ciCorrector = Nothing + , ciMin = Nothing + , ciTot = Nothing + , ciMax = Nothing + } diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 16ab29afa..8297f7266 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -2,6 +2,7 @@ module Handler.Utils.DateTime ( utcToLocalTime , localTimeToUTC, TZ.LocalToUTCResult(..) , toMidnight, beforeMidnight, toMidday, toMorning + , formatDiffDays , formatTime, formatTime', formatTimeW , getTimeLocale, getDateTimeFormat , validDateTimeFormats, dateTimeFormatOptions @@ -29,6 +30,37 @@ import qualified Data.Set as Set import Data.Time.Clock.System (systemEpochDay) + +-------------------- +-- NominalDiffTime + +-- | One hour in 'NominalDiffTime'. +nominalHour :: NominalDiffTime +nominalHour = 3600 + +-- | One minute in 'NominalDiffTime'. +nominalMinute :: NominalDiffTime +nominalMinute= 60 + +formatDiffDays :: NominalDiffTime -> Text +formatDiffDays t + | t > nominalDay = inDays <> "d" + | t > nominalHour = inHours <> "h" + | t > nominalMinute = inMinutes <> "m" + | otherwise = tshow $ roundToDigits 0 t + where + convertBy :: NominalDiffTime -> Double + convertBy len = realToFrac $ roundToDigits 1 $ t / len + inDays = tshow $ convertBy nominalDay + inHours = tshow $ convertBy nominalHour + inMinutes = tshow $ convertBy nominalMinute + + + +------------ +-- UTCTime + + utcToLocalTime :: UTCTime -> LocalTime utcToLocalTime = TZ.utcToLocalTimeTZ appTZ @@ -52,7 +84,6 @@ toMorning :: Day -> UTCTime toMorning d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 6 0 0 - class FormatTime t => HasLocalTime t where toLocalTime :: t -> LocalTime diff --git a/src/Utils.hs b/src/Utils.hs index e8f0d27f5..22e5b3b91 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -343,6 +343,17 @@ notUsedT = notUsed +---------- +-- Bool -- +---------- + +-- | Logical implication, readable synonym for (<=) which appears the wrong way around +implies :: Bool -> Bool -> Bool +implies True x = x +implies _ _ = True + + + ------------- -- Numeric -- ------------- @@ -523,12 +534,6 @@ flipMaybe :: b -> Maybe a -> Maybe b flipMaybe x Nothing = Just x flipMaybe _ (Just _) = Nothing - -maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap -maybeAdd (Just x) (Just y) = Just (x + y) -maybeAdd Nothing y = y -maybeAdd x Nothing = x - -- | Deep alternative to avoid any occurrence of Nothing at all costs, left-biased deepAlt :: Maybe (Maybe a) -> Maybe (Maybe a) -> Maybe (Maybe a) deepAlt Nothing altSnd = altSnd @@ -574,6 +579,12 @@ mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs +-- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap +ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +ignoreNothing _ Nothing y = y +ignoreNothing _ x Nothing = x +ignoreNothing f (Just x) (Just y) = Just $ f x y + newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom instance Eq a => Eq (NTop (Maybe a)) where