From 405067d019be3b5f63222ab3e87322339613ce98 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Jun 2019 08:01:14 +0200 Subject: [PATCH 01/13] changelog update --- ChangeLog.md | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 64cf0b8f7..25616306d 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,31 +1,37 @@ + * Version 07.06.2019 + + Abgaben können bestimmte Dateinamen und Endungen erzwingen + + Übungsblätter bieten nun Zip-Archive für alle veröffentlichte Dateien, bzw. Dateigruppen an + * Version 20.05.2019 - + Komplett überarbeitete Funktionalität zur automatischen Verteilung von Korrekturen * Version 13.05.2019 - + Kursverwalter können Teilnehmer hinzufügen * Version 10.05.2019 - + Besseres Interface zum Einstellen von Abgebenden - + Download von allen Dateien pro Kursmaterial/Übungsblatt - + * Version 04.05.2019 - + Kursmaterial * Version 29.04.2019 - + Tutorien - + Anzeige von Korrektoren auf den Kursseiten * Version 20.04.2019 - + Versand von Benachrichtigungen an Kursteilnehmer - + Eintragen von Korrektoren und Kursverwaltern auch ohne bestehenden Account * Version 27.03.2019 From 0185fd3c87f46223eb99df44588f615467845f3b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 13 Jun 2019 09:49:17 +0200 Subject: [PATCH 02/13] assignSubmission split into planning and assigning part --- src/Foundation.hs | 114 ++++++++++++++++---------------- src/Handler/Utils/Submission.hs | 28 +++++--- 2 files changed, 76 insertions(+), 66 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 4567440f8..7ce7a5eed 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1744,7 +1744,7 @@ pageActions InstanceR = [ ] pageActions (HelpR) = [ -- MenuItem - -- { menuItemType = PageActionPrime + -- { menuItemType = PageActionPrime -- , menuItemLabel = MsgInfoLecturerTitle -- , menuItemIcon = Nothing -- , menuItemRoute = SomeRoute InfoLecturerR @@ -1754,7 +1754,7 @@ pageActions (HelpR) = [ ] pageActions (ProfileR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuProfileData , menuItemIcon = Just "book" , menuItemRoute = SomeRoute ProfileDataR @@ -1762,7 +1762,7 @@ pageActions (ProfileR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuAuthPreds , menuItemIcon = Nothing , menuItemRoute = SomeRoute AuthPredsR @@ -1772,7 +1772,7 @@ pageActions (ProfileR) = ] pageActions TermShowR = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuTermCreate , menuItemIcon = Nothing , menuItemRoute = SomeRoute TermEditR @@ -1782,7 +1782,7 @@ pageActions TermShowR = ] pageActions (TermCourseListR tid) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCourseNew , menuItemIcon = Just "book" , menuItemRoute = SomeRoute CourseNewR @@ -1790,7 +1790,7 @@ pageActions (TermCourseListR tid) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuTermEdit , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ TermEditExistR tid @@ -1810,7 +1810,7 @@ pageActions (TermSchoolCourseListR _tid _ssh) = ] pageActions (CourseListR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCourseNew , menuItemIcon = Just "book" , menuItemRoute = SomeRoute CourseNewR @@ -1820,7 +1820,7 @@ pageActions (CourseListR) = ] pageActions (CourseNewR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgInfoLecturerTitle , menuItemIcon = Nothing , menuItemRoute = SomeRoute InfoLecturerR @@ -1849,7 +1849,7 @@ pageActions (CourseR tid ssh csh CShowR) = in runDB $ lecturerAccess `or2M` existsVisible } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetList , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR @@ -1877,7 +1877,7 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseMembers , menuItemIcon = Just "user-graduate" , menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR @@ -1885,7 +1885,7 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseCommunication , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR @@ -1893,7 +1893,7 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseEdit , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR @@ -1901,7 +1901,7 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseClone , menuItemIcon = Just "copy" , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) @@ -1909,9 +1909,9 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseDelete - , menuItemIcon = Just "trash" + , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR , menuItemModal = False , menuItemAccessCallback' = return True @@ -1919,17 +1919,17 @@ pageActions (CourseR tid ssh csh CShowR) = ] pageActions (CourseR tid ssh csh CCorrectionsR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CourseR tid ssh csh SheetListR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetCurrent , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR @@ -1939,7 +1939,7 @@ pageActions (CourseR tid ssh csh SheetListR) = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetOldUnassigned , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR @@ -1949,25 +1949,25 @@ pageActions (CourseR tid ssh csh SheetListR) = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsOwn - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid) , ("corrections-school", CI.original $ unSchoolKey ssh) , ("corrections-course", CI.original csh) @@ -1988,7 +1988,7 @@ pageActions (CourseR tid ssh csh SheetListR) = return ok } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetNew , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR @@ -2082,7 +2082,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissionNew , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR @@ -2094,7 +2094,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissionOwn , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR @@ -2118,49 +2118,49 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectors - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSheetEdit - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSheetClone - , menuItemIcon = Just "copy" + , menuItemIcon = Just "copy" , menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSheetDelete - , menuItemIcon = Just "trash" + , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR , menuItemModal = False , menuItemAccessCallback' = return True @@ -2168,7 +2168,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) = ] pageActions (CSheetR tid ssh csh shn SSubsR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissionNew , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR @@ -2176,25 +2176,25 @@ pageActions (CSheetR tid ssh csh shn SSubsR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectors - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrectionsAssign - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR - , menuItemModal = True + , menuItemModal = False , menuItemAccessCallback' = return True } ] pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuCorrection , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR @@ -2202,7 +2202,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgCorrectorAssignTitle , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR @@ -2210,7 +2210,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSubmissionDelete , menuItemIcon = Just "trash" , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR @@ -2220,7 +2220,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = ] pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = [ MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSubmissionDelete , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR @@ -2230,17 +2230,17 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = ] pageActions (CSheetR tid ssh csh shn SCorrR) = [ MenuItem - { menuItemType = PageActionPrime + { menuItemType = PageActionPrime , menuItemLabel = MsgMenuSubmissions - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR , menuItemModal = False , menuItemAccessCallback' = return True } , MenuItem - { menuItemType = PageActionSecondary + { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuSheetEdit - , menuItemIcon = Nothing + , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR , menuItemModal = False , menuItemAccessCallback' = return True diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 9bb44bf00..dc55df410 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -67,6 +67,24 @@ assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors , Set SubmissionId ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load assignSubmissions sid restriction = do + newSubmissionData <- planSubmissions sid restriction + now <- liftIO getCurrentTime + execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, mCorrector) -> case mCorrector of + Just corrector -> do + lift $ update subId [ SubmissionRatingBy =. Just corrector + , SubmissionRatingAssigned =. Just now + ] + tell (Set.singleton subId, mempty) + Nothing -> + tell (mempty, Set.singleton subId) + + +-- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet! +planSubmissions :: SheetId -- ^ Sheet to distribute to correctors + -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider + -> YesodDB UniWorX (Map SubmissionId (Maybe UserId)) + -- ^ Return map that assigns submissions to Corrector +planSubmissions sid restriction = do Sheet{..} <- getJust sid correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet @@ -210,15 +228,7 @@ assignSubmissions sid restriction = do ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) - now <- liftIO getCurrentTime - execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, (mCorrector, _, _)) -> case mCorrector of - Just corrector -> do - lift $ update subId [ SubmissionRatingBy =. Just corrector - , SubmissionRatingAssigned =. Just now - ] - tell (Set.singleton subId, mempty) - Nothing -> - tell (mempty, Set.singleton subId) + return $ fmap (view _1) newSubmissionData where maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs From 718a2b026cb2333c079a7c37bcc95e4c34205873 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 14 Jun 2019 17:05:45 +0200 Subject: [PATCH 03/13] Correction stats coded, but not yet used online --- .vscode/tasks.json | 5 ++ messages/uniworx/de.msg | 10 ++- models/sheets | 2 +- src/Handler/Corrections.hs | 142 +++++++++++++++++++++++++++++-- src/Handler/Tutorial.hs | 4 +- src/Handler/Utils/Corrections.hs | 45 ++++++++++ src/Handler/Utils/DateTime.hs | 33 ++++++- src/Utils.hs | 23 +++-- 8 files changed, 248 insertions(+), 16 deletions(-) create mode 100644 src/Handler/Utils/Corrections.hs 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 From e33704dca43ecdd9e3b61f4e67cdbc501b946ab6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 14 Jun 2019 20:43:14 +0200 Subject: [PATCH 04/13] Implementation okay, but throws NoCorrectors (FIXME) --- src/Handler/Corrections.hs | 110 +++++++++++--------------- src/Handler/Utils/Submission.hs | 14 +++- src/Utils.hs | 5 ++ src/Utils/Form.hs | 32 +++++++- templates/corrections-overview.hamlet | 69 ++++++++++++++++ 5 files changed, 159 insertions(+), 71 deletions(-) create mode 100644 templates/corrections-overview.hamlet diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 0e2f70e21..6a9c1b7aa 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1042,19 +1042,21 @@ data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiC getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAssignR = postCAssignR postCAssignR tid ssh csh = do - shids <- runDB $ do + (shids,cid) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] - assignHandler tid ssh csh shids + shids <- selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] + return (shids,cid) + assignHandler tid ssh csh cid shids getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSAssignR = postSAssignR postSAssignR tid ssh csh shn = do - shid <- runDB $ fetchSheetId tid ssh csh shn - assignHandler tid ssh csh [shid] + (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn + assignHandler tid ssh csh cid [shid] -assignHandler :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html -assignHandler tid ssh csh rawSids = do +-- DEPRECATED assignHandler' +assignHandler' :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html +assignHandler' tid ssh csh _cid rawSids = do -- gather data openSubs <- runDB $ (\f -> foldM f Map.empty rawSids) $ \acc sid -> maybeT (return acc) $ do @@ -1094,11 +1096,28 @@ assignHandler tid ssh csh rawSids = do else btnForm -assignHandler' :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html -assignHandler' tid ssh csh _rawSids = do +{- TODO: make buttons for each sheet, so that users see which sheet is assigned +data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Button UniWorX ButtonCorrectionsAssign +-- Are those needed any more? +instance Universe ButtonCorrectionsAssign +instance Finite ButtonCorrectionsAssign +nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece +embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id +instance Button UniWorX ButtonCorrectionsAssign where + btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary] +-- use runButtonForm' instead later on +-} + +assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html +assignHandler tid ssh csh cid assignSids = do + -- evaluate form first, since it affects DB action + (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions + -- gather data - (nrParticipants, groupsPossible, infoMap, correctorMap) <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do + -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh nrParticipants <- count [CourseParticipantCourse ==. cid] sheetList <- selectList [SheetCourse ==. cid] [Asc SheetName] @@ -1144,7 +1163,19 @@ assignHandler' tid ssh csh _rawSids = do , ciMax = corTime } in Map.insertWith (Map.unionWith (<>)) shnm cinf m - return (nrParticipants, groupsPossible, infoMap, correctorMap) + -- plan or assign unassigned submissions for given sheets + -- assignment :: Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int) + assignment <- fmap Map.fromList $ forM assignSids $ \sid -> do + plan <- planSubmissions sid Nothing + let shn = sheetName $ sheets ! sid + status <- case btnResult of + Nothing -> return (Set.empty, Set.empty) + (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan + return (shn, (status, countMapElems plan)) + + return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) + + let -- create aggregate maps sheetMap :: Map SheetName CorrectionInfo @@ -1167,60 +1198,7 @@ assignHandler' tid ssh csh _rawSids = do 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 - - |] + $(widgetFile "corrections-overview") diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index dc55df410..61bb7ee53 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -1,6 +1,6 @@ module Handler.Utils.Submission ( AssignSubmissionException(..) - , assignSubmissions + , assignSubmissions, writeSubmissionPlan, planSubmissions , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg , submissionFileSource, submissionFileQuery , submissionMultiArchive @@ -66,8 +66,15 @@ assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> YesodDB UniWorX ( Set SubmissionId , Set SubmissionId ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load -assignSubmissions sid restriction = do - newSubmissionData <- planSubmissions sid restriction +assignSubmissions sid restriction = planSubmissions sid restriction >>= writeSubmissionPlan + +-- | Assigns all submissions according to an already given assignment plan +writeSubmissionPlan :: Map SubmissionId (Maybe UserId) + -- ^ map that assigns submissions to correctors + -> YesodDB UniWorX ( Set SubmissionId + , Set SubmissionId + ) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load +writeSubmissionPlan newSubmissionData = do now <- liftIO getCurrentTime execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, mCorrector) -> case mCorrector of Just corrector -> do @@ -78,7 +85,6 @@ assignSubmissions sid restriction = do Nothing -> tell (mempty, Set.singleton subId) - -- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet! planSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider diff --git a/src/Utils.hs b/src/Utils.hs index 22e5b3b91..da5d7f0c4 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -500,6 +500,11 @@ partMap = Map.fromListWith mappend invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) invertMap = groupMap . map swap . Map.toList +-- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons) +countMapElems :: (Ord v) => Map k v -> Map v Int +countMapElems = Map.fromListWith (+) . map (\(_k,v)->(v,1)) . Map.toList + + --------------- -- Functions -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index ec6e12730..69eb65254 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -356,10 +356,11 @@ buttonView btn = do fieldView bField btnId "" mempty (Right btn) False - +-- | generate a form that only shows a finite amount of buttons buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ()) buttonForm = buttonForm' universeF +-- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass buttonForm' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ()) buttonForm' btns csrf = do (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns "" @@ -370,6 +371,35 @@ buttonForm' btns csrf = do ^{fvInput bView} |]) +-- | buttons-only form complete with widget-generation and evaluation; return type determines buttons shown. +runButtonForm ::(PathPiece ident, Eq ident, RenderMessage site FormMessage, + Button site ButtonSubmit, Button site a, Finite a) + => ident -> HandlerT site IO (WidgetT site IO (), Maybe a) +runButtonForm fid = do + currentRoute <- getCurrentRoute + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid buttonForm + let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute + , formEncoding = btnEnctype + , formSubmit = FormNoSubmit + } + res <- formResultMaybe btnResult (return . Just) + return (btnForm, res) + +-- | like `runButtonForm` but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass. +runButtonForm' ::(PathPiece ident, Eq ident, RenderMessage site FormMessage, + Button site ButtonSubmit, Button site a) + => [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a) +runButtonForm' btns fid = do + currentRoute <- getCurrentRoute + ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ buttonForm' btns + let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute + , formEncoding = btnEnctype + , formSubmit = FormNoSubmit + } + res <- formResultMaybe btnResult (return . Just) + return (btnForm, res) + + ------------------- -- Custom Fields -- ------------------- diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet new file mode 100644 index 000000000..595b28a80 --- /dev/null +++ b/templates/corrections-overview.hamlet @@ -0,0 +1,69 @@ +
+

_{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} + $maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment + #{ciSubmissions} + (+#{show (Set.size splus)}) + #{ciSubmissions - ciAssigned} + (#{show (Set.size sfailed)}) + $nothing + #{ciSubmissions} + #{ciSubmissions - ciAssigned} + #{ciSubmissions - ciCorrected} + #{showDiffDays ciMin} + #{showAvgsDays ciTot ciCorrected} + #{showDiffDays ciMax} +
+

_{MsgCorrectionCorrectors} + + + + - + @@ -51,14 +56,22 @@ +
_{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 + $maybe (_,cass) <- Map.lookup shn assignment + $maybe nrNew <- Map.lookup ciCorrector cass + #{ciAssigned} + (+#{nrNew}) + #{ciAssigned - ciCorrected} + #{showAvgsDays ciTot ciCorrected} + $nothing + #{ciAssigned} + #{ciAssigned - ciCorrected} + #{showAvgsDays ciTot ciCorrected} + $nothing + #{ciAssigned} + #{ciAssigned - ciCorrected} + #{showAvgsDays ciTot ciCorrected} + $nothing + + $nothing + + ^{btnWdgt} \ No newline at end of file From b09b876969f43cc0d21af9f9c0057c1285811e3c Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Fri, 14 Jun 2019 22:13:00 +0200 Subject: [PATCH 05/13] feat(fe-heatmap): add css class heated for heatmap elements relates to #405 --- templates/default-layout.lucius | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 8e9b86452..ed7950f98 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -606,3 +606,29 @@ section { .notification__content { color: var(--color-font); } + + + + +/* + "Heated" element. + Set custom property "--hotness" to a value from 0 to 1 to turn + the element's background to a color on a gradient from green to red. + + TBD: + - move to a proper place + - think about font-weight... + + Example: +
Lorem ipsum +*/ + +.heated { + --hotness: 0; + --red: calc(var(--hotness) * 200); + --green: calc(255 - calc(var(--hotness) * 255)); + --opacity: calc(calc(var(--red) / 600) + 0.1); + + font-weight: var(--weight, 600); + background-color: rgba(var(--red), var(--green), 0, var(--opacity)); +} From 28dcc8dc377c5a7c942daad7743f473208f5b99c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 15 Jun 2019 12:27:51 +0200 Subject: [PATCH 06/13] fix(fe-async-table): Emulate no-js behaviour when handling pagesize --- frontend/src/utils/async-table/async-table.js | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/frontend/src/utils/async-table/async-table.js b/frontend/src/utils/async-table/async-table.js index ee662229d..26dfb5624 100644 --- a/frontend/src/utils/async-table/async-table.js +++ b/frontend/src/utils/async-table/async-table.js @@ -297,19 +297,17 @@ export class AsyncTable { } _changePagesizeHandler = (event) => { - const paginationParamKey = this._asyncTableId + '-pagination'; - const pagesizeParamKey = this._asyncTableId + '-pagesize'; - const pageParamKey = this._asyncTableId + '-page'; - - const paginationParamEl = this._pagesizeForm.querySelector('[name="' + paginationParamKey + '"]'); const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href); - url.searchParams.set(pagesizeParamKey, event.target.value); - url.searchParams.set(pageParamKey, 0); + const formData = new FormData(this._pagesizeForm); - if (paginationParamEl) { - const encodedValue = encodeURIComponent(paginationParamEl.value); - url.searchParams.set(paginationParamKey, encodedValue); + for (var k of url.searchParams.keys()) { + url.searchParams.delete(k); } + + for (var kv of formData.entries()) { + url.searchParams.append(kv[0], kv[1]); + } + this._updateTableFrom(url.href); } From fc80f087242201ddcf2509dbed1f6034dc5ea73e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 15 Jun 2019 12:46:36 +0200 Subject: [PATCH 07/13] fix(fe): style notifications acceptably for now --- templates/default-layout.lucius | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 8e9b86452..b6236c080 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -565,6 +565,7 @@ section { color: var(--color-dark); box-shadow: 0 0 4px 2px inset currentColor; padding-left: 20%; + min-height: 100px; &::before { content: 'i'; @@ -579,6 +580,10 @@ section { justify-content: center; } } + +.form-group__input > .notification { + margin: 0; +} @media (max-width: 768px) { From 4f1b2886cdb60cdd0ac79fd0d008b685d98c743f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sun, 16 Jun 2019 13:16:01 +0200 Subject: [PATCH 08/13] guards added as needed for plan generartion without exceptions --- src/Handler/Corrections.hs | 33 +++++++++++++++++++++++++-------- src/Handler/Utils/Submission.hs | 1 + src/Utils.hs | 13 +++++++++++++ 3 files changed, 39 insertions(+), 8 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 6a9c1b7aa..a251ddf56 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1164,14 +1164,29 @@ assignHandler tid ssh csh cid assignSids = do } in Map.insertWith (Map.unionWith (<>)) shnm cinf m -- plan or assign unassigned submissions for given sheets - -- assignment :: Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int) - assignment <- fmap Map.fromList $ forM assignSids $ \sid -> do - plan <- planSubmissions sid Nothing - let shn = sheetName $ sheets ! sid - status <- case btnResult of - Nothing -> return (Set.empty, Set.empty) - (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan - return (shn, (status, countMapElems plan)) + let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) + buildA acc sid = maybeT (return acc) $ do + let shn = sheetName $ sheets ! sid + -- is sheet closed? + guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable + -- has at least one submisison? + [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> + E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid + guard hasSubmission + -- has at least one active corrector? + [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do + E.where_ $ corrector E.^. SheetCorrectorSheet E.==. E.val sid + E.where_ $ corrector E.^. SheetCorrectorState E.==. E.val CorrectorNormal + -- E.where_ $ corrector E.^. SheetCorrectorLoad E./=. E.val (Load {byTutorial = Nothing, byProportion = 0}) + guard hasCorrector + -- TODO: Refactor guards above! We already have these informations, but forcing the maps inside the DB acces might not be a good idea + -- TODO: Maybe refactor planSubmissions instead to not throw exceptions, but signal "ok" or "not possible" instead! + plan <- lift $ planSubmissions sid Nothing + status <- lift $ case btnResult of + Nothing -> return (Set.empty, Set.empty) + (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan + return $ Map.insert shn (status, countMapElems plan) acc + assignment <- foldM buildA Map.empty assignSids return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) @@ -1194,6 +1209,8 @@ assignHandler tid ssh csh cid assignSids = do showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text showAvgsDays Nothing _ = mempty showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n + heat :: Double -> Double -> Double + heat achieved full = roundToDigits 3 $ cutOffPercent 0.4 full achieved let headingShort = MsgMenuCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign siteLayoutMsg headingShort $ do diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 61bb7ee53..7cb28cfa5 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -86,6 +86,7 @@ writeSubmissionPlan newSubmissionData = do tell (mempty, Set.singleton subId) -- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet! +-- May throw an exception if there are no suitable correctors planSubmissions :: SheetId -- ^ Sheet to distribute to correctors -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider -> YesodDB UniWorX (Map SubmissionId (Maybe UserId)) diff --git a/src/Utils.hs b/src/Utils.hs index da5d7f0c4..a6fa63d38 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -379,6 +379,19 @@ roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c roundDiv digits numerator denominator = roundToDigits digits $ fromIntegral numerator / fromIntegral denominator +-- | A value between 0 and 1, measuring how close `achieved` is to `full`; 0 meaning very and 1 meaning not at all +-- `offset` specifies minimum result value, unless the goal is already achieved )i.e. full <= max(0,achieved) +-- Useful for heat maps, with offset giving a visual step between completed and not yet completed +cutOffPercent :: Double -> Double -> Double -> Double +cutOffPercent offset full achieved + | full <= achieved = 0 + | full <= 0 = 0 +  | otherwise = offset + (1-offset * (1 - percent)) + where + percent = achieved / full + + + ------------ -- Monoid -- ------------ From af00b061300a3a5efc79e0dae58a5e7105b98823 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sun, 16 Jun 2019 16:38:28 +0200 Subject: [PATCH 09/13] Compiles and works, but still needs some minor fixes --- src/Handler/Corrections.hs | 8 +++----- templates/corrections-overview.hamlet | 4 ++-- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index a251ddf56..eb9be55a3 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1134,6 +1134,7 @@ assignHandler tid ssh csh cid assignSids = do 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 + -- TODO: CorrectorMap should contain Map SheetId SheetCorrector submissions <- E.select . E.from $ \submission -> do E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds @@ -1187,11 +1188,8 @@ assignHandler tid ssh csh cid assignSids = do (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan return $ Map.insert shn (status, countMapElems plan) acc assignment <- foldM buildA Map.empty assignSids - return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) - - let -- create aggregate maps sheetMap :: Map SheetName CorrectionInfo sheetMap = Map.map fold infoMap @@ -1209,8 +1207,8 @@ assignHandler tid ssh csh cid assignSids = do showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text showAvgsDays Nothing _ = mempty showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n - heat :: Double -> Double -> Double - heat achieved full = roundToDigits 3 $ cutOffPercent 0.4 full achieved + heat :: Integer -> Integer -> Double + heat full achieved = roundToDigits 3 $ cutOffPercent 0.4 (fromIntegral full) (fromIntegral achieved) let headingShort = MsgMenuCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign siteLayoutMsg headingShort $ do diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 595b28a80..88deec48a 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -41,7 +41,7 @@
^{showCorrector ciCorrector} #{ciSubmissions} - #{ciSubmissions - ciCorrected} + #{ciSubmissions - ciCorrected} #{showDiffDays ciMin} #{showAvgsDays ciTot ciCorrected} #{showDiffDays ciMax} @@ -52,7 +52,7 @@ $maybe nrNew <- Map.lookup ciCorrector cass #{ciAssigned} (+#{nrNew}) - #{ciAssigned - ciCorrected} + #{ciAssigned - ciCorrected} #{showAvgsDays ciTot ciCorrected} $nothing #{ciAssigned} From 8201aa84e5e2328c0e229c776dd035125fcac6b1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 17 Jun 2019 08:33:15 +0200 Subject: [PATCH 10/13] Bugfix: only attemp to assign unassigned submissions --- src/Handler/Corrections.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index eb9be55a3..58e775dea 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1171,8 +1171,9 @@ assignHandler tid ssh csh cid assignSids = do -- is sheet closed? guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable -- has at least one submisison? - [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> + [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> do E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid + E.where_ $ E.isNothing $ submission E.^. SubmissionRatingBy guard hasSubmission -- has at least one active corrector? [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do From d5b094d6b442883c197b219cc9e1c6eb9c84d6eb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 17 Jun 2019 09:47:50 +0200 Subject: [PATCH 11/13] Corrector loads shown; BUG preview somehow missing now --- src/Handler/Corrections.hs | 37 +++++++++++++++------ src/Model/Types/Sheet.hs | 12 +++++++ templates/corrections-overview.hamlet | 47 ++++++++++++--------------- 3 files changed, 60 insertions(+), 36 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 58e775dea..547dd8447 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1082,7 +1082,7 @@ assignHandler' tid ssh csh _cid rawSids = do \acc sid -> flip (Map.insert sid) acc <$> assignSubmissions sid Nothing -- Too much important information for an alert message. Display proper info page instead let btnForm = wrapForm btnWdgt def - { formAction = SomeRoute <$> currentRoute -- TODO: should be a modal route + { formAction = SomeRoute <$> currentRoute , formEncoding = btnEnctype , formSubmit = FormNoSubmit } @@ -1132,9 +1132,11 @@ assignHandler tid ssh csh cid assignSids = 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 - -- TODO: CorrectorMap should contain Map SheetId SheetCorrector + let correctorMap :: Map UserId (User, Map SheetName SheetCorrector) + correctorMap = (\f -> foldl f Map.empty correctors) (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) -> + let shn = sheetName $ sheets ! sheetCorrectorSheet + in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc + ) submissions <- E.select . E.from $ \submission -> do E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds @@ -1191,18 +1193,33 @@ assignHandler tid ssh csh cid assignSids = do assignment <- foldM buildA Map.empty assignSids return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) - let -- create aggregate maps + let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference + -- 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}|] + -- avoid nestes hamelt $maybe with duplicated $nothing + getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector) + getCorrector (Just uid) + | Just (User{..},loadMap) <- Map.lookup uid correctorMap + = (nameEmailWidget userEmail userDisplayName userSurname, loadMap) + getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty) + -- avoid nestes hamelt $maybe with duplicated $nothing + getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo + getCorrSheetStatus corr shn + | (Just smap) <- Map.lookup shn infoMap + = Map.lookup corr smap + getCorrSheetStatus _ _ = Nothing + -- avoid nestes hamelt $maybe with duplicated $nothing + getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int + getCorrNewAssignment corr shn + | (Just (_,cass)) <- Map.lookup shn assignment + = Map.lookup corr cass + getCorrNewAssignment _ _ = Nothing + showDiffDays :: Maybe NominalDiffTime -> Text showDiffDays = foldMap formatDiffDays showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 74fb91dc1..5e971fb1d 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -305,3 +305,15 @@ instance Hashable CorrectorState nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) derivePersistField "CorrectorState" + +showCompactCorrectorLoad :: Load -> CorrectorState -> Text +showCompactCorrectorLoad load CorrectorMissing = "[" <> showCompactCorrectorLoad load CorrectorNormal <> "]" +showCompactCorrectorLoad load CorrectorExcused = "{" <> showCompactCorrectorLoad load CorrectorNormal <> "}" +showCompactCorrectorLoad Load{..} CorrectorNormal = proportionText <> tutorialText + where + proportionText = let propDbl :: Double + propDbl = fromRational byProportion + in tshow $ roundToDigits 2 propDbl + tutorialText = case byTutorial of Nothing -> mempty + Just True -> " (T)" + Just False -> " +T " diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 88deec48a..76ac17905 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -36,34 +36,29 @@ _{MsgNrSubmissionsNotCorrected} _{MsgCorrectionTime} $forall shn <- sheetNames - #{shn} + #{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 - $maybe (_,cass) <- Map.lookup shn assignment - $maybe nrNew <- Map.lookup ciCorrector cass - #{ciAssigned} - (+#{nrNew}) - #{ciAssigned - ciCorrected} - #{showAvgsDays ciTot ciCorrected} - $nothing - #{ciAssigned} - #{ciAssigned - ciCorrected} - #{showAvgsDays ciTot ciCorrected} + $with (nameW,loadM) <- getCorrector ciCorrector +
^{nameW} + #{ciSubmissions} + #{ciSubmissions - ciCorrected} + #{showDiffDays ciMin} + #{showAvgsDays ciTot ciCorrected} + #{showDiffDays ciMax} + $forall shn <- sheetNames + $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM + #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState} + $nothing + + $maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn + $maybe nrNew <- getCorrNewAssignment ciCorrector shn + #{ciAssigned} + (+#{nrNew}) $nothing #{ciAssigned} - #{ciAssigned - ciCorrected} - #{showAvgsDays ciTot ciCorrected} + #{ciAssigned - ciCorrected} + #{showAvgsDays ciTot ciCorrected} $nothing - - $nothing - + ^{btnWdgt} \ No newline at end of file From 55cd175f06e1bf55de097d343188116b4075377e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 17 Jun 2019 09:55:02 +0200 Subject: [PATCH 12/13] Minor Bugfix --- src/Handler/Corrections.hs | 52 ++++++++++++++------------- templates/corrections-overview.hamlet | 2 +- 2 files changed, 28 insertions(+), 26 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 547dd8447..35cc932c8 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1128,6 +1128,32 @@ assignHandler tid ssh csh cid assignSids = do let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups in List.foldr foldFun False sheetList + -- plan or assign unassigned submissions for given sheets + let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) + buildA acc sid = maybeT (return acc) $ do + let shn = sheetName $ sheets ! sid + -- is sheet closed? + guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable + -- has at least one submisison? + [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> do + E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid + E.where_ $ E.isNothing $ submission E.^. SubmissionRatingBy + guard hasSubmission + -- has at least one active corrector? + [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do + E.where_ $ corrector E.^. SheetCorrectorSheet E.==. E.val sid + E.where_ $ corrector E.^. SheetCorrectorState E.==. E.val CorrectorNormal + -- E.where_ $ corrector E.^. SheetCorrectorLoad E./=. E.val (Load {byTutorial = Nothing, byProportion = 0}) + guard hasCorrector + -- TODO: Refactor guards above! We already have these informations, but forcing the maps inside the DB acces might not be a good idea + -- TODO: Maybe refactor planSubmissions instead to not throw exceptions, but signal "ok" or "not possible" instead! + plan <- lift $ planSubmissions sid Nothing + status <- lift $ case btnResult of + Nothing -> return (Set.empty, Set.empty) + (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan -- TODO: this comes to late!! + return $ Map.insert shn (status, countMapElems plan) acc + assignment <- foldM buildA Map.empty assignSids + 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 @@ -1166,31 +1192,7 @@ assignHandler tid ssh csh cid assignSids = do , ciMax = corTime } in Map.insertWith (Map.unionWith (<>)) shnm cinf m - -- plan or assign unassigned submissions for given sheets - let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) - buildA acc sid = maybeT (return acc) $ do - let shn = sheetName $ sheets ! sid - -- is sheet closed? - guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable - -- has at least one submisison? - [E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> do - E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid - E.where_ $ E.isNothing $ submission E.^. SubmissionRatingBy - guard hasSubmission - -- has at least one active corrector? - [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do - E.where_ $ corrector E.^. SheetCorrectorSheet E.==. E.val sid - E.where_ $ corrector E.^. SheetCorrectorState E.==. E.val CorrectorNormal - -- E.where_ $ corrector E.^. SheetCorrectorLoad E./=. E.val (Load {byTutorial = Nothing, byProportion = 0}) - guard hasCorrector - -- TODO: Refactor guards above! We already have these informations, but forcing the maps inside the DB acces might not be a good idea - -- TODO: Maybe refactor planSubmissions instead to not throw exceptions, but signal "ok" or "not possible" instead! - plan <- lift $ planSubmissions sid Nothing - status <- lift $ case btnResult of - Nothing -> return (Set.empty, Set.empty) - (Just BtnSubmissionsAssign) -> writeSubmissionPlan plan - return $ Map.insert shn (status, countMapElems plan) acc - assignment <- foldM buildA Map.empty assignSids + return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 76ac17905..33f5b1e0a 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -60,5 +60,5 @@ #{ciAssigned - ciCorrected} #{showAvgsDays ciTot ciCorrected} $nothing - + ^{btnWdgt} \ No newline at end of file From fedcc9a2ad76cc2cdfa234621ac7752db06ab0b3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 17 Jun 2019 16:30:04 +0200 Subject: [PATCH 13/13] Overview Corrections working now --- messages/uniworx/de.msg | 4 ++- src/Foundation.hs | 2 +- src/Handler/Corrections.hs | 13 +++++++--- templates/corrections-overview.hamlet | 35 ++++++++++++++++++--------- 4 files changed, 37 insertions(+), 17 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 570730adf..22c502e1f 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -409,6 +409,7 @@ NrSubmissionsNewlyAssigned: Neu zugeteilt NrSubmissionsNotAssigned: Nicht zugeteilt NrSubmissionsNotCorrected: Unkorrigiert CorrectionTime: Korrekturdauer (Min/Avg/Max) +AssignSubmissionsRandomWarning: Die Zuteilungsvorschau kann geringfügig von der tatsächlichen Zuteilung abweichen, da die Zuteilung ein randomisierter Prozess ist. Mehrfaches neues Laden dieser Seite vor Betätigung des Zuteilungsknopfes kann dies sichtbar machen. CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert: NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden. @@ -836,7 +837,8 @@ MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsDownload: Offene Abgaben herunterladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben online korrigieren -MenuCorrectionsAssign: Abgaben automatisch zuteilen +MenuCorrectionsAssign: Zuteilung Korrekturen +MenuCorrectionsAssignSheet name@Text: Zuteilung Korrekturen von #{name} MenuAuthPreds: Authorisierungseinstellungen MenuTutorialDelete: Tutorium löschen MenuTutorialEdit: Tutorium editieren diff --git a/src/Foundation.hs b/src/Foundation.hs index 7ce7a5eed..ad0d88b3c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1427,7 +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 CAssignR) = return ("Korrektur" , 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) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 35cc932c8..b64959f0c 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1054,7 +1054,7 @@ postSAssignR tid ssh csh shn = do (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn assignHandler tid ssh csh cid [shid] --- DEPRECATED assignHandler' +-- DEPRECATED assignHandler', delete me soonish assignHandler' :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html assignHandler' tid ssh csh _cid rawSids = do -- gather data @@ -1175,7 +1175,10 @@ assignHandler tid ssh csh cid assignSids = do 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 + emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds + emptyCorrs = foldl (\m uid -> let cic = Just uid in + Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap + 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 = @@ -1184,7 +1187,7 @@ assignHandler tid ssh csh cid assignSids = do cinf = Map.singleton submissionRatingBy $ CorrectionInfo { ciSubmittors = fromIntegral nrSbmtrs , ciSubmissions = 1 - , ciAssigned = maybe 0 (const 1) submissionRatingBy + , ciAssigned = maybe 0 (const 1) submissionRatingBy -- only used in sheetMap , ciCorrected = maybe 0 (const 1) submissionRatingTime , ciCorrector = submissionRatingBy , ciMin = corTime @@ -1229,7 +1232,9 @@ assignHandler tid ssh csh cid assignSids = do showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n heat :: Integer -> Integer -> Double heat full achieved = roundToDigits 3 $ cutOffPercent 0.4 (fromIntegral full) (fromIntegral achieved) - let headingShort = MsgMenuCorrectionsAssign + let headingShort + | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment + | otherwise = MsgMenuCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign siteLayoutMsg headingShort $ do setTitleI headingLong diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 33f5b1e0a..19d13e265 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -6,7 +6,7 @@ _{MsgSheet} $if groupsPossible _{MsgNrSubmittorsTotal} - _{MsgNrSubmissionsTotal} + _{MsgNrSubmissionsTotal} _{MsgNrSubmissionsNotAssigned} _{MsgNrSubmissionsNotCorrected} _{MsgCorrectionTime} @@ -15,13 +15,17 @@ ^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)} $if groupsPossible #{ciSubmittors} + #{ciSubmissions} $maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment - #{ciSubmissions} - (+#{show (Set.size splus)}) - #{ciSubmissions - ciAssigned} - (#{show (Set.size sfailed)}) + $if 0 < Set.size sfailed + #{ciSubmissions - ciAssigned} + (-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)}) + $elseif 0 < Set.size splus + #{ciSubmissions - ciAssigned} + (-#{show (Set.size splus)}) + $else + #{ciSubmissions - ciAssigned} $nothing - #{ciSubmissions} #{ciSubmissions - ciAssigned} #{ciSubmissions - ciCorrected} #{showDiffDays ciMin} @@ -37,6 +41,7 @@ _{MsgCorrectionTime} $forall shn <- sheetNames #{shn} + $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)} $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap $with (nameW,loadM) <- getCorrector ciCorrector
#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState} $nothing - $maybe CorrectionInfo{ciAssigned,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn + $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn $maybe nrNew <- getCorrNewAssignment ciCorrector shn - #{ciAssigned} + #{ciSubmissions} + $# #{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap` (+#{nrNew}) $nothing - #{ciAssigned} - #{ciAssigned - ciCorrected} + #{ciSubmissions} + #{ciSubmissions - ciCorrected} #{showAvgsDays ciTot ciCorrected} $nothing - ^{btnWdgt} \ No newline at end of file + $if 0 < length sheetNames +
+ $forall shn <- sheetNames + ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)} + ^{btnWdgt} +
+

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file