From 782110a824405143f35ef13ab56e0c45d14b3435 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 19 Jun 2019 11:11:55 +0200 Subject: [PATCH 1/9] feat minor: E.isJust added --- src/Database/Esqueleto/Utils.hs | 7 ++++++- src/Handler/Corrections.hs | 4 ++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 38105a37a..bd8120ba7 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -2,6 +2,7 @@ module Database.Esqueleto.Utils ( true, false + , isJust , isInfixOf, hasInfix , any, all , SqlIn(..) @@ -11,7 +12,7 @@ module Database.Esqueleto.Utils , anyFilter, allFilter ) where -import ClassyPrelude.Yesod hiding (isInfixOf, any, all) +import ClassyPrelude.Yesod hiding (isInfixOf, any, all, isJust) import qualified Data.Set as Set import qualified Data.Foldable as F import qualified Database.Esqueleto as E @@ -34,6 +35,10 @@ true = E.val True false :: E.SqlExpr (E.Value Bool) false = E.val False +-- | Negation of `isNothing` which is missing +isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool) +isJust = E.not_ . E.isNothing + -- | Check if the first string is contained in the text derived from the second argument isInfixOf :: (E.Esqueleto query expr backend, E.SqlString s2) => Text -> expr (E.Value s2) -> expr (E.Value Bool) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index dc8cb791e..92a60d00e 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -337,13 +337,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d , ( "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 True -> E.isJust $ 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) - Just True -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime + Just True -> E.isJust $ submission E.^. SubmissionRatingTime Just False-> E.isNothing $ submission E.^. SubmissionRatingTime ) , ( "corrector-name-email" -- corrector filter does not work for text-filtering From 463b2b78780ecf24aa3b48f0740c18fce45e8d3c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Jun 2019 16:52:00 +0200 Subject: [PATCH 2/9] fix(ratings): disallow ratings for graded sheets without point value --- messages/uniworx/de.msg | 1 + src/Handler/Corrections.hs | 66 +++++++++++++++++++------------------ src/Handler/Utils/Rating.hs | 7 +++- src/Model/Rating.hs | 1 + 4 files changed, 42 insertions(+), 33 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c0ee216ae..6ce7b8bbb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -464,6 +464,7 @@ RatingNegative: Bewertungspunkte dürfen nicht negativ sein RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl RatingNotExpected: Keine Bewertungen erlaubt RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein +RatingPointsRequired: Bewertung erfordert für dieses Blatt eine Punktzahl SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden. diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index dc8cb791e..049eda984 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -710,12 +710,12 @@ postCorrectionR tid ssh csh shn cid = do results <- runDB $ correctionData tid ssh csh shn sub case results of - [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do + [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) pointsForm = case sheetType of NotGraded -> pure Nothing _otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) - (fslpI MsgRatingPoints "Punktezahl") + (fslpI MsgRatingPoints "Punktezahl" & setTooltip sheetType) (Just submissionRatingPoints) ((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,) @@ -734,22 +734,20 @@ postCorrectionR tid ssh csh shn cid = do , formEncoding = uploadEncoding } - case corrResult of - FormMissing -> return () - FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess (rated, ratingPoints', ratingComment') -> do - uid <- liftHandlerT requireAuthId - now <- liftIO getCurrentTime + formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do + uid <- liftHandlerT requireAuthId + now <- liftIO getCurrentTime - if - | errs <- validateRating sheetType Rating' - { ratingPoints = ratingPoints' - , ratingComment = ratingComment' - , ratingTime = (now <$ guard rated) - } - , not $ null errs - -> mapM_ (addMessageI Error) errs - | otherwise -> runDBJobs $ do + if + | errs <- validateRating sheetType Rating' + { ratingPoints = ratingPoints' + , ratingComment = ratingComment' + , ratingTime = (now <$ guard rated) + } + , not $ null errs + -> mapM_ (addMessageI Error) errs + | otherwise -> do + runDBJobs $ do update sub [ SubmissionRatingBy =. Just uid , SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingPoints =. ratingPoints' @@ -761,25 +759,29 @@ postCorrectionR tid ssh csh shn cid = do when (rated && isNothing submissionRatingTime) $ do $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub - - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR - - case uploadResult of - FormMissing -> return () - FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess fileUploads -> do - uid <- requireAuthId - - res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True - case res of - Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors - (Just _) -> do - addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + formResult uploadResult $ \fileUploads -> do + uid <- requireAuthId + + res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + case res of + Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors + (Just _) -> do + addMessageI Success MsgRatingFilesUpdated + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + mr <- getMessageRender let sheetTypeDesc = mr sheetType - defaultLayout $ do + heading = MsgCorrectionHead tid ssh csh shn cid + headingWgt = [whamlet| + $newline never + _{heading} + $if not (submissionRatingDone subm) + \ ^{isVisibleWidget False} + |] + siteLayout headingWgt $ do + setTitleI heading let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") _ -> notFound diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 2e980312f..472e49950 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -56,7 +56,7 @@ instance Pretty SheetGrading where validateRating :: SheetType -> Rating' -> [RatingException] -validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} +validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. } | rp < 0 = [RatingNegative] | NotGraded <- ratingSheetType @@ -67,6 +67,11 @@ validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} | (Just PassBinary) <- ratingSheetType ^? _grading , not (rp == 0 || rp == 1) = [RatingBinaryExpected] +validateRating ratingSheetType Rating'{ .. } + | has _grading ratingSheetType + , is _Nothing ratingPoints + , isn't _Nothing ratingTime + = [RatingPointsRequired] validateRating _ _ = [] getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index c7b4e910f..295d275eb 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -31,6 +31,7 @@ data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to p | RatingExceedsMax -- ^ Rating point must not exceed maximum points | RatingNotExpected -- ^ Rating not expected | RatingBinaryExpected -- ^ Rating must be 0 or 1 + | RatingPointsRequired -- ^ Rating without points for sheet that requires there to be points deriving (Show, Eq, Generic, Typeable) instance Exception RatingException From 16d422d9d82467ea6e6800bee5d1af06b7fe1d3b Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Tue, 25 Jun 2019 20:45:46 +0200 Subject: [PATCH 3/9] fix(fe-deflist): avoid horizontal scroll on pages with deflist --- templates/default-layout.lucius | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 9db97efb6..6306920e2 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -502,7 +502,7 @@ ul.list--inline { @media (min-width: 768px) { .deflist { - grid-template-columns: max-content minmax(auto, max-content); + grid-template-columns: max-content minmax(0, max-content); .deflist { margin-top: -10px; From c82c3a9d80c4111b77ecda6ead30fdae25106b37 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Tue, 25 Jun 2019 23:09:47 +0200 Subject: [PATCH 4/9] chore: small commit to get the pipeline started --- templates/default-layout.lucius | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 6306920e2..2fdc1b3de 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -580,7 +580,7 @@ section { justify-content: center; } } - + .form-group__input > .notification { margin: 0; } From 2f7f733628a1c57e5eb2690bfd218b4d8cb023fd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jun 2019 12:12:19 +0200 Subject: [PATCH 5/9] =?UTF-8?q?Abgaben=20Zuteilung=20=C3=BCberarbeitet?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .vscode/tasks.json | 1 + messages/uniworx/de.msg | 15 +++++- src/Foundation.hs | 9 ++++ src/Handler/Corrections.hs | 69 ++++++++++++++++++--------- src/Handler/Utils/Submission.hs | 14 ++++-- templates/corrections-overview.hamlet | 63 +++++++++++++++++------- 6 files changed, 125 insertions(+), 46 deletions(-) diff --git a/.vscode/tasks.json b/.vscode/tasks.json index fabc6a5d5..4c18542ba 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -14,6 +14,7 @@ "reveal": "always", "focus": false, "panel": "dedicated", + "clear": true, "showReuseMessage": false } }, diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c0ee216ae..455b57773 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -34,6 +34,12 @@ GenericShort: Kürzel GenericIsNew: Neu GenericHasConflict: Konflikt GenericBack: Zurück +GenericChange: Änderung +GenericNumChange: +/- +GenericMin: Min +GenericAvg: Avg +GenericMax: Max +GenericAll: Insgesamt SummerTerm year@Integer: Sommersemester #{display year} WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year} @@ -316,6 +322,7 @@ Correctors: Korrektoren CorState: Status CorByTut: Zuteilung nach Tutorium CorProportion: Anteil +CorDeficit: Defizit CorByProportionOnly proportion@Rational: #{display proportion} Anteile CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium @@ -391,10 +398,11 @@ UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neue NoCorrector: Kein Korrektor RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt. UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt. +UpdatedSheetCorrectorsAutoAssigned n@Int: #{display n} #{pluralDE n "Abgabe wurde einem Korrektor" "Abgaben wurden Korrektoren"} zugteilt. +UpdatedSheetCorrectorsAutoFailed n@Int: #{display n} #{pluralDE n "Abgabe konnte" "Abgaben konnten"} nicht automatisch zugewiesen werden. 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 @@ -402,13 +410,15 @@ AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden NrSubmittorsTotal: Abgebende NrSubmissionsTotal: Abgaben +NrSubmissionsTotalShort: Abg. NrSubmissionsUnassigned: Ohne Korrektor NoCorrectorAssigned: Ohne Korrektor NrCorrectors: Korrektoren NrSubmissionsNewlyAssigned: Neu zugeteilt NrSubmissionsNotAssigned: Nicht zugeteilt NrSubmissionsNotCorrected: Unkorrigiert -CorrectionTime: Korrekturdauer (Min/Avg/Max) +NrSubmissionsNotCorrectedShort: Unkg. +CorrectionTime: Korrekturdauer 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: @@ -831,6 +841,7 @@ MenuCourseDelete: Kurs löschen MenuSubmissionNew: Abgabe anlegen MenuSubmissionOwn: Abgabe MenuCorrectors: Korrektoren +MenuCorrectorsChange: Korrektoren ändern MenuSheetEdit: Übungsblatt editieren MenuSheetDelete: Übungsblatt löschen MenuSheetClone: Als neues Übungsblatt klonen diff --git a/src/Foundation.hs b/src/Foundation.hs index 3be718bb7..3e243af41 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -206,6 +206,15 @@ noneOneMoreDE num noneText singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm +noneMoreDE :: (Eq a, Num a) + => a -- ^ Count + -> Text -- ^ None + -> Text -- ^ Some + -> Text +noneMoreDE num noneText someText + | num == 0 = noneText + | otherwise = someText + -- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers type IntMaybe = Maybe Int type TextList = [Text] diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 92a60d00e..bc46eb157 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1137,30 +1137,33 @@ assignHandler tid ssh csh cid assignSids = do 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)) + let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) 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 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 -- 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 - 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 + -- ask for assignment plan + let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections + ignoreExceptions NoCorrectors = return mempty + ignoreExceptions NoCorrectorsByProportion = return mempty + ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing + (plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing + guard $ not $ null plan -- only proceed if there is a plan for this sheet + -- implement assignment plan 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 + (Just BtnSubmissionsAssign) -> do + status@(sub_ok,sub_fail) <- writeSubmissionPlan plan + let nr_ok = olength sub_ok + nr_fail = olength sub_fail + alert_ok = toMaybe (nr_ok > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok + alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed nr_fail + msg_status = bool Success Error $ nr_fail > 0 + msg_header = SomeMessage $ shn <> ":" + when (nr_ok > 0 || nr_fail > 0) $ + addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail] + return status + return $ Map.insert shn (status, countMapElems plan, deficit) acc assignment <- foldM buildA Map.empty assignSids correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do @@ -1211,28 +1214,50 @@ assignHandler tid ssh csh cid assignSids = do -- create aggregate maps sheetMap :: Map SheetName CorrectionInfo sheetMap = Map.map fold infoMap + + sheetLoad :: Map SheetName Load + sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap) + let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc + buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal} + = Map.insertWith (<>) s l acc + buildL acc _ _ = acc + in Map.foldl buildSL Map.empty correctorMap + + deficitMap :: Map UserId Rational + deficitMap = foldMap (view _3) assignment + corrMap :: Map (Maybe UserId) CorrectionInfo corrMap = Map.unionsWith (<>) $ Map.elems infoMap sheetNames = Map.keys infoMap let -- whamlet convenience functions - -- avoid nestes hamelt $maybe with duplicated $nothing + -- avoid nestes hamlet $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 + -- avoid nestes hamlet $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 + -- avoid nestes hamlet $maybe with duplicated $nothing getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int getCorrNewAssignment corr shn - | (Just (_,cass)) <- Map.lookup shn assignment + | (Just (_,cass,_)) <- Map.lookup shn assignment = Map.lookup corr cass getCorrNewAssignment _ _ = Nothing + -- avoid nestes hamlet $maybe with duplicated $nothing + getCorrDeficit :: Maybe UserId -> Maybe Rational + getCorrDeficit (Just uid) = Map.lookup uid deficitMap + getCorrDeficit _ = Nothing + + getLoadSum :: SheetName -> Text + getLoadSum shn + | (Just load) <- Map.lookup shn sheetLoad + = "Σ" <> showCompactCorrectorLoad load CorrectorNormal + getLoadSum _ = mempty showDiffDays :: Maybe NominalDiffTime -> Text showDiffDays = foldMap formatDiffDays diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 7cb28cfa5..0a1e04e9c 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -66,7 +66,9 @@ 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 = planSubmissions sid restriction >>= writeSubmissionPlan +assignSubmissions sid restriction = do + (plan,_) <- planSubmissions sid restriction + writeSubmissionPlan plan -- | Assigns all submissions according to an already given assignment plan writeSubmissionPlan :: Map SubmissionId (Maybe UserId) @@ -89,8 +91,8 @@ writeSubmissionPlan newSubmissionData = do -- 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)) - -- ^ Return map that assigns submissions to Corrector + -> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational) + -- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit planSubmissions sid restriction = do Sheet{..} <- getJust sid correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do @@ -171,6 +173,10 @@ planSubmissions sid restriction = do -> m b withSubmissionData f = f <$> (mappend <$> ask <*> State.get) + -- | Old Deficit for protocol purposes, not used here + oldDeficit :: Map UserId Rational + oldDeficit = Map.mapWithKey (\k _v -> calculateDeficit k submissionData) sheetCorrectors + -- | How many additional submission should the given corrector be assigned, if possible? calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet @@ -235,7 +241,7 @@ planSubmissions sid restriction = do ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors) - return $ fmap (view _1) newSubmissionData + return (fmap (view _1) newSubmissionData, oldDeficit) 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 diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 621ffd51e..5d3f6ba8b 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -3,20 +3,26 @@ _{MsgCourseParticipants nrParticipants} - +
_{MsgSheet} + _{MsgSheet} $if groupsPossible - _{MsgNrSubmittorsTotal} - _{MsgNrSubmissionsTotal} + _{MsgNrSubmittorsTotal} + _{MsgNrSubmissionsTotal} _{MsgNrSubmissionsNotAssigned} - _{MsgNrSubmissionsNotCorrected} + _{MsgNrSubmissionsNotCorrected} _{MsgCorrectionTime} +
+ _{MsgGenericNumChange} + _{MsgGenericMin} + _{MsgGenericAvg} + _{MsgGenericMax} $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} - $maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment + $maybe ((splus,sfailed),_,_) <- Map.lookup sheetName assignment $if 0 < Set.size sfailed #{ciSubmissions - ciAssigned} (-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)}) @@ -24,9 +30,11 @@ #{ciSubmissions - ciAssigned} (-#{show (Set.size splus)}) $else - #{ciSubmissions - ciAssigned} + #{ciSubmissions - ciAssigned} + $nothing - #{ciSubmissions - ciAssigned} + #{ciSubmissions - ciAssigned} + #{ciSubmissions - ciCorrected} #{showDiffDays ciMin} #{showAvgsDays ciTot ciCorrected} @@ -35,43 +43,62 @@

