522 lines
26 KiB
Haskell
522 lines
26 KiB
Haskell
module Handler.Course.User
|
|
( getCUserR, postCUserR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.SheetType
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Database.Persist.Sql (deleteWhereCount)
|
|
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
|
|
import Handler.Course.Register
|
|
|
|
import Jobs.Queue
|
|
|
|
import Handler.Submission.List
|
|
|
|
import Handler.Utils.StudyFeatures
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
import qualified Data.Text.Lazy as LT
|
|
|
|
|
|
data ExamAction = ExamDeregister
|
|
| ExamSetResult
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
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, Typeable)
|
|
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
|
|
|
|
forM_ sections . fromMaybe $ return ()
|
|
|
|
courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget
|
|
courseUserProfileSection (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 <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
|
|
let regButton
|
|
| is _Just mRegistration = BtnCourseDeregister
|
|
| otherwise = BtnCourseRegister
|
|
((regButtonRes, regButtonView), regButtonEnctype) <- lift . runFormPost . identifyForm FIDcRegButton $
|
|
if | is _Just $ courseParticipantAllocated . entityVal =<< mRegistration
|
|
-> renderWForm FormStandard $ fmap (regButton, )
|
|
<$ (wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip)
|
|
<*> optionalActionW ((,)
|
|
<$> areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing
|
|
<*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing
|
|
) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
|
|
| otherwise
|
|
-> \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
|
|
deregisterParticipant courseParticipantUser courseParticipantCourse
|
|
|
|
whenIsJust mbReason $ \(reason, noShow) -> do
|
|
updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ]
|
|
|
|
now <- liftIO getCurrentTime
|
|
insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason)
|
|
let recordNoShow eId = do
|
|
didRecord <- is _Just <$> insertUnique ExamResult
|
|
{ examResultExam = eId
|
|
, examResultUser = uid
|
|
, examResultResult = ExamNoShow
|
|
, examResultLastChanged = now
|
|
}
|
|
when didRecord $
|
|
audit $ TransactionExamResultEdit eId uid
|
|
when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
|
|
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 Nothing CourseParticipantActive)
|
|
[ CourseParticipantRegistration =. now
|
|
, CourseParticipantAllocated =. Nothing
|
|
, CourseParticipantState =. CourseParticipantActive
|
|
]
|
|
queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
|
|
audit $ TransactionCourseParticipantEdit cid uid
|
|
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
|
redirect currentRoute
|
|
_other -> error "Invalid @regButton@"
|
|
|
|
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 . 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>
|
|
_{MsgLastEdit} ^{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 _) = do
|
|
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR
|
|
|
|
let 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 $ \mPrev -> mconcat
|
|
[ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
|
|
, prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgMatrikelNr)
|
|
-- "pseudonym" TODO DB only stores Word24
|
|
, Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
|
|
, prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgCorrector)
|
|
, prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgHasCorrector)
|
|
, prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingTime)
|
|
, prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgSubmission)
|
|
]
|
|
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
|
|
(cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI 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 . 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 = traverse $ \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 MsgExamName) $ 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 MsgExamOccurrence) $ maybe mempty (cell . toWidget) . preview (_dbrOutput . _2 . _Just . _entityVal . _examOccurrenceName)
|
|
, sortable (Just "registration-time") (i18nCell MsgExamRegistrationTime) $ maybe mempty (cell . formatTimeW SelFormatDateTime) . preview (_dbrOutput . _5 . _Just . _entityVal . _examRegistrationTime)
|
|
, sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) $ maybe mempty i18nCell . preview (_dbrOutput . _3 . _Just . _entityVal . _examBonusBonus)
|
|
, sortable (Just "result") (i18nCell MsgExamResult) $ 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 MsgExamResult) Nothing
|
|
]
|
|
|
|
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) 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 = traverse $ \(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 MsgTutorialType) $ textCell . CI.original . view (_dbrOutput . _1 . _entityVal . _tutorialType)
|
|
, sortable (Just "name") (i18nCell MsgTutorialName) $ 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 MsgTutorialTutors) $ \(view $ _dbrOutput . _3 -> tutors) -> cell
|
|
[whamlet|
|
|
$newline never
|
|
<ul .list--iconless .list--inline .list--comma-separated>
|
|
$forall (Entity _ User{userEmail, userDisplayName, userSurname}) <- tutors
|
|
<li>
|
|
^{nameEmailWidget userEmail userDisplayName userSurname}
|
|
|]
|
|
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ maybe (i18nCell MsgTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom)
|
|
, sortable Nothing (i18nCell MsgTutorialTime) $ occurrencesCell . 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 "room" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialRoom
|
|
, 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 MsgAction) 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")
|