870 lines
52 KiB
Haskell
870 lines
52 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-25 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-redundant-constraints #-}
|
|
|
|
module Handler.Course.Users
|
|
( queryUser
|
|
, makeCourseUserTable
|
|
, postCUsersR, getCUsersR
|
|
, colUserSex'
|
|
, colUserQualifications, colUserQualificationBlocked
|
|
, colUserExams, colUserExamOccurrences, colUserExamOccurrencesCheck, colUserExamOccurrencesCheckDB
|
|
, _userQualifications
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.Course
|
|
import Handler.Utils.Company
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.PostgreSQL as E
|
|
import qualified Database.Esqueleto.Experimental as X (from,on,table,innerJoin,leftJoin)
|
|
import Database.Esqueleto.Experimental ((:&)(..))
|
|
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import Handler.Course.Register (deregisterParticipant)
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
import Data.Map ((!?))
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Vector as Vector
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Database.Persist.Sql (updateWhereCount)
|
|
|
|
import Handler.Sheet.PersonalisedFiles
|
|
|
|
import qualified Data.Text.Lazy as Lazy (Text)
|
|
|
|
import qualified Data.Aeson as JSON
|
|
|
|
|
|
type UserTableExpr = ( E.SqlExpr (Entity User)
|
|
`E.InnerJoin` E.SqlExpr (Entity CourseParticipant)
|
|
)
|
|
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
|
|
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity SubmissionGroup))
|
|
`E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionGroupUser))
|
|
)
|
|
|
|
-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
|
|
-- forceUserTableType = id
|
|
|
|
-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
|
|
-- This ought to ease refactoring the query
|
|
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
|
|
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
|
|
|
queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
|
|
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
|
|
|
queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
|
|
queryUserNote = $(sqlLOJproj 3 2)
|
|
|
|
querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup))
|
|
querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 3 3)
|
|
|
|
|
|
userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
|
|
, E.SqlExpr (Entity CourseParticipant)
|
|
, E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
|
|
, E.SqlExpr (Maybe (Entity SubmissionGroup))
|
|
)
|
|
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do
|
|
-- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
|
|
E.on $ subGroup E.?. SubmissionGroupId E.==. subGroupUser E.?. SubmissionGroupUserSubmissionGroup
|
|
E.on $ subGroupUser E.?. SubmissionGroupUserUser E.==. E.just (user E.^. UserId)
|
|
E.&&. subGroup E.?. SubmissionGroupCourse E.==. E.just (E.val cid)
|
|
E.on $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser))
|
|
E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
|
|
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
|
|
return (user, participant, note E.?. CourseUserNoteId, subGroup)
|
|
|
|
type UserTableQualifications = [(Entity Qualification, Entity QualificationUser, Maybe (Entity QualificationUserBlock))]
|
|
|
|
type UserTableData = DBRow ( Entity User
|
|
, Entity CourseParticipant
|
|
, Maybe CourseUserNoteId
|
|
, ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
|
|
, ([Entity Exam], [(Entity ExamOccurrence, Maybe UserDisplayName)]) -- Paired with ExamOccurrence is an examiner name, iff user is registered for another ExamOccurrence with this examiner, regardless of CourseId and time
|
|
, Maybe (Entity SubmissionGroup)
|
|
, Map SheetName (SheetType SqlBackendKey, Maybe Points)
|
|
, UserTableQualifications
|
|
)
|
|
|
|
instance HasEntity UserTableData User where
|
|
hasEntity = _dbrOutput . _1
|
|
|
|
instance HasUser UserTableData where
|
|
hasUser = _dbrOutput . _1 . _entityVal
|
|
|
|
_userTableParticipant :: Lens' UserTableData (Entity CourseParticipant)
|
|
_userTableParticipant = _dbrOutput . _2
|
|
|
|
_userTableRegistration :: Lens' UserTableData UTCTime
|
|
_userTableRegistration = _userTableParticipant . _entityVal . _courseParticipantRegistration
|
|
|
|
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
|
|
_userTableNote = _dbrOutput . _3
|
|
|
|
_userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
|
|
_userTutorials = _dbrOutput . _4
|
|
|
|
_userExams :: Lens' UserTableData [Entity Exam]
|
|
_userExams = _dbrOutput . _5 . _1
|
|
|
|
_userExamOccsDblExaminers :: Lens' UserTableData [(Entity ExamOccurrence, Maybe UserDisplayName)]
|
|
_userExamOccsDblExaminers = _dbrOutput . _5 . _2
|
|
|
|
_userExamOccurrences :: Getter UserTableData [Entity ExamOccurrence]
|
|
_userExamOccurrences = _userExamOccsDblExaminers . to (map fst)
|
|
|
|
_userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup)
|
|
_userSubmissionGroup = _dbrOutput . _6 . _Just
|
|
|
|
_userSheets :: Lens' UserTableData (Map SheetName (SheetType SqlBackendKey, Maybe Points))
|
|
_userSheets = _dbrOutput . _7
|
|
|
|
-- _userQualifications :: Traversal' UserTableData [Entity Qualification]
|
|
-- _userQualifications = _dbrOutput . _8 . (traverse _1)
|
|
-- last part: ([Entity Qualification] -> f [Entity Qualification]) -> UserTableQualifications -> f UserTableQualifications
|
|
|
|
_userCourseQualifications :: Lens' UserTableData UserTableQualifications
|
|
_userCourseQualifications = _dbrOutput . _8
|
|
|
|
_userQualifications :: Getter UserTableData [Entity Qualification]
|
|
_userQualifications = _userCourseQualifications . to (map fst3)
|
|
|
|
|
|
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserComment tid ssh csh =
|
|
sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) ->
|
|
maybeEmpty mbNoteKey $ const $
|
|
anchorCellM (courseLink <$> encrypt uid) (hasComment True)
|
|
where
|
|
courseLink = CourseR tid ssh csh . CUserR
|
|
|
|
colUserTutorials :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserTutorials tid ssh csh = sortable (Just "tutorials") (i18nCell MsgCourseUserTutorials)
|
|
$ \(view _userTutorials -> tuts') ->
|
|
let tuts = sortOn (tutorialName . entityVal) $ (tuts' ^. _1) ++ (tuts' ^.. _2 . folded . _Just)
|
|
in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell tuts $ anchorCell'
|
|
(\(Entity _ Tutorial{..}) -> CTutorialR tid ssh csh tutorialName TUsersR)
|
|
(tutorialName . entityVal)
|
|
|
|
colUserExams :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams)
|
|
$ \(view _userExams -> exams') ->
|
|
let exams = sortOn (examName . entityVal) exams'
|
|
in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell exams $ anchorCell'
|
|
(\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR)
|
|
(examName . entityVal)
|
|
|
|
colUserExamOccurrences :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserExamOccurrences _tid _ssh _csh = sortable (Just "exam-occurrences") (i18nCell MsgCourseUserExamOccurrences)
|
|
$ \(view _userExamOccurrences -> exams') ->
|
|
let exams = sortOn (examOccurrenceName . entityVal) exams'
|
|
in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams examOccurrenceCell
|
|
|
|
colUserExamOccurrencesCheck :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserExamOccurrencesCheck _tid _ssh _csh = sortable (Just "exam-occurrences") (i18nCell MsgCourseUserExamOccurrences)
|
|
$ \(view _userExamOccsDblExaminers -> exams') ->
|
|
let exams = sortOn (examOccurrenceName . entityVal .fst) exams'
|
|
in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams
|
|
(\(exOcc, dblExmnr) ->
|
|
let warnExaminer :: Widget = foldMapM (messageTooltip <=< messageI Warning . MsgExaminerReocurrence) dblExmnr
|
|
in wgtCell warnExaminer <> examOccurrenceCell exOcc
|
|
)
|
|
|
|
colUserExamOccurrencesCheckDB :: (IsDBTable (MForm Handler) c, MonadHandler (DBCell (MForm Handler)), HandlerSite (DBCell (MForm Handler)) ~ UniWorX) -- this type seems to be unusable+
|
|
=> TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell (MForm Handler) c)
|
|
colUserExamOccurrencesCheckDB _tid _ssh _csh = sortable (Just "exam-occurrences") (i18nCell MsgCourseUserExamOccurrences)
|
|
$ \row -> do
|
|
let exams = sortOn (examOccurrenceName . entityVal) (row ^. _userExamOccurrences)
|
|
uid = row ^. hasEntity . _entityKey
|
|
(Map.fromAscList . map $(E.unValueN 2) -> dblExaminers) <- liftHandler . runDB $ E.select $ do
|
|
(reg :& occ :& usr) <- X.from $ X.table @ExamRegistration
|
|
`X.innerJoin` X.table @ExamOccurrence `X.on` (\(reg :& occ) -> occ E.^. ExamOccurrenceExam E.==. reg E.^. ExamRegistrationExam)
|
|
`X.innerJoin` X.table @User `X.on` (\(_ :& occ :& usr) -> occ E.^. ExamOccurrenceExaminer E.?=. usr E.^. UserId)
|
|
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
|
|
E.&&. E.isJust (occ E.^. ExamOccurrenceExaminer)
|
|
E.&&. occ E.^. ExamOccurrenceId `E.notIn` E.valList (entityKey <$> exams)
|
|
E.&&. occ E.^. ExamOccurrenceExaminer `E.in_` E.valList (exams ^.. traverse . _entityVal . _examOccurrenceExaminer)
|
|
E.orderBy [E.asc $ usr E.^. UserId]
|
|
E.distinct $ pure (usr E.^. UserId, usr E.^. UserDisplayName)
|
|
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams
|
|
(\(Entity _ eo@ExamOccurrence{..}) -> wgtCell $ do
|
|
$logDebugS "ExOccWarning" [st|Problems: #{tshow dblExaminers}. ExamOccurrence: #{tshow eo}|]
|
|
warnExaminer <- case (dblExaminers !?) =<< examOccurrenceExaminer of
|
|
Nothing -> pure mempty
|
|
(Just exname) -> messageTooltip <$> messageI Warning (MsgExaminerReocurrence exname)
|
|
[whamlet|^{warnExaminer}#{examOccurrenceName}:^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}|]
|
|
)
|
|
|
|
colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserSex' = colUserSex $ hasUser . _userSex
|
|
|
|
colUserSubmissionGroup :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgTableSubmissionGroup) $
|
|
foldMap (cell . toWidget) . preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
|
|
|
|
colUserSheets :: forall m c. IsDBTable m c => [SheetName] -> Cornice Sortable ('Cap 'Base) UserTableData (DBCell m c)
|
|
colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
|
|
where
|
|
caption = i18nCell MsgCourseUserSheets
|
|
& cellAttrs <>~ [ ("uw-hide-column-header", "sheets")
|
|
, ("uw-hide-column-default-hidden", "")
|
|
]
|
|
|
|
userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
|
|
userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) $ \dat -> flip (views $ _userSheets . at shn) dat $ \case
|
|
Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgTableAchievedOf points maxPoints
|
|
Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgTableNotPassed MsgTablePassed $ Just True == gradingPassed grading' points
|
|
_other -> mempty
|
|
|
|
colUserQualifications :: forall m c. IsDBTable m c => Day -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserQualifications cutoff = sortable (Just "qualifications") (i18nCell MsgTableQualifications) $
|
|
let qualNamedValidCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidUntilCell cutoff qb qu
|
|
in \(view _userCourseQualifications -> qualis) ->
|
|
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedValidCell
|
|
|
|
colUserQualificationBlocked :: forall m c. IsDBTable m c => Bool -> Day -> Colonnade Sortable UserTableData (DBCell m c)
|
|
colUserQualificationBlocked isAdmin cutoff = sortable (Just "qualification-block") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $
|
|
let qualNamedReasonCell (q,qu,qb) = textCell ((q ^. hasQualification . _qualificationShorthand . _CI) <> ": ") <> qualificationValidReasonCell' Nothing isAdmin cutoff qb qu
|
|
in \(view _userCourseQualifications -> qualis) ->
|
|
(cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell qualis $ qualNamedReasonCell
|
|
|
|
data UserTableCsv = UserTableCsv
|
|
{ csvUserSurname :: UserSurname
|
|
, csvUserFirstName :: UserFirstName
|
|
, csvUserName :: UserDisplayName
|
|
, csvUserSex :: Maybe Sex
|
|
, csvUserBirthday :: Maybe Day
|
|
, csvUserMatriculation :: Maybe UserMatriculation
|
|
, csvUserEPPN :: Maybe UserEduPersonPrincipalName
|
|
, csvUserEmail :: UserEmail
|
|
, csvUserQualifications :: [QualificationName]
|
|
, csvUserSubmissionGroup :: Maybe SubmissionGroupName
|
|
, csvUserRegistration :: UTCTime
|
|
, csvUserNote :: Maybe StoredMarkup
|
|
, csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
|
|
, csvUserExams :: [ExamName]
|
|
, csvUserSheets :: Map SheetName (SheetType (), Maybe Points)
|
|
} deriving (Eq, Ord, Read, Show, Generic)
|
|
makeLenses_ ''UserTableCsv
|
|
|
|
instance Csv.ToNamedRecord UserTableCsv where
|
|
toNamedRecord UserTableCsv{..} = Csv.namedRecord $
|
|
[ "surname" Csv..= csvUserSurname
|
|
, "first-name" Csv..= csvUserFirstName
|
|
, "name" Csv..= csvUserName
|
|
, "sex" Csv..= csvUserSex
|
|
, "birthday" Csv..= csvUserBirthday
|
|
, "matriculation" Csv..= csvUserMatriculation
|
|
, "eduPersonPrincipalName" Csv..= csvUserEPPN
|
|
, "email" Csv..= csvUserEmail
|
|
, "qualifications" Csv..= CsvSemicolonList csvUserQualifications
|
|
, "submission-group" Csv..= csvUserSubmissionGroup
|
|
, "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1)
|
|
] ++
|
|
[ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut)
|
|
| (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2
|
|
] ++
|
|
[ "exams" Csv..= CsvSemicolonList csvUserExams
|
|
, "registration" Csv..= csvUserRegistration
|
|
] ++
|
|
[ encodeUtf8 (CI.foldedCase shn) Csv..= res
|
|
| (shn, res) <- Map.toList csvUserSheets
|
|
] ++
|
|
[ "note" Csv..= csvUserNote
|
|
]
|
|
instance CsvColumnsExplained UserTableCsv where
|
|
csvColumnsExplanations _ = mconcat
|
|
[ single "surname" MsgCsvColumnUserSurname
|
|
, single "first-name" MsgCsvColumnUserFirstName
|
|
, single "name" MsgCsvColumnUserName
|
|
, single "sex" MsgCsvColumnUserSex
|
|
, single "birthday" MsgCsvColumnUserBirthday
|
|
, single "matriculation" MsgCsvColumnUserMatriculation
|
|
, single "email" MsgCsvColumnUserEmail
|
|
, single "submission-group" MsgCsvColumnUserSubmissionGroup
|
|
, single "tutorial" MsgCsvColumnUserTutorial
|
|
, single "exams" MsgCsvColumnUserExam
|
|
, single "registration" MsgCsvColumnUserRegistration
|
|
, single "note" MsgCsvColumnUserNote
|
|
]
|
|
where
|
|
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
|
|
single k v = singletonMap k [whamlet|_{v}|]
|
|
|
|
newtype UserCsvExportData = UserCsvExportData
|
|
{ csvUserIncludeSheets :: Bool
|
|
} deriving (Eq, Ord, Read, Show, Generic)
|
|
instance Default UserCsvExportData where
|
|
def = UserCsvExportData False
|
|
|
|
userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExportData -> Csv.Header
|
|
userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $
|
|
[ "surname", "first-name", "name" ] ++
|
|
[ "sex" | showSex ] ++
|
|
[ "matriculation", "eduPersonPrincipalName", "email", "study-features"] ++
|
|
[ "tutorial" | hasEmptyRegGroup ] ++
|
|
map (encodeUtf8 . CI.foldedCase) regGroups ++
|
|
[ "exams", "registration" ] ++
|
|
guardOnM csvUserIncludeSheets [ encodeUtf8 $ CI.foldedCase sheetName | Entity _ Sheet{..} <- sheets ] ++
|
|
[ "note" ]
|
|
where
|
|
hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts
|
|
regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts
|
|
|
|
data UserTableJson = UserTableJson
|
|
{ jsonUserSurname :: UserSurname
|
|
, jsonUserFirstName :: UserFirstName
|
|
, jsonUserName :: UserDisplayName
|
|
, jsonUserSex :: Maybe (Maybe Sex)
|
|
, jsonUserMatriculation :: Maybe UserMatriculation
|
|
, jsonUserEPPN :: Maybe UserEduPersonPrincipalName
|
|
, jsonUserEmail :: UserEmail
|
|
, jsonUserQualifications :: Set QualificationName
|
|
, jsonUserSubmissionGroup :: Maybe SubmissionGroupName
|
|
, jsonUserRegistration :: UTCTime
|
|
, jsonUserNote :: Maybe Lazy.Text
|
|
, jsonUserTutorials :: Set TutorialName
|
|
, jsonUserTutorialGroups :: Map (CI Text) (Maybe TutorialName)
|
|
, jsonUserExams :: Set ExamName
|
|
, jsonUserSheets :: Map SheetName UserTableJsonSheetResult
|
|
} deriving (Generic)
|
|
|
|
data UserTableJsonSheetResult = UserTableJsonSheetResult
|
|
{ jsonSheetType :: SheetType UserTableJsonSheetTypeExamPartRef
|
|
, jsonPoints :: Maybe Points
|
|
} deriving (Generic)
|
|
|
|
data UserTableJsonSheetTypeExamPartRef = UserTableJsonSheetTypeExamPartRef
|
|
{ jsonExam :: ExamName
|
|
, jsonExamPart :: ExamPartNumber
|
|
} deriving (Generic)
|
|
|
|
deriveToJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''UserTableJsonSheetTypeExamPartRef
|
|
|
|
deriveToJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''UserTableJsonSheetResult
|
|
|
|
instance ToJSON UserTableJson where
|
|
toJSON UserTableJson{..} = JSON.object $ catMaybes
|
|
[ pure $ "surname" JSON..= jsonUserSurname
|
|
, pure $ "first-name" JSON..= jsonUserFirstName
|
|
, pure $ "name" JSON..= jsonUserName
|
|
, ("sex" JSON..=) <$> jsonUserSex
|
|
, ("matriculation" JSON..=) <$> jsonUserMatriculation
|
|
, ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN
|
|
, pure $ "email" JSON..= jsonUserEmail
|
|
, ("qualifications" JSON..=) <$> assertM' (not . onull) jsonUserQualifications
|
|
, ("submission-group" JSON..=) <$> jsonUserSubmissionGroup
|
|
, pure $ "registration" JSON..= jsonUserRegistration
|
|
, ("note" JSON..=) <$> jsonUserNote
|
|
, ("tutorials" JSON..=) <$> assertM' (not . onull) jsonUserTutorials
|
|
, ("tutorial-groups" JSON..=) <$> assertM' (any $ is _Just) jsonUserTutorialGroups
|
|
, ("exams" JSON..=) <$> assertM' (not . onull) jsonUserExams
|
|
, ("sheets" JSON..=) <$> assertM' (any $ has (to jsonPoints . _Just)) jsonUserSheets
|
|
]
|
|
|
|
data CourseUserAction = CourseUserSendMail
|
|
| CourseUserRegisterTutorial
|
|
| CourseUserRegisterExam
|
|
| CourseUserSetSubmissionGroup
|
|
| CourseUserReRegister
|
|
| CourseUserDeregister
|
|
| CourseUserDownloadPersonalisedSheetFiles
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
instance Universe CourseUserAction
|
|
instance Finite CourseUserAction
|
|
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''CourseUserAction id
|
|
|
|
data CourseUserActionData = CourseUserSendMailData
|
|
| CourseUserDeregisterData
|
|
{ deregisterSelfImposed :: Maybe (Text, Bool {- no-show -})
|
|
}
|
|
| CourseUserRegisterTutorialData
|
|
{ registerTutorial :: TutorialId
|
|
}
|
|
| CourseUserRegisterExamData
|
|
{ registerExam :: (ExamId, Maybe ExamOccurrenceId)
|
|
}
|
|
| CourseUserSetSubmissionGroupData
|
|
{ setSubmissionGroup :: Maybe SubmissionGroupName
|
|
}
|
|
| CourseUserReRegisterData
|
|
| CourseUserDownloadPersonalisedSheetFilesData
|
|
{ downloadPersonalisedFilesForSheet :: SheetName
|
|
, downloadPersonalisedFilesAnonMode :: PersonalisedSheetFilesDownloadAnonymous
|
|
}
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
makeCourseUserTable :: forall h p cols act act'.
|
|
( Functor h, ToSortable h, Ord act, PathPiece act, RenderMessage UniWorX act
|
|
-- , HandlerSite (DBCell (MForm Handler)) ~ UniWorX, MonadHandler (DBCell (MForm Handler)) -- for colUserExamOccurrencesCheckDB, but this does not work at all
|
|
, AsCornice h p UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))) cols
|
|
)
|
|
=> CourseId
|
|
-> Map act (AForm Handler act')
|
|
-> (UserTableExpr -> E.SqlExpr (E.Value Bool))
|
|
-> cols
|
|
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))
|
|
-> Maybe (Csv.Name -> Bool)
|
|
-> DB (FormResult (act', Set UserId), Widget)
|
|
makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
|
|
currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
|
|
Course{..} <- getJust cid
|
|
courseQualis <- getCourseQualifications cid
|
|
let cqids = entityKey <$> courseQualis
|
|
tutorials <- selectList [ TutorialCourse ==. cid ] []
|
|
exams <- selectList [ ExamCourse ==. cid ] []
|
|
exOccs <- selectList [ ExamOccurrenceExam <-. fmap entityKey exams] [ Asc ExamOccurrenceId ] <&> Map.fromAscList . fmap (\ent -> (entityKey ent, ent))
|
|
sheets <- selectList [ SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
|
|
personalisedSheets <- E.select . E.from $ \sheet -> do
|
|
let hasPersonalised = E.exists . E.from $ \psFile ->
|
|
E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
|
|
E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission)
|
|
E.||. hasPersonalised
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
E.orderBy [ E.desc $ sheet E.^. SheetActiveTo
|
|
, E.desc $ sheet E.^. SheetActiveFrom
|
|
]
|
|
return $ sheet E.^. SheetName
|
|
-- -- psValidator has default sorting and filtering
|
|
showSex <- getShowSex
|
|
let dbtIdent = "courseUsers" :: Text
|
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
|
|
dbtRowKey = queryUser >>> (E.^. UserId)
|
|
dbtProj = dbtProjSimple $ \(user, participant, E.Value userNoteId, subGroup) -> do
|
|
tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
|
|
usrExams :: [(Entity ExamRegistration, E.Value (Maybe UserId), E.Value (Maybe UserDisplayName))] <- E.select $ do
|
|
(reg :& _occ :& usr) <- X.from $ X.table @ExamRegistration
|
|
`X.leftJoin` X.table @ExamOccurrence `X.on` (\(reg :& occ) -> occ E.?. ExamOccurrenceId E.==. reg E.^. ExamRegistrationOccurrence)
|
|
`X.leftJoin` X.table @User `X.on` (\(_ :& occ :& usr) -> E.joinV (occ E.?. ExamOccurrenceExaminer) E.==. usr E.?. UserId)
|
|
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val (entityKey user)
|
|
pure (reg, usr E.?. UserId, usr E.?. UserDisplayName)
|
|
subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
|
|
E.on $ submissionUser E.?. SubmissionUserSubmission E.==. submission E.?. SubmissionId
|
|
E.on $ E.just (sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
|
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.just (E.val $ entityKey user)
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
return ( sheet E.^. SheetName
|
|
, ( sheet E.^. SheetType
|
|
, submission
|
|
)
|
|
)
|
|
qualis <- E.select . E.from $ \(qualification `E.InnerJoin` qualificationUser `E.LeftOuterJoin` qualificationBlock) -> do
|
|
E.on $ qualificationUser E.^. QualificationUserId E.=?. qualificationBlock E.?. QualificationUserBlockQualificationUser
|
|
E.&&. qualificationBlock `isLatestBlockBefore` E.now_
|
|
E.on $ qualificationUser E.^. QualificationUserQualification E.==. qualification E.^. QualificationId
|
|
E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val (entityKey user)
|
|
E.&&. qualification E.^. QualificationId `E.in_` E.valList cqids
|
|
E.orderBy [E.asc $ qualification E.^. QualificationShorthand] -- we should sort by CourseQualificationSortOrder instead, but since we have not seen a course with multiple qualifications yet, we take a shortcut here
|
|
return (qualification, qualificationUser, qualificationBlock)
|
|
let
|
|
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
|
|
tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials
|
|
tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts'
|
|
exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal . fst3) usrExams) exams
|
|
usrDblExaminer :: Map UserId (Set ExamRegistrationId)
|
|
usrDblExaminer = Map.filter ((1 <) . Set.size) $ Map.fromListWith (<>) [(examiner, Set.singleton reg) | (Entity{entityKey=reg}, E.Value (Just examiner), _) <- usrExams]
|
|
checkUsrDbl :: Maybe UserId -> Maybe UserDisplayName -> Maybe UserDisplayName
|
|
checkUsrDbl (Just exid) exnm | isJust (usrDblExaminer !? exid) = exnm
|
|
checkUsrDbl _ _ = Nothing
|
|
ocs = [ (occ, checkUsrDbl exUsrId exUsrName)
|
|
| (Entity{entityVal=ExamRegistration{examRegistrationOccurrence = Just _oId@((exOccs !?) -> Just occ)}}, E.Value exUsrId, E.Value exUsrName) <- usrExams]
|
|
subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs'
|
|
return (user, participant, userNoteId, tuts, (exs,ocs), subGroup, subs, qualis)
|
|
dbtColonnade = colChoices
|
|
dbtSorting = mconcat
|
|
[ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header
|
|
, single $ sortUserSurname queryUser -- needed for initial sorting
|
|
, single $ sortUserDisplayName queryUser -- needed for initial sorting
|
|
, single $ sortUserEmail queryUser
|
|
, single $ sortUserMatriclenr queryUser
|
|
, sortUserSex (to queryUser . to (E.^. UserSex))
|
|
, single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
|
|
, single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
|
|
E.subSelectMaybe . E.from $ \edit -> do
|
|
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
|
|
return . E.max_ $ edit E.^. CourseUserNoteEditTime
|
|
)
|
|
, single ("tutorials" , SortColumn $ queryUser >>> \user ->
|
|
E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
|
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
|
|
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
|
|
return . E.min_ $ tutorial E.^. TutorialName
|
|
)
|
|
, single ("exams" , SortColumn $ queryUser >>> \user ->
|
|
E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.&&. exam E.^. ExamCourse E.==. E.val cid
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
|
return . E.min_ $ exam E.^. ExamName
|
|
)
|
|
, single ("exam-occurrences", SortColumn $ queryUser >>> \user ->
|
|
E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do
|
|
E.on $ examOccurrence E.^. ExamOccurrenceId E.=?. examRegistration E.^. ExamRegistrationOccurrence
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.&&. exam E.^. ExamCourse E.==. E.val cid
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
|
E.&&. E.isJust (examRegistration E.^. ExamRegistrationOccurrence)
|
|
return $ E.arrayAggWith E.AggModeDistinct (examOccurrence E.^. ExamOccurrenceName) [E.asc $ examOccurrence E.^. ExamOccurrenceName]
|
|
)
|
|
, single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
|
, single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
|
|
, mconcat
|
|
[ single ( SortingKey $ "sheet-" <> sheetName
|
|
, SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
|
|
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
|
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shId
|
|
return $ submission E.^. SubmissionRatingPoints
|
|
|
|
)
|
|
| Entity shId Sheet{..} <- sheets
|
|
]
|
|
]
|
|
where single = uncurry Map.singleton
|
|
dbtFilter = mconcat
|
|
[ single $ fltrUserNameLink queryUser
|
|
, single $ fltrUserEmail queryUser
|
|
, single $ fltrUserMatriclenr queryUser
|
|
, single $ fltrUserNameEmail queryUser
|
|
, fltrUserSex (to queryUser . to (E.^. UserSex))
|
|
, single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
|
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
|
|
)
|
|
, single ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
|
E.from $ \(exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
|
E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
|
E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId
|
|
)
|
|
-- , ("course-registration", error "TODO") -- TODO
|
|
-- , ("course-user-note", error "TODO") -- TODO
|
|
, single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
|
|
, single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
|
|
, single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> ifNothing criterion E.true $ \shn
|
|
-> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
|
|
E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
|
|
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
E.&&. sheet E.^. SheetName E.==. E.val shn
|
|
)
|
|
--, fltrRelevantStudyFeaturesTerms (to $
|
|
-- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
|
|
-- , queryUser t E.^. UserId
|
|
-- ))
|
|
--, fltrRelevantStudyFeaturesDegree (to $
|
|
-- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
|
|
-- , queryUser t E.^. UserId
|
|
-- ))
|
|
--, fltrRelevantStudyFeaturesSemester (to $
|
|
-- \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
|
|
-- , queryUser t E.^. UserId
|
|
-- ))
|
|
]
|
|
where single = uncurry Map.singleton
|
|
dbtFilterUI mPrev = mconcat $
|
|
[ prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (courseParticipantStateIsActiveField . Just $ SomeMessage MsgTableNoFilter) (fslI MsgCourseParticipantStateIsActiveFilter)
|
|
, fltrUserNameEmailUI mPrev
|
|
, fltrUserMatriclenrUI mPrev
|
|
] ++
|
|
[ fltrUserSexUI mPrev | showSex ] ++
|
|
[ prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup)
|
|
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial)
|
|
, prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam)
|
|
--, fltrRelevantStudyFeaturesDegreeUI mPrev
|
|
--, fltrRelevantStudyFeaturesTermsUI mPrev
|
|
--, fltrRelevantStudyFeaturesSemesterUI mPrev
|
|
] ++
|
|
[ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter)
|
|
| not $ null personalisedSheets
|
|
]
|
|
dbtParams = DBParamsForm
|
|
{ dbParamsFormMethod = POST
|
|
, dbParamsFormAction = Just $ SomeRoute currentRoute
|
|
, dbParamsFormAttrs = []
|
|
, dbParamsFormSubmit = FormSubmit
|
|
, dbParamsFormAdditional
|
|
= renderAForm FormStandard
|
|
$ (, mempty) . First . Just
|
|
<$> multiActionA acts (fslI MsgTableAction) Nothing
|
|
, dbParamsFormEvaluate = liftHandler . runFormPost
|
|
, dbParamsFormResult = id
|
|
, dbParamsFormIdent = def
|
|
}
|
|
dbtCsvName = MsgCourseUserCsvName courseTerm courseSchool courseShorthand
|
|
dbtCsvSheetName = MsgCourseUserCsvSheetName courseTerm courseSchool courseShorthand
|
|
dbtCsvEncode = do
|
|
csvColumns' <- csvColumns
|
|
return $ DBTCsvEncode
|
|
{ dbtCsvExportForm = UserCsvExportData
|
|
<$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
|
|
, dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(_, row) -> flip runReaderT row $
|
|
UserTableCsv
|
|
<$> view (hasUser . _userSurname)
|
|
<*> view (hasUser . _userFirstName)
|
|
<*> view (hasUser . _userDisplayName)
|
|
<*> view (hasUser . _userSex)
|
|
<*> view (hasUser . _userBirthday)
|
|
<*> view (hasUser . _userMatrikelnummer)
|
|
<*> view (hasUser . _userLdapPrimaryKey)
|
|
<*> view (hasUser . _userEmail)
|
|
<*> (over traverse (qualificationName . entityVal) <$> view _userQualifications)
|
|
<*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
|
|
<*> view _userTableRegistration
|
|
<*> userNote
|
|
<*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials)
|
|
<*> (over traverse (examName . entityVal) <$> view _userExams)
|
|
<*> views _userSheets (set (mapped . _1 . mapped) ())
|
|
, dbtCsvName, dbtCsvSheetName
|
|
, dbtCsvNoExportData = Nothing
|
|
, dbtCsvHeader = return . Vector.filter csvColumns' . userTableCsvHeader showSex tutorials sheets . fromMaybe def
|
|
, dbtCsvExampleData = Nothing
|
|
}
|
|
userNote = runMaybeT $ do
|
|
noteId <- MaybeT . preview $ _userTableNote . _Just
|
|
CourseUserNote{..} <- lift . lift $ getJust noteId
|
|
return courseUserNoteNote
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = withCsvExtraRep dbtCsvSheetName (UserCsvExportData True) dbtCsvEncode
|
|
[ DBTExtraRep $ toPrettyJSON <$> repUserJson, DBTExtraRep $ toYAML <$> repUserJson
|
|
]
|
|
|
|
repUserJson :: ConduitT (E.Value UserId, UserTableData) Void DB (Map CryptoUUIDUser UserTableJson)
|
|
repUserJson = C.foldMapM $ \(E.Value uid, res) -> Map.singleton <$> encrypt uid <*> mkUserTableJson res
|
|
where
|
|
mkUserTableJson res' = flip runReaderT res' $ UserTableJson
|
|
<$> view (hasUser . _userSurname)
|
|
<*> view (hasUser . _userFirstName)
|
|
<*> view (hasUser . _userDisplayName)
|
|
<*> views (hasUser . _userSex) (guardOn showSex)
|
|
<*> view (hasUser . _userMatrikelnummer)
|
|
<*> view (hasUser . _userLdapPrimaryKey)
|
|
<*> view (hasUser . _userEmail)
|
|
<*> view (_userQualifications . folded . to (Set.singleton . qualificationName . entityVal))
|
|
<*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
|
|
<*> view _userTableRegistration
|
|
<*> (fmap markupInput <$> userNote)
|
|
<*> view (_userTutorials . _1 . folded . to (Set.singleton . tutorialName . entityVal))
|
|
<*> views (_userTutorials . _2) (over (traverse . _Just) $ tutorialName . entityVal)
|
|
<*> view (_userExams . folded . to (Set.singleton . examName . entityVal))
|
|
<*> (fmap (fmap $ uncurry UserTableJsonSheetResult) . traverseOf (traverse . _1) (lift . resolveSheetType') =<< view _userSheets)
|
|
resolveSheetType' sType = do
|
|
sType' <- resolveSheetType cid sType
|
|
for sType' $ \(Entity _ ExamPart{..}) -> do
|
|
Exam{..} <- getJust examPartExam
|
|
return $ UserTableJsonSheetTypeExamPartRef examName examPartNumber
|
|
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
|
where
|
|
postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId)
|
|
postprocess inp = do
|
|
(First (Just act), usrMap) <- inp
|
|
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
|
return (act, usrSet)
|
|
|
|
courseUserDeregisterForm :: CourseId -> AForm Handler CourseUserActionData
|
|
courseUserDeregisterForm _cid = wFormToAForm . pure . pure $ CourseUserDeregisterData Nothing
|
|
|
|
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getCUsersR = postCUsersR
|
|
postCUsersR tid ssh csh = do
|
|
now <- liftIO getCurrentTime
|
|
let nowaday = utctDay now
|
|
showSex <- getShowSex
|
|
(course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do
|
|
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
|
|
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
hasTutorials <- exists [TutorialCourse ==. cid]
|
|
examOccurrencesPerExam <- E.select . E.from $ \(exam `E.LeftOuterJoin` examOccurrence) -> do
|
|
E.on $ E.just (exam E.^. ExamId) E.==. examOccurrence E.?. ExamOccurrenceExam
|
|
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
|
return (exam, examOccurrence)
|
|
hasSubmissionGroups <- E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` courseParticipant) -> do
|
|
E.on $ courseParticipant E.^. CourseParticipantUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
|
|
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. submissionGroup E.^. SubmissionGroupCourse
|
|
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
|
|
sheetList <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
|
|
personalisedSheets <- E.select . E.from $ \sheet -> do
|
|
let hasPersonalised = E.exists . E.from $ \psFile ->
|
|
E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
|
|
E.where_ $ E.not_ (sheet E.^. SheetAllowNonPersonalisedSubmission)
|
|
E.||. hasPersonalised
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
E.orderBy [ E.desc $ sheet E.^. SheetActiveTo
|
|
, E.desc $ sheet E.^. SheetActiveFrom
|
|
]
|
|
return $ sheet E.^. SheetName
|
|
let exams = nubOrdOn entityKey $ examOccurrencesPerExam ^.. folded . _1
|
|
let colChoices = mconcat $ catMaybes
|
|
[ pure . cap' $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
|
, pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR)
|
|
, guardOn showSex . cap' $ colUserSex'
|
|
, pure . cap' $ colUserEmail
|
|
, pure . cap' $ colUserMatriclenr False
|
|
, pure . cap' $ colUserQualifications nowaday
|
|
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
|
|
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
|
|
, guardOn hasExams . cap' $ colUserExams tid ssh csh
|
|
, guardOn hasExams . cap' $ colUserExamOccurrences tid ssh csh
|
|
, pure . cap' $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive))
|
|
, pure . cap' $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState))
|
|
, guardOn (not $ null sheetList) . colUserSheets $ map (sheetName . entityVal) sheetList
|
|
, pure . cap' $ colUserComment tid ssh csh
|
|
]
|
|
psValidator = def & defaultSortingByName
|
|
& defaultFilter (singletonMap "active" [toPathPiece True])
|
|
hasExams = not $ null exams
|
|
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
|
|
examOccActs = examOccurrencesPerExam
|
|
& map (bimap entityKey hoistMaybe)
|
|
& Map.fromListWith (<>)
|
|
& imap (\k v -> case v of
|
|
[] -> pure (k, Nothing)
|
|
_ -> (k,) <$> aopt (selectField' (Just $ SomeMessage MsgExamNoOccurrence) $ examOccOpts v) (fslI MsgTableExamOccurrence) (Just Nothing)
|
|
)
|
|
where
|
|
examOccOpts :: [Entity ExamOccurrence] -> Handler (OptionList ExamOccurrenceId)
|
|
examOccOpts examOccs = fmap mkOptionList . forM examOccs $ \Entity{..} -> do
|
|
optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExamOccurrence
|
|
let
|
|
optionExternalValue = toPathPiece optionExternalValue'
|
|
optionInternalValue = entityKey
|
|
optionDisplay = CI.original $ examOccurrenceName entityVal
|
|
return Option{..}
|
|
examActs :: Handler (OptionList ExamId)
|
|
examActs = fmap mkOptionList . forM exams $ \Entity{..} -> do
|
|
optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExam
|
|
let
|
|
optionExternalValue = toPathPiece optionExternalValue'
|
|
optionInternalValue = entityKey
|
|
optionDisplay = CI.original $ examName entityVal
|
|
return Option{..}
|
|
submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
|
|
acts :: Map CourseUserAction (AForm Handler CourseUserActionData)
|
|
acts = mconcat $ catMaybes
|
|
[ pure . singletonMap CourseUserSendMail $ pure CourseUserSendMailData
|
|
, pure . singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData
|
|
<$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
|
|
(fslI MsgCourseTutorial)
|
|
Nothing
|
|
, pure . singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$>
|
|
multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing
|
|
, pure . singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original)
|
|
<$> aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgTableSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
|
|
, guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
|
|
, guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData
|
|
, guardOn (not $ null personalisedSheets) . singletonMap CourseUserDownloadPersonalisedSheetFiles $
|
|
CourseUserDownloadPersonalisedSheetFilesData
|
|
<$> apopt (selectField' Nothing . optionsF $ map E.unValue personalisedSheets) (fslI MsgExerciseSheet) Nothing
|
|
<*> apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField) (Just PersonalisedSheetFilesDownloadAnonymous)
|
|
]
|
|
numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
|
|
table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True)
|
|
return (ent, numParticipants, table)
|
|
formResult participantRes $ \case
|
|
(CourseUserSendMailData, selectedUsers) -> do
|
|
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
|
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
|
(CourseUserDeregisterData{}, selectedUsers) -> do
|
|
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
|
|
Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
|
|
unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid"
|
|
lift $ deregisterParticipant courseParticipantUser course
|
|
return 1
|
|
addMessageI Success $ MsgCourseUsersDeregistered nrDel
|
|
redirect $ CourseR tid ssh csh CUsersR
|
|
(CourseUserRegisterTutorialData{..}, selectedUsers) -> do
|
|
Sum nrOk <- runDB $ flip foldMapM selectedUsers $ \uid -> do
|
|
fsh <- selectCompanyUserPrime' uid
|
|
mbKey <- insertUnique $ TutorialParticipant registerTutorial uid fsh Nothing Nothing Nothing
|
|
return $ Sum $ length mbKey
|
|
let mStatus = bool Success Warning $ nrOk < Set.size selectedUsers
|
|
addMessageI mStatus $ MsgCourseUsersTutorialRegistered $ fromIntegral nrOk
|
|
redirect $ CourseR tid ssh csh CUsersR
|
|
(CourseUserRegisterExamData{..}, selectedUsers) -> do
|
|
Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do
|
|
guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
|
|
let (exam, mOccurrence) = registerExam
|
|
mExamReg <- lift $ insertUnique ExamRegistration
|
|
{ examRegistrationExam = exam
|
|
, examRegistrationUser = uid
|
|
, examRegistrationOccurrence = mOccurrence
|
|
, examRegistrationTime = now
|
|
}
|
|
case mExamReg of
|
|
Just _ -> do
|
|
lift . audit $ TransactionExamRegister exam uid
|
|
return 1
|
|
Nothing ->
|
|
return mempty
|
|
addMessageI Success $ MsgCourseUsersExamRegistered nrReg
|
|
redirect $ CourseR tid ssh csh CUsersR
|
|
(CourseUserSetSubmissionGroupData{..}, selectedUsers) -> do
|
|
nrSet <- runDB $ setUsersSubmissionGroup cid selectedUsers setSubmissionGroup
|
|
|
|
case setSubmissionGroup of
|
|
Nothing -> addMessageI Success $ MsgCourseUsersSubmissionGroupUnset nrSet
|
|
Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet
|
|
|
|
redirect $ CourseR tid ssh csh CUsersR
|
|
(CourseUserReRegisterData, selectedUsers) -> do
|
|
Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
|
|
didUpdate <- lift $ updateWhereCount
|
|
[ CourseParticipantUser ==. uid
|
|
, CourseParticipantCourse ==. cid
|
|
, CourseParticipantState !=. CourseParticipantActive
|
|
]
|
|
[ CourseParticipantState =. CourseParticipantActive
|
|
, CourseParticipantRegistration =. now
|
|
]
|
|
guard $ didUpdate > 0
|
|
lift . audit $ TransactionCourseParticipantEdit cid uid
|
|
return $ Sum didUpdate
|
|
addMessageI Success $ MsgCourseUsersStateSet nrSet
|
|
redirect $ CourseR tid ssh csh CUsersR
|
|
(CourseUserDownloadPersonalisedSheetFilesData shn anonMode, selectedUsers) -> do
|
|
shId <- runDB . getKeyBy404 $ CourseSheet cid shn
|
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $
|
|
MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand shn
|
|
sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cid (Just shId) (Just selectedUsers) anonMode Set.empty
|
|
|
|
|
|
let headingLong = [whamlet|_{MsgHeadingCourseMembers} #{courseName} #{tid}|]
|
|
headingShort = prependCourseTitle tid ssh csh MsgHeadingCourseMembers
|
|
siteLayout headingLong $ do
|
|
setTitleI headingShort
|
|
$(widgetFile "course-participants")
|