From 405067d019be3b5f63222ab3e87322339613ce98 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Jun 2019 08:01:14 +0200 Subject: [PATCH 01/18] 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/18] 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 09e681eeb1ec77a1f8c263978322026683aae031 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Fri, 14 Jun 2019 00:05:23 +0200 Subject: [PATCH 03/18] fix(fe-check-all): use arrow fn to keep scope in event listeners --- frontend/src/utils/check-all/check-all.js | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/frontend/src/utils/check-all/check-all.js b/frontend/src/utils/check-all/check-all.js index 46194c029..340dca0b1 100644 --- a/frontend/src/utils/check-all/check-all.js +++ b/frontend/src/utils/check-all/check-all.js @@ -36,7 +36,7 @@ export class CheckAll { } destroy() { - console.log('TBD: Destroy CheckAll'); + this._checkAllCheckbox.destroy(); } _getCheckboxId() { @@ -95,7 +95,7 @@ export class CheckAll { // set up new checkbox this._app.utilRegistry.setupAll(th); - this._checkAllCheckbox.addEventListener('input', this._onCheckAllCheckboxInput); + this._checkAllCheckbox.addEventListener('input', () => this._onCheckAllCheckboxInput()); this._setupCheckboxListeners(); } @@ -108,7 +108,7 @@ export class CheckAll { return cell.querySelector(CHECKBOX_SELECTOR); }) .forEach((checkbox) => { - checkbox.addEventListener('input', this.updateCheckAllCheckboxState); + checkbox.addEventListener('input', () => this._updateCheckAllCheckboxState()); }); } From 718a2b026cb2333c079a7c37bcc95e4c34205873 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 14 Jun 2019 17:05:45 +0200 Subject: [PATCH 04/18] 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 05/18] 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 06/18] 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 07/18] 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 08/18] 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 09/18] 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 10/18] 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 11/18] 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 12/18] 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 13/18] 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 14/18] 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 From 17429193da3e97ef93f044b40a964d1d6eefbb34 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Tue, 18 Jun 2019 20:20:31 +0200 Subject: [PATCH 15/18] =?UTF-8?q?docs:=20re-add=20the=20README=20file=20?= =?UTF-8?q?=F0=9F=8E=89?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- README.md | 130 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 130 insertions(+) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 000000000..f61775faa --- /dev/null +++ b/README.md @@ -0,0 +1,130 @@ +# "Quick Start" Guide + +The following description applies to Ubuntu and similar debian based Linux distributions. + +## Prerequisites +These are the things you need to do/install before you can get started working on Uni2work. + +### Clone repository +Clone this repository and navigate into it +```sh +$ git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git && cd UniWorX +``` + +### `LDAP` +LDAP is needed to handle logins. + +Install: +```sh +sudo apt-get install slapd ldap-utils +``` + +### `PostgreSQL` +PostgreSQL will serve as database for Uni2work. + +Install: +```sh +$ sudo apt-get install postgresql +``` + +Switch to user *postgres* (got created during installation): +```sh +$ sudo -i -u postgres +``` + +Add new database user *uniworx*: +```sh +$ createuser --interactive +``` + +You'll get a prompt: + +```sh +Enter name of role to add: uniworx +Shall the new role be a superuser? (y/n) [not exactly sure. Guess not?] +Password: uniworx +... +``` + +Create database *uniworx*: +```sh +$ psql -c 'create database uniworx owner uniworx' +$ psql -c 'create database uniworx_test owner uniworx' +``` + +After you added the database switch back to your own user with `Ctrl + D`. + +To properly access the database you now need to add a new linux user called *uniworx*. Enter "uniworx" as the password. +```sh +$ sudo adduser uniworx +``` + +### `Stack` +Stack is a toolbox for "Haskellers" to aid in developing Haskell projects. + +Install: +```sh +$ curl -sSL https://get.haskellstack.org/ | sh +``` + +Setup stack and install dependencies. This needs to be run from inside the directory you cloned this repository to: +```sh +$ stack setup +``` + +During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using +```sh +$ sudo apt-get install libsasl2-dev libldap2-dev +``` + +If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.* +Go ahead and install `libpq-dev` with +```sh +$ sudo apt-get install libpq-dev +``` + +Other packages you might need to install during this process: +```sh +$ sudo apt-get install pkg-config +$ sudo apt-get install libsodium-dev +``` + +Build the app: +```sh +$ stack build +``` + +This might take a few minutes... if not hours... be prepared. + +install yesod: +```sh +$ stack install yesod-bin --install-ghc +``` + +### `Node` & `npm` +Node and Npm are needed to compile the frontend. + +Install: +```sh +$ curl -sL https://deb.nodesource.com/setup_12.x | sudo -E bash - +$ sudo apt-get install -y nodejs +``` + +### Add dummy data to the database +After building the app you can prepare the database and add some dummy data: +```sh +$ ./db.sh -f +``` + +## Run Uni2work +```sh +$ npm start +``` + +This will compile both frontend and backend and will start Uni2work in development mode (might take a few minutes the first time). It will keep running and will watch any file changes to automatically re-compile the application if necessary. + +If you followed the steps above you should now be able to visit http://localhost:3000 and login as one of the accounts from the Development-Logins dropdown. + +## Troubleshooting + +Please see the [wiki](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/wikis/home) for more infos. From 55468496e0842ca014af6d6b93e87c1c0f46f222 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Jun 2019 09:53:01 +0200 Subject: [PATCH 16/18] fix: minor heat correction for correction overview --- messages/uniworx/de.msg | 2 +- src/Foundation.hs | 2 +- src/Handler/Corrections.hs | 5 +++-- src/Utils.hs | 2 +- templates/corrections-overview.hamlet | 4 ++-- 5 files changed, 8 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 22c502e1f..8057ca78a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -409,7 +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. +AssignSubmissionsRandomWarning: Die Zuteilungsvorschau kann von der tatsächlichen Zuteilung abweichen, wenn mehrere Blätter auf einmal zugeteilt werden, da beim Ausgleich der Kontigente nur bereits zugeteilte Abgaben berücksichtigt werden. Da es ein randomisierte Prozess ist, kann es auch bei einzelnen Blättern gerinfgügige Abweichungen geben. CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert: NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden. diff --git a/src/Foundation.hs b/src/Foundation.hs index ad0d88b3c..3be718bb7 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 ("Korrektur" , Just $ CourseR tid ssh csh CCorrectionsR) + breadcrumb (CourseR tid ssh csh CAssignR) = return ("Zuteilung" , 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 b64959f0c..26ba218cc 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1134,10 +1134,11 @@ assignHandler tid ssh csh cid assignSids = 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? + -- has at least one uncorrected / unassigned 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 + E.where_ $ E.isNothing $ submission E.^. SubmissionRatingBy -- no corrector + E.where_ $ E.isNothing $ submission E.^. SubmissionRatingTime -- not done guard hasSubmission -- has at least one active corrector? [E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do diff --git a/src/Utils.hs b/src/Utils.hs index a6fa63d38..4f565befe 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -386,7 +386,7 @@ cutOffPercent :: Double -> Double -> Double -> Double cutOffPercent offset full achieved | full <= achieved = 0 | full <= 0 = 0 -  | otherwise = offset + (1-offset * (1 - percent)) +  | otherwise = offset + (1-offset) * (1 - percent) where percent = achieved / full diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 19d13e265..621ffd51e 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -22,7 +22,7 @@

(-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)}) $elseif 0 < Set.size splus #{ciSubmissions - ciAssigned} - (-#{show (Set.size splus)}) + (-#{show (Set.size splus)}) $else #{ciSubmissions - ciAssigned} $nothing @@ -60,7 +60,7 @@ $maybe nrNew <- getCorrNewAssignment ciCorrector shn #{ciSubmissions} $# #{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap` - (+#{nrNew}) + (+#{nrNew}) $nothing #{ciSubmissions} #{ciSubmissions - ciCorrected} From 3bded5071bf0e32a6d4df0dcc49f6039f283785e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Jun 2019 10:49:22 +0200 Subject: [PATCH 17/18] fix: filter submission by not having corrector --- messages/uniworx/de.msg | 1 + src/Handler/Corrections.hs | 18 +++++++++++++----- templates/table/layout.hamlet | 4 ++++ templates/table/layout.lucius | 7 +++++++ 4 files changed, 25 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8057ca78a..c0ee216ae 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -415,6 +415,7 @@ CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert: NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden. RatingBy: Korrigiert von +HasCorrector: Korrektor zugeteilt AssignedTime: Zuteilung AchievedBonusPoints: Erreichte Bonuspunkte AchievedNormalPoints: Erreichte Punkte diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 26ba218cc..dc8cb791e 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -334,6 +334,12 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails) E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False) ) + , ( "isassigned" + , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of + Nothing -> E.val True :: E.SqlExpr (E.Value Bool) + Just True -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingBy + Just False-> E.isNothing $ submission E.^. SubmissionRatingBy + ) , ( "israted" , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) @@ -636,10 +642,11 @@ postCCorrectionsR tid ssh csh = do filterUI = Just $ \mPrev -> mconcat [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers) , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr) - , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) - -- "pseudonym" TODO DB only stores Word24 + -- "pseudonym" TODO DB only stores Word24 , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime) + , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) + , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgHasCorrector) + , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime) ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway correctionsR whereClause colonnade filterUI psValidator $ Map.fromList @@ -669,8 +676,9 @@ postSSubsR tid ssh csh shn = do [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers) , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr) , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector) - -- "pseudonym" TODO DB only stores Word24 - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime) + , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgHasCorrector) + , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime) + -- "pseudonym" TODO DB only stores Word24 ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway correctionsR whereClause colonnade filterUI psValidator $ Map.fromList diff --git a/templates/table/layout.hamlet b/templates/table/layout.hamlet index b292cee5c..eb8baadcb 100644 --- a/templates/table/layout.hamlet +++ b/templates/table/layout.hamlet @@ -2,6 +2,10 @@ $newline never $if null rows && (dbsEmptyStyle == DBESNoHeading) _{dbsEmptyMessage} $else +
+
+ _{MsgRowCount rowCount} + ^{table}
diff --git a/templates/table/layout.lucius b/templates/table/layout.lucius index c03851b27..0c402442b 100644 --- a/templates/table/layout.lucius +++ b/templates/table/layout.lucius @@ -1,3 +1,10 @@ +/* TABLE HEADER */ +.table-header { + display: flex; + flex-flow: row-reverse; + justify-content: space-between; +} + /* TABLE FOOTER */ .table-footer { display: flex; From 4423817ef536f9ee0844059b82f3eedd6a604206 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Jun 2019 10:55:59 +0200 Subject: [PATCH 18/18] fix build: linting javascript --- .vscode/tasks.json | 5 +++++ frontend/src/utils/async-table/async-table.js | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 1c0b71c32..fabc6a5d5 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -63,6 +63,11 @@ "type": "npm", "script": "frontend:lint", "problemMatcher": [] + }, + { + "type": "npm", + "script": "lint", + "problemMatcher": [] } ] } \ No newline at end of file diff --git a/frontend/src/utils/async-table/async-table.js b/frontend/src/utils/async-table/async-table.js index 26dfb5624..0c9e9cb04 100644 --- a/frontend/src/utils/async-table/async-table.js +++ b/frontend/src/utils/async-table/async-table.js @@ -296,7 +296,7 @@ export class AsyncTable { return el.getAttribute('href') || el.querySelector('a').getAttribute('href'); } - _changePagesizeHandler = (event) => { + _changePagesizeHandler = () => { const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href); const formData = new FormData(this._pagesizeForm);