_{MsgCorrectionCorrectors} - + -
_{MsgCorrector} - _{MsgNrSubmissionsTotal} - _{MsgNrSubmissionsNotCorrected} + _{MsgCorrector} + _{MsgGenericAll} + _{MsgCorProportion} _{MsgCorrectionTime} $forall shn <- sheetNames #{shn} $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)} +
_{MsgNrSubmissionsTotal} + _{MsgNrSubmissionsNotCorrected} + _{MsgCorDeficit} + _{MsgGenericMin} + _{MsgGenericAvg} + _{MsgGenericMax} + $forall _shn <- sheetNames + _{MsgCorProportion} + _{MsgNrSubmissionsTotalShort} + _{MsgGenericNumChange} + _{MsgNrSubmissionsNotCorrectedShort} + _{MsgGenericAvg} $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap $with (nameW,loadM) <- getCorrector ciCorrector
^{nameW} #{ciSubmissions} #{ciSubmissions - ciCorrected} + + $maybe deficit <- getCorrDeficit ciCorrector + #{display deficit} #{showDiffDays ciMin} #{showAvgsDays ciTot ciCorrected} #{showDiffDays ciMax} $forall shn <- sheetNames - $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM - #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState} - $nothing - + + $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM + #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState} $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn + #{ciSubmissions} $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}) $nothing - #{ciSubmissions} + #{ciSubmissions - ciCorrected} #{showAvgsDays ciTot ciCorrected} $nothing - + + + + $if 0 < length sheetNames
$forall shn <- sheetNames - ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)} + #{getLoadSum shn} + ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} ^{btnWdgt}

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file From d63a8903273360aa1dccc875b871f467e48a3f01 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Jun 2019 13:39:33 +0200 Subject: [PATCH 6/9] chore: fix build environment on NixOS --- shell.nix | 7 +++---- stack.nix | 13 ++++--------- stack.yaml | 19 +++++++------------ stackage.nix | 30 ++++++++++++++++++++++++++++++ 4 files changed, 44 insertions(+), 25 deletions(-) create mode 100644 stackage.nix diff --git a/shell.nix b/shell.nix index f98506e41..94ef0ba00 100644 --- a/shell.nix +++ b/shell.nix @@ -1,8 +1,7 @@ -{ nixpkgs ? import , compiler ? null }: +{ nixpkgs ? import }: let - inherit (nixpkgs {}) pkgs; - haskellPackages = if isNull compiler then pkgs.haskellPackages else pkgs.haskell.packages."${compiler}"; + haskellPackages = import ./stackage.nix { inherit nixpkgs; }; drv = haskellPackages.callPackage ./uniworx.nix {}; @@ -19,7 +18,7 @@ let ''; override = oldAttrs: { - nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); + nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-8_x postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]); shellHook = '' export PROMPT_INFO="${oldAttrs.name}" diff --git a/stack.nix b/stack.nix index e986ba349..a9a2af3de 100644 --- a/stack.nix +++ b/stack.nix @@ -1,16 +1,11 @@ { ghc, nixpkgs ? import }: let - snapshot = "lts-10.5"; - stackage = import (fetchTarball { - url = "https://stackage.serokell.io/drczwlyf6mi0ilh3kgv01wxwjfgvq14b-stackage/default.nix.tar.gz"; - sha256 = "1bwlbxx6np0jfl6z9gkmmcq22crm0pa07a8zrwhz5gkal64y6jpz"; - }); - inherit (nixpkgs { overlays = [ stackage."${snapshot}" ]; }) haskell pkgs; - - haskellPackages = pkgs.haskell.packages."${snapshot}"; -in haskell.lib.buildStackProject { + haskellPackages = import ./stackage.nix { inherit nixpkgs; }; + inherit (nixpkgs {}) pkgs; +in pkgs.haskell.lib.buildStackProject { inherit ghc; + inherit (haskellPackages) stack; name = "stackenv"; buildInputs = (with pkgs; [ postgresql zlib libsodium diff --git a/stack.yaml b/stack.yaml index 02b25ee57..67b72469b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,20 +9,15 @@ extra-package-dbs: [] packages: - . - - location: - git: https://github.com/pngwjpgh/zip-stream.git - commit: 9272bbed000928d500febad1cdc98d1da29d399e - extra-dep: true - - location: - git: https://github.com/pngwjpgh/encoding.git - commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84 - extra-dep: true - - location: - git: https://github.com/pngwjpgh/memcached-binary.git - commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad - extra-dep: true extra-deps: + - git: https://github.com/pngwjpgh/zip-stream.git + commit: 9272bbed000928d500febad1cdc98d1da29d399e + - git: https://github.com/pngwjpgh/encoding.git + commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84 + - git: https://github.com/pngwjpgh/memcached-binary.git + commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad + - colonnade-1.2.0 - yesod-colonnade-1.2.0 diff --git a/stackage.nix b/stackage.nix new file mode 100644 index 000000000..4fb2c4623 --- /dev/null +++ b/stackage.nix @@ -0,0 +1,30 @@ +{ nixpkgs ? import +, snapshot ? "lts-10.5" +}: + +let + stackage = import (fetchTarball { + url = "https://stackage.serokell.io/drczwlyf6mi0ilh3kgv01wxwjfgvq14b-stackage/default.nix.tar.gz"; + sha256 = "1bwlbxx6np0jfl6z9gkmmcq22crm0pa07a8zrwhz5gkal64y6jpz"; + }); + + overlays = + [ stackage."${snapshot}" + (self: super: { + haskell = super.haskell // { + packages = super.haskell.packages // { + "${snapshot}" = super.haskell.packages."${snapshot}".override { + overrides = hself: hsuper: { + zip-archive = self.haskell.lib.overrideCabal hsuper.zip-archive (old: { + testToolDepends = old.testToolDepends ++ (with self; [ unzip ]); + }); + }; + }; + }; + }; + } + ) + ]; + + inherit (nixpkgs { inherit overlays; }) pkgs; +in pkgs.haskell.packages."${snapshot}" From 228cd507498a74f92978c2c9082d91348e68c564 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jun 2019 15:08:03 +0200 Subject: [PATCH 7/9] feat(corrector-assignment): show load/submission percentages --- messages/uniworx/de.msg | 2 +- src/Handler/Corrections.hs | 15 +++++--- src/Handler/Health.hs | 4 +-- src/Handler/Sheet.hs | 4 +-- src/Utils.hs | 34 +++++++++++++------ templates/corrections-overview.hamlet | 32 ++++++++++++----- .../grading-summary-row.hamlet | 4 +-- 7 files changed, 63 insertions(+), 32 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index cd7300b09..012b6b587 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -322,7 +322,7 @@ Correctors: Korrektoren CorState: Status CorByTut: Zuteilung nach Tutorium CorProportion: Anteil -CorDeficit: Defizit +CorDeficitProportion: Defizit Anteile CorByProportionOnly proportion@Rational: #{display proportion} Anteile CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 81335f4ac..f62fc6487 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1214,6 +1214,9 @@ assignHandler tid ssh csh cid assignSids = do let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps + sheetNames :: [SheetName] + sheetNames = Map.keys infoMap + sheetMap :: Map SheetName CorrectionInfo sheetMap = Map.map fold infoMap @@ -1230,7 +1233,10 @@ assignHandler tid ssh csh cid assignSids = do corrMap :: Map (Maybe UserId) CorrectionInfo corrMap = Map.unionsWith (<>) $ Map.elems infoMap - sheetNames = Map.keys infoMap + + corrMapSum :: CorrectionInfo + corrMapSum = fold corrMap + let -- whamlet convenience functions -- avoid nestes hamlet $maybe with duplicated $nothing getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector) @@ -1256,10 +1262,9 @@ assignHandler tid ssh csh cid assignSids = do getCorrDeficit _ = Nothing getLoadSum :: SheetName -> Text - getLoadSum shn - | (Just load) <- Map.lookup shn sheetLoad - = "Σ" <> showCompactCorrectorLoad load CorrectorNormal - getLoadSum _ = mempty + getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad + = showCompactCorrectorLoad load CorrectorNormal + getLoadSum _ = mempty showDiffDays :: Maybe NominalDiffTime -> Text showDiffDays = foldMap formatDiffDays diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 046c16aff..7b29e2bbd 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -63,7 +63,7 @@ getHealthR = do

#{boolSymbol passed} $of HealthLDAPAdmins (Just found)
_{MsgHealthLDAPAdmins} -
#{textPercent found} +
#{textPercent found 1} $of HealthSMTPConnect (Just passed)
_{MsgHealthSMTPConnect}
#{boolSymbol passed} @@ -80,7 +80,7 @@ getInstanceR = do instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID setWeakEtagHashable (clusterId, instanceId) - + selectRep $ do provideRep $ siteLayoutMsg MsgInstanceIdentification $ do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c14424251..791bce180 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -257,9 +257,7 @@ getSheetListR tid ssh csh = do (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> case preview (_grading . _maxPoints) sType of Just maxPoints - | maxPoints /= 0 -> - let percent = sPoints / maxPoints - in textCell $ textPercent $ realToFrac percent + | maxPoints /= 0 -> textCell $ textPercent sPoints maxPoints _other -> mempty _other -> mempty ] diff --git a/src/Utils.hs b/src/Utils.hs index 4f565befe..e02a8b9b2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -2,12 +2,13 @@ module Utils ( module Utils ) where -import ClassyPrelude.Yesod hiding (foldlM) +import ClassyPrelude.Yesod hiding (foldlM, Proxy) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold import Data.Foldable as Utils (foldlM, foldrM) import Data.Monoid (Sum(..)) +import Data.Proxy import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -67,7 +68,7 @@ import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Data.PKCS7 as PKCS7 import Data.Fixed -import Data.Ratio ((%)) +-- import Data.Ratio ((%)) import Data.Binary (Binary) import qualified Data.Binary as Binary @@ -293,15 +294,28 @@ instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out display = pack . show -} -textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? -textPercent x = lz <> pack (show rx) <> "%" - where - rx :: Centi - rx = realToFrac (x * 100) - lz = if rx < 10.0 then "0" else "" +-- | Convert `part` and `whole` into percentage including symbol +-- showing trailing zeroes and to decimal digits +textPercent :: Real a => a -> a -> Text +textPercent = textPercent' False 2 + +-- | Convert `part` and `whole` into percentage including symbol +-- `trailZero` shows trailing Zeros, `precision` is number of decimal digits +textPercent' :: Real a => Bool -> Int -> a -> a -> Text +textPercent' trailZero precision part whole + | precision == 0 = showPercent (frac :: Uni) + | precision == 1 = showPercent (frac :: Deci) + | precision == 2 = showPercent (frac :: Centi) + | precision == 3 = showPercent (frac :: Milli) + | precision == 4 = showPercent (frac :: Micro) + | otherwise = showPercent (frac :: Pico) + where + frac :: forall a . HasResolution a => Fixed a + frac = MkFixed $ round $ (* (fromInteger $ resolution (Proxy :: Proxy a))) $ (100*) $ toRational part / toRational whole + + showPercent :: HasResolution a => Fixed a -> Text + showPercent f = pack $ showFixed trailZero f <> "%" -textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? -textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole -- | Convert number of bytes to human readable format textBytes :: Integral a => a -> Text diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 5d3f6ba8b..c4d4c0f3c 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -45,7 +45,7 @@
_{MsgCorrector} _{MsgGenericAll} - _{MsgCorProportion} + _{MsgCorDeficitProportion} _{MsgCorrectionTime} $forall shn <- sheetNames #{shn} @@ -53,7 +53,6 @@
_{MsgNrSubmissionsTotal} _{MsgNrSubmissionsNotCorrected} - _{MsgCorDeficit} _{MsgGenericMin} _{MsgGenericAvg} _{MsgGenericMax} @@ -63,24 +62,33 @@ _{MsgGenericNumChange} _{MsgNrSubmissionsNotCorrectedShort} _{MsgGenericAvg} - $forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap + $forall (CorrectionInfo{ciCorrector, ciSubmissions=ciSubmissionsNr, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap $with (nameW,loadM) <- getCorrector ciCorrector
^{nameW} - #{ciSubmissions} - #{ciSubmissions - ciCorrected} + #{ciSubmissionsNr} + $with total <- ciSubmissions corrMapSum + $if total > 0 + \ (#{textPercent' True 0 ciSubmissionsNr total}) + #{ciSubmissionsNr - ciCorrected} $maybe deficit <- getCorrDeficit ciCorrector #{display deficit} #{showDiffDays ciMin} #{showAvgsDays ciTot ciCorrected} #{showDiffDays ciMax} - $forall shn <- sheetNames + $forall (shn, CorrectionInfo{ciSubmissions=sheetSubmissionsNr}) <- Map.toList sheetMap $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState} + $if sheetCorrectorState == CorrectorNormal + $maybe Load{byProportion=total} <- Map.lookup shn sheetLoad + $if total > 0 + \ (#{textPercent' True 0 (byProportion sheetCorrectorLoad) total}) $maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn #{ciSubmissions} + $if sheetSubmissionsNr > 0 + \ (#{textPercent' True 0 ciSubmissions sheetSubmissionsNr}) $maybe nrNew <- getCorrNewAssignment ciCorrector shn $# #{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap` (+#{nrNew}) @@ -95,10 +103,16 @@ $if 0 < length sheetNames
+ Σ + #{ciSubmissions corrMapSum} + #{ciCorrected corrMapSum} + + #{showDiffDays (ciMin corrMapSum)} + #{showAvgsDays (ciTot corrMapSum) (ciCorrected corrMapSum)} + #{showDiffDays (ciMax corrMapSum)} $forall shn <- sheetNames - #{getLoadSum shn} - ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} + #{getLoadSum shn} + ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} ^{btnWdgt}

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file diff --git a/templates/widgets/grading-summary/grading-summary-row.hamlet b/templates/widgets/grading-summary/grading-summary-row.hamlet index 261b98e1a..0e64a515b 100644 --- a/templates/widgets/grading-summary/grading-summary-row.hamlet +++ b/templates/widgets/grading-summary/grading-summary-row.hamlet @@ -19,7 +19,7 @@ $# $with Sum pacv <- summary ^. _achievedPasses

$if pmax > 0 - #{textPercentInt pacv pmax} + #{textPercent pacv pmax} #{display pacv} / #{display pmax} $else @@ -35,7 +35,7 @@ $# $with Sum pacv <- summary ^. _achievedPoints $if pmax > 0 - #{textPercent $ realToFrac $ pacv / pmax} + #{textPercent pacv pmax} #{display pacv} / #{display pmax} $if ((summary ^. _numMarkedPoints) /= (summary ^. _numSheets)) From 749cd2f7bcf990f5eee18d90099843151cb56716 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jun 2019 15:22:46 +0200 Subject: [PATCH 8/9] fix(sheet corrector assigment): minor bugfix --- templates/corrections-overview.hamlet | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index c4d4c0f3c..94ada0543 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -104,15 +104,17 @@ $if 0 < length sheetNames
Σ - #{ciSubmissions corrMapSum} + $with ciSubmissionsNr <- ciSubmissions corrMapSum + $with ciCorrectedNr <- ciCorrected corrMapSum + #{ciSubmissionsNr} + #{ciSubmissionsNr - ciCorrectedNr} #{ciCorrected corrMapSum} - #{showDiffDays (ciMin corrMapSum)} #{showAvgsDays (ciTot corrMapSum) (ciCorrected corrMapSum)} #{showDiffDays (ciMax corrMapSum)} $forall shn <- sheetNames #{getLoadSum shn} - ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} + ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} ^{btnWdgt}

_{MsgAssignSubmissionsRandomWarning} \ No newline at end of file From 89d5364c937132a642d7b7960e90b73868fe56f4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jun 2019 19:35:49 +0200 Subject: [PATCH 9/9] fix(Help Widget, Corrector Assignment): Modal Form closes in place; assign alerts Closes #195 --- .directory | 2 +- messages/uniworx/de.msg | 2 ++ src/Foundation.hs | 4 +-- src/Handler/Corrections.hs | 69 ++++++++++---------------------------- src/Handler/Help.hs | 2 +- src/Handler/Profile.hs | 4 +-- src/Utils/Form.hs | 5 +++ 7 files changed, 31 insertions(+), 57 deletions(-) diff --git a/.directory b/.directory index 59c2c250d..9e958424d 100644 --- a/.directory +++ b/.directory @@ -1,5 +1,5 @@ [Dolphin] -Timestamp=2018,3,14,10,57,55 +Timestamp=2019,6,26,19,32,25 Version=4 [Settings] diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 012b6b587..2195c86a5 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -203,6 +203,7 @@ SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausg SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden SheetNoCurrent: Es gibt momentan kein aktives Übungsblatt. SheetNoOldUnassigned: Alle Abgaben inaktiver Blätter sind bereits einen Korrektor zugeteilt. +SheetsUnassignable name@Text: Momentan keine Abgaben zuteilbar für #{name} Deadline: Abgabe Done: Eingereicht @@ -403,6 +404,7 @@ UpdatedSheetCorrectorsAutoFailed n@Int: #{display n} #{pluralDE n "Abgabe konnte 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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 3e243af41..ed6a01a70 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1436,7 +1436,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 ("Zuteilung" , Just $ CourseR tid ssh csh CCorrectionsR) + breadcrumb (CourseR tid ssh csh CAssignR) = return ("Zuteilung Korrekturen" , 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) @@ -1454,7 +1454,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten" , Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen" , Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben" , Just $ CSheetR tid ssh csh shn SShowR) - breadcrumb (CSheetR tid ssh csh shn SAssignR) = return ("Zuteilen" , Just $ CSheetR tid ssh csh shn SSubsR) + breadcrumb (CSheetR tid ssh csh shn SAssignR) = return ("Zuteilung Korrekturen" , Just $ CSheetR tid ssh csh shn SSubsR) breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index f62fc6487..446b93273 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1052,11 +1052,8 @@ data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiC getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAssignR = postCAssignR postCAssignR tid ssh csh = do - (shids,cid) <- runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - shids <- selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] - return (shids,cid) - assignHandler tid ssh csh cid shids + cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh + assignHandler tid ssh csh cid [] getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSAssignR = postSAssignR @@ -1064,51 +1061,13 @@ postSAssignR tid ssh csh shn = do (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn assignHandler tid ssh csh cid [shid] --- DEPRECATED assignHandler', delete me soonish -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 - Just Sheet{sheetName=saiName} <- lift $ get sid - guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh saiName SAssignR -- we must check, whether the submission is already closed and thus assignable - saiUnassignedNr <- lift $ count [SubmissionSheet ==. sid, SubmissionRatingBy ==. Nothing] - guard $ 0 < saiUnassignedNr -- only consider sheets with unassigned submissions - saiSubmissionNr <- lift $ count [SubmissionSheet ==. sid] - saiCorrectorNr <- lift $ count [SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal] - -- guard $ saiCorrectorNr > 0 -- COMMENTED OUT BECAUSE we should show sheets without possible correctors to inform the user about these problematic sheets - return $ Map.insert sid SubAssignInfo{..} acc - let sids = Map.keys openSubs - linkBack <- simpleLinkI (SomeMessage MsgGenericBack) <$> case sids of - [sid] -> do Sheet{sheetName} <- runDB $ getJust sid - return $ CSheetR tid ssh csh sheetName SSubsR - _ -> return $ CourseR tid ssh csh CCorrectionsR - -- process form - currentRoute <- getCurrentRoute - ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm FIDAssignSubmissions buttonForm - assignmentStatus <- fmap (fromMaybe Map.empty) . formResultMaybe btnResult $ \BtnSubmissionsAssign -> - -- Assign submissions - fmap Just . runDB $ (\f -> foldM f Map.empty sids) $ - \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 - , formEncoding = btnEnctype - , formSubmit = FormNoSubmit - } - headingShort = MsgMenuCorrectionsAssign - headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign - siteLayoutMsg headingShort $ do - setTitleI headingLong - $(widgetFile "corrections-assign") - if null sids || not (null assignmentStatus) - then linkBack -- TODO: convenience link might be unnecessary: either via breadcrumb or closing model. Remove, if modal works fine. Otherwise change to PrimaryAction? - else btnForm +{- TODO: Feature: + make distivt buttons for each sheet, so that users see which sheet will be assigned. + Currently this information is available within the page heading! - -{- TODO: make buttons for each sheet, so that users see which sheet is assigned + Stub: data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName - deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Button UniWorX ButtonCorrectionsAssign -- Are those needed any more? instance Universe ButtonCorrectionsAssign @@ -1126,7 +1085,7 @@ assignHandler tid ssh csh cid assignSids = do (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions -- gather data - (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do + (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh nrParticipants <- count [CourseParticipantCourse ==. cid] @@ -1137,6 +1096,7 @@ assignHandler tid ssh csh cid assignSids = do groupsPossible = let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups in List.foldr foldFun False sheetList + assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids -- plan or assign unassigned submissions for given sheets let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) @@ -1166,7 +1126,10 @@ assignHandler tid ssh csh cid assignSids = do addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail] return status return $ Map.insert shn (status, countMapElems plan, deficit) acc - assignment <- foldM buildA Map.empty assignSids + assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts + then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] + else return assignSids + 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 @@ -1210,7 +1173,7 @@ assignHandler tid ssh csh cid assignSids = do } in Map.insertWith (Map.unionWith (<>)) shnm cinf m - return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment) + return (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps @@ -1277,6 +1240,10 @@ assignHandler tid ssh csh cid assignSids = do | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment | otherwise = MsgMenuCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign + + unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames + unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets + siteLayoutMsg headingShort $ do setTitleI headingLong $(widgetFile "corrections-overview") diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index bf33da8d5..5380d9880 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -66,6 +66,6 @@ postHelpR = do let formWidget = wrapForm formWidget' def { formAction = Just $ SomeRoute HelpR , formEncoding = formEnctype - , formAttrs = [ ("data-ajax-submit", "") | isModal ] + , formAttrs = [ asyncSubmitAttr | isModal ] } $(widgetFile "help") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 403e133c7..282286f4f 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -147,7 +147,7 @@ postProfileR = do siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do setTitle . toHtml $ "Profil " <> userIdent - let settingsForm = + let settingsForm = wrapForm formWidget FormSettings { formMethod = POST , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings @@ -593,7 +593,7 @@ postUserNotificationR cID = do let formWidget = wrapForm nsInnerWdgt def { formAction = Just . SomeRoute $ UserNotificationR cID , formEncoding = nsEnc - , formAttrs = [ ("data-ajax-submit", "") | isModal ] + , formAttrs = [ asyncSubmitAttr | isModal ] } formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 69eb65254..b189485a5 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -156,6 +156,11 @@ inputReadonly = addAttr "readonly" "" addAutosubmit :: FieldSettings site -> FieldSettings site addAutosubmit = addAttr "uw-auto-submit-input" "" +-- | Asynchronous Submit, e.g. use with forms in modals +asyncSubmitAttr :: (Text,Text) +asyncSubmitAttr = ("uw-async-form", "") + + ------------------------------------------------ -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------