-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Submission.Assign ( getSubAssignR, postSubAssignR , getCAssignR, postCAssignR , getSAssignR, postSAssignR ) where import Import hiding (link, unzip) import Handler.Utils hiding (colSchool) import Handler.Utils.Corrections import Handler.Utils.Submission import Data.List as List (foldl, foldr) import qualified Data.Set as Set import Data.Map.Strict ((!), (!?)) import qualified Data.Map.Strict as Map import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto.Legacy as E import Data.List.NonEmpty (unzip) getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubAssignR = postSubAssignR postSubAssignR tid ssh csh shn cID = do let actionUrl = CSubmissionR tid ssh csh shn cID SubAssignR sId <- decrypt cID (currentCorrector, sheetCorrectors) <- runDB $ do Submission{submissionRatingBy, submissionSheet} <- get404 sId sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] [] userCorrector <- traverse getJustEntity submissionRatingBy return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors) $logDebugS "SubAssignR" $ tshow currentCorrector let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName ((corrResult, corrForm'), corrEncoding) <- runFormPost . renderAForm FormStandard $ aopt correctorField (fslI MsgTableCorrector) (Just currentCorrector) formResult corrResult $ \(fmap entityKey -> mbUserId) -> do when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do now <- liftIO getCurrentTime update sId [ SubmissionRatingBy =. mbUserId , SubmissionRatingAssigned =. (now <$ mbUserId) ] addMessageI Success MsgCorrectorUpdated sub <- getJust sId audit $ TransactionSubmissionEdit sId $ sub ^. _submissionSheet redirect actionUrl let corrForm = wrapForm' BtnSave corrForm' def { formAction = Just $ SomeRoute actionUrl , formEncoding = corrEncoding , formSubmit = FormSubmit } defaultLayout $ do setTitleI MsgCorrectorAssignTitle $(widgetFile "submission-assign") getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAssignR = postCAssignR postCAssignR tid ssh csh = do cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh assignHandler tid ssh csh cid [] getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSAssignR = postSAssignR postSAssignR tid ssh csh shn = do (shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn assignHandler tid ssh csh cid [shid] assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html assignHandler tid ssh csh cid assignSids = do currentRoute <- fromMaybe (error "assignHandler called from 404-handler") <$> liftHandler getCurrentRoute -- gather data (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, ((btnViews, btnCsrf), btnEncoding)) <- runDB $ do -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh nrParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom] assignSids' <- if | null assignSids -> -- assignAll; we distinguish assignSids' here avoid useless Alerts selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo] | otherwise -> return $ filter (`elem` map entityKey sheetList) assignSids let orderedSheetNames = fmap (\(Entity _ Sheet{sheetName}) -> sheetName) sheetList 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 assignSheetNames = sheetName <$> mapMaybe (`Map.lookup` sheets) assignSids assignSheetNames' = sheetName <$> mapMaybe (`Map.lookup` sheets) assignSids' assignButtons = Map.fromSet (maybe BtnSubmissionsAssignAll BtnSubmissionsAssign) $ Set.fromList . bool (Nothing :) id (null sheetList) $ map Just assignSheetNames' ((btnResult, btnViews'), btnEncoding) <- runFormPost . identifyForm FIDAssignSubmissions $ \csrf -> fmap (over _1 (asum . fmap (hoistMaybe =<<)) . over _2 (, csrf) . unzip) . for assignButtons $ \btn -> mopt (buttonField btn) "" Nothing -- 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)) 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 -- 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 status@(sub_ok, sub_fail) <- fmap fold . formResultMaybe btnResult $ \btn -> lift . maybeT (return Nothing) $ do guard $ case btn of BtnSubmissionsAssignAll -> True BtnSubmissionsAssign shn' -> shn' == shn status@(sub_ok,sub_fail) <- lift $ 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 <> ":" if | nr_ok > 0 || nr_fail > 0 -> do addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail] return $ Just status | otherwise -> do addMessageI Error $ MsgSheetsUnassignable $ CI.original shn return Nothing if | null sub_ok && null sub_fail -> return $ Map.insert shn (status, countMapElems plan, deficit) acc | otherwise -> do (plan', deficit') <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing 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 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 (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 ) -- Lecturers may correct without being enlisted SheetCorrectors, so fetch all names act_correctors <- E.select . E.distinct . E.from $ \(submission `E.InnerJoin` user) -> do E.on $ submission E.^. SubmissionRatingBy E.==. E.just (user E.^. UserId) E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds return (submission E.^. SubmissionSheet, user) let correctorMap :: Map UserId (User, Map SheetName SheetCorrector) correctorMap = (\f -> foldl f correctorMap' act_correctors) (\acc (E.Value sheetCorrectorSheet, Entity uid user) -> let shn = sheetName $ sheets ! sheetCorrectorSheet scr = SheetCorrector uid sheetCorrectorSheet mempty CorrectorExcused in Map.insertWith (\_new old -> old) uid (user, Map.singleton shn scr) acc -- keep already known correctors unchanged ) submissions <- E.select . E.from $ \submission -> do E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds let numSubmittors = E.subSelectCount . E.from $ \subUser -> E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission 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) 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 = 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 -- only used in sheetMap , ciCorrected = maybe 0 (const 1) submissionRatingTime , ciCorrector = submissionRatingBy , ciMin = corTime , ciTot = corTime , ciMax = corTime } in Map.insertWith (Map.unionWith (<>)) shnm cinf m return (orderedSheetNames, assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, (btnViews', btnEncoding)) let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps -- Always iterate over orderedSheetNames for consistent sorting! 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 corrInfos :: [CorrectionInfo] corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap where byName Nothing = Nothing byName (Just uid) = Map.lookup uid correctorMap corrMapSum :: CorrectionInfo corrMapSum = fold corrMap let -- whamlet convenience functions -- avoid nestes hamlet $maybe with duplicated $nothing getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector, Text) getCorrector (Just uid) | Just (User{..},loadMap) <- Map.lookup uid correctorMap = (nameEmailWidget userEmail userDisplayName userSurname, loadMap, userDisplayName) -- | Just (User{..} ) <- Map.lookup uid lecturerNames -- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty, mempty) -- 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 hamlet $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 -- 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 showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text showAvgsDays Nothing _ = mempty showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n let headingShort = MsgHeadingCorrectionsAssign headingLong = prependCourseTitle tid ssh csh MsgHeadingCorrectionsAssign unassignableSheets = filter (`Map.notMember` assignment) assignSheetNames unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets siteLayoutMsg headingShort $ do setTitleI headingLong let doWrap wdgt | null btnViews = wdgt | otherwise = wrapForm (toWidget btnCsrf <> wdgt) def { formAction = Just . SomeRoute $ currentRoute , formEncoding = btnEncoding , formSubmit = FormNoSubmit } sheetBtnViews = Map.fromList [ (shn, btn) | (Just shn, btn) <- Map.toList btnViews, shn `elem` assignSheetNames' ] assignSheetNames' = Map.keys $ Map.filter (\(_, new, _) -> any (> 0) $ Map.delete Nothing new) assignment doWrap $(widgetFile "corrections-overview") data ButtonSubmissionsAssign = BtnSubmissionsAssign SheetName | BtnSubmissionsAssignAll deriving (Eq, Ord, Read, Show, Generic) derivePathPiece ''ButtonSubmissionsAssign (camelToPathPiece' 2) "--" instance RenderMessage UniWorX ButtonSubmissionsAssign where renderMessage f ls = \case BtnSubmissionsAssign _ -> mr MsgBtnSubmissionsAssign BtnSubmissionsAssignAll -> mr MsgBtnSubmissionsAssignAll where mr = renderMessage f ls instance Button UniWorX ButtonSubmissionsAssign where btnClasses _ = [BCIsButton, BCPrimary]