302 lines
16 KiB
Haskell
302 lines
16 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- 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]
|