503 lines
25 KiB
Haskell
503 lines
25 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.Course.User
|
|
( getCUserR, postCUserR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Utils.Mail (pickValidUserEmail)
|
|
import Handler.Utils
|
|
import Handler.Utils.SheetType
|
|
import Handler.Utils.StudyFeatures
|
|
import Handler.Submission.List
|
|
import Handler.Course.Register
|
|
|
|
import Jobs.Queue
|
|
|
|
import Database.Persist.Sql (deleteWhereCount)
|
|
import Database.Esqueleto.Utils.TH
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Text.Lazy as LT
|
|
|
|
|
|
data ExamAction = ExamDeregister
|
|
| ExamSetResult
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
nullaryPathPiece ''ExamAction $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''ExamAction $ Text.replace "Exam" "ExamUser"
|
|
|
|
data ExamActionData = ExamDeregisterData
|
|
| ExamSetResultData (Maybe ExamResultPassedGrade)
|
|
|
|
data TutorialAction = TutorialDeregister
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
deriving anyclass (Universe, Finite)
|
|
nullaryPathPiece ''TutorialAction $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''TutorialAction $ Text.replace "Tutorial" "TutorialUser"
|
|
|
|
data TutorialActionData = TutorialDeregisterData
|
|
|
|
|
|
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
|
|
getCUserR = postCUserR
|
|
postCUserR tid ssh csh uCId = do
|
|
showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth
|
|
|
|
(course, user@(Entity _ User{..}), registered) <- runDB $ do
|
|
uid <- decrypt uCId
|
|
course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
user <- get404 uid
|
|
registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]
|
|
|
|
return (course, Entity uid user, registered)
|
|
|
|
sections <- mapM (runMaybeT . ($ user) . ($ course))
|
|
[ courseUserProfileSection
|
|
, courseUserNoteSection
|
|
, courseUserExamsSection
|
|
, courseUserTutorialsSection
|
|
, courseUserSubmissionsSection
|
|
]
|
|
|
|
-- generate output
|
|
let headingLong
|
|
| registered
|
|
, Just sex <- guardOn showSex =<< userSex
|
|
= [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseMemberOf} #{csh} #{tid}|]
|
|
| registered
|
|
= [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseMemberOf} #{csh} #{tid}|]
|
|
| Just sex <- guardOn showSex =<< userSex
|
|
= [whamlet|^{nameWidget userDisplayName userSurname} (_{ShortSex sex}), _{MsgCourseAssociatedWith} #{csh} #{tid}|]
|
|
| otherwise
|
|
= [whamlet|^{nameWidget userDisplayName userSurname}, _{MsgCourseAssociatedWith} #{csh} #{tid}|]
|
|
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
|
|
siteLayout headingLong $ do
|
|
setTitleI headingShort
|
|
|
|
mapM_ maybeVoid sections
|
|
|
|
courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget
|
|
courseUserProfileSection course@(Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do
|
|
showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth
|
|
currentRoute <- MaybeT getCurrentRoute
|
|
|
|
(mRegistration, studies) <- lift . runDB $ do
|
|
registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
|
|
studies <- E.select $ E.from $ \(course' `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do
|
|
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
|
|
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
|
|
E.on $ isCourseStudyFeature course' studyfeat
|
|
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
|
|
E.where_ $ course' E.^. CourseId E.==. E.val cid
|
|
return (studyfeat, studydegree, studyterms)
|
|
return (registration, studies)
|
|
|
|
mayRegister <- lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
|
|
let regButton
|
|
| is _Just mRegistration = BtnCourseDeregister
|
|
| otherwise = BtnCourseRegister
|
|
((regButtonRes, regButtonView), regButtonEnctype) <- lift . runFormPost . identifyForm FIDcRegButton $ \csrf -> pure (FormSuccess (regButton, Nothing), toWidget csrf)
|
|
|
|
let registrationButtonFrag :: Text
|
|
registrationButtonFrag = "registration-button"
|
|
regButtonWidget = wrapForm' regButton regButtonView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
|
|
, formEncoding = regButtonEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just registrationButtonFrag
|
|
}
|
|
formResult regButtonRes $ \case
|
|
_
|
|
| not mayRegister
|
|
-> permissionDenied "User may not be registered"
|
|
(BtnCourseDeregister, mbReason)
|
|
| Just (Entity _pId CourseParticipant{..}) <- mRegistration
|
|
-> do
|
|
lift . runDB $ do
|
|
unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid"
|
|
deregisterParticipant courseParticipantUser course
|
|
|
|
whenIsJust mbReason $ \(_reason, noShow) -> do
|
|
updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ]
|
|
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
|
|
redirect $ CourseR courseTerm courseSchool courseShorthand CUsersR
|
|
| otherwise
|
|
-> invalidArgs ["User not registered"]
|
|
(BtnCourseRegister, _) -> do
|
|
now <- liftIO getCurrentTime
|
|
lift . runDBJobs $ do
|
|
void $ upsert
|
|
(CourseParticipant cid uid now CourseParticipantActive)
|
|
[ CourseParticipantRegistration =. now
|
|
, CourseParticipantState =. CourseParticipantActive
|
|
]
|
|
queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
|
|
audit $ TransactionCourseParticipantEdit cid uid
|
|
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
|
redirect currentRoute
|
|
|
|
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
|
|
|
|
return $(widgetFile "course/user/profile")
|
|
|
|
|
|
courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget
|
|
courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
|
|
guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR
|
|
|
|
currentRoute <- MaybeT getCurrentRoute
|
|
|
|
(thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do
|
|
let thisUniqueNote = UniqueCourseUserNote uid cid
|
|
mbNoteEnt <- getBy thisUniqueNote
|
|
(noteText,noteEdits) <- case mbNoteEnt of
|
|
Nothing -> return (Nothing,[])
|
|
(Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
|
|
noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
|
|
E.on $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
|
|
E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
|
|
E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
|
|
E.limit 1 -- more will be shown, if changed here
|
|
return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
|
|
return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
|
|
return (thisUniqueNote, noteText, noteEdits)
|
|
let editByWgt = [whamlet|
|
|
$newline never
|
|
<ul .list--iconless>
|
|
$forall (etime,_eemail,ename,_esurname) <- noteEdits
|
|
<li>
|
|
_{MsgCourseLastEdit} ^{editedByW SelFormatDateTime etime ename}
|
|
|] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
|
|
|
|
((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
|
|
aopt (annotateField editByWgt htmlField) (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
|
|
let noteFrag :: Text
|
|
noteFrag = "notes"
|
|
noteWidget = wrapForm noteView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ currentRoute :#: noteFrag
|
|
, formEncoding = noteEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just noteFrag
|
|
}
|
|
formResult noteRes $ \mbNote -> do
|
|
now <- liftIO getCurrentTime
|
|
lift . runDB $ case mbNote of
|
|
Nothing -> do
|
|
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
|
|
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
|
|
deleteBy thisUniqueNote
|
|
addMessageI Info MsgCourseUserNoteDeleted
|
|
_ | ((==) `on` fmap (LT.strip . renderHtml . markupOutput)) mbNote noteText -> return () -- no changes
|
|
(Just note) -> do
|
|
dozentId <- requireAuthId
|
|
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
|
|
void . insert $ CourseUserNoteEdit dozentId now noteKey
|
|
addMessageI Success MsgCourseUserNoteSaved
|
|
redirect $ currentRoute :#: noteFrag -- reload page after post
|
|
|
|
return $(widgetFile "course/user/note")
|
|
|
|
|
|
courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
|
|
courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid User{..}) = do
|
|
guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR
|
|
|
|
let whereClause :: CorrectionTableWhere
|
|
whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
|
|
colonnade = mconcat -- should match getSSubsR for consistent UX
|
|
[ colSelect
|
|
, colSheet
|
|
, colSMatrikel
|
|
, colSubmittors
|
|
, colSubmissionLink
|
|
, colLastEdit
|
|
, colRating
|
|
, colRated
|
|
, colCorrector
|
|
, colAssigned
|
|
] -- Continue here
|
|
filterUI = Just $ mconcat
|
|
[ filterUIUserNameEmail
|
|
, filterUIUserMatrikelnummer
|
|
, filterUIPseudonym
|
|
, filterUISheetSearch
|
|
, filterUICorrectorNameEmail
|
|
, filterUIIsAssigned
|
|
, filterUIIsRated
|
|
, filterUISubmission
|
|
]
|
|
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
|
csvSettings = Just CorrectionTableCsvSettings
|
|
{ cTableCsvQualification = CorrectionTableCsvQualifySheet
|
|
, cTableCsvName = MsgCorrectionTableCsvNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName
|
|
, cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName
|
|
, cTableShowCorrector = True
|
|
}
|
|
(cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
|
|
[ downloadAction
|
|
, assignAction (Left cid)
|
|
, deleteAction
|
|
]
|
|
|
|
guard $ statistics /= mempty
|
|
|
|
return $(widgetFile "course/user/corrections")
|
|
|
|
|
|
courseUserExamsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
|
|
courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do
|
|
guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR
|
|
|
|
uCID <- encrypt uid
|
|
|
|
let
|
|
examDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery exam = do
|
|
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
|
E.where_ $ E.or
|
|
[ E.exists . E.from $ \examRegistration ->
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
|
E.&&. examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
|
, E.exists . E.from $ \(examPart `E.InnerJoin` examPartResult) -> do
|
|
E.on $ examPart E.^. ExamPartId E.==. examPartResult E.^. ExamPartResultExamPart
|
|
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
|
|
E.&&. examPart E.^. ExamPartExam E.==. exam E.^. ExamId
|
|
, E.exists . E.from $ \examBonus ->
|
|
E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val uid
|
|
E.&&. examBonus E.^. ExamBonusExam E.==. exam E.^. ExamId
|
|
, E.exists . E.from $ \examResult ->
|
|
E.where_ $ examResult E.^. ExamResultUser E.==. E.val uid
|
|
E.&&. examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
|
]
|
|
return exam
|
|
dbtRowKey = (E.^. ExamId)
|
|
dbtProj = dbtProjSimple $ \exam@(Entity eId _) -> do
|
|
registration <- getBy $ UniqueExamRegistration eId uid
|
|
occurrence <- runMaybeT $ do
|
|
Entity _ ExamRegistration{..} <- hoistMaybe registration
|
|
occId <- hoistMaybe examRegistrationOccurrence
|
|
MaybeT $ getEntity occId
|
|
bonus <- getBy $ UniqueExamBonus eId uid
|
|
result <- getBy $ UniqueExamResult eId uid
|
|
|
|
return ( exam
|
|
, occurrence
|
|
, bonus
|
|
, result
|
|
, registration
|
|
)
|
|
dbtColonnade = mconcat
|
|
[ dbSelect (_2 . applying _2) _1 $ return . view (_dbrOutput . _1 . _entityKey)
|
|
, sortable (Just "name") (i18nCell MsgTableExamName) $ tellCell (Any True, mempty) . anchorCell' (\(view $ _dbrOutput . _1 . _entityVal -> Exam{..}) -> CExamR courseTerm courseSchool courseShorthand examName EShowR) (view $ _dbrOutput . _1 . _entityVal . _examName)
|
|
, sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (cell . toWidget) . preview (_dbrOutput . _2 . _Just . _entityVal . _examOccurrenceName)
|
|
, sortable (Just "registration-time") (i18nCell MsgCourseExamRegistrationTime) $ foldMap dateTimeCell . preview (_dbrOutput . _5 . _Just . _entityVal . _examRegistrationTime)
|
|
, sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) $ maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _examBonusBonus)
|
|
, sortable (Just "result") (i18nCell MsgTableExamResult) $ maybe mempty i18nCell . preview (_dbrOutput . _4 . _Just . _entityVal . _examResultResult)
|
|
]
|
|
dbtSorting = mconcat
|
|
[ singletonMap "name" . SortColumn $ \exam -> exam E.^. ExamName
|
|
, singletonMap "occurrence" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \(examOccurrence `E.InnerJoin` examRegistration) -> do
|
|
E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
|
|
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
|
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
|
return . E.just $ examOccurrence E.^. ExamOccurrenceName
|
|
, singletonMap "registration-time" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examRegistration -> do
|
|
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
|
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
|
return . E.just $ examRegistration E.^. ExamRegistrationTime
|
|
, singletonMap "bonus" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examBonus -> do
|
|
E.where_ $ examBonus E.^. ExamBonusExam E.==. exam E.^. ExamId
|
|
E.&&. examBonus E.^. ExamBonusUser E.==. E.val uid
|
|
return . E.just $ examBonus E.^. ExamBonusBonus
|
|
, singletonMap "result" . SortColumn $ \exam -> E.subSelectMaybe . E.from $ \examResult -> do
|
|
E.where_ $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
|
E.&&. examResult E.^. ExamResultUser E.==. E.val uid
|
|
return . E.just $ examResult E.^. ExamResultResult
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI _mPrev = mempty
|
|
dbtStyle = def
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just . SomeRoute . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional = \csrf -> do
|
|
let
|
|
actionMap :: Map ExamAction (AForm Handler ExamActionData)
|
|
actionMap = mconcat
|
|
[ singletonMap ExamDeregister $
|
|
pure ExamDeregisterData
|
|
, singletonMap ExamSetResult $
|
|
ExamSetResultData <$> aopt (examResultModeField (Just $ SomeMessage MsgExamResultNone) ExamGradingMixed) (fslI MsgTableExamResult) Nothing
|
|
]
|
|
|
|
(res, formWgt) <- multiActionM actionMap (fslI MsgTableAction) Nothing csrf
|
|
let formRes = (, mempty) . First . Just <$> res
|
|
return (formRes, formWgt)
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = _2
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtIdent :: Text
|
|
dbtIdent = "course-user-exams"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
examDBTableValidator = def & defaultSorting [SortAscBy "registration-time"]
|
|
postprocess :: FormResult (First ExamActionData, DBFormResult ExamId (Bool, _) _) -> FormResult (ExamActionData, Map ExamId _)
|
|
postprocess inp = do
|
|
(First (Just act), regMap) <- inp
|
|
let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
|
|
return (act, regMap')
|
|
((Any hasExams, actRes), examTable) <- lift . runDB $ over (_1 . _2) postprocess <$> dbTable examDBTableValidator examDBTable
|
|
|
|
lift . formResult actRes $ \case
|
|
(ExamDeregisterData, Map.keys -> selectedExams) -> do
|
|
nrDel <- runDB $ deleteWhereCount
|
|
[ ExamRegistrationUser ==. uid
|
|
, ExamRegistrationExam <-. selectedExams
|
|
]
|
|
if | nrDel > 0 -> addMessageI Success $ MsgCourseUserExamsDeregistered nrDel
|
|
| otherwise -> addMessageI Info MsgCourseUserNoExamsDeregistered
|
|
redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
|
|
(ExamSetResultData mRes, selectedExams) -> do
|
|
now <- liftIO getCurrentTime
|
|
Sum nrUpdated <- runDB . flip ifoldMapM selectedExams $ \eId (view $ _dbrOutput . _1 . _entityVal -> Exam{..}) -> if
|
|
| hasExamGradingGrades examGradingMode || isn't (_Just . _ExamAttended . _Right) mRes
|
|
, hasExamGradingPass examGradingMode || isn't (_Just . _ExamAttended . _Left ) mRes
|
|
-> do
|
|
oldResult <- getBy $ UniqueExamResult eId uid
|
|
case mRes of
|
|
Just res
|
|
| maybe True ((/= res) . examResultResult . entityVal) oldResult -> do
|
|
void $ upsert
|
|
ExamResult
|
|
{ examResultExam = eId
|
|
, examResultUser = uid
|
|
, examResultResult = res
|
|
, examResultLastChanged = now
|
|
}
|
|
[ ExamResultResult =. res, ExamResultLastChanged =. now ]
|
|
audit $ TransactionExamResultEdit eId uid
|
|
return $ Sum 1
|
|
Nothing
|
|
| is _Just oldResult -> do
|
|
deleteBy $ UniqueExamResult eId uid
|
|
audit $ TransactionExamResultDeleted eId uid
|
|
return $ Sum 1
|
|
_other -> return mempty
|
|
| otherwise -> mempty <$ addMessageI Error (MsgCourseUserExamResultDoesNotMatchMode examName)
|
|
when (nrUpdated > 0) . addMessageI Success $ MsgCourseUserExamsResultSet nrUpdated
|
|
redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
|
|
|
|
guard hasExams
|
|
|
|
return $(widgetFile "course/user/exams")
|
|
|
|
|
|
courseUserTutorialsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
|
|
courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
|
|
uCID <- encrypt uid
|
|
|
|
let
|
|
tutorialDBTable = DBTable{..}
|
|
where
|
|
dbtSQLQuery (tutorial `E.InnerJoin` tutorialParticipant) = do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
|
return (tutorial, tutorialParticipant)
|
|
dbtRowKey (_ `E.InnerJoin` tutorialParticipant) = tutorialParticipant E.^. TutorialParticipantId
|
|
dbtProj = dbtProjSimple $ \(tutorial, tutorialParticipant) -> do
|
|
tutors <- E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
|
E.where_ $ tutor E.^. TutorTutorial E.==. E.val (tutorial ^. _entityKey)
|
|
return user
|
|
return (tutorial, tutorialParticipant, tutors)
|
|
dbtColonnade = mconcat
|
|
[ dbSelect (_2 . applying _2) _1 $ return . view (_dbrOutput . _2 . _entityKey)
|
|
, sortable (Just "type") (i18nCell MsgTableTutorialType) $ textCell . CI.original . view (_dbrOutput . _1 . _entityVal . _tutorialType)
|
|
, sortable (Just "name") (i18nCell MsgTableTutorialName) $ tellCell (Any True, mempty) . anchorCell' (\(view $ _dbrOutput . _1 . _entityVal . _tutorialName -> tutn) -> CTutorialR courseTerm courseSchool courseShorthand tutn TUsersR) (view $ _dbrOutput . _1 . _entityVal . _tutorialName)
|
|
, sortable (Just "tutors") (i18nCell MsgTableTutorialTutors) $ \(view $ _dbrOutput . _3 -> tutors) -> cell
|
|
[whamlet|
|
|
$newline never
|
|
<ul .list--iconless .list--inline .list--comma-separated>
|
|
$forall (Entity _ usr) <- tutors
|
|
<li>
|
|
^{userEmailWidget usr}
|
|
|]
|
|
, sortable Nothing (i18nCell MsgTableTutorialOccurrence) $ occurrencesCell False . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
|
|
]
|
|
dbtSorting = mconcat
|
|
[ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType
|
|
, singletonMap "name" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialName
|
|
, singletonMap "tutors" . SortColumn $ \(tutorial `E.InnerJoin` _) -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
|
|
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
|
E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
|
return . E.min_ $ user E.^. UserSurname
|
|
]
|
|
dbtFilter = mempty
|
|
dbtFilterUI _mPrev = mempty
|
|
dbtStyle = def
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just . SomeRoute . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional = \csrf -> do
|
|
let
|
|
actionMap :: Map TutorialAction (AForm Handler TutorialActionData)
|
|
actionMap = mconcat
|
|
[ singletonMap TutorialDeregister $
|
|
pure TutorialDeregisterData
|
|
]
|
|
|
|
(res, formWgt) <- multiActionM actionMap (fslI MsgTableAction) Nothing csrf
|
|
let formRes = (, mempty) . First . Just <$> res
|
|
return (formRes, formWgt)
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = _2
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtIdent :: Text
|
|
dbtIdent = "tutorials"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
tutorialDBTableValidator = def & defaultSorting [SortAscBy "type", SortAscBy "name"]
|
|
postprocess :: FormResult (First TutorialActionData, DBFormResult TutorialParticipantId (Bool, _) _) -> FormResult (TutorialActionData, Map TutorialParticipantId _)
|
|
postprocess inp = do
|
|
(First (Just act), regMap) <- inp
|
|
let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
|
|
return (act, regMap')
|
|
((Any hasTutorials, actRes), tutorialTable) <- lift . runDB $ over (_1 . _2) postprocess <$> dbTable tutorialDBTableValidator tutorialDBTable
|
|
|
|
lift . formResult actRes $ \case
|
|
(TutorialDeregisterData, Map.keys -> selectedTutParts) -> do
|
|
nrDel <- runDB $ deleteWhereCount [ TutorialParticipantId <-. selectedTutParts ]
|
|
if | nrDel > 0 -> addMessageI Success $ MsgCourseUserTutorialsDeregistered nrDel
|
|
| otherwise -> addMessageI Info MsgCourseUserNoTutorialsDeregistered
|
|
redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
|
|
|
|
guard hasTutorials
|
|
|
|
return $(widgetFile "course/user/tutorials")
